msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

before the optimizations OptParametrize and OptValues were applied twice. in addition the values optimization is now always applied because it become very cheep

Browse Source
This commit is contained in:
krasimir
2009-11-12 21:11:51 +00:00
parent 3aa208dd2b
commit 94171908c0
8 changed files with 224 additions and 409 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
GF.cabal
View File

@@ -139,7 +139,6 @@ executable gf
GF.Compile.Update GF.Compile.Update
GF.Compile.CheckGrammar GF.Compile.CheckGrammar
GF.Compile.Refresh GF.Compile.Refresh
GF.Compile.BackOpt
GF.Compile.Rename GF.Compile.Rename
GF.Compile.ReadFiles GF.Compile.ReadFiles
GF.Compile.GrammarToGFCC GF.Compile.GrammarToGFCC
@@ -150,7 +149,7 @@ executable gf
GF.Compile.Abstract.TypeCheck GF.Compile.Abstract.TypeCheck
GF.Compile.Abstract.Compute GF.Compile.Abstract.Compute
GF.Compile.Optimize GF.Compile.Optimize
GF.Compile.OptimizeGF GF.Compile.SubExOpt
GF.Compile.OptimizeGFCC GF.Compile.OptimizeGFCC
GF.Compile.ModDeps GF.Compile.ModDeps
GF.Compile.GetGrammar GF.Compile.GetGrammar

8
src/GF/Compile.hs
View File

@@ -5,7 +5,7 @@ import GF.Compile.GetGrammar
import GF.Compile.Rename import GF.Compile.Rename
import GF.Compile.CheckGrammar import GF.Compile.CheckGrammar
import GF.Compile.Optimize import GF.Compile.Optimize
import GF.Compile.OptimizeGF import GF.Compile.SubExOpt
import GF.Compile.OptimizeGFCC import GF.Compile.OptimizeGFCC
import GF.Compile.GrammarToGFCC import GF.Compile.GrammarToGFCC
import GF.Compile.ReadFiles import GF.Compile.ReadFiles
@@ -183,10 +183,8 @@ compileOne opts env@(_,srcgr,_) file = do
intermOut opts DumpSource (ppModule Qualified sm0) intermOut opts DumpSource (ppModule Qualified sm0)
(k',sm) <- compileSourceModule opts env sm0 (k',sm) <- compileSourceModule opts env sm0
let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm
cm <- putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm1 extendCompileEnvInt env k' (Just gfo) sm
-- sm is optimized before generation, but not in the env
extendCompileEnvInt env k' (Just gfo) sm1
where where
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete

104
src/GF/Compile/BackOpt.hs
View File

@@ -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

19
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -2,7 +2,6 @@
module GF.Compile.GrammarToGFCC (mkCanon2gfcc,addParsers) where module GF.Compile.GrammarToGFCC (mkCanon2gfcc,addParsers) where
import GF.Compile.Export import GF.Compile.Export
import GF.Compile.OptimizeGF (unshareModule)
import qualified GF.Compile.GenerateFCFG as FCFG import qualified GF.Compile.GenerateFCFG as FCFG
import qualified GF.Compile.GeneratePMCFG as PMCFG import qualified GF.Compile.GeneratePMCFG as PMCFG
@@ -298,8 +297,8 @@ canon2canon opts abs cg0 =
j2j cg (f,j) = j2j cg (f,j) =
let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in
case j of case j of
CncFun x (Just tr) z -> CncFun x (Just (debug (t2t tr))) z 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 x)) y CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y
_ -> j _ -> j
where where
cg1 = cg cg1 = cg
@@ -307,6 +306,17 @@ canon2canon opts abs cg0 =
ty2ty = type2type cg1 pv ty2ty = type2type cg1 pv
pv@(labels,untyps,typs) = trs $ paramValues cg1 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 -- flatten record arguments of param constructors
p2p (f,j) = case j of p2p (f,j) = case j of
ResParam (Just ps) (Just vs) -> ResParam (Just ps) (Just vs) ->
@@ -334,7 +344,7 @@ canon2canon opts abs cg0 =
purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
purgeGrammar abstr gr = purgeGrammar abstr gr =
(M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr (M.MGrammar . list . filter complete . purge . M.modules) gr
where where
list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms 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) 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 acncs = abstr : M.allConcretes gr abstr
isSingle = True isSingle = True
complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon
unopt = unshareModule gr -- subexp elim undone when compiled
type ParamEnv = type ParamEnv =
(Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels

70
src/GF/Compile/Optimize.hs
View File

@@ -24,7 +24,6 @@ import GF.Grammar.Lookup
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Compile.Refresh import GF.Compile.Refresh
import GF.Compile.Concrete.Compute import GF.Compile.Concrete.Compute
import GF.Compile.BackOpt
import GF.Compile.CheckGrammar import GF.Compile.CheckGrammar
import GF.Compile.Update import GF.Compile.Update
@@ -37,6 +36,7 @@ import Data.List
import qualified Data.Set as Set import qualified Data.Set as Set
import Text.PrettyPrint import Text.PrettyPrint
import Debug.Trace import Debug.Trace
import qualified Data.ByteString.Char8 as BS
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. -- | 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 | mstatus mi == MSComplete = do
ids <- topoSortJments m ids <- topoSortJments m
mi <- foldM updateEvalInfo mi ids mi <- foldM updateEvalInfo mi ids
return (shareModule oopts (name,mi)) return (name,mi)
| otherwise = return m | otherwise = return m
where where
oopts = opts `addOptions` flagsModule m oopts = opts `addOptions` flagsModule m
@@ -64,10 +64,13 @@ evalInfo opts ms m c info = do
CncCat ptyp pde ppr -> do CncCat ptyp pde ppr -> do
pde' <- case (ptyp,pde) of pde' <- case (ptyp,pde) of
(Just typ, Just de) -> (Just typ, Just de) -> do
liftM Just $ partEval opts gr ([(Explicit, varStr, typeStr)], typ) de de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
(Just typ, Nothing) -> return (Just (factor param c 0 de))
liftM Just $ mkLinDefault gr typ >>= partEval noOptions gr ([(Explicit, varStr, typeStr)],typ) (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 _ -> return pde -- indirection
ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c) 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) $ 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 eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
pde' <- case pde of 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 Nothing -> return pde
ppr' <- liftM Just $ evalPrintname gr c ppr pde' ppr' <- liftM Just $ evalPrintname gr c ppr pde'
return $ CncFun mt pde' ppr' -- only cat in type actually needed 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 ResOper pty pde
| OptExpand `Set.member` optim -> do | OptExpand `Set.member` optim -> do
pde' <- case pde of 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 Nothing -> return Nothing
return $ ResOper pty pde' return $ ResOper pty pde'
@@ -93,6 +98,7 @@ evalInfo opts ms m c info = do
where where
gr = MGrammar (m : ms) gr = MGrammar (m : ms)
optim = flag optOptimizations opts optim = flag optOptimizations opts
param = OptParametrize `Set.member` optim
eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon)) eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
-- | the main function for compiling linearizations -- | the main function for compiling linearizations
@@ -132,17 +138,13 @@ recordExpand typ trm = case typ of
-- | auxiliaries for compiling the resource -- | auxiliaries for compiling the resource
mkLinDefault :: SourceGrammar -> Type -> Err Term mkLinDefault :: SourceGrammar -> Type -> Err Term
mkLinDefault gr typ = do mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
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
where where
mkDefField typ = case typ of mkDefField typ = case typ of
Table p t -> do Table p t -> do
t' <- mkDefField t t' <- mkDefField t
let T _ cs = mkWildCases t' let T _ cs = mkWildCases t'
return $ T (TWild p) cs return $ T (TWild p) cs
Sort s | s == cStr -> return $ Vr varStr Sort s | s == cStr -> return $ Vr varStr
QC q p -> do vs <- lookupParamValues gr q p QC q p -> do vs <- lookupParamValues gr q p
case vs of case vs of
@@ -150,8 +152,8 @@ mkLinDefault gr typ = do
_ -> Bad (render (text "no parameter values given to type" <+> ppIdent p)) _ -> Bad (render (text "no parameter values given to type" <+> ppIdent p))
RecType r -> do RecType r -> do
let (ls,ts) = unzip r let (ls,ts) = unzip r
ts' <- mapM mkDefField ts ts <- mapM mkDefField ts
return $ R $ [assign l t | (l,t) <- zip ls ts'] return $ R (zipWith assign ls ts)
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ)) _ -> 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 c:cs -> c: clean cs
_ -> s _ -> 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

270
src/GF/Compile/OptimizeGF.hs
View File

@@ -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''")

142
src/GF/Compile/SubExOpt.hs Normal file
View File

@@ -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''")

17
src/GF/Infra/Option.hs
View File

@@ -109,7 +109,7 @@ data SISRFormat =
| SISR_1_0 | SISR_1_0
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data CFGTransform = CFGNoLR data CFGTransform = CFGNoLR
@@ -268,7 +268,7 @@ defaultFlags = Flags {
optResName = Nothing, optResName = Nothing,
optPreprocessors = [], optPreprocessors = [],
optEncoding = ISO_8859_1, optEncoding = ISO_8859_1,
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues], optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
CFGTopDownFilter, CFGMergeIdentical], CFGTopDownFilter, CFGMergeIdentical],
optLibraryPath = [], optLibraryPath = [],
@@ -474,12 +474,15 @@ instance Read OutputFormat where
optimizationPackages :: [(String, Set Optimization)] optimizationPackages :: [(String, Set Optimization)]
optimizationPackages = optimizationPackages =
[("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), -- deprecated [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), ("values", Set.fromList [OptStem,OptCSE,OptExpand]),
("values", Set.fromList [OptStem,OptCSE,OptExpand,OptValues]), ("noexpand", Set.fromList [OptStem,OptCSE]),
-- deprecated
("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("none", Set.fromList [OptStem,OptCSE,OptExpand]), ("none", Set.fromList [OptStem,OptCSE,OptExpand])
("noexpand", Set.fromList [OptStem,OptCSE])] ]
cfgTransformNames :: [(String, CFGTransform)] cfgTransformNames :: [(String, CFGTransform)]
cfgTransformNames = cfgTransformNames =