From 6d765e75ad838f099ede33090165b830da9843ed Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 10 Oct 2007 20:29:10 +0000 Subject: [PATCH] tuning gf optimization --- src/GF/Devel/Compile.hs | 18 ++++++++++-------- src/GF/Devel/GrammarToGFCC.hs | 2 +- src/GF/Devel/OptimizeGF.hs | 28 ++++++++++++++++++---------- 3 files changed, 29 insertions(+), 19 deletions(-) diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs index 0054ff4b7..43deb4493 100644 --- a/src/GF/Devel/Compile.hs +++ b/src/GF/Devel/Compile.hs @@ -104,13 +104,15 @@ compileOne opts env@(_,srcgr) file = do case gf of - -- for compiled gf, read the file and update environment, also source env + -- for compiled gf, read the file and update environment + -- also undo common subexp optimization, to enable normal computations "gfc" -> do sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file - sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0 + let sm1 = unsubexpModule sm0 + sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1 extendCompileEnv env sm - -- for gf source, do full compilation + -- for gf source, do full compilation and generate code _ -> do let modu = unsuffixFile file @@ -123,7 +125,7 @@ compileOne opts env@(_,srcgr) file = do getSourceModule opts file (k',sm) <- compileSourceModule opts env sm0 cm <- putpp " generating code... " $ generateModuleCode opts path sm - + -- sm is optimized before generation, but not in the env extendCompileEnvInt env (k',sm) @@ -170,7 +172,7 @@ generateModuleCode opts path minfo@(name,info) = do let pname = prefixPathName path (prt name) let minfo0 = minfo - let minfo1 = shareModule minfo + let minfo1 = (if isConcr info then optModule else id) minfo let minfo2 = minfo1 let (file,out) = (gfcFile pname, prGrammar (MGrammar [minfo2])) @@ -180,9 +182,9 @@ generateModuleCode opts path minfo@(name,info) = do where putp = putPointE opts putpp = putPointEsil opts - isCompilable mi = case mi of - ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete - _ -> True + isConcr mi = case mi of + ModMod m -> isModCnc m && mstatus m /= MSIncomplete + _ -> False -- auxiliaries diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index 686e9f4bb..a5ec71a77 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -230,7 +230,7 @@ purgeGrammar abstr gr = acncs = abstr : M.allConcretes gr abstr isSingle = True complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon - unopt = unshareModule gr + unopt = unshareModule gr -- subexp elim undone when compiled type ParamEnv = (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels diff --git a/src/GF/Devel/OptimizeGF.hs b/src/GF/Devel/OptimizeGF.hs index ccf5ffe56..d095d3ae7 100644 --- a/src/GF/Devel/OptimizeGF.hs +++ b/src/GF/Devel/OptimizeGF.hs @@ -15,7 +15,8 @@ -- following advice of Josef Svenningsson ----------------------------------------------------------------------------- -module GF.Devel.OptimizeGF (shareModule,unshareModule) where +module GF.Devel.OptimizeGF ( + optModule,unshareModule,unsubexpModule,unoptModule) where import GF.Grammar.Grammar import GF.Grammar.Lookup @@ -30,11 +31,14 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.List -shareModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo) -shareModule = subexpModule . processModule optim +optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo) +optModule = subexpModule . processModule optim + +unoptModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) +unoptModule gr = unshareModule gr . unsubexpModule unshareModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -unshareModule gr = processModule (const (unoptim gr)) . unsubexpModule +unshareModule gr = processModule (const (unoptim gr)) processModule :: (Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) @@ -107,8 +111,9 @@ replace old new trm = case trm of 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 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? _ -> C.composSafeOp values t @@ -166,7 +171,7 @@ subexpModule (mo,m) = errVal (mo,m) $ case m of unsubexpModule :: SourceModule -> SourceModule unsubexpModule mo@(i,m) = case m of - M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) | hasSub ljs -> + M.ModMod (M.Module mt st fs me ops js) | hasSub ljs -> (i, M.ModMod (M.Module mt st fs me ops (rebuild (map unparInfo ljs)))) where ljs = tree2list js @@ -176,10 +181,12 @@ unsubexpModule mo@(i,m) = case m of hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] unparInfo (c,info) = case info of CncFun xs (Yes t) m -> [(c, CncFun xs (Yes (unparTerm t)) m)] - ResOper _ _ -> [] ---- + ResOper (Yes (EInt 8)) _ -> [] -- subexp-generated opers + ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))] _ -> [(c,info)] unparTerm t = case t of - Q m c -> errVal t $ liftM unparTerm $ lookupResDef gr m c + Q m c@(IC ('A':'\'':'\'':_)) -> --- name convention of subexp opers + errVal t $ liftM unparTerm $ lookupResDef gr m c _ -> C.composSafeOp unparTerm t gr = M.MGrammar [mo] rebuild = buildTree . concat @@ -210,7 +217,8 @@ addSubexpConsts mo tree lins = do list = Map.toList tree - oper id trm = (ident id, ResOper Nope (Yes trm)) + oper id trm = (ident id, ResOper (Yes (EInt 8)) (Yes trm)) + --- impossible type encoding generated opers getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) getSubtermsMod mo js = do