cleand up Structural

src/GF/Compile/Compile.hs

@@ -262,10 +262,10 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
 
       (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
 
-      mo4:_ <- 
+      mo4 <- 
 ----        case snd mo1b of
 ----          ModMod n | isModCnc n -> 
-        putp "  optimizing " $ ioeErr $ evalModule mos mo3r
+        putp "  optimizing " $ ioeErr $ optimizeModule opts mos mo3r
 ----        _ -> return [mo3r]
       return (k',mo4)
  where

src/GF/Compile/GrammarToCanon.hs

@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Code generator from optimized GF source code to GFC.
 -----------------------------------------------------------------------------
 
 module GrammarToCanon where
@@ -187,7 +187,9 @@ redCType t = case t of
 
 redCTerm :: Term -> Err G.Term
 redCTerm t = case t of
-  Vr x -> liftM G.Arg $ redArgvar x
+  Vr x -> checkAgain 
+            (liftM G.Arg $ redArgvar x) 
+            (liftM G.LI  $ redIdent x) --- for parametrize optimization
   App _ _ -> do  -- only constructor applications can remain
     (_,c,xx) <- termForm t
     xx' <- mapM redCTerm xx
@@ -212,6 +214,13 @@ redCTerm t = case t of
     ps' <- mapM redPatt ps
     ts' <- mapM redCTerm ts
     return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts'
+  TSh i cs -> do
+    ty  <- getTableType i
+    ty' <- redCType ty
+    let (pss,ts) = unzip cs
+    pss' <- mapM (mapM redPatt) pss
+    ts' <- mapM redCTerm ts
+    return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts'
   V ty ts     -> do
     ty' <- redCType ty
     ts' <- mapM redCTerm ts
@@ -247,6 +256,7 @@ redPatt p = case p of
     return $ G.PR $  map (uncurry G.PAss) $ zip ls' ts
   PT _ q -> redPatt q
   PInt i -> return $ G.PI (toInteger i)
+  PV x -> liftM G.PV $ redIdent x --- for parametrize optimization
   _ -> prtBad "cannot reduce pattern" p
 
 redLabel :: Label -> G.Label

src/GF/Compile/MkResource.hs

@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
 -----------------------------------------------------------------------------
 
 module MkResource where

src/GF/Compile/Optimize.hs

@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Top-level partial evaluation for GF source modules.
 -----------------------------------------------------------------------------
 
 module Optimize where
@@ -22,25 +22,38 @@ import Macros
 import Lookup
 import Refresh
 import Compute
+import BackOpt
 import CheckGrammar
 import Update
 
 import Operations
 import CheckM
+import Option
 
 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 
--}
+-- partial evaluation of concrete syntax. AR 6/2001 -- 16/5/2003 -- 5/2/2005
+-- only do this for resource: concrete is optimized in gfc form
+
+optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> 
+                  Err (Ident,SourceModInfo)
+optimizeModule opts ms mo@(_,mi) = case mi of
+  ModMod m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do
+      mo1 <- evalModule ms mo
+      let oopts = addOptions opts (iOpts (flagsModule mo1))
+          optim = maybe "none" id $ getOptVal oopts useOptimizer
+      return $ case optim of
+        "parametrize" -> shareModule paramOpt mo1  -- parametrization and sharing
+        "values"      -> shareModule valOpt mo1    -- tables as courses-of-values
+        "share"       -> shareModule shareOpt mo1  -- sharing of branches
+        "all"         -> shareModule allOpt mo1    -- first parametrize then values
+        "none"        -> mo1                       -- no optimization
+        _             -> mo1                       -- none; default for src
+  _ -> evalModule ms mo
+
 evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> 
-               Err [(Ident,SourceModInfo)]
+               Err (Ident,SourceModInfo)
 evalModule ms mo@(name,mod) = case mod of
 
   ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
@@ -48,13 +61,13 @@ evalModule ms mo@(name,mod) = case mod of
       let deps = allOperDependencies name js
       ids <- topoSortOpers deps
       MGrammar (mod' : _) <- foldM evalOp gr ids
-      return $ mod' : ms
+      return $ mod'
     MTConcrete a -> do
       js' <- mapMTree (evalCncInfo gr0 name a) js
-      return $ (name, ModMod (Module mt st fs me ops js')) : ms
+      return $ (name, ModMod (Module mt st fs me ops js'))
 
-    _ -> return $ (name,mod):ms
-  _ -> return $ (name,mod):ms
+    _ -> return $ (name,mod)
+  _ -> return $ (name,mod)
  where
    gr0 = MGrammar $ ms
    gr  = MGrammar $ (name,mod) : ms