From 0325f7264d6790f9207ade099a8db3952dea5ef3 Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 30 Aug 2011 18:54:50 +0000 Subject: [PATCH] GF.Infra.Modules: keep the modules of a grammar in a finite map instead of a list This speeds up the compilation of PhrasebookFin.pgf by 12%, mosly by speeding up calls to lookupModule in calls from lookupParamValues, in calls from allParamValues. The invariant "modules are stored in dependency order" is no longer respected! But the type MGrammar is now abstract, making it easier to maintain this or other invariants in the future. --- src/compiler/GF/Compile.hs | 10 +++---- src/compiler/GF/Compile/CheckGrammar.hs | 4 +-- src/compiler/GF/Compile/GrammarToPGF.hs | 17 +++++++----- src/compiler/GF/Compile/Optimize.hs | 2 +- src/compiler/GF/Compile/Refresh.hs | 2 +- src/compiler/GF/Compile/Rename.hs | 4 +-- src/compiler/GF/Compile/SubExOpt.hs | 2 +- src/compiler/GF/Grammar/Binary.hs | 4 +-- src/compiler/GF/Grammar/CF.hs | 2 +- src/compiler/GF/Grammar/Grammar.hs | 4 +-- src/compiler/GF/Infra/Modules.hs | 36 ++++++++++++++++--------- src/compiler/GFI.hs | 2 +- 12 files changed, 52 insertions(+), 37 deletions(-) diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 00b08dbf3..b0c228e53 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -69,8 +69,8 @@ batchCompile opts files = do -- to compile a set of modules, e.g. an old GF or a .cf file compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar -compileSourceGrammar opts gr@(MGrammar ms) = do - (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) ms +compileSourceGrammar opts gr = do + (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) (modules gr) return gr' where compOne env mo = do @@ -215,19 +215,19 @@ generateModuleCode opts file minfo = do -- auxiliaries -reverseModules (MGrammar ms) = MGrammar $ reverse ms +--reverseModules (MGrammar ms) = MGrammar $ reverse ms emptyCompileEnv :: CompileEnv emptyCompileEnv = (0,emptyMGrammar,Map.empty) -extendCompileEnvInt (_,MGrammar ss,menv) k mfile sm = do +extendCompileEnvInt (_,gr,menv) k mfile sm = do let (mod,imps) = importsOfModule sm menv2 <- case mfile of Just file -> do t <- ioeIO $ getModificationTime file return $ Map.insert mod (t,imps) menv _ -> return menv - return (k,MGrammar (sm:ss),menv2) --- reverse later + return (k,mGrammar (sm:modules gr),menv2) --- reverse later extendCompileEnv e@(k,_,_) file sm = extendCompileEnvInt e k (Just file) sm diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 035b47238..b3129128b 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -47,7 +47,7 @@ checkModule :: [SourceModule] -> SourceModule -> Check SourceModule checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do checkRestrictedInheritance ms m m <- case mtype mo of - MTConcrete a -> do let gr = MGrammar (m:ms) + MTConcrete a -> do let gr = mGrammar (m:ms) abs <- checkErr $ lookupModule gr a checkCompleteGrammar gr (a,abs) m _ -> return m @@ -221,7 +221,7 @@ checkInfo ms (m,mo) c info = do _ -> return info where - gr = MGrammar ((m,mo) : ms) + gr = mGrammar ((m,mo) : ms) chIn loc cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition m loc <> colon) mkPar (L loc (f,co)) = diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index a6c7035d5..ed10697fd 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -44,10 +44,13 @@ mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr -- Generate PGF from grammar. -canon2pgf :: Options -> SourceGrammar -> SourceGrammar -> IO D.PGF -canon2pgf opts gr cgr@(M.MGrammar (am:cms)) = do +type AbsConcsGrammar = (IdModInfo,[IdModInfo]) -- (abstract,concretes) +type IdModInfo = (Ident,SourceModInfo) + +canon2pgf :: Options -> SourceGrammar -> AbsConcsGrammar -> IO D.PGF +canon2pgf opts gr (am,cms) = do if dump opts DumpCanon - then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr)))) + then putStrLn (render (vcat (map (ppModule Qualified) (am:cms)))) else return () (an,abs) <- mkAbstr am cncs <- mapM (mkConcr am) cms @@ -148,12 +151,12 @@ compilePatt eqs = whilePP eqs Map.empty -- return just one module per language -reorder :: Ident -> SourceGrammar -> SourceGrammar +reorder :: Ident -> SourceGrammar -> AbsConcsGrammar reorder abs cg = - M.MGrammar $ - (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs): +-- M.MGrammar $ + ((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs), [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs) - | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc] + | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc]) where aflags = concatOptions (reverse [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]) diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index 10f6c08be..95ee460ef 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -96,7 +96,7 @@ evalInfo opts ms m c info = do _ -> return info where - gr = MGrammar (m : ms) + gr = mGrammar (m : ms) optim = flag optOptimizations opts param = OptParametrize `Set.member` optim eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon)) diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs index 159c26a38..3780db2cf 100644 --- a/src/compiler/GF/Compile/Refresh.hs +++ b/src/compiler/GF/Compile/Refresh.hs @@ -108,7 +108,7 @@ refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) whe -- for concrete and resource in grammar, before optimizing refreshGrammar :: SourceGrammar -> Err SourceGrammar -refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules +refreshGrammar = liftM (mGrammar . snd) . foldM refreshModule (0,[]) . modules refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]) refreshModule (k,ms) mi@(i,mo) diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index c8bf8cdd9..f1c7e2022 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -62,7 +62,7 @@ renameSourceJudgement g m (i,t) = do renameModule :: [SourceModule] -> SourceModule -> Check SourceModule renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do let js1 = jments mo - status <- buildStatus (MGrammar ms) name mo + status <- buildStatus (mGrammar ms) name mo js2 <- checkMap (renameInfo status name) js1 return (name, mo {opens = map forceQualif (opens mo), jments = js2}) @@ -128,7 +128,7 @@ tree2status o = case o of buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Check Status buildStatus gr c mo = let mo' = self2status c mo in do - let gr1 = MGrammar ((c,mo) : modules gr) + let gr1 = mGrammar ((c,mo) : modules gr) ops = [OSimple e | e <- allExtends gr1 c] ++ opens mo mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops let sts = map modInfo2status $ zip ops mods diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs index 42824845e..49d7efb81 100644 --- a/src/compiler/GF/Compile/SubExOpt.hs +++ b/src/compiler/GF/Compile/SubExOpt.hs @@ -61,7 +61,7 @@ unsubexpModule sm@(i,mo) 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] + gr = M.mGrammar [sm] rebuild = buildTree . concat -- implementation diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 0cee6f2c6..32ddfe6ad 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -27,8 +27,8 @@ instance Binary Ident where else return (identC bs) instance Binary a => Binary (MGrammar a) where - put (MGrammar ms) = put ms - get = fmap MGrammar get + put = put . modules + get = fmap mGrammar get instance Binary a => Binary (ModInfo a) where put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi) diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs index 009bbd3c2..93ae10b4a 100644 --- a/src/compiler/GF/Grammar/CF.hs +++ b/src/compiler/GF/Grammar/CF.hs @@ -81,7 +81,7 @@ type CFFun = String -------------------------- cf2gf :: String -> CF -> SourceGrammar -cf2gf name cf = MGrammar [ +cf2gf name cf = mGrammar [ (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat})) (emptyModInfo{mtype = MTAbstract, jments = abs})), (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc}) diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index f99ed0414..e29bc331a 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- module GF.Grammar.Grammar (SourceGrammar, - emptySourceGrammar, + emptySourceGrammar,mGrammar, SourceModInfo, SourceModule, mapSourceModule, @@ -56,7 +56,7 @@ import qualified Data.ByteString.Char8 as BS -- | grammar as presented to the compiler type SourceGrammar = MGrammar Info -emptySourceGrammar = MGrammar [] +emptySourceGrammar = mGrammar [] type SourceModInfo = ModInfo Info diff --git a/src/compiler/GF/Infra/Modules.hs b/src/compiler/GF/Infra/Modules.hs index 5175dfdd5..8c54ddf30 100644 --- a/src/compiler/GF/Infra/Modules.hs +++ b/src/compiler/GF/Infra/Modules.hs @@ -15,12 +15,12 @@ -- -- The same structure will be used in both source code and canonical. -- The parameters tell what kind of data is involved. --- Invariant: modules are stored in dependency order ----------------------------------------------------------------------------- module GF.Infra.Modules ( - MGrammar(..), ModInfo(..), ModuleType(..), + MGrammar, ModInfo(..), ModuleType(..), MInclude (..), + mGrammar,modules, extends, isInherited,inheritAll, updateMGrammar, updateModule, replaceJudgements, addFlag, addOpenQualif, flagsModule, allFlags, mapModules, @@ -28,7 +28,8 @@ module GF.Infra.Modules ( ModuleStatus(..), openedModule, depPathModule, allDepsModule, partOfGrammar, allExtends, allExtendSpecs, allExtendsPlus, allExtensions, - searchPathModule, addModule, + searchPathModule, + -- addModule, emptyMGrammar, emptyModInfo, abstractOfConcrete, abstractModOfConcrete, lookupModule, lookupModuleType, lookupInfo, @@ -50,10 +51,16 @@ import Text.PrettyPrint -- The same structure will be used in both source code and canonical. -- The parameters tell what kind of data is involved. --- Invariant: modules are stored in dependency order +-- No longer maintained invariant (TH 2011-08-30): +-- modules are stored in dependency order -newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]} +--mGrammar = MGrammar +--newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]} + +newtype MGrammar a = MGrammar {moduleMap :: Map.Map Ident (ModInfo a)} deriving Show +modules = Map.toList . moduleMap +mGrammar = MGrammar . Map.fromList data ModInfo a = ModInfo { mtype :: ModuleType, @@ -94,9 +101,9 @@ inheritAll i = (i,MIAll) -- destructive update --- | dep order preserved since old cannot depend on new +-- | dep order preserved since old cannot depend on new (not anymore TH 2011-08-30) updateMGrammar :: MGrammar a -> MGrammar a -> MGrammar a -updateMGrammar old new = MGrammar $ +updateMGrammar old new = mGrammar $ [(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns where os = modules old @@ -121,7 +128,8 @@ allFlags :: MGrammar a -> Options allFlags gr = concatOptions [flags m | (_,m) <- modules gr] mapModules :: (ModInfo a -> ModInfo a) -> MGrammar a -> MGrammar a -mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms) +--mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms) +mapModules f (MGrammar ms) = MGrammar (fmap f ms) data OpenSpec = OSimple Ident @@ -159,7 +167,7 @@ allDepsModule gr m = iterFix add os0 where -- | select just those modules that a given one depends on, including itself partOfGrammar :: MGrammar a -> (Ident,ModInfo a) -> MGrammar a -partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor] +partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor] where mods = modules gr modsFor = (i:) $ map openedModule $ allDepsModule gr m @@ -208,12 +216,15 @@ allExtensions gr i = searchPathModule :: ModInfo a -> [Ident] searchPathModule m = [i | OSimple i <- depPathModule m] +{- -- | a new module can safely be added to the end, since nothing old can depend on it addModule :: MGrammar a -> Ident -> ModInfo a -> MGrammar a -addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)]) +--addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)]) +addModule gr name mi = MGrammar $ Map.insert name mi (moduleMap gr) +-} emptyMGrammar :: MGrammar a -emptyMGrammar = MGrammar [] +emptyMGrammar = mGrammar [] emptyModInfo :: ModInfo a emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree @@ -238,7 +249,8 @@ abstractModOfConcrete gr c = do --- canonFileName s = prt s ++ ".gfc" lookupModule :: MGrammar a -> Ident -> Err (ModInfo a) -lookupModule gr m = case lookup m (modules gr) of +--lookupModule gr m = case lookup m (modules gr) of +lookupModule gr m = case Map.lookup m (moduleMap gr) of Just i -> return i Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr))) diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs index ffae88c7d..6efd0f3e0 100644 --- a/src/compiler/GFI.hs +++ b/src/compiler/GFI.hs @@ -365,7 +365,7 @@ data GFEnv = GFEnv { emptyGFEnv :: GFEnv emptyGFEnv = - GFEnv emptySourceGrammar{modules=[(identW,emptyModInfo)]} (mkCommandEnv emptyPGF) [] {-0-} + GFEnv (mGrammar [(identW,emptyModInfo)]) (mkCommandEnv emptyPGF) [] {-0-} wordCompletion gfenv (left,right) = do case wc_type (reverse left) of