From 48ebf562b9bfcacff7c0fabeaa5892f31ddd3e1c Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Thu, 4 Oct 2007 21:38:59 +0000
Subject: new GFCC format in GF/GFCC

---
 src/GF/Devel/OptimizeGFCC.hs | 105 +++++++++++++++++++++----------------------
 1 file changed, 50 insertions(+), 55 deletions(-)

(limited to 'src/GF/Devel/OptimizeGFCC.hs')

diff --git a/src/GF/Devel/OptimizeGFCC.hs b/src/GF/Devel/OptimizeGFCC.hs
index 27f510828..78d03911f 100644
--- a/src/GF/Devel/OptimizeGFCC.hs
+++ b/src/GF/Devel/OptimizeGFCC.hs
@@ -1,41 +1,36 @@
 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 GF.GFCC.AbsGFCC
+import GF.GFCC.DataGFCC
 
-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
 optGFCC gfcc = gfcc {
-  D.concretes = 
-    Map.fromAscList
-    [(lang, (opt cnc)) | (lang,cnc) <- Map.assocs (D.concretes gfcc)]
+  concretes = Map.map opt (concretes gfcc)
   }
  where 
-  opt cnc = Map.fromAscList $ subex [(f,optTerm t) | (f,t) <- Map.assocs cnc]
+  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 :: C.Term -> C.Term  
+optTerm :: Term -> 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)
+    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
@@ -45,67 +40,67 @@ optTerm tr = case tr 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
+    K (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))
+  mkSuff ("":ws) = R (map (K . KS) ws)
+  mkSuff (p:ws) = W p (R (map (K . KS) ws))
 
 
--- common subexpression elimination; see ./Subexpression.hs for the idea
+-- common subexpression elimination
 
-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
+---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 C.Term (Int,Int) -- number of occs, id
+type TermList = Map.Map 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
+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 -> C.F $ fid id -- not to replace oper itself
+     Just (_,id) | fid id /= f -> 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)
+       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 = C.CId $ "_" ++ show n
-   list = Map.toList tree
+   fid n = CId $ "_" ++ show n
+   rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]
 
-getSubtermsMod :: [(C.CId,C.Term)] -> TermM TermList
-getSubtermsMod js = do
-  mapM (getInfo collectSubterms) js
+
+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
-   getInfo get (f,trm) = do
-     get trm
-     return ()
+   getSubterms (f,trm) = collectSubterms trm >> return ()
 
-collectSubterms :: C.Term -> TermM ()
+collectSubterms :: Term -> TermM ()
 collectSubterms t = case t of
-  C.R ts -> do
+  R ts -> do
     mapM collectSubterms ts
     add t
-  C.RP u v -> do
-    collectSubterms v
-    add t
-  C.S ts -> do
+  S ts -> do
     mapM collectSubterms ts
     add t
-  C.W s u -> do
+  W s u -> do
     collectSubterms u
     add t
-  C.P p u -> do
+  P p u -> do
     collectSubterms p
     collectSubterms u
     add t
-- 
cgit v1.2.3