From 055c0d0d5a5bb0dc75904fe53df7f2e4f5732a8f Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 21 May 2008 09:26:44 +0000 Subject: GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3 --- src-3.0/GF/Canon/Subexpressions.hs | 170 +++++++++++++++++++++++++++++++++++++ 1 file changed, 170 insertions(+) create mode 100644 src-3.0/GF/Canon/Subexpressions.hs (limited to 'src-3.0/GF/Canon/Subexpressions.hs') diff --git a/src-3.0/GF/Canon/Subexpressions.hs b/src-3.0/GF/Canon/Subexpressions.hs new file mode 100644 index 000000000..683f9eecf --- /dev/null +++ b/src-3.0/GF/Canon/Subexpressions.hs @@ -0,0 +1,170 @@ +---------------------------------------------------------------------- +-- | +-- Module : Subexpressions +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/20 09:32:56 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.4 $ +-- +-- Common subexpression elimination. +-- all tables. AR 18\/9\/2005. +----------------------------------------------------------------------------- + +module GF.Canon.Subexpressions ( + elimSubtermsMod, prSubtermStat, unSubelimCanon, unSubelimModule + ) where + +import GF.Canon.AbsGFC +import GF.Infra.Ident +import GF.Canon.GFC +import GF.Canon.Look +import GF.Grammar.PrGrammar +import GF.Canon.CMacros as C +import GF.Data.Operations +import qualified GF.Infra.Modules as M + +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List + +{- +This module implements a simple common subexpression elimination + for gfc grammars, to factor out shared subterms in lin rules. +It works in three phases: + + (1) collectSubterms collects recursively all subterms of forms table and (P x..y) + from lin definitions (experience shows that only these forms + tend to get shared) and counts how many times they occur + (2) addSubexpConsts takes those subterms t that occur more than once + and creates definitions of form "oper A''n = t" where n is a + fresh number; notice that we assume no ids of this form are in + scope otherwise + (3) elimSubtermsMod goes through lins and the created opers by replacing largest + possible subterms by the newly created identifiers + +The optimization is invoked in gf by the flag i -subs. + +If an application does not support GFC opers, the effect of this +optimization can be undone by the function unSubelimCanon. + +The function unSubelimCanon can be used to diagnostisize how much +cse is possible in the grammar. It is used by the flag pg -printer=subs. + +-} + +-- exported functions + +elimSubtermsMod :: (Ident,CanonModInfo) -> Err (Ident, CanonModInfo) +elimSubtermsMod (mo,m) = case m of + M.ModMod (M.Module mt st fs me ops js) -> do + (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0) + js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js + return (mo,M.ModMod (M.Module mt st fs me ops js2)) + _ -> return (mo,m) + +prSubtermStat :: CanonGrammar -> String +prSubtermStat gr = unlines [prt mo ++++ expsIn mo js | (mo,js) <- mos] where + mos = [(i, tree2list (M.jments m)) | (i, M.ModMod m) <- M.modules gr, M.isModCnc m] + expsIn mo js = err id id $ do + (tree,_) <- appSTM (getSubtermsMod mo js) (Map.empty,0) + let list0 = Map.toList tree + let list1 = sortBy (\ (_,(m,_)) (_,(n,_)) -> compare n m) list0 + return $ unlines [show n ++ "\t" ++ prt trm | (trm,(n,_)) <- list1] + +unSubelimCanon :: CanonGrammar -> CanonGrammar +unSubelimCanon gr@(M.MGrammar modules) = + M.MGrammar $ map unSubelimModule modules + +unSubelimModule :: CanonModule -> CanonModule +unSubelimModule mo@(i,m) = case m of + M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) | hasSub ljs -> + (i, M.ModMod (M.Module mt st fs me ops + (rebuild (map unparInfo ljs)))) + where ljs = tree2list js + _ -> (i,m) + where + -- perform this iff the module has opers + hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] + unparInfo (c,info) = case info of + CncFun k xs t m -> [(c, CncFun k xs (unparTerm t) m)] + ResOper _ _ -> [] + _ -> [(c,info)] + unparTerm t = case t of + I c -> errVal t $ liftM unparTerm $ lookupGlobal gr c + _ -> C.composSafeOp unparTerm t + gr = M.MGrammar [mo] + rebuild = buildTree . concat + +-- implementation + +type TermList = Map Term (Int,Int) -- number of occs, id +type TermM a = STM (TermList,Int) a + +addSubexpConsts :: Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)] +addSubexpConsts mo tree lins = do + let opers = [oper id trm | (trm,(_,id)) <- list] + mapM mkOne $ opers ++ lins + where + + mkOne (f,def) = case def of + CncFun ci xs trm pn -> do + trm' <- recomp f trm + return (f,CncFun ci xs trm' pn) + ResOper ty trm -> do + trm' <- recomp f trm + return (f,ResOper ty trm') + _ -> return (f,def) + recomp f t = case Map.lookup t tree of + Just (_,id) | ident id /= f -> return $ I $ cident mo id + _ -> composOp (recomp f) t + + list = Map.toList tree + + oper id trm = (ident id, ResOper TStr trm) --- type TStr does not matter + +getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) +getSubtermsMod mo js = do + mapM (getInfo (collectSubterms mo)) js + (tree0,_) <- readSTM + return $ Map.filter (\ (nu,_) -> nu > 1) tree0 + where + getInfo get fi@(f,i) = case i of + CncFun ci xs trm pn -> do + get trm + return $ fi + ResOper ty trm -> do + get trm + return $ fi + _ -> return fi + +collectSubterms :: Ident -> Term -> TermM Term +collectSubterms mo t = case t of + Par _ (_:_) -> add t + T ty cs -> do + let (ps,ts) = unzip [(p,t) | Cas p t <- cs] + mapM (collectSubterms mo) ts + add t + V ty ts -> do + mapM (collectSubterms mo) ts + add t + K (KP _ _) -> add t + _ -> composOp (collectSubterms mo) t + 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) + return t --- only because of composOp + +ident :: Int -> Ident +ident i = identC ("A''" ++ show i) --- + +cident :: Ident -> Int -> CIdent +cident mo = CIQ mo . ident -- cgit v1.2.3