gf works with the new gfcc format

1 files changed, 116 insertions, 0 deletions

diff --git a/src/GF/GFCC/OptimizeGFCC.hs b/src/GF/GFCC/OptimizeGFCC.hs
new file mode 100644
index 000000000..68ee66c42
--- /dev/null
+++ b/src/GF/GFCC/OptimizeGFCC.hs
@@ -0,0 +1,116 @@
+module GF.GFCC.OptimizeGFCC where
+
+import GF.GFCC.AbsGFCC
+import GF.GFCC.DataGFCC
+
+import GF.Data.Operations
+
+import Data.List
+import qualified Data.Map as Map
+
+
+-- back-end optimization: 
+-- suffix analysis followed by common subexpression elimination
+
+optGFCC :: GFCC -> GFCC
+optGFCC gfcc = gfcc {
+  concretes = Map.map opt (concretes gfcc)
+  }
+ where 
+  opt cnc = subex $ cnc {
+    lins = Map.map optTerm (lins cnc),
+    lindefs = Map.map optTerm (lindefs cnc),
+    printnames = Map.map optTerm (printnames cnc)
+  }
+
+-- analyse word form lists into prefix + suffixes
+-- suffix sets can later be shared by subex elim
+
+optTerm :: Term -> Term  
+optTerm tr = case tr of
+    R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | K (KS s) <- ts]
+    R ts  -> R $ map optTerm ts
+    P t v -> P (optTerm t) v
+    _ -> 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
+    K (KS _) -> True
+    _ -> False
+  mkSuff ("":ws) = R (map (K . KS) ws)
+  mkSuff (p:ws) = W p (R (map (K . KS) ws))
+
+
+-- common subexpression elimination
+
+---subex :: [(CId,Term)] -> [(CId,Term)]
+subex :: Concr -> Concr
+subex cnc = errVal cnc $ do
+  (tree,_) <- appSTM (getSubtermsMod cnc) (Map.empty,0)
+  return $ addSubexpConsts tree cnc
+
+type TermList = Map.Map Term (Int,Int) -- number of occs, id
+type TermM a = STM (TermList,Int) a
+
+addSubexpConsts :: TermList -> Concr -> Concr
+addSubexpConsts tree cnc = cnc {
+  opers = Map.fromList [(f,recomp f trm) | (f,trm) <- ops],
+  lins  = rec lins,
+  lindefs = rec lindefs,
+  printnames = rec printnames
+  }
+ where
+   ops = [(fid id, trm) | (trm,(_,id)) <- Map.assocs tree]
+   mkOne (f,trm) = (f, recomp f trm)
+   recomp f t = case Map.lookup t tree of
+     Just (_,id) | fid id /= f -> F $ fid id -- not to replace oper itself
+     _ -> case t of
+       R ts   -> R $ map (recomp f) ts
+       S ts   -> S $ map (recomp f) ts
+       W s t  -> W s (recomp f t)
+       P t p  -> P (recomp f t) (recomp f p)
+       _ -> t
+   fid n = CId $ "_" ++ show n
+   rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]
+
+
+getSubtermsMod :: Concr -> TermM TermList
+getSubtermsMod cnc = do
+  mapM getSubterms (Map.assocs (lins cnc))
+  mapM getSubterms (Map.assocs (lindefs cnc))
+  mapM getSubterms (Map.assocs (printnames cnc))
+  (tree0,_) <- readSTM
+  return $ Map.filter (\ (nu,_) -> nu > 1) tree0
+ where
+   getSubterms (f,trm) = collectSubterms trm >> return ()
+
+collectSubterms :: Term -> TermM ()
+collectSubterms t = case t of
+  R ts -> do
+    mapM collectSubterms ts
+    add t
+  S ts -> do
+    mapM collectSubterms ts
+    add t
+  W s u -> do
+    collectSubterms u
+    add t
+  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)
+