Founding the newly structured GF2.0 cvs archive.

src/GF/Compile/Optimize.hs

@@ -0,0 +1,171 @@
+module Optimize where
+
+import Grammar
+import Ident
+import Modules
+import PrGrammar
+import Macros
+import Lookup
+import Refresh
+import Compute
+import CheckGrammar
+import Update
+
+import Operations
+import CheckM
+
+import Monad
+import List
+
+-- partial evaluation of concrete syntax. AR 6/2001 -- 16/5/2003
+{-
+evalGrammar :: SourceGrammar -> Err SourceGrammar
+evalGrammar gr = do
+  gr2 <- refreshGrammar gr
+  mos <- foldM evalModule [] $ modules gr2
+  return $ MGrammar $ reverse mos 
+-}
+evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> 
+               Err [(Ident,SourceModInfo)]
+evalModule ms mo@(name,mod) = case mod of
+
+  ModMod (Module mt fs me ops js) -> case mt of
+    MTResource -> do
+      let deps = allOperDependencies name js
+      ids <- topoSortOpers deps
+      MGrammar (mod' : _) <- foldM evalOp gr ids
+      return $ mod' : ms
+    MTConcrete a -> do
+      js' <- mapMTree (evalCncInfo gr0 name a) js
+      return $ (name, ModMod (Module mt fs me ops js')) : ms
+
+    _ -> return $ (name,mod):ms
+ where
+   gr0 = MGrammar $ ms
+   gr  = MGrammar $ (name,mod) : ms
+
+   evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
+     info  <- lookupTree prt i $ jments m
+     info' <- evalResInfo gr (i,info)
+     return $ updateRes g name i info'
+
+-- only operations need be compiled in a resource, and this is local to each
+-- definition since the module is traversed in topological order
+
+evalResInfo :: SourceGrammar -> (Ident,Info) -> Err Info
+evalResInfo gr (c,info) = case info of
+
+  ResOper pty pde -> eIn "operation" $ do
+    pde' <- case pde of
+       Yes de -> liftM yes $ comp de
+       _ -> return pde
+    return $ ResOper pty pde'
+
+  _ ->  return info
+ where
+   comp = computeConcrete gr
+   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+
+
+evalCncInfo :: 
+  SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
+evalCncInfo gr cnc abs (c,info) = case info of
+
+  CncCat ptyp pde ppr -> do
+
+    pde' <- case (ptyp,pde) of
+      (Yes typ, Yes de) -> 
+        liftM yes $ pEval ([(strVar, typeStr)], typ) de
+      (Yes typ, Nope)   -> 
+        liftM yes $ mkLinDefault gr typ >>= pEval ([(strVar, typeStr)],typ)
+      (May b, Nope) ->
+        return $ May b
+      _ -> return pde   -- indirection
+
+    ppr' <- return ppr ----
+
+    return (c, CncCat ptyp pde' ppr')
+
+  CncFun (mt@(Just (_,ty))) pde ppr -> eIn ("linearization in type" +++  
+                                             show ty +++ "of") $ do
+    pde' <- case pde of
+      Yes de -> do
+        liftM yes $ pEval ty de
+      _ -> return pde
+    ppr' <- case ppr of
+      Yes pr -> liftM yes $ comp pr
+      _ -> return ppr  
+    return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
+
+  _ ->  return (c,info)
+ where
+   comp = computeConcrete gr
+   pEval = partEval gr
+   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+
+-- the main function for compiling linearizations
+
+partEval :: SourceGrammar -> (Context,Type) -> Term -> Err Term
+partEval gr (context, val) trm = do
+  let vars  = map fst context
+      args  = map Vr vars
+      subst = [(v, Vr v) | v <- vars]
+      trm1  = mkApp trm args
+  trm2 <- etaExpand val trm1 
+  trm3 <- comp subst trm2
+  return $ mkAbs vars trm3
+
+ where 
+
+   comp g t = {- refreshTerm t >>= -} computeTerm gr g t
+
+   etaExpand val t = recordExpand val t   --- >>= caseEx  -- done by comp
+
+-- here we must be careful not to reduce
+--   variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
+--   {s  = variants {"Auto" ; "Wagen"} ; g  = variants {N ; M}} ;
+
+recordExpand :: Type -> Term -> Err Term
+recordExpand typ trm = case unComputed typ of
+  RecType tys -> case trm of
+    FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
+    _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
+  _ -> return trm
+
+
+-- auxiliaries for compiling the resource
+
+allOperDependencies :: Ident -> BinTree (Ident,Info) -> [(Ident,[Ident])]
+allOperDependencies m b = 
+  [(f, nub (opty pty ++ opty pt)) | (f, ResOper pty pt) <- tree2list b]
+  where
+    opersIn t = case t of
+      Q n c | n == m -> [c]
+      _ -> collectOp opersIn t
+    opty (Yes ty) = opersIn ty
+    opty _ = []
+
+topoSortOpers :: [(Ident,[Ident])] -> Err [Ident]
+topoSortOpers st = do
+  let eops = topoTest st
+  either return (\ops -> Bad ("circular operations" +++ unwords (map prt (head ops)))) eops
+
+mkLinDefault :: SourceGrammar -> Type -> Err Term
+mkLinDefault gr typ = do
+  case unComputed typ of
+    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
+    _ -> prtBad "linearization type must be a record type, not" typ
+ where
+   mkDefField typ = case unComputed typ of
+     Table p t  -> do
+       t' <- mkDefField t
+       let T _ cs = mkWildCases t'
+       return $ T (TWild p) cs 
+     Sort "Str" -> return $ Vr strVar
+     QC q p     -> lookupFirstTag gr q p
+     RecType r  -> do
+       let (ls,ts) = unzip r
+       ts' <- mapM mkDefField ts
+       return $ R $ [assign l t | (l,t) <- zip ls ts']
+     _ -> prtBad "linearization type field cannot be" typ
+