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.

6 files changed, 17 insertions, 14 deletions

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