diff options
Diffstat (limited to 'src/GF/GFCC/OptimizeGFCC.hs')
| -rw-r--r-- | src/GF/GFCC/OptimizeGFCC.hs | 116 |
1 files changed, 0 insertions, 116 deletions
diff --git a/src/GF/GFCC/OptimizeGFCC.hs b/src/GF/GFCC/OptimizeGFCC.hs deleted file mode 100644 index 394458041..000000000 --- a/src/GF/GFCC/OptimizeGFCC.hs +++ /dev/null @@ -1,116 +0,0 @@ -module GF.GFCC.OptimizeGFCC where - -import GF.GFCC.CId -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) - |
