optimizations on evaluated gf in gfc

4 files changed, 151 insertions, 37 deletions

diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs
index 2e9de8a16..0054ff4b7 100644
--- a/src/GF/Devel/Compile.hs
+++ b/src/GF/Devel/Compile.hs
@@ -1,15 +1,5 @@
 module GF.Devel.Compile (batchCompile) where
 
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Infra.Option
-import GF.Infra.CompactPrint
-import GF.Devel.PrGrammar
-import GF.Compile.Update
-import GF.Grammar.Lookup
-import GF.Infra.Modules
-import GF.Devel.ReadFiles
-
 -- the main compiler passes
 import GF.Devel.GetGrammar
 import GF.Compile.Extend
@@ -19,9 +9,20 @@ import GF.Grammar.Refresh
 import GF.Compile.CheckGrammar
 import GF.Compile.Optimize
 import GF.Compile.Evaluate ----
+import GF.Devel.OptimizeGF
 --import GF.Canon.Share
 --import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule)
 
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.CompactPrint
+import GF.Devel.PrGrammar
+import GF.Compile.Update
+import GF.Grammar.Lookup
+import GF.Infra.Modules
+import GF.Devel.ReadFiles
+
 import GF.Data.Operations
 import GF.Devel.UseIO
 import GF.Devel.Arch
@@ -167,31 +168,10 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do
 generateModuleCode :: Options -> InitPath -> SourceModule -> IOE SourceModule
 generateModuleCode opts path minfo@(name,info) = do
 
-  let pname = prefixPathName path (prt name)
+  let pname  = prefixPathName path (prt name)
   let minfo0 = minfo 
-  let minfo1 = minfo
-  let minfo2 = minfo
-
-{- ---- restore optimizations!
-  let oopts  = addOptions opts (iOpts (flagsModule minfo))
-      optims = maybe "all_subs" id $ getOptVal oopts useOptimizer
-      optim  = takeWhile (/='_') optims
-      subs   = drop 1 (dropWhile (/='_') optims) == "subs"
-  minfo1     <- return $
-    case optim of
-      "parametrize" -> shareModule paramOpt minfo0  -- parametrization and sharing
-      "values"      -> shareModule valOpt minfo0    -- tables as courses-of-values
-      "share"       -> shareModule shareOpt minfo0  -- sharing of branches
-      "all"         -> shareModule allOpt minfo0    -- first parametrize then values
-      "none"        -> minfo0                       -- no optimization
-      _             -> shareModule shareOpt minfo0  -- sharing; default
-
-  -- do common subexpression elimination if required by flag "subs"
-  minfo2 <- 
-    if subs
-      then ioeErr $ elimSubtermsMod minfo1
-      else return minfo1
--}
+  let minfo1 = shareModule minfo
+  let minfo2 = minfo1
 
   let (file,out) = (gfcFile pname, prGrammar (MGrammar [minfo2]))
   putp ("  wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out
diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs
index 4fe2e6e0d..686e9f4bb 100644
--- a/src/GF/Devel/GrammarToGFCC.hs
+++ b/src/GF/Devel/GrammarToGFCC.hs
@@ -1,5 +1,7 @@
 module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc) where
 
+import GF.Devel.OptimizeGF (unshareModule)
+
 import GF.Grammar.Grammar
 import qualified GF.Grammar.Lookup as Look
 
@@ -220,12 +222,15 @@ canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs
 
 
 purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
-purgeGrammar abstr gr = (M.MGrammar . filter complete . purge . M.modules) gr where
+purgeGrammar abstr gr = 
+  (M.MGrammar . map unopt . filter complete . purge . M.modules) gr 
+ where
   purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
   needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
   acncs = abstr : M.allConcretes gr abstr
   isSingle = True
   complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon
+  unopt = unshareModule gr
 
 type ParamEnv =
   (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
diff --git a/src/GF/Devel/OptimizeGF.hs b/src/GF/Devel/OptimizeGF.hs
new file mode 100644
index 000000000..a5b7d27f5
--- /dev/null
+++ b/src/GF/Devel/OptimizeGF.hs
@@ -0,0 +1,128 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : OptimizeGF
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:33 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- Optimizations on GF source code: sharing, parametrization, value sets.
+--
+-- optimization: sharing branches in tables. AR 25\/4\/2003.
+-- following advice of Josef Svenningsson
+-----------------------------------------------------------------------------
+
+module GF.Devel.OptimizeGF (shareModule,unshareModule) where 
+
+import GF.Grammar.Grammar
+import GF.Grammar.Lookup
+import GF.Infra.Ident
+import qualified GF.Grammar.Macros as C
+import GF.Grammar.PrGrammar (prt)
+import qualified GF.Infra.Modules as M
+import GF.Data.Operations
+
+import Data.List
+
+shareModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo)
+shareModule = processModule optim
+
+unshareModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
+unshareModule gr = processModule (const (unoptim gr))
+
+processModule :: 
+  (Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
+processModule opt (i,m) = case m of
+  M.ModMod (M.Module mt st fs me ops js) -> 
+    (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
+  _ -> (i,m)
+
+shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m)
+shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (opt c t)) m)
+shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (opt c t)))
+shareInfo _ i = i
+
+-- the function putting together optimizations
+optim :: Ident -> Term -> Term
+optim c = values . factor c 0
+
+-- we need no counter to create new variable names, since variables are 
+-- local to tables (only true in GFC) ---
+
+-- factor parametric branches
+
+factor :: Ident -> Int -> Term -> Term
+factor c i t = case t of
+  T _ [_] -> t
+  T _ []  -> t
+  T (TComp ty) cs -> 
+    T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
+  _ -> C.composSafeOp (factor c i) t
+ where
+
+   factors i psvs =   -- we know psvs has at least 2 elements
+     let p   = qqIdent c i
+         vs' = map (mkFun p) psvs
+     in if   allEqs vs'
+        then mkCase p vs' 
+        else psvs
+
+   mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
+
+   allEqs (v:vs) = all (==v) vs
+
+   mkCase p (v:_) = [(PV p, v)]
+
+--- we hope this will be fresh and don't check... in GFC would be safe
+
+qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
+
+
+--  we need to replace subterms
+
+replace :: Term -> Term -> Term -> Term
+replace old new trm = case trm of
+  
+  -- these are the important cases, since they can correspond to patterns  
+  QC _ _   | trm == old -> new
+  App t ts | trm == old -> new
+  App t ts              -> App (repl t) (repl ts)
+  R _ | isRec && trm == old -> new
+  _ -> C.composSafeOp repl trm
+ where
+   repl = replace old new
+   isRec = case trm of
+     R _ -> True
+     _ -> False
+
+-- It is very important that this is performed only after case
+-- expansion since otherwise the order and number of values can
+-- be incorrect. Guaranteed by the TComp flag.
+
+values :: Term -> Term
+values t = case t of
+  T ty [(ps,t)]   -> T ty [(ps,values t)] -- don't destroy parametrization
+  T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
+  _ -> C.composSafeOp values t
+
+
+-- to undo the effect of factorization
+
+unoptim :: SourceGrammar -> Term -> Term
+unoptim gr = unfactor gr
+
+unfactor :: SourceGrammar -> Term -> Term
+unfactor gr t = case t of
+  T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty]
+  _ -> C.composSafeOp unfac t
+ where
+   unfac = unfactor gr
+   vals  = err error id . allParamValues gr
+   restore x u t = case t of
+     Vr y | y == x -> u
+     _ -> C.composSafeOp (restore x u) t
+
+
diff --git a/src/GF/GFCC/CheckGFCC.hs b/src/GF/GFCC/CheckGFCC.hs
index 12f92bcac..bf9a846e3 100644
--- a/src/GF/GFCC/CheckGFCC.hs
+++ b/src/GF/GFCC/CheckGFCC.hs
@@ -70,11 +70,11 @@ inferTerm args trm = case trm of
           testErr (all (==typ) tys) ("different types in table " ++ prt trm) 
           return (P t' u', typ)      -- table: types must be same
       _ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt
-  FV [] -> returnt str ----
+  FV [] -> returnt TM ----
   FV (t:ts) -> do
     (t',ty) <- infer t
     (ts',tys) <- mapM infer ts >>= return . unzip
-    testErr (all (==ty) tys) ("different types in variants " ++ prt trm)
+    testErr (all (eqType ty) tys) ("different types in variants " ++ prt trm)
     return (FV (t':ts'),ty)
   W s r -> infer r
   _ -> Bad ("no type inference for " ++ prt trm)
@@ -99,6 +99,7 @@ eqType :: CType -> CType -> Bool
 eqType inf exp = case (inf,exp) of
   (C k, C n)  -> k <= n -- only run-time corr.
   (R rs,R ts) -> length rs == length ts && and [eqType r t | (r,t) <- zip rs ts]
+  (TM,  _)    -> True ---- for variants [] ; not safe
   _ -> inf == exp
 
 -- should be in a generic module, but not in the run-time DataGFCC