From 0d4f6e9b5ed4efeb4853d3aa1447ffb95d75fd2e Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 10 Oct 2007 16:13:57 +0000 Subject: [PATCH] optimizations on evaluated gf in gfc --- src/GF/Devel/Compile.hs | 48 ++++--------- src/GF/Devel/GrammarToGFCC.hs | 7 +- src/GF/Devel/OptimizeGF.hs | 128 ++++++++++++++++++++++++++++++++++ src/GF/GFCC/CheckGFCC.hs | 5 +- 4 files changed, 151 insertions(+), 37 deletions(-) create mode 100644 src/GF/Devel/OptimizeGF.hs diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs index 2e9de8a16..0054ff4b7 100644 --- a/src/GF/Devel/Compile.hs +++ b/src/GF/Devel/Compile.hs @@ -1,15 +1,5 @@ module GF.Devel.Compile (batchCompile) where -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.CompactPrint -import GF.Devel.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules -import GF.Devel.ReadFiles - -- the main compiler passes import GF.Devel.GetGrammar import GF.Compile.Extend @@ -19,9 +9,20 @@ import GF.Grammar.Refresh import GF.Compile.CheckGrammar import GF.Compile.Optimize import GF.Compile.Evaluate ---- +import GF.Devel.OptimizeGF --import GF.Canon.Share --import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Option +import GF.Infra.CompactPrint +import GF.Devel.PrGrammar +import GF.Compile.Update +import GF.Grammar.Lookup +import GF.Infra.Modules +import GF.Devel.ReadFiles + import GF.Data.Operations import GF.Devel.UseIO import GF.Devel.Arch @@ -167,31 +168,10 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do generateModuleCode :: Options -> InitPath -> SourceModule -> IOE SourceModule generateModuleCode opts path minfo@(name,info) = do - let pname = prefixPathName path (prt name) + let pname = prefixPathName path (prt name) let minfo0 = minfo - let minfo1 = minfo - let minfo2 = minfo - -{- ---- restore optimizations! - let oopts = addOptions opts (iOpts (flagsModule minfo)) - optims = maybe "all_subs" id $ getOptVal oopts useOptimizer - optim = takeWhile (/='_') optims - subs = drop 1 (dropWhile (/='_') optims) == "subs" - minfo1 <- return $ - case optim of - "parametrize" -> shareModule paramOpt minfo0 -- parametrization and sharing - "values" -> shareModule valOpt minfo0 -- tables as courses-of-values - "share" -> shareModule shareOpt minfo0 -- sharing of branches - "all" -> shareModule allOpt minfo0 -- first parametrize then values - "none" -> minfo0 -- no optimization - _ -> shareModule shareOpt minfo0 -- sharing; default - - -- do common subexpression elimination if required by flag "subs" - minfo2 <- - if subs - then ioeErr $ elimSubtermsMod minfo1 - else return minfo1 --} + let minfo1 = shareModule minfo + let minfo2 = minfo1 let (file,out) = (gfcFile pname, prGrammar (MGrammar [minfo2])) putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index 4fe2e6e0d..686e9f4bb 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -1,5 +1,7 @@ module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc) where +import GF.Devel.OptimizeGF (unshareModule) + import GF.Grammar.Grammar import qualified GF.Grammar.Lookup as Look @@ -220,12 +222,15 @@ canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar -purgeGrammar abstr gr = (M.MGrammar . filter complete . purge . M.modules) gr where +purgeGrammar abstr gr = + (M.MGrammar . map unopt . filter complete . purge . M.modules) gr + where purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) needed = nub $ concatMap (requiredCanModules isSingle gr) acncs acncs = abstr : M.allConcretes gr abstr isSingle = True complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon + unopt = unshareModule gr type ParamEnv = (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels diff --git a/src/GF/Devel/OptimizeGF.hs b/src/GF/Devel/OptimizeGF.hs new file mode 100644 index 000000000..a5b7d27f5 --- /dev/null +++ b/src/GF/Devel/OptimizeGF.hs @@ -0,0 +1,128 @@ +---------------------------------------------------------------------- +-- | +-- 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.Devel.OptimizeGF (shareModule,unshareModule) where + +import GF.Grammar.Grammar +import GF.Grammar.Lookup +import GF.Infra.Ident +import qualified GF.Grammar.Macros as C +import GF.Grammar.PrGrammar (prt) +import qualified GF.Infra.Modules as M +import GF.Data.Operations + +import Data.List + +shareModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo) +shareModule = processModule optim + +unshareModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) +unshareModule gr = processModule (const (unoptim gr)) + +processModule :: + (Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) +processModule opt (i,m) = case m of + M.ModMod (M.Module mt st fs me ops js) -> + (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js))) + _ -> (i,m) + +shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m) +shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (opt c t)) m) +shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (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 ("q_" ++ prt 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 + + +-- 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 + + diff --git a/src/GF/GFCC/CheckGFCC.hs b/src/GF/GFCC/CheckGFCC.hs index 12f92bcac..bf9a846e3 100644 --- a/src/GF/GFCC/CheckGFCC.hs +++ b/src/GF/GFCC/CheckGFCC.hs @@ -70,11 +70,11 @@ inferTerm args trm = case trm of testErr (all (==typ) tys) ("different types in table " ++ prt trm) return (P t' u', typ) -- table: types must be same _ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt - FV [] -> returnt str ---- + FV [] -> returnt TM ---- FV (t:ts) -> do (t',ty) <- infer t (ts',tys) <- mapM infer ts >>= return . unzip - testErr (all (==ty) tys) ("different types in variants " ++ prt trm) + testErr (all (eqType ty) tys) ("different types in variants " ++ prt trm) return (FV (t':ts'),ty) W s r -> infer r _ -> Bad ("no type inference for " ++ prt trm) @@ -99,6 +99,7 @@ eqType :: CType -> CType -> Bool eqType inf exp = case (inf,exp) of (C k, C n) -> k <= n -- only run-time corr. (R rs,R ts) -> length rs == length ts && and [eqType r t | (r,t) <- zip rs ts] + (TM, _) -> True ---- for variants [] ; not safe _ -> inf == exp -- should be in a generic module, but not in the run-time DataGFCC