added optimization to GrammarToGFCC

4 files changed, 130 insertions, 141 deletions

diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs
index a94e0e1fb..05f591627 100644
--- a/src/GF/Canon/GFCC/CheckGFCC.hs
+++ b/src/GF/Canon/GFCC/CheckGFCC.hs
@@ -25,8 +25,12 @@ checkGFCC gfcc = do
 checkConcrete :: GFCC -> (CId,Concr) -> IO ((CId,Concr),Bool)
 checkConcrete gfcc (lang,cnc) = 
   labelBoolIO ("happened in language " ++ printTree lang) $ do
-    (rs,bs) <- mapM (checkLin gfcc lang) (linRules cnc) >>= return . unzip
+    (rs,bs) <- mapM checkl (Map.assocs cnc) >>= return . unzip
     return ((lang,Map.fromAscList rs),and bs)
+ where
+   checkl r@(CId f,_) = case head f of 
+     '_' -> return (r,True)
+     _   -> checkLin gfcc lang r
 
 checkLin :: GFCC -> CId -> (CId,Term) -> IO ((CId,Term),Bool)
 checkLin gfcc lang (f,t) = 
@@ -89,7 +93,7 @@ checkTerm (args,val) trm = case inferTerm args trm of
     putStrLn $ "term: " ++ printTree trm ++ 
                "\nexpected type: " ++ printTree val ++
                "\ninferred type: " ++ printTree ty
-    return (trm,False)
+    return (t,False)
   Bad s -> do
     putStrLn s
     return (trm,False)
diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs
index 0e3c75501..8b694c3dc 100644
--- a/src/GF/Devel/GFC.hs
+++ b/src/GF/Devel/GFC.hs
@@ -2,6 +2,7 @@ module Main where
 
 import GF.Devel.Compile
 import GF.Devel.GrammarToGFCC
+import GF.Devel.OptimizeGFCC
 import GF.Canon.GFCC.CheckGFCC
 import GF.Canon.GFCC.PrintGFCC
 import GF.Canon.GFCC.DataGFCC
@@ -21,7 +22,8 @@ main = do
       gr <- batchCompile opts fs
       let name = justModuleName (last fs)
       let (abs,gc0) = mkCanon2gfcc opts name gr
-      gc <- check gc0
+      gc1 <- check gc0
+      let gc = if oElem (iOpt "noopt") opts then gc1 else optGFCC gc1
       let target = abs ++ ".gfcc"
       writeFile target (printGFCC gc)
       putStrLn $ "wrote file " ++ target
diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs
index 6a499b21f..0b226acf2 100644
--- a/src/GF/Devel/GrammarToGFCC.hs
+++ b/src/GF/Devel/GrammarToGFCC.hs
@@ -48,7 +48,6 @@ canon2gfcc opts cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
             (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f]
   cncs  = [C.Cnc (i2i lang) (concr m) | (lang,M.ModMod m) <- cms]
   concr mo = cats mo ++ lindefs mo ++ 
-               (if oElem (iOpt "noopt") opts then id else optConcrete) 
                  [C.Lin (i2i f) (mkTerm tr) | 
                    (f,CncFun _ (Yes tr) _) <- tree2list (M.jments mo)]
   cats mo = [C.Lin (i2ic c) (mkCType ty) | 
@@ -355,16 +354,6 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
 
 mkLab k = LIdent (("_" ++ show k))
 
-
-{-
-{CommonScand.VI} ({CommonScand.VSupin} (table ({CommonScand.VType} ) {
-  CommonScand.VAct => {CommonScand.Act} ;
-  CommonScand.VPass => {CommonScand.Pass} ;
-  CommonScand.VRefl => {CommonScand.Act} 
-} ! {CommonScand.VAct}
--}
-
-
 -- remove lock fields; in fact, any empty records and record types
 unlock = filter notlock where
   notlock (l,(_, t)) = case t of --- need not look at l
@@ -378,130 +367,3 @@ unlockTyp = filter notlock where
 prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n
 prTrace  tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
 
--- back-end optimization: 
--- suffix analysis followed by common subexpression elimination
-
-optConcrete :: [C.CncDef] -> [C.CncDef]
-optConcrete defs = subex 
-  [C.Lin f (optTerm t) | C.Lin f t <- defs]
-
--- analyse word form lists into prefix + suffixes
--- suffix sets can later be shared by subex elim
-
-optTerm :: C.Term -> C.Term  
-optTerm tr = case tr of
-    C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts]
-    C.R ts  -> C.R $ map optTerm ts
-    C.P t v -> C.P (optTerm t) v
-    C.L x t -> C.L x (optTerm t)
-    _ -> tr
- where
-  optToks ss = prf : suffs where
-    prf = pref (head ss) (tail ss)
-    suffs = map (drop (length prf)) ss
-    pref cand ss = case ss of
-      s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss
-      _ -> cand
-  isK t = case t of
-    C.K (C.KS _) -> True
-    _ -> False
-  mkSuff ("":ws) = C.R (map (C.K . C.KS) ws)
-  mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws))
-
-
--- common subexpression elimination; see ./Subexpression.hs for the idea
-
-subex :: [C.CncDef] -> [C.CncDef]
-subex js = errVal js $ do
-  (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0)
-  return $ addSubexpConsts tree js
-
-type TermList = Map.Map C.Term (Int,Int) -- number of occs, id
-type TermM a = STM (TermList,Int) a
-
-addSubexpConsts :: TermList -> [C.CncDef] -> [C.CncDef]
-addSubexpConsts tree lins =
-  let opers = sortBy (\ (C.Lin f _) (C.Lin g _) -> compare f g)
-                [C.Lin (fid id) trm | (trm,(_,id)) <- list]
-  in map mkOne $ opers ++ lins
- where
-   mkOne (C.Lin f trm) = (C.Lin f (recomp f trm))
-   recomp f t = case Map.lookup t tree of
-     Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself
-     _ -> case t of
-       C.R ts   -> C.R $ map (recomp f) ts
-       C.S ts   -> C.S $ map (recomp f) ts
-       C.W s t  -> C.W s (recomp f t)
-       C.P t p  -> C.P (recomp f t) (recomp f p)
-       C.RP t p -> C.RP (recomp f t) (recomp f p)
-       C.L x t  -> C.L x (recomp f t)
-       _ -> t
-   fid n = C.CId $ "_" ++ show n
-   list = Map.toList tree
-
-getSubtermsMod :: [C.CncDef] -> TermM TermList
-getSubtermsMod js = do
-  mapM (getInfo collectSubterms) js
-  (tree0,_) <- readSTM
-  return $ Map.filter (\ (nu,_) -> nu > 1) tree0
- where
-   getInfo get (C.Lin f trm) = do
-     get trm
-     return ()
-
-collectSubterms :: C.Term -> TermM ()
-collectSubterms t = case t of
-  C.R ts -> do
-    mapM collectSubterms ts
-    add t
-  C.RP u v -> do
-    collectSubterms v
-    add t
-  C.S ts -> do
-    mapM collectSubterms ts
-    add t
-  C.W s u -> do
-    collectSubterms u
-    add t
-  C.P p u -> do
-    collectSubterms p
-    collectSubterms u
-    add t
-  _ -> return ()
- where
-   add t = do
-     (ts,i) <- readSTM
-     let 
-       ((count,id),next) = case Map.lookup t ts of
-         Just (nu,id) -> ((nu+1,id), i)
-         _ ->            ((1,   i ), i+1)
-     writeSTM (Map.insert t (count,id) ts, next)
-
-{-
--- needed in the past
-isStr tr = case tr of
-     App _ _ -> False
-     QC _ _  -> False
-     EInt _  -> False
-     R rs    -> any (isStr . trmAss) rs
-     FV ts   -> any isStr ts
-     S t _   -> isStr t
-     Empty   -> True
-     T _ cs  -> any isStr [v | (_, v) <- cs]
-     V _ ts  -> any isStr ts
-     P t r   -> case getLab tr of
-       Ok (cat,labs) -> case 
-          Map.lookup (cat,labs) labels of
-            Just (ty,_) -> isStrType ty 
-            _ -> True ---- TODO?
-       _ -> True
-     _ -> True ----
-   trmAss (_,(_, t)) = t
-
-
-isStrType ty = case ty of
-     Sort "Str" -> True
-     RecType ts -> any isStrType [t | (_, t) <- ts]
-     Table _ t -> isStrType t
-     _ -> False
--}
diff --git a/src/GF/Devel/OptimizeGFCC.hs b/src/GF/Devel/OptimizeGFCC.hs
new file mode 100644
index 000000000..27f510828
--- /dev/null
+++ b/src/GF/Devel/OptimizeGFCC.hs
@@ -0,0 +1,121 @@
+module GF.Devel.OptimizeGFCC where
+
+import qualified GF.Canon.GFCC.AbsGFCC as C
+import qualified GF.Canon.GFCC.DataGFCC as D
+import qualified GF.Canon.GFCC.PrintGFCC as Pr
+
+import qualified GF.Infra.Option as O
+
+import GF.Infra.Option
+import GF.Data.Operations
+
+import Data.List
+import Data.Char (isDigit)
+import qualified Data.Map as Map
+import Debug.Trace ----
+
+
+-- back-end optimization: 
+-- suffix analysis followed by common subexpression elimination
+
+optGFCC :: D.GFCC -> D.GFCC
+optGFCC gfcc = gfcc {
+  D.concretes = 
+    Map.fromAscList
+    [(lang, (opt cnc)) | (lang,cnc) <- Map.assocs (D.concretes gfcc)]
+  }
+ where 
+  opt cnc = Map.fromAscList $ subex [(f,optTerm t) | (f,t) <- Map.assocs cnc]
+
+-- analyse word form lists into prefix + suffixes
+-- suffix sets can later be shared by subex elim
+
+optTerm :: C.Term -> C.Term  
+optTerm tr = case tr of
+    C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts]
+    C.R ts  -> C.R $ map optTerm ts
+    C.P t v -> C.P (optTerm t) v
+    C.L x t -> C.L x (optTerm t)
+    _ -> tr
+ where
+  optToks ss = prf : suffs where
+    prf = pref (head ss) (tail ss)
+    suffs = map (drop (length prf)) ss
+    pref cand ss = case ss of
+      s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss
+      _ -> cand
+  isK t = case t of
+    C.K (C.KS _) -> True
+    _ -> False
+  mkSuff ("":ws) = C.R (map (C.K . C.KS) ws)
+  mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws))
+
+
+-- common subexpression elimination; see ./Subexpression.hs for the idea
+
+subex :: [(C.CId,C.Term)] -> [(C.CId,C.Term)]
+subex js = errVal js $ do
+  (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0)
+  return $ addSubexpConsts tree js
+
+type TermList = Map.Map C.Term (Int,Int) -- number of occs, id
+type TermM a = STM (TermList,Int) a
+
+addSubexpConsts :: TermList -> [(C.CId,C.Term)] -> [(C.CId,C.Term)]
+addSubexpConsts tree lins =
+  let opers = sortBy (\ (f,_) (g,_) -> compare f g)
+                [(fid id, trm) | (trm,(_,id)) <- list]
+  in map mkOne $ opers ++ lins
+ where
+   mkOne (f,trm) = (f, recomp f trm)
+   recomp f t = case Map.lookup t tree of
+     Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself
+     _ -> case t of
+       C.R ts   -> C.R $ map (recomp f) ts
+       C.S ts   -> C.S $ map (recomp f) ts
+       C.W s t  -> C.W s (recomp f t)
+       C.P t p  -> C.P (recomp f t) (recomp f p)
+       C.RP t p -> C.RP (recomp f t) (recomp f p)
+       C.L x t  -> C.L x (recomp f t)
+       _ -> t
+   fid n = C.CId $ "_" ++ show n
+   list = Map.toList tree
+
+getSubtermsMod :: [(C.CId,C.Term)] -> TermM TermList
+getSubtermsMod js = do
+  mapM (getInfo collectSubterms) js
+  (tree0,_) <- readSTM
+  return $ Map.filter (\ (nu,_) -> nu > 1) tree0
+ where
+   getInfo get (f,trm) = do
+     get trm
+     return ()
+
+collectSubterms :: C.Term -> TermM ()
+collectSubterms t = case t of
+  C.R ts -> do
+    mapM collectSubterms ts
+    add t
+  C.RP u v -> do
+    collectSubterms v
+    add t
+  C.S ts -> do
+    mapM collectSubterms ts
+    add t
+  C.W s u -> do
+    collectSubterms u
+    add t
+  C.P p u -> do
+    collectSubterms p
+    collectSubterms u
+    add t
+  _ -> return ()
+ where
+   add t = do
+     (ts,i) <- readSTM
+     let 
+       ((count,id),next) = case Map.lookup t ts of
+         Just (nu,id) -> ((nu+1,id), i)
+         _ ->            ((1,   i ), i+1)
+     writeSTM (Map.insert t (count,id) ts, next)
+