summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/Compile.hs8
-rw-r--r--src/GF/Compile/BackOpt.hs104
-rw-r--r--src/GF/Compile/GrammarToGFCC.hs19
-rw-r--r--src/GF/Compile/Optimize.hs70
-rw-r--r--src/GF/Compile/OptimizeGF.hs270
-rw-r--r--src/GF/Compile/SubExOpt.hs142
-rw-r--r--src/GF/Infra/Option.hs17
7 files changed, 223 insertions, 407 deletions
diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs
index 33f5e44ea..e0c60178e 100644
--- a/src/GF/Compile.hs
+++ b/src/GF/Compile.hs
@@ -5,7 +5,7 @@ import GF.Compile.GetGrammar
import GF.Compile.Rename
import GF.Compile.CheckGrammar
import GF.Compile.Optimize
-import GF.Compile.OptimizeGF
+import GF.Compile.SubExOpt
import GF.Compile.OptimizeGFCC
import GF.Compile.GrammarToGFCC
import GF.Compile.ReadFiles
@@ -183,10 +183,8 @@ compileOne opts env@(_,srcgr,_) file = do
intermOut opts DumpSource (ppModule Qualified sm0)
(k',sm) <- compileSourceModule opts env sm0
- let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str
- cm <- putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm1
- -- sm is optimized before generation, but not in the env
- extendCompileEnvInt env k' (Just gfo) sm1
+ putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm
+ extendCompileEnvInt env k' (Just gfo) sm
where
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
diff --git a/src/GF/Compile/BackOpt.hs b/src/GF/Compile/BackOpt.hs
deleted file mode 100644
index 70dbcc9ba..000000000
--- a/src/GF/Compile/BackOpt.hs
+++ /dev/null
@@ -1,104 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : BackOpt
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:21:33 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- Optimizations on GF source code: sharing, parametrization, value sets.
---
--- optimization: sharing branches in tables. AR 25\/4\/2003.
--- following advice of Josef Svenningsson
------------------------------------------------------------------------------
-
-module GF.Compile.BackOpt (shareModule) where
-
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Infra.Option
-import qualified GF.Grammar.Macros as C
-import GF.Data.Operations
-import Data.List
-import qualified GF.Infra.Modules as M
-import qualified Data.ByteString.Char8 as BS
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-shareModule :: Options -> SourceModule -> SourceModule
-shareModule opts (i,mo) = (i,M.replaceJudgements mo (mapTree (shareInfo optim) (M.jments mo)))
- where
- optim = flag optOptimizations opts
-
-type OptSpec = Set Optimization
-
-shareInfo :: OptSpec -> (Ident, Info) -> Info
-shareInfo opt (c, CncCat ty (Just t) m) = CncCat ty (Just (shareOptim opt c t)) m
-shareInfo opt (c, CncFun kxs (Just t) m) = CncFun kxs (Just (shareOptim opt c t)) m
-shareInfo opt (c, ResOper ty (Just t)) = ResOper ty (Just (shareOptim opt c t))
-shareInfo _ (_,i) = i
-
--- the function putting together optimizations
-shareOptim :: OptSpec -> Ident -> Term -> Term
-shareOptim opt c = (if OptValues `Set.member` opt then values else id)
- . (if OptParametrize `Set.member` opt then factor c 0 else id)
-
--- do even more: factor parametric branches
-
-factor :: Ident -> Int -> Term -> Term
-factor c i t = case t of
- T _ [_] -> t
- T _ [] -> t
- T (TComp ty) cs ->
- T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
- _ -> C.composSafeOp (factor c i) t
- where
-
- factors i psvs = -- we know psvs has at least 2 elements
- let p = qqIdent c i
- vs' = map (mkFun p) psvs
- in if allEqs vs'
- then mkCase p vs'
- else psvs
-
- mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
-
- allEqs (v:vs) = all (==v) vs
-
- mkCase p (v:_) = [(PV p, v)]
-
---- we hope this will be fresh and don't check... in GFC would be safe
-
-qqIdent c i = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i))
-
-
--- we need to replace subterms
-
-replace :: Term -> Term -> Term -> Term
-replace old new trm = case trm of
-
- -- these are the important cases, since they can correspond to patterns
- QC _ _ | trm == old -> new
- App t ts | trm == old -> new
- App t ts -> App (repl t) (repl ts)
- R _ | isRec && trm == old -> new
- _ -> C.composSafeOp repl trm
- where
- repl = replace old new
- isRec = case trm of
- R _ -> True
- _ -> False
-
--- It is very important that this is performed only after case
--- expansion since otherwise the order and number of values can
--- be incorrect. Guaranteed by the TComp flag.
-
-values :: Term -> Term
-values t = case t of
- T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization
- T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
- _ -> C.composSafeOp values t
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index a022d4f43..fb92ef74c 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -2,7 +2,6 @@
module GF.Compile.GrammarToGFCC (mkCanon2gfcc,addParsers) where
import GF.Compile.Export
-import GF.Compile.OptimizeGF (unshareModule)
import qualified GF.Compile.GenerateFCFG as FCFG
import qualified GF.Compile.GeneratePMCFG as PMCFG
@@ -298,8 +297,8 @@ canon2canon opts abs cg0 =
j2j cg (f,j) =
let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in
case j of
- CncFun x (Just tr) z -> CncFun x (Just (debug (t2t tr))) z
- CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t x)) y
+ CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z
+ CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y
_ -> j
where
cg1 = cg
@@ -307,6 +306,17 @@ canon2canon opts abs cg0 =
ty2ty = type2type cg1 pv
pv@(labels,untyps,typs) = trs $ paramValues cg1
+ unfactor :: SourceGrammar -> Term -> Term
+ unfactor gr t = case t of
+ T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty]
+ _ -> GM.composSafeOp unfac t
+ where
+ unfac = unfactor gr
+ vals = err error id . Look.allParamValues gr
+ restore x u t = case t of
+ Vr y | y == x -> u
+ _ -> GM.composSafeOp (restore x u) t
+
-- flatten record arguments of param constructors
p2p (f,j) = case j of
ResParam (Just ps) (Just vs) ->
@@ -334,7 +344,7 @@ canon2canon opts abs cg0 =
purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
purgeGrammar abstr gr =
- (M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr
+ (M.MGrammar . list . filter complete . purge . M.modules) gr
where
list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
@@ -342,7 +352,6 @@ purgeGrammar abstr gr =
acncs = abstr : M.allConcretes gr abstr
isSingle = True
complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon
- unopt = unshareModule gr -- subexp elim undone when compiled
type ParamEnv =
(Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
index ed7384e89..2c556b36f 100644
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -24,7 +24,6 @@ import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Compile.Refresh
import GF.Compile.Concrete.Compute
-import GF.Compile.BackOpt
import GF.Compile.CheckGrammar
import GF.Compile.Update
@@ -37,6 +36,7 @@ import Data.List
import qualified Data.Set as Set
import Text.PrettyPrint
import Debug.Trace
+import qualified Data.ByteString.Char8 as BS
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
@@ -46,7 +46,7 @@ optimizeModule opts ms m@(name,mi)
| mstatus mi == MSComplete = do
ids <- topoSortJments m
mi <- foldM updateEvalInfo mi ids
- return (shareModule oopts (name,mi))
+ return (name,mi)
| otherwise = return m
where
oopts = opts `addOptions` flagsModule m
@@ -64,10 +64,13 @@ evalInfo opts ms m c info = do
CncCat ptyp pde ppr -> do
pde' <- case (ptyp,pde) of
- (Just typ, Just de) ->
- liftM Just $ partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
- (Just typ, Nothing) ->
- liftM Just $ mkLinDefault gr typ >>= partEval noOptions gr ([(Explicit, varStr, typeStr)],typ)
+ (Just typ, Just de) -> do
+ de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
+ return (Just (factor param c 0 de))
+ (Just typ, Nothing) -> do
+ de <- mkLinDefault gr typ
+ de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
+ return (Just (factor param c 0 de))
_ -> return pde -- indirection
ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c)
@@ -77,7 +80,8 @@ evalInfo opts ms m c info = do
CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
pde' <- case pde of
- Just de -> liftM Just $ partEval opts gr (cont,val) de
+ Just de -> do de <- partEval opts gr (cont,val) de
+ return (Just (factor param c 0 de))
Nothing -> return pde
ppr' <- liftM Just $ evalPrintname gr c ppr pde'
return $ CncFun mt pde' ppr' -- only cat in type actually needed
@@ -85,7 +89,8 @@ evalInfo opts ms m c info = do
ResOper pty pde
| OptExpand `Set.member` optim -> do
pde' <- case pde of
- Just de -> liftM Just $ computeConcrete gr de
+ Just de -> do de <- computeConcrete gr de
+ return (Just (factor param c 0 de))
Nothing -> return Nothing
return $ ResOper pty pde'
@@ -93,6 +98,7 @@ evalInfo opts ms m c info = do
where
gr = MGrammar (m : ms)
optim = flag optOptimizations opts
+ param = OptParametrize `Set.member` optim
eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
-- | the main function for compiling linearizations
@@ -132,17 +138,13 @@ recordExpand typ trm = case typ of
-- | auxiliaries for compiling the resource
mkLinDefault :: SourceGrammar -> Type -> Err Term
-mkLinDefault gr typ = do
- case typ of
- RecType lts -> mapPairsM mkDefField lts >>= (return . Abs Explicit varStr . R . mkAssign)
- _ -> liftM (Abs Explicit varStr) $ mkDefField typ
----- _ -> prtBad "linearization type must be a record type, not" typ
+mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
where
mkDefField typ = case typ of
Table p t -> do
t' <- mkDefField t
let T _ cs = mkWildCases t'
- return $ T (TWild p) cs
+ return $ T (TWild p) cs
Sort s | s == cStr -> return $ Vr varStr
QC q p -> do vs <- lookupParamValues gr q p
case vs of
@@ -150,8 +152,8 @@ mkLinDefault gr typ = do
_ -> Bad (render (text "no parameter values given to type" <+> ppIdent p))
RecType r -> do
let (ls,ts) = unzip r
- ts' <- mapM mkDefField ts
- return $ R $ [assign l t | (l,t) <- zip ls ts']
+ ts <- mapM mkDefField ts
+ return $ R (zipWith assign ls ts)
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
@@ -188,3 +190,39 @@ evalPrintname gr c ppr lin =
c:cs -> c: clean cs
_ -> s
+
+-- do even more: factor parametric branches
+
+factor :: Bool -> Ident -> Int -> Term -> Term
+factor param c i t =
+ case t of
+ T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
+ _ -> composSafeOp (factor param c i) t
+ where
+ factors ty pvs0
+ | not param = V ty (map snd pvs0)
+ factors ty [] = V ty []
+ factors ty pvs0@[(p,v)] = V ty [v]
+ factors ty pvs0@(pv:pvs) =
+ let t = mkFun pv
+ ts = map mkFun pvs
+ in if all (==t) ts
+ then T (TTyped ty) (mkCases t)
+ else V ty (map snd pvs0)
+
+ --- we hope this will be fresh and don't check... in GFC would be safe
+ qvar = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i))
+
+ mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val
+ mkCases t = [(PV qvar, t)]
+
+-- we need to replace subterms
+replace :: Term -> Term -> Term -> Term
+replace old new trm =
+ case trm of
+ -- these are the important cases, since they can correspond to patterns
+ QC _ _ | trm == old -> new
+ App _ _ | trm == old -> new
+ R _ | trm == old -> new
+ App x y -> App (replace old new x) (replace old new y)
+ _ -> composSafeOp (replace old new) trm
diff --git a/src/GF/Compile/OptimizeGF.hs b/src/GF/Compile/OptimizeGF.hs
deleted file mode 100644
index d68ede00b..000000000
--- a/src/GF/Compile/OptimizeGF.hs
+++ /dev/null
@@ -1,270 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : OptimizeGF
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:21:33 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- Optimizations on GF source code: sharing, parametrization, value sets.
---
--- optimization: sharing branches in tables. AR 25\/4\/2003.
--- following advice of Josef Svenningsson
------------------------------------------------------------------------------
-
-module GF.Compile.OptimizeGF (
- optModule,unshareModule,unsubexpModule,unoptModule,subexpModule,shareModule
- ) where
-
-import GF.Grammar.Grammar
-import GF.Grammar.Lookup
-import GF.Infra.Ident
-import qualified GF.Grammar.Macros as C
-import qualified GF.Infra.Modules as M
-import GF.Data.Operations
-
-import Control.Monad
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.ByteString.Char8 as BS
-import Data.List
-
-optModule :: SourceModule -> SourceModule
-optModule = subexpModule . shareModule
-
-shareModule = processModule optim
-
-unoptModule :: SourceGrammar -> SourceModule -> SourceModule
-unoptModule gr = unshareModule gr . unsubexpModule
-
-unshareModule :: SourceGrammar -> SourceModule -> SourceModule
-unshareModule gr = processModule (const (unoptim gr))
-
-processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule
-processModule opt (i,mo) = (i,M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))
-
-shareInfo :: (Ident -> Term -> Term) -> (Ident,Info) -> Info
-shareInfo opt (c, CncCat ty (Just t) m) = CncCat ty (Just (opt c t)) m
-shareInfo opt (c, CncFun kxs (Just t) m) = CncFun kxs (Just (opt c t)) m
-shareInfo opt (c, ResOper ty (Just t)) = ResOper ty (Just (opt c t))
-shareInfo _ (_,i) = i
-
--- the function putting together optimizations
-optim :: Ident -> Term -> Term
-optim c = values . factor c 0
-
--- we need no counter to create new variable names, since variables are
--- local to tables (only true in GFC) ---
-
--- factor parametric branches
-
-factor :: Ident -> Int -> Term -> Term
-factor c i t = case t of
- T _ [_] -> t
- T _ [] -> t
- T (TComp ty) cs ->
- T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
- _ -> C.composSafeOp (factor c i) t
- where
-
- factors i psvs = -- we know psvs has at least 2 elements
- let p = qqIdent c i
- vs' = map (mkFun p) psvs
- in if allEqs vs'
- then mkCase p vs'
- else psvs
-
- mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
-
- allEqs (v:vs) = all (==v) vs
-
- mkCase p (v:_) = [(PV p, v)]
-
---- we hope this will be fresh and don't check... in GFC would be safe
-
-qqIdent c i = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i))
-
-
--- we need to replace subterms
-
-replace :: Term -> Term -> Term -> Term
-replace old new trm = case trm of
-
- -- these are the important cases, since they can correspond to patterns
- QC _ _ | trm == old -> new
- App t ts | trm == old -> new
- App t ts -> App (repl t) (repl ts)
- R _ | isRec && trm == old -> new
- _ -> C.composSafeOp repl trm
- where
- repl = replace old new
- isRec = case trm of
- R _ -> True
- _ -> False
-
--- It is very important that this is performed only after case
--- expansion since otherwise the order and number of values can
--- be incorrect. Guaranteed by the TComp flag.
-
-values :: Term -> Term
-values t = case t of
- T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization
- T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
- T (TTyped ty) cs -> V ty [values t | (_, t) <- cs]
- ---- why are these left?
- ---- printing with GrammarToSource does not preserve the distinction
- _ -> C.composSafeOp values t
-
-
--- to undo the effect of factorization
-
-unoptim :: SourceGrammar -> Term -> Term
-unoptim gr = unfactor gr
-
-unfactor :: SourceGrammar -> Term -> Term
-unfactor gr t = case t of
- T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty]
- _ -> C.composSafeOp unfac t
- where
- unfac = unfactor gr
- vals = err error id . allParamValues gr
- restore x u t = case t of
- Vr y | y == x -> u
- _ -> C.composSafeOp (restore x u) t
-
-
-----------------------------------------------------------------------
-
-{-
-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.
-
--}
-
-subexpModule :: SourceModule -> SourceModule
-subexpModule (n,mo) = errVal (n,mo) $ do
- let ljs = tree2list (M.jments mo)
- (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
- js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
- return (n,M.replaceJudgements mo js2)
-
-unsubexpModule :: SourceModule -> SourceModule
-unsubexpModule sm@(i,mo)
- | hasSub ljs = (i,M.replaceJudgements mo (rebuild (map unparInfo ljs)))
- | otherwise = sm
- where
- ljs = tree2list (M.jments mo)
-
- -- perform this iff the module has opers
- hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
- unparInfo (c,info) = case info of
- CncFun xs (Just t) m -> [(c, CncFun xs (Just (unparTerm t)) m)]
- ResOper (Just (EInt 8)) _ -> [] -- subexp-generated opers
- ResOper pty (Just t) -> [(c, ResOper pty (Just (unparTerm t)))]
- _ -> [(c,info)]
- unparTerm t = case t of
- Q m c | isOperIdent c -> --- name convention of subexp opers
- errVal t $ liftM unparTerm $ lookupResDef gr m c
- _ -> C.composSafeOp unparTerm t
- gr = M.MGrammar [sm]
- 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 xs (Just trm) pn -> do
- trm' <- recomp f trm
- return (f,CncFun xs (Just trm') pn)
- ResOper ty (Just trm) -> do
- trm' <- recomp f trm
- return (f,ResOper ty (Just trm'))
- _ -> return (f,def)
- recomp f t = case Map.lookup t tree of
- Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id)
- _ -> C.composOp (recomp f) t
-
- list = Map.toList tree
-
- oper id trm = (operIdent id, ResOper (Just (EInt 8)) (Just trm))
- --- impossible type encoding generated opers
-
-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 xs (Just trm) pn -> do
- get trm
- return $ fi
- ResOper ty (Just trm) -> do
- get trm
- return $ fi
- _ -> return fi
-
-collectSubterms :: Ident -> Term -> TermM Term
-collectSubterms mo t = case t of
- App f a -> do
- collect f
- collect a
- add t
- T ty cs -> do
- let (_,ts) = unzip cs
- mapM collect ts
- add t
- V ty ts -> do
- mapM collect ts
- add t
----- K (KP _ _) -> add t
- _ -> C.composOp (collectSubterms mo) t
- where
- collect = collectSubterms mo
- 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
-
-operIdent :: Int -> Ident
-operIdent i = identC (operPrefix `BS.append` (BS.pack (show i))) ---
-
-isOperIdent :: Ident -> Bool
-isOperIdent id = BS.isPrefixOf operPrefix (ident2bs id)
-
-operPrefix = BS.pack ("A''")
diff --git a/src/GF/Compile/SubExOpt.hs b/src/GF/Compile/SubExOpt.hs
new file mode 100644
index 000000000..c7dbb5d3d
--- /dev/null
+++ b/src/GF/Compile/SubExOpt.hs
@@ -0,0 +1,142 @@
+----------------------------------------------------------------------
+-- |
+-- Module : SubExOpt
+-- Maintainer : AR
+-- Stability : (stable)
+-- Portability : (portable)
+--
+-- This module implements a simple common subexpression elimination
+-- for .gfo 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
+--
+-----------------------------------------------------------------------------
+
+module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Lookup
+import GF.Infra.Ident
+import qualified GF.Grammar.Macros as C
+import qualified GF.Infra.Modules as M
+import GF.Data.Operations
+
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.ByteString.Char8 as BS
+import Data.List
+
+subexpModule :: SourceModule -> SourceModule
+subexpModule (n,mo) = errVal (n,mo) $ do
+ let ljs = tree2list (M.jments mo)
+ (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
+ js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
+ return (n,M.replaceJudgements mo js2)
+
+unsubexpModule :: SourceModule -> SourceModule
+unsubexpModule sm@(i,mo)
+ | hasSub ljs = (i,M.replaceJudgements mo (rebuild (map unparInfo ljs)))
+ | otherwise = sm
+ where
+ ljs = tree2list (M.jments mo)
+
+ -- perform this iff the module has opers
+ hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
+ unparInfo (c,info) = case info of
+ CncFun xs (Just t) m -> [(c, CncFun xs (Just (unparTerm t)) m)]
+ ResOper (Just (EInt 8)) _ -> [] -- subexp-generated opers
+ ResOper pty (Just t) -> [(c, ResOper pty (Just (unparTerm t)))]
+ _ -> [(c,info)]
+ unparTerm t = case t of
+ Q m c | isOperIdent c -> --- name convention of subexp opers
+ errVal t $ liftM unparTerm $ lookupResDef gr m c
+ _ -> C.composSafeOp unparTerm t
+ gr = M.MGrammar [sm]
+ 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 xs (Just trm) pn -> do
+ trm' <- recomp f trm
+ return (f,CncFun xs (Just trm') pn)
+ ResOper ty (Just trm) -> do
+ trm' <- recomp f trm
+ return (f,ResOper ty (Just trm'))
+ _ -> return (f,def)
+ recomp f t = case Map.lookup t tree of
+ Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id)
+ _ -> C.composOp (recomp f) t
+
+ list = Map.toList tree
+
+ oper id trm = (operIdent id, ResOper (Just (EInt 8)) (Just trm))
+ --- impossible type encoding generated opers
+
+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 xs (Just trm) pn -> do
+ get trm
+ return $ fi
+ ResOper ty (Just trm) -> do
+ get trm
+ return $ fi
+ _ -> return fi
+
+collectSubterms :: Ident -> Term -> TermM Term
+collectSubterms mo t = case t of
+ App f a -> do
+ collect f
+ collect a
+ add t
+ T ty cs -> do
+ let (_,ts) = unzip cs
+ mapM collect ts
+ add t
+ V ty ts -> do
+ mapM collect ts
+ add t
+---- K (KP _ _) -> add t
+ _ -> C.composOp (collectSubterms mo) t
+ where
+ collect = collectSubterms mo
+ 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
+
+operIdent :: Int -> Ident
+operIdent i = identC (operPrefix `BS.append` (BS.pack (show i))) ---
+
+isOperIdent :: Ident -> Bool
+isOperIdent id = BS.isPrefixOf operPrefix (ident2bs id)
+
+operPrefix = BS.pack ("A''")
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index 2963da609..dc15d1929 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -109,7 +109,7 @@ data SISRFormat =
| SISR_1_0
deriving (Show,Eq,Ord)
-data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues
+data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
deriving (Show,Eq,Ord)
data CFGTransform = CFGNoLR
@@ -268,7 +268,7 @@ defaultFlags = Flags {
optResName = Nothing,
optPreprocessors = [],
optEncoding = ISO_8859_1,
- optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues],
+ optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
CFGTopDownFilter, CFGMergeIdentical],
optLibraryPath = [],
@@ -474,12 +474,15 @@ instance Read OutputFormat where
optimizationPackages :: [(String, Set Optimization)]
optimizationPackages =
- [("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), -- deprecated
- ("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]),
- ("values", Set.fromList [OptStem,OptCSE,OptExpand,OptValues]),
+ [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
+ ("values", Set.fromList [OptStem,OptCSE,OptExpand]),
+ ("noexpand", Set.fromList [OptStem,OptCSE]),
+
+ -- deprecated
+ ("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
- ("none", Set.fromList [OptStem,OptCSE,OptExpand]),
- ("noexpand", Set.fromList [OptStem,OptCSE])]
+ ("none", Set.fromList [OptStem,OptCSE,OptExpand])
+ ]
cfgTransformNames :: [(String, CFGTransform)]
cfgTransformNames =
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:33:49 +0000