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

@@ -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
+compileSourceGrammar opts gr = do
-  (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) ms
+  (_,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
 

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)) = 

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
+type AbsConcsGrammar = (IdModInfo,[IdModInfo]) -- (abstract,concretes)
-canon2pgf opts gr cgr@(M.MGrammar (am:cms)) = do
+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 $ 
+--  M.MGrammar $
-       (abs, M.ModInfo M.MTAbstract       M.MSComplete aflags [] Nothing [] [] adefs):
+       ((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])

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))

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)

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    

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

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
+  put = put . modules
-  get               = fmap MGrammar get
+  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)

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})

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
 

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)))
 

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