From 7e40df7d4c4dc475db08483dac5fd01823598a26 Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 12 Nov 2007 17:25:00 +0000 Subject: [PATCH] made compile from source use optimized modules internally --- src/GF/Devel/Compile.hs | 15 +++++++++------ src/GF/Devel/GrammarToGFCC.hs | 21 ++++++++++----------- src/GF/Devel/OptimizeGF.hs | 7 +++++-- src/GF/Grammar/Lookup.hs | 1 + 4 files changed, 25 insertions(+), 19 deletions(-) diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs index 6b55d0eea..f5a16114f 100644 --- a/src/GF/Devel/Compile.hs +++ b/src/GF/Devel/Compile.hs @@ -126,9 +126,15 @@ compileOne opts env@(_,srcgr) file = do sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ getSourceModule opts file (k',sm) <- compileSourceModule opts env sm0 - cm <- putpp " generating code... " $ generateModuleCode opts path sm + let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str + cm <- putpp " generating code... " $ generateModuleCode opts path sm1 -- sm is optimized before generation, but not in the env - extendCompileEnvInt env (k',sm) + let cm2 = unsubexpModule cm + extendCompileEnvInt env (k',sm1) + where + isConcr (_,mi) = case mi of + ModMod m -> isModCnc m && mstatus m /= MSIncomplete + _ -> False compileSourceModule :: Options -> CompileEnv -> @@ -174,7 +180,7 @@ generateModuleCode opts path minfo@(name,info) = do let pname = prefixPathName path (prt name) let minfo0 = minfo - let minfo1 = (if isConcr info then optModule else id) minfo + let minfo1 = subexpModule minfo0 let minfo2 = minfo1 let (file,out) = (gfoFile pname, prGrammar (MGrammar [minfo2])) @@ -184,9 +190,6 @@ generateModuleCode opts path minfo@(name,info) = do where putp = putPointE opts putpp = putPointEsil opts - 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 327898eff..647e4ae65 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -319,12 +319,12 @@ paramValues cgr = (labels,untyps,typs) where typsFromTrm :: Term -> STM [Type] Term typsFromTrm tr = case tr of - V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr R fs -> mapM_ (typsFromField . snd) fs >> return tr where typsFromField (mty, t) = case mty of Just x -> updateSTM (x:) >> typsFromTrm t _ -> typsFromTrm t + V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr T (TTyped ty) cs -> updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr T (TComp ty) cs -> @@ -396,14 +396,12 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of --- this is mainly needed for parameter record projections ---- was: errVal t $ Compute.computeConcreteRec cgr t comp t = case t of - T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should - T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should + T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should... + T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should V typ ts -> V typ (map comp ts) S (V typ ts) v0 -> err error id $ do let v = comp v0 - vs <- Look.allParamValues cgr typ - return $ maybe t ---- (error (prt t)) -- should be safe after doVar though - (comp . (ts !!)) $ lookup v (zip vs [0 .. length vs - 1]) + return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r] P (R r) l -> maybe t (comp . snd) $ lookup l r _ -> GM.composSafeOp comp t @@ -437,6 +435,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of Vr (IA (cat, _)) -> return (identC cat,[]) Vr (IC s) -> return (identC cat,[]) where cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser +---- Vr _ -> error $ "getLab " ++ show tr P p lab2 -> do (cat,labs) <- getLab p return (cat,labs++[lab2]) @@ -450,15 +449,15 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of _ | tr == x -> t _ -> GM.composSafeOp (mkBranch x t) tr - valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps + valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps where - tryPerm tr = valNumFV $ tryVar tr - tryVar tr = case GM.appForm tr of - (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryVar ts)] + tryFV tr = case GM.appForm tr of + (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)] (FV ts,_) -> ts _ -> [tr] valNumFV ts = case ts of - [tr] -> prtTrace tr $ K "66667" + [tr] -> trace (unwords (map prt (Map.keys typs))) $ + prtTrace tr $ K "66667" _ -> FV $ map valNum ts mkCurry trm = case trm of diff --git a/src/GF/Devel/OptimizeGF.hs b/src/GF/Devel/OptimizeGF.hs index d095d3ae7..de05ed428 100644 --- a/src/GF/Devel/OptimizeGF.hs +++ b/src/GF/Devel/OptimizeGF.hs @@ -16,7 +16,8 @@ ----------------------------------------------------------------------------- module GF.Devel.OptimizeGF ( - optModule,unshareModule,unsubexpModule,unoptModule) where + optModule,unshareModule,unsubexpModule,unoptModule,subexpModule,shareModule + ) where import GF.Grammar.Grammar import GF.Grammar.Lookup @@ -32,7 +33,9 @@ import qualified Data.Map as Map import Data.List optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo) -optModule = subexpModule . processModule optim +optModule = subexpModule . shareModule + +shareModule = processModule optim unoptModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) unoptModule gr = unshareModule gr . unsubexpModule diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index a57793cd3..2acfa5f26 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -194,6 +194,7 @@ allParamValues cnc ptyp = case ptyp of App (Q (IC "Predef") (IC "Ints")) (EInt n) -> return [EInt i | i <- [0..n]] QC p c -> lookupParamValues cnc p c + Q p c -> lookupParamValues cnc p c ---- RecType r -> do let (ls,tys) = unzip $ sortByFst r tss <- mapM allPV tys