mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
before the optimizations OptParametrize and OptValues were applied twice. in addition the values optimization is now always applied because it become very cheep
This commit is contained in:
krasimir
3
GF.cabal
3
GF.cabal
@@ -139,7 +139,6 @@ executable gf
|
||||
GF.Compile.Update
|
||||
GF.Compile.CheckGrammar
|
||||
GF.Compile.Refresh
|
||||
GF.Compile.BackOpt
|
||||
GF.Compile.Rename
|
||||
GF.Compile.ReadFiles
|
||||
GF.Compile.GrammarToGFCC
|
||||
@@ -150,7 +149,7 @@ executable gf
|
||||
GF.Compile.Abstract.TypeCheck
|
||||
GF.Compile.Abstract.Compute
|
||||
GF.Compile.Optimize
|
||||
GF.Compile.OptimizeGF
|
||||
GF.Compile.SubExOpt
|
||||
GF.Compile.OptimizeGFCC
|
||||
GF.Compile.ModDeps
|
||||
GF.Compile.GetGrammar
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
142
src/GF/Compile/SubExOpt.hs
Normal 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''")
|
||||
@@ -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 =
|
||||
|
||||
Reference in New Issue
Block a user