Now PMCFG is compiled per module and at the end we only link it. The new compilation schema is few times faster.

22 files changed, 609 insertions, 524 deletions

diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index c737480e1..597044845 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -6,6 +6,7 @@ import GF.Compile.Rename
 import GF.Compile.CheckGrammar
 import GF.Compile.Optimize
 import GF.Compile.SubExOpt
+import GF.Compile.GeneratePMCFG
 import GF.Compile.GrammarToPGF
 import GF.Compile.ReadFiles
 import GF.Compile.Update
@@ -55,7 +56,8 @@ link :: Options -> Ident -> SourceGrammar -> IOE PGF
 link opts cnc gr = do
   let isv = (verbAtLeast opts Normal)
   putPointE Normal opts "linking ... " $ do
-    pgf <- ioeIO (mkCanon2pgf opts cnc gr)
+    let abs = err (const cnc) id $ abstractOfConcrete gr cnc
+    pgf <- ioeIO (mkCanon2pgf opts gr abs)
     probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
     ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK"     
     return $ setProbabilities probs 
@@ -183,9 +185,9 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
     (_,n) | not (isCompleteModule n) -> do
       case mb_gfo of
         Just gfo -> if flag optMode opts /= ModeTags
-                      then putPointE Verbose opts "  generating code... " $ generateModuleCode opts gfo mo1b
-                      else putStrLnE "" >> return mo1b
-        Nothing  -> return mo1b
+                      then writeGFO opts gfo mo1b
+                      else putStrLnE ""
+        Nothing  -> return ()
 
       extendCompileEnvInt env k mb_gfo mo1b
     _ -> do
@@ -206,22 +208,26 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
                 mo4 <- putpp "  optimizing " $ ioeErr $ optimizeModule opts mos mo3r
                 intermOut opts DumpOptimize (ppModule Qualified mo4)
 
+                mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
+                         then putpp "  generating PMCFG " $ ioeIO $ generatePMCFG opts mos mo4
+                         else return mo4
+                intermOut opts DumpCanon (ppModule Qualified mo5)
+
                 case mb_gfo of
-                  Just gfo -> putPointE Verbose opts "  generating code... " $ generateModuleCode opts gfo mo4
-                  Nothing  -> return mo4
-                  
-                extendCompileEnvInt env k' mb_gfo mo4
+                  Just gfo -> writeGFO opts gfo mo5
+                  Nothing  -> return ()
+
+                extendCompileEnvInt env k' mb_gfo mo5
         else do putStrLnE ""
                 extendCompileEnvInt env k  mb_gfo mo3
 
 
-generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule
-generateModuleCode opts file minfo = do
-  let minfo1 = subexpModule minfo
-      minfo2 = case minfo1 of
-                 (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
-  putPointE Normal opts ("  wrote file" +++ file) $ ioeIO $ encodeFile file minfo2
-  return minfo1
+writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
+writeGFO opts file mo = do
+  let mo1 = subexpModule mo
+      mo2 = case mo1 of
+              (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
+  putPointE Normal opts ("  write file" +++ file) $ ioeIO $ encodeFile file mo2
 
 -- auxiliaries
 
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 2b82bc781..1770e60e8 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -102,52 +102,52 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
                                                                      return info
                                                   _            -> return info
                                         case info of
-                                          CncCat (Just (L loc (RecType []))) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
-                                          _                                      -> Bad "no def lin"
+                                          CncCat (Just (L loc (RecType []))) _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
+                                          _                                        -> Bad "no def lin"
                                              
                                   case lookupIdent c js of
                                     Ok (AnyInd _ _) -> return js
-                                    Ok (CncFun ty (Just def) pn) -> 
-                                                  return $ updateTree (c,CncFun ty (Just def) pn) js
-                                    Ok (CncFun ty Nothing    pn) ->
+                                    Ok (CncFun ty (Just def) mn mf) -> 
+                                                  return $ updateTree (c,CncFun ty (Just def) mn mf) js
+                                    Ok (CncFun ty Nothing    mn mf) ->
                                       case mb_def of
-                                        Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) pn) js
+                                        Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js
                                         Bad _  -> do checkWarn $ text "no linearization of" <+> ppIdent c
                                                      return js
                                     _ -> do
                                       case mb_def of
                                         Ok def -> do (cont,val) <- linTypeOfType gr cm ty
                                                      let linty = (snd (valCat ty),cont,val)
-                                                     return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing) js
+                                                     return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
                                         Bad _  -> do checkWarn $ text "no linearization of" <+> ppIdent c
                                                      return js
        AbsCat (Just _) -> case lookupIdent c js of
          Ok (AnyInd _ _) -> return js
-         Ok (CncCat (Just _) _ _) -> return js
-         Ok (CncCat _ mt mp) -> do
+         Ok (CncCat (Just _) _ _ _) -> return js
+         Ok (CncCat _ mt mp mpmcfg) -> do
            checkWarn $ 
              text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
-           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp) js
+           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js
          _ -> do
            checkWarn $ 
              text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
-           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing) js
+           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js
        _ -> return js
      
    checkCnc js i@(c,info) =
      case info of
-       CncFun _ d pn -> case lookupOrigInfo gr (am,c) of
-                          Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> 
-                                     do (cont,val) <- linTypeOfType gr cm ty
-                                        let linty = (snd (valCat ty),cont,val)
-                                        return $ updateTree (c,CncFun (Just linty) d pn) js
-                          _       -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
+       CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
+                             Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> 
+                                        do (cont,val) <- linTypeOfType gr cm ty
+                                           let linty = (snd (valCat ty),cont,val)
+                                           return $ updateTree (c,CncFun (Just linty) d mn mf) js
+                             _       -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
+                                           return js
+       CncCat _ _ _ _   -> case lookupOrigInfo gr (am,c) of
+                             Ok _ -> return $ updateTree i js
+                             _    -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
                                         return js
-       CncCat _ _ _  -> case lookupOrigInfo gr (am,c) of
-                          Ok _ -> return $ updateTree i js
-                          _    -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
-                                     return js
-       _             -> return $ updateTree i js
+       _                -> return $ updateTree i js
 
 
 -- | General Principle: only Just-values are checked. 
@@ -170,21 +170,41 @@ checkInfo ms (m,mo) c info = do
         Nothing  -> return ()
       return (AbsFun (Just (L loc typ)) ma md moper)
 
-    CncFun linty@(Just (cat,cont,val)) (Just (L loc trm)) mpr -> chIn loc "linearization of" $ do
-      (trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
-      mpr <- checkPrintname gr mpr
-      return (CncFun linty (Just (L loc trm')) mpr)
+    CncCat mty mdef mpr mpmcfg -> do
+      mty  <- case mty of
+                Just (L loc typ) -> chIn loc "linearization type of" $ do
+                                       (typ,_) <- checkLType gr [] typ typeType
+                                       typ  <- computeLType gr [] typ
+                                       return (Just (L loc typ))
+                Nothing          -> return Nothing
+      mdef <- case (mty,mdef) of
+                (Just (L _ typ),Just (L loc def)) -> 
+                    chIn loc "default linearization of" $ do
+                       (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
+                       return (Just (L loc def))
+                _ -> return Nothing
+      mpr  <- case mpr of
+                (Just (L loc t)) -> 
+                    chIn loc "print name of" $ do
+                       (t,_) <- checkLType gr [] t typeStr
+                       return (Just (L loc t))
+                _ -> return Nothing
+      return (CncCat mty mdef mpr mpmcfg)
 
-    CncCat (Just (L loc typ)) mdef mpr -> chIn loc "linearization type of" $ do
-      (typ,_) <- checkLType gr [] typ typeType
-      typ  <- computeLType gr [] typ
-      mdef <- case mdef of
-        Just (L loc def) -> do
-          (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
-          return $ Just (L loc def)
-        _ -> return mdef
-      mpr <- checkPrintname gr mpr
-      return (CncCat (Just (L loc typ)) mdef mpr)
+    CncFun mty mt mpr mpmcfg -> do
+      mt <- case (mty,mt) of
+              (Just (cat,cont,val),Just (L loc trm)) -> 
+                  chIn loc "linearization of" $ do
+                     (trm,_) <- checkLType gr [] trm (mkProd cont val [])
+                     return (Just (L loc trm))
+              _ -> return mt
+      mpr  <- case mpr of
+                (Just (L loc t)) -> 
+                    chIn loc "print name of" $ do
+                       (t,_) <- checkLType gr [] t typeStr
+                       return (Just (L loc t))
+                _ -> return Nothing
+      return (CncFun mty mt mpr mpmcfg)
 
     ResOper pty pde -> do
       (pty', pde') <- case (pty,pde) of
@@ -252,11 +272,6 @@ checkInfo ms (m,mo) c info = do
      _ -> composOp (compAbsTyp g) t  
 
 
-checkPrintname :: SourceGrammar -> Maybe (L Term) -> Check (Maybe (L Term))
-checkPrintname gr (Just (L loc t)) = do (t,_) <- checkLType gr [] t typeStr
-                                        return (Just (L loc t))
-checkPrintname gr Nothing          = return Nothing
-
 -- | for grammars obtained otherwise than by parsing ---- update!!
 checkReservedId :: Ident -> Check ()
 checkReservedId x
diff --git a/src/compiler/GF/Compile/Coding.hs b/src/compiler/GF/Compile/Coding.hs
index 1b8753afe..5dc463d0e 100644
--- a/src/compiler/GF/Compile/Coding.hs
+++ b/src/compiler/GF/Compile/Coding.hs
@@ -20,10 +20,10 @@ codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
 codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
  where
     codj (c,info) = case info of
-      ResOper     pty pt  -> ResOper (codeLTerms co pty) (codeLTerms co pt) 
-      ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
-      CncCat pty pt mpr   -> CncCat pty (codeLTerms co pt) (codeLTerms co mpr)
-      CncFun mty pt mpr   -> CncFun mty (codeLTerms co pt) (codeLTerms co mpr)
+      ResOper     pty pt   -> ResOper (codeLTerms co pty) (codeLTerms co pt) 
+      ResOverload es tyts  -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
+      CncCat mty mt mpr mpmcfg -> CncCat mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
+      CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
       _ -> info
 
 codeLTerms co = fmap (codeLTerm co)
diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs
index af440ba0d..514b471c4 100644
--- a/src/compiler/GF/Compile/Compute/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs
@@ -45,7 +45,7 @@ arrityPredefined f = do ty <- typPredefined f
                         return (length ctxt)
 
 predefModInfo :: SourceModInfo
-predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives
+predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives
 
 primitives = Map.fromList
   [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index aaa4a2961..f4f1a3fca 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -10,10 +10,11 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.GeneratePMCFG
-    (convertConcrete) where
+    (generatePMCFG, pgfCncCat
+    ) where
 
 import PGF.CId
-import PGF.Data hiding (Type)
+import PGF.Data hiding (Type, Production)
 
 import GF.Infra.Option
 import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -28,9 +29,11 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
 import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
 import qualified Data.ByteString.Char8 as BS
 import Text.PrettyPrint hiding (Str)
 import Data.Array.IArray
+import Data.Array.Unboxed
 import Data.Maybe
 import Data.Char (isDigit)
 import Control.Monad
@@ -40,155 +43,83 @@ import Control.Exception
 ----------------------------------------------------------------------
 -- main conversion function
 
-
-convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
-convertConcrete opts0 gr am cm = do
-  let env = emptyGrammarEnv gr cm
-  when (flag optProf opts) $ do
-    profileGrammar cm env pfrules
-  env <- foldM (convertLinDef gr opts) env pflindefs
-  env <- foldM (convertRule gr opts) env pfrules
-  return $ getConcr flags printnames env
-  where
-    (m,mo) = cm
-    
-    opts = addOptions (mflags (snd am)) opts0
-
-    pflindefs = [
-      ((m,id),term,lincat) |
-        (id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (jments mo)]
-
-    pfrules = [
-      (PFRule id args ([],res) (map (\(_,_,ty) -> ty) cont) val term) |
-        (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (jments mo),
-        let (ctxt,res,_) = err error typeForm (lookupFunType gr (fst am) id)
-            args         = [catSkeleton ty | (_,_,ty) <- ctxt]]
-
-    flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (mflags mo)]
-
-    printnames = Map.fromAscList [(i2i id, name) | (id,info) <- Map.toList (jments mo), name <- prn info]
-      where
-        prn (GF.Grammar.CncFun _ _ (Just (L _ tr))) = [flatten tr]
-        prn (GF.Grammar.CncCat _ _ (Just (L _ tr))) = [flatten tr]
-        prn _                                       = []
-
-        flatten (K s)      = s
-        flatten (Alts x _) = flatten x
-        flatten (C x y)    = flatten x +++ flatten y
-
-i2i :: Ident -> CId
-i2i = CId . ident2bs
-
-profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) pfrules = do
-  hPutStrLn stderr ""
-  hPutStrLn stderr ("Language: " ++ showIdent m)
-  hPutStrLn stderr ""
-  hPutStrLn stderr "Categories                 Count"
-  hPutStrLn stderr "--------------------------------"
-  mapM_ profileCat (Map.toList catSet)
-  hPutStrLn stderr "--------------------------------"
-  hPutStrLn stderr ""
-  hPutStrLn stderr "Rules                      Count"
-  hPutStrLn stderr "--------------------------------"
-  mapM_ profileRule pfrules
-  hPutStrLn stderr "--------------------------------"
+generatePMCFG :: Options -> [SourceModule] -> SourceModule -> IO SourceModule
+generatePMCFG opts mos cmo@(cm,cmi) = do
+  (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr am cm) Map.empty (jments cmi)
+  when (verbAtLeast opts Verbose) $ hPutStrLn stderr ""
+  return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
   where
-    profileCat (cid,(fcat1,fcat2,_)) = do
-      hPutStrLn stderr (lformat 23 (showIdent cid) ++ rformat 9 (show (fcat2-fcat1+1)))
-
-    profileRule (PFRule fun args res ctypes ctype term) = do
-      let pargs = map (protoFCat env) args
-      hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args))))
-      where
-        catFactor (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (n,(_,cat)) =
-          case Map.lookup cat catSet of
-            Just (s,e,_) -> e-s+1
-            Nothing      -> 0
-
-    lformat :: Int -> String -> String
-    lformat n s = s ++ replicate (n-length s) ' '
-
-    rformat :: Int -> String -> String
-    rformat n s = replicate (n-length s) ' ' ++ s
-
-data ProtoFRule = PFRule Ident         {- function -}
-                         [([Cat],Cat)] {- argument types: context size and category -}
-                         ([Cat],Cat)   {- result   type : context size (always 0) and category  -}
-                         [Type]        {- argument lin-types representation -}
-                         Type          {- result   lin-type  representation -}
-                         Term          {- body -}
-
-optimize :: [ProtoFCat] -> GrammarEnv -> GrammarEnv
-optimize pargs (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) =
-  IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet IntMap.empty prodSet) appSet
+    gr = mGrammar (cmo:mos)
+    MTConcrete am = mtype cmi
+
+mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a
+                                     -> Map.Map k b -> m (a,Map.Map k c)
+mapAccumWithKeyM f a m = do let xs = Map.toAscList m
+                            (a,ys) <- mapAccumM f a xs
+                            return (a,Map.fromAscList ys)
   where
-    optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | (funid,args) <- Set.toList ps])
-      where
-        ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv
-        ff funid xs env
-          | product (map Set.size ys) == count
-                      = case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of
-                          (env,args) -> let xs = sequence (zipWith addContext pargs args)
-                                        in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs
-          | otherwise = List.foldl (\env args -> let xs = sequence (zipWith addContext pargs args)
-                                                 in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs) env xs
-          where
-            count = length xs
-            ys    = foldr (zipWith Set.insert) (repeat Set.empty) xs
-
-        addContext (PFCat ctxt _ _) fid = do hyps <- mapM toCncHypo ctxt
-                                             return (PArg hyps fid)
-
-        toCncHypo cat =
-          case Map.lookup cat catSet of
-            Just (s,e,_) -> do fid <- range (s,e)
-                               guard (fid `IntMap.member` lindefSet)
-                               return (fidVar,fid)
-            Nothing      -> mzero
-
-convertRule :: SourceGrammar -> Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
-convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
-  let pres  = protoFCat grammarEnv res
-      pargs = map (protoFCat grammarEnv) args
-
-      b     = runCnvMonad gr (unfactor term >>= convertTerm opts CNil ctype) (pargs,[])
-      (grammarEnv1,b1) = addSequencesB grammarEnv b
-      grammarEnv2 = foldBM addRule
-                           grammarEnv1
-                           (goB b1 CNil [])
-                           (pres,pargs)
-      grammarEnv3 = optimize pargs grammarEnv2
-  when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun)
-  return $! grammarEnv3
+    mapAccumM f a []          = return (a,[])
+    mapAccumM f a ((k,x):kxs) = do (a,y ) <- f a k x
+                                   (a,kys) <- mapAccumM f a kxs
+                                   return (a,(k,y):kys)
+
+
+addPMCFG :: Options -> SourceGrammar -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
+addPMCFG opts gr am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L _ term)) mprn _) = do
+  let pres  = protoFCat gr res val
+      pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
+
+      pmcfgEnv0   = emptyPMCFGEnv
+
+      b          = runCnvMonad gr (unfactor term >>= convertTerm opts CNil val) (pargs,[])
+      (seqs1,b1) = addSequencesB seqs b
+      pmcfgEnv1  = foldBM addRule
+                          pmcfgEnv0
+                          (goB b1 CNil [])
+                          (pres,pargs)
+      pmcfg      = getPMCFG pmcfgEnv1
+      
+      stats      = let PMCFG prods funs = pmcfg
+                       (s,e)            = bounds funs
+                       !prods_cnt       = length prods
+                       !funs_cnt        = e-s+1
+                   in (prods_cnt,funs_cnt)
+
+  when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
+  seqs1 `seq` stats `seq` return ()
+  when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats)
+  return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
   where
+    (ctxt,res,_) = err error typeForm (lookupFunType gr am id)
+
     addRule lins (newCat', newArgs') env0 =
-      let [newCat]        = getFIds env0 newCat'
-          (env1, newArgs) = List.mapAccumL (\env -> addCoercion env . getFIds env) env0 newArgs'
-
-          (env2,funid) = addCncFun env1 (PGF.Data.CncFun (i2i fun) (mkArray lins))
-
-      in addApplication env2 newCat (funid,newArgs)
-
-convertLinDef :: SourceGrammar -> Options -> GrammarEnv -> (Cat,Term,Type) -> IO GrammarEnv
-convertLinDef gr opts grammarEnv (cat,lindef,lincat) = do
-  let pres = protoFCat grammarEnv ([],cat)
-      parg = protoFCat grammarEnv ([],(identW,cVar))
-
-      b     = runCnvMonad gr (unfactor lindef >>= convertTerm opts CNil lincat) ([parg],[])
-      (grammarEnv1,b1) = addSequencesB grammarEnv b
-      grammarEnv2 = foldBM addRule
-                           grammarEnv1
-                           (goB b1 CNil [])
-                           (pres,[parg])
-  when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId lindefCId)
-  return $! grammarEnv2
+      let [newCat] = getFIds newCat'
+          !fun     = mkArray lins
+          newArgs  = map getFIds newArgs'
+      in addFunction env0 newCat fun newArgs
+
+addPMCFG opts gr am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L _ term)) mprn _) = do
+  let pres = protoFCat gr (am,id) lincat
+      parg = protoFCat gr (identW,cVar) typeStr
+
+      pmcfgEnv0  = emptyPMCFGEnv
+
+      b          = runCnvMonad gr (unfactor term >>= convertTerm opts CNil lincat) ([parg],[])
+      (seqs1,b1) = addSequencesB seqs b
+      pmcfgEnv1  = foldBM addRule
+                          pmcfgEnv0
+                          (goB b1 CNil [])
+                          (pres,[parg])
+      pmcfg     = getPMCFG pmcfgEnv1
+  when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres))
+  seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg))
   where
-    lindefCId = mkCId ("lindef "++showIdent (snd cat))
-
     addRule lins (newCat', newArgs') env0 =
-      let [newCat]     = getFIds env0 newCat'
-          (env1,funid) = addCncFun env0 (PGF.Data.CncFun lindefCId (mkArray lins))
-      in addLinDef env1 newCat funid
+      let [newCat] = getFIds newCat'
+          !fun     = mkArray lins
+      in addFunction env0 newCat fun [[fidVar]]
+
+addPMCFG opts gr am cm seqs id info = return (seqs, info)
 
 unfactor :: Term -> CnvMonad Term
 unfactor t = CM (\gr c -> c (unfac gr t))
@@ -202,6 +133,22 @@ unfactor t = CM (\gr c -> c (unfac gr t))
                           Vr y | y == x -> u
                           _             -> composSafeOp (restore x u) t
 
+pgfCncCat :: SourceGrammar -> Type -> Int -> PGF.Data.CncCat
+pgfCncCat gr lincat index =
+  let ((_,size),schema) = computeCatRange gr lincat
+  in PGF.Data.CncCat index
+                     (index+size-1)
+                     (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) 
+                                   (getStrPaths schema)))
+  where
+    getStrPaths :: Schema Identity s c -> [Path]
+    getStrPaths = collect CNil []
+      where
+        collect path paths (CRec rs)   = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
+        collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel  trm path) paths t) paths cs
+        collect path paths (CStr _)    = reversePath path : paths
+        collect path paths (CPar _)    = paths
+
 ----------------------------------------------------------------------
 -- CnvMonad monad
 --
@@ -248,7 +195,7 @@ variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
 choices :: Int -> Path -> CnvMonad Term
 choices nr path = do (args,_) <- get
                      let PFCat _ _ schema = args !! nr
-		     descend schema path CNil
+                     descend schema path CNil
   where
     descend (CRec rs)     (CProj lbl path) rpath = case lookup lbl rs of
                                                      Just (Identity t) -> descend t path (CProj lbl rpath)
@@ -305,15 +252,43 @@ data Path
 -- The annotations are as follows: the strings are annotated with
 -- their index in the PMCFG tuple, the parameters are annotated
 -- with their value both as term and as index.
-data ProtoFCat  = PFCat [Ident] Ident Proto
+data ProtoFCat  = PFCat Ident Int (Schema Identity Int (Int,[(Term,Int)]))
 type Env        = (ProtoFCat, [ProtoFCat])
 
-protoFCat :: GrammarEnv -> ([Cat],Cat) -> ProtoFCat
-protoFCat (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (ctxt,(_,cat)) =
-  case Map.lookup cat catSet of
-    Just (_,_,proto) -> PFCat (map snd ctxt) cat proto
-    Nothing          -> error "unknown category"
-  
+protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat
+protoFCat gr cat lincat =
+  case computeCatRange gr lincat of
+    ((_,f),schema) -> PFCat (snd cat) f schema
+
+getFIds :: ProtoFCat -> [FId]
+getFIds (PFCat _ _ schema) =
+  reverse (solutions (variants schema) ())
+  where
+    variants (CRec rs)         = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
+    variants (CTbl _ cs)       = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
+    variants (CStr _)          = return 0
+    variants (CPar (m,values)) = do (value,index) <- member values
+                                    return (m*index)
+
+catFactor :: ProtoFCat -> Int
+catFactor (PFCat _ f _) = f
+
+computeCatRange gr lincat = compute (0,1) lincat
+  where
+    compute st (RecType  rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
+                                                                              in (st',(lbl,Identity t'))) st rs
+                               in (st',CRec rs')
+    compute st (Table pt vt) = let vs        = err error id (allParamValues gr pt)
+                                   (st',cs') = List.mapAccumL (\st v       -> let (st',vt') = compute st vt
+                                                                              in (st',(v,Identity vt'))) st vs
+                               in (st',CTbl pt cs')
+    compute st (Sort s)
+                   | s == cStr = let (index,m) = st
+                                 in ((index+1,m),CStr index)
+    compute st t               = let vs = err error id (allParamValues gr t)
+                                     (index,m) = st
+                                 in ((index,m*length vs),CPar (m,zip vs [0..]))
+
 ppPath (CProj lbl path) = ppLabel lbl              <+> ppPath path
 ppPath (CSel  trm path) = ppTerm Unqualified 5 trm <+> ppPath path
 ppPath CNil             = empty
@@ -363,7 +338,7 @@ convertArg opts (Table pt vt) nr path = do
   mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
 convertArg opts (Sort _)      nr path = do
   (args,_) <- get
-  let PFCat _ cat schema = args !! nr
+  let PFCat cat _ schema = args !! nr
       l = index (reversePath path) schema
       sym | CProj (LVar i) CNil <- path = SymVar nr i
           | isLiteralCat opts cat       = SymLit nr l
@@ -411,26 +386,31 @@ goV (CTbl _ xs)  rpath ss = foldM (\ss (trm,b) -> goB b (CSel  trm rpath) ss) ss
 goV (CStr seqid) rpath ss = return (seqid : ss)
 goV (CPar t)     rpath ss = restrictHead (reversePath rpath) t >> return ss
 
-addSequencesB :: GrammarEnv -> Branch (Value [Symbol]) -> (GrammarEnv, Branch (Value SeqId))
-addSequencesB env (Case nr path bs) = let (env1,bs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
-                                                                                       in (env',(trm,b'))) env bs
-                                      in (env1,Case nr path bs1)
-addSequencesB env (Variant bs)      = let (env1,bs1) = List.mapAccumL addSequencesB env bs
-                                      in (env1,Variant bs1)
-addSequencesB env (Return  v)       = let (env1,v1) = addSequencesV env v
-                                      in (env1,Return v1)
-
-addSequencesV :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId)
-addSequencesV env (CRec vs)  = let (env1,vs1) = List.mapAccumL (\env (lbl,b) -> let (env',b') = addSequencesB env b
-                                                                                in (env',(lbl,b'))) env vs
-                               in (env1,CRec vs1)
-addSequencesV env (CTbl pt vs)=let (env1,vs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
-                                                                                in (env',(trm,b'))) env vs
-                               in (env1,CTbl pt vs1)
-addSequencesV env (CStr lin) = let (env1,seqid) = addSequence env (optimizeLin lin)
-                               in (env1,CStr seqid)
-addSequencesV env (CPar i)   = (env,CPar i)
 
+----------------------------------------------------------------------
+-- SeqSet
+
+type SeqSet   = Map.Map Sequence SeqId
+
+addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
+addSequencesB seqs (Case nr path bs) = let (seqs1,bs1) = List.mapAccumL (\seqs (trm,b) -> let (seqs',b') = addSequencesB seqs b
+                                                                                          in (seqs',(trm,b'))) seqs bs
+                                       in (seqs1,Case nr path bs1)
+addSequencesB seqs (Variant bs)      = let (seqs1,bs1) = List.mapAccumL addSequencesB seqs bs
+                                       in (seqs1,Variant bs1)
+addSequencesB seqs (Return  v)       = let (seqs1,v1) = addSequencesV seqs v
+                                       in (seqs1,Return v1)
+
+addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
+addSequencesV seqs (CRec vs)  = let (seqs1,vs1) = List.mapAccumL (\seqs (lbl,b) -> let (seqs',b') = addSequencesB seqs b
+                                                                                   in (seqs',(lbl,b'))) seqs vs
+                                in (seqs1,CRec vs1)
+addSequencesV seqs (CTbl pt vs)=let (seqs1,vs1) = List.mapAccumL (\seqs (trm,b) -> let (seqs',b') = addSequencesB seqs b
+                                                                                   in (seqs',(trm,b'))) seqs vs
+                                in (seqs1,CTbl pt vs1)
+addSequencesV seqs (CStr lin) = let (seqs1,seqid) = addSequence seqs (optimizeLin lin)
+                                in (seqs1,CStr seqid)
+addSequencesV seqs (CPar i)   = (seqs,CPar i)
 
 optimizeLin [] = []
 optimizeLin lin@(SymKS _ : _) = 
@@ -442,6 +422,15 @@ optimizeLin lin@(SymKS _ : _) =
     getRest             lin  = ([],lin)
 optimizeLin (sym : lin) = sym : optimizeLin lin
 
+addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
+addSequence seqs lst =
+  case Map.lookup seq seqs of
+    Just id -> (seqs,id)
+    Nothing -> let !last_seq = Map.size seqs
+               in (Map.insert seq last_seq seqs, last_seq)
+  where
+    seq = mkArray lst
+
 
 ------------------------------------------------------------
 -- eval a term to ground terms
@@ -478,124 +467,36 @@ getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd
 ----------------------------------------------------------------------
 -- GrammarEnv
 
-data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet LinDefSet CoerceSet AppSet ProdSet
-type Proto    = Schema Identity Int (Int,[(Term,Int)])
-type CatSet   = Map.Map Ident (FId,FId,Proto)
-type SeqSet   = Map.Map Sequence SeqId
-type FunSet   = Map.Map CncFun FunId
-type LinDefSet= IntMap.IntMap [FunId]
-type CoerceSet= Map.Map [FId] FId
-type AppSet   = IntMap.IntMap (Set.Set (FunId,[FId]))
-type ProdSet  = IntMap.IntMap (Set.Set Production)
-
-emptyGrammarEnv gr (m,mo) =
-  let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
-  in GrammarEnv last_id catSet Map.empty Map.empty IntMap.empty Map.empty IntMap.empty IntMap.empty
-  where
-    computeCatRange index cat ctype
-      | cat == cString = (index,(fidString,fidString,CRec [(theLinLabel,Identity (CStr 0))]))
-      | cat == cInt    = (index,(fidInt,   fidInt,   CRec [(theLinLabel,Identity (CStr 0))]))
-      | cat == cFloat  = (index,(fidFloat, fidFloat, CRec [(theLinLabel,Identity (CStr 0))]))
-      | cat == cVar    = (index,(fidVar,   fidVar,   CStr 0))
-      | otherwise      = (index+size,(index,index+size-1,schema))
-      where
-        ((_,size),schema) = compute (0,1) ctype
- 
-    compute st (RecType  rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
-                                                                              in (st',(lbl,Identity t'))) st rs
-                               in (st',CRec rs')
-    compute st (Table pt vt) = let vs        = err error id (allParamValues gr pt)
-                                   (st',cs') = List.mapAccumL (\st v       -> let (st',vt') = compute st vt
-                                                                              in (st',(v,Identity vt'))) st vs
-                               in (st',CTbl pt cs')
-    compute st (Sort s)
-                   | s == cStr = let (index,m) = st
-                                 in ((index+1,m),CStr index)
-    compute st t               = let vs = err error id (allParamValues gr t)
-                                     (index,m) = st
-                                 in ((index,m*length vs),CPar (m,zip vs [0..]))
+data PMCFGEnv = PMCFGEnv !ProdSet !FunSet
+type ProdSet  = Set.Set Production
+type FunSet   = Map.Map (UArray LIndex SeqId) FunId
 
-    lincats =
-      Map.insert cVar (Sort cStr) $
-      Map.fromAscList 
-        [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (jments mo)]
-
-addApplication :: GrammarEnv -> FId -> (FunId,[FId]) -> GrammarEnv
-addApplication (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid p =
-  GrammarEnv last_id catSet seqSet funSet lindefSet crcSet (IntMap.insertWith Set.union fid (Set.singleton p) appSet) prodSet
-
-addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv
-addProduction (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) cat p =
-  GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
-
-addSequence :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId)
-addSequence env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) lst =
-  case Map.lookup seq seqSet of
-    Just id -> (env,id)
-    Nothing -> let !last_seq = Map.size seqSet
-               in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet lindefSet crcSet appSet prodSet,last_seq)
-  where
-    seq = mkArray lst
+emptyPMCFGEnv =
+  PMCFGEnv Set.empty Map.empty
 
-addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId)
-addCncFun env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fun = 
+addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv
+addFunction (PMCFGEnv prodSet funSet) !fid fun args =
   case Map.lookup fun funSet of
-    Just id -> (env,id)
-    Nothing -> let !last_funid = Map.size funSet
-               in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) lindefSet crcSet appSet prodSet,last_funid)
-
-addCoercion :: GrammarEnv -> [FId] -> (GrammarEnv,FId)
-addCoercion env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) sub_fcats =
-  case sub_fcats of
-    [fcat] -> (env,fcat)
-    _      -> case Map.lookup sub_fcats crcSet of
-                Just fcat -> (env,fcat)
-                Nothing   -> let !fcat = last_id+1
-                             in (GrammarEnv fcat catSet seqSet funSet lindefSet (Map.insert sub_fcats fcat crcSet) appSet prodSet,fcat)
-
-addLinDef :: GrammarEnv -> FId -> FunId -> GrammarEnv
-addLinDef (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid funid =
-  GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith (++) fid [funid] lindefSet) crcSet appSet prodSet
-
-getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr
-getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) =
-  Concr { cflags = flags
-        , printnames = printnames
-        , cncfuns   = mkSetArray funSet
-        , lindefs = lindefSet
-        , sequences   = mkSetArray seqSet
-        , productions = IntMap.union prodSet coercions
-        , pproductions = IntMap.empty
-        , lproductions = Map.empty
-        , lexicon      = IntMap.empty
-        , cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema))))
-                                     | (cat,(start,end,schema)) <- Map.toList catSet]
-        , totalCats   = last_id+1
-        }
+    Just !funid -> PMCFGEnv (Set.insert (Production fid funid args) prodSet)
+                            funSet
+    Nothing     -> let !funid = Map.size funSet
+                   in PMCFGEnv (Set.insert (Production fid funid args) prodSet)
+                               (Map.insert fun funid funSet)
+
+getPMCFG :: PMCFGEnv -> PMCFG
+getPMCFG (PMCFGEnv prodSet funSet) =
+  PMCFG (optimize prodSet) (mkSetArray funSet)
   where
-    mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-    
-    coercions = IntMap.fromList [(fcat,Set.fromList (map PCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet]
-
-    getStrPaths :: Schema Identity s c -> [Path]
-    getStrPaths = collect CNil []
+    optimize ps = Map.foldWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps])
       where
-        collect path paths (CRec rs)   = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
-        collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel  trm path) paths t) paths cs
-        collect path paths (CStr _)    = reversePath path : paths
-        collect path paths (CPar _)    = paths
-
-
-getFIds :: GrammarEnv -> ProtoFCat -> [FId]
-getFIds (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (PFCat ctxt cat schema) =
-  case Map.lookup cat catSet of
-    Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ())
-  where
-    variants (CRec rs)         = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
-    variants (CTbl _ cs)       = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
-    variants (CStr _)          = return 0
-    variants (CPar (m,values)) = do (value,index) <- member values
-                                    return (m*index)
+        ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production]
+        ff (fid,funid) xs prods
+          | product (map IntSet.size ys) == count
+                      = (Production fid funid (map IntSet.toList ys)) : prods
+          | otherwise = map (Production fid funid) xs ++ prods
+          where
+            count = sum (map (product . map length) xs)
+            ys    = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
 
 ------------------------------------------------------------
 -- updating the MCF rule
@@ -613,9 +514,9 @@ restrictHead path term = do
   put (head, args)
 
 restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
-restrictProtoFCat path v (PFCat ctxt cat schema) = do
+restrictProtoFCat path v (PFCat cat f schema) = do
   schema <- addConstraint path v schema
-  return (PFCat ctxt cat schema)
+  return (PFCat cat f schema)
   where
     addConstraint (CProj lbl path) v (CRec rs)     = fmap CRec      $ update lbl (addConstraint path v) rs
     addConstraint (CSel  trm path) v (CTbl pt cs)  = fmap (CTbl pt) $ update trm (addConstraint path v) cs
@@ -631,4 +532,5 @@ restrictProtoFCat path v (PFCat ctxt cat schema) = do
       | otherwise  = do xs <- update k0 f xs
                         return (x:xs)
 
-mkArray lst = listArray (0,length lst-1) lst
+mkArray    lst = listArray (0,length lst-1) lst
+mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index 06ececb3c..7e73b36de 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -1,10 +1,11 @@
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE BangPatterns #-}
 module GF.Compile.GrammarToPGF (mkCanon2pgf) where
 
 import GF.Compile.Export
 import GF.Compile.GeneratePMCFG
 
 import PGF.CId
+import PGF.Data(fidInt,fidFloat,fidString)
 import PGF.Optimize(updateProductionIndices)
 import qualified PGF.Macros as CM
 import qualified PGF.Data as C
@@ -15,8 +16,8 @@ import GF.Grammar.Grammar
 import qualified GF.Grammar.Lookup as Look
 import qualified GF.Grammar as A
 import qualified GF.Grammar.Macros as GM
---import qualified GF.Compile.Compute.Concrete as Compute ---- 
 import qualified GF.Infra.Option as O
+import GF.Compile.GeneratePMCFG
 
 import GF.Infra.Ident
 import GF.Infra.Option
@@ -25,61 +26,72 @@ import GF.Data.Operations
 import Data.List
 import Data.Function
 import Data.Char (isDigit,isSpace)
+import qualified Data.Set as Set
 import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
 import qualified Data.ByteString.Char8 as BS
+import Data.Array.IArray
 import Text.PrettyPrint
---import Debug.Trace ----
-
--- when developing, swap commenting
---traceD s t = trace s t 
-traceD s t = t 
+import Control.Monad.Identity
 
 
--- the main function: generate PGF from GF.
-mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF
-mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr
-  where
-    abs = err (const cnc) id $ abstractOfConcrete gr cnc
-
--- Generate PGF from grammar.
-
-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) (am:cms))))
-    else return ()
-  (an,abs) <- mkAbstr am
-  cncs     <- mapM (mkConcr am) cms
+mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IO D.PGF
+mkCanon2pgf opts gr am = do
+  (an,abs) <- mkAbstr gr am
+  cncs     <- mapM (mkConcr gr) (allConcretes gr am)
   return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
   where
-    mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats)
+    mkAbstr gr am = return (i2i am, D.Abstr flags funs cats)
       where
-        flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (mflags abm)]
+        aflags = 
+          concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo])
+
+        adefs =
+          [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
+          Look.allOrigInfos gr am
+
+        flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags]
         
         funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) | 
-                                   (f,AbsFun (Just (L _ ty)) ma pty _) <- Map.toAscList (jments abm)]
+                                   ((m,f),AbsFun (Just (L _ ty)) ma pty _) <- adefs]
                                    
         cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
-                                   (c,AbsCat (Just (L _ cont))) <- Map.toAscList (jments abm)]
+                                   ((m,c),AbsCat (Just (L _ cont))) <- adefs]
 
         catfuns cat =
               (map (\x -> (0,snd x)) . sortBy (compare `on` fst))
-                 [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _ (Just True)) <- tree2list (jments abm), snd (GM.valCat ty) == cat]
+                 [(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
+
+    mkConcr gr cm = do
+      return (i2i cm, D.Concr flags 
+                              printnames
+                              cncfuns
+                              lindefs
+                              sequences
+                              productions
+                              IntMap.empty
+                              Map.empty
+                              cnccats
+                              IntMap.empty
+                              fid_cnt2)
+      where
+        cflags  = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo, 
+                                                Just r <- [lookup i (allExtendSpecs gr cm)]]
+
+        cdefs = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
+                Look.allOrigInfos gr cm
 
-    mkConcr am cm@(lang,mo) = do
-      cnc <- convertConcrete opts gr am cm
-      return (i2i lang, cnc)
+        flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF cflags]
+
+        !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
+        !(!fid_cnt2,!productions,!lindefs,!sequences,!cncfuns)
+                              = genCncFuns gr am cm cdefs fid_cnt1 cnccats
+        
+        printnames = genPrintNames cdefs
 
 i2i :: Ident -> CId
 i2i = CId . ident2bs
 
-b2b :: A.BindType -> C.BindType
-b2b A.Explicit = C.Explicit
-b2b A.Implicit = C.Implicit
-
 mkType :: [Ident] -> A.Type -> C.Type
 mkType scope t =
   case GM.typeForm t of
@@ -94,7 +106,7 @@ mkExp scope t =
     Vr x     -> case lookup x (zip scope [0..]) of
                   Just i  -> C.EVar  i
                   Nothing -> C.EMeta 0
-    Abs b x t-> C.EAbs (b2b b) (i2i x) (mkExp (x:scope) t)
+    Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
     App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
     EInt i   -> C.ELit (C.LInt (fromIntegral i))
     EFloat f -> C.ELit (C.LFlt f)
@@ -120,8 +132,8 @@ mkPatt scope p =
 mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
 mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                       in if x == identW
-                                                           then (  scope,(b2b bt,i2i x,ty'))
-                                                           else (x:scope,(b2b bt,i2i x,ty'))) scope hyps 
+                                                           then (  scope,(bt,i2i x,ty'))
+                                                           else (x:scope,(bt,i2i x,ty'))) scope hyps 
 
 mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
 mkDef Nothing    = Nothing
@@ -148,28 +160,121 @@ compilePatt eqs        = whilePP eqs Map.empty
     mkCase cns vrs = Case (fmap compilePatt cns) (compilePatt vrs)
 
 
--- return just one module per language
+genCncCats gr am cm cdefs =
+  let (index,cats) = mkCncCats 0 cdefs
+  in (index, Map.fromList cats)
+  where
+    mkCncCats index []                                                = (index,[])
+    mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _):cdefs) 
+      | id == cInt    = 
+            let cc            = pgfCncCat gr lincat fidInt
+                (index',cats) = mkCncCats index cdefs
+            in (index', (i2i id,cc) : cats)
+      | id == cFloat  = 
+            let cc            = pgfCncCat gr lincat fidFloat
+                (index',cats) = mkCncCats index cdefs
+            in (index', (i2i id,cc) : cats)
+      | id == cString = 
+            let cc            = pgfCncCat gr lincat fidString
+                (index',cats) = mkCncCats index cdefs
+            in (index', (i2i id,cc) : cats)
+      | otherwise     =
+            let cc@(C.CncCat s e _) = pgfCncCat gr lincat index
+                (index',cats)       = mkCncCats (e+1) cdefs
+            in (index', (i2i id,cc) : cats)
+    mkCncCats index (_                      :cdefs) = mkCncCats index cdefs
+
 
-reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
-reorder abs cg =
---  M.MGrammar $
-       ((abs, ModInfo MTAbstract       MSComplete aflags [] Nothing [] [] "" adefs),
-      [(cnc, ModInfo (MTConcrete abs) MSComplete cflags [] Nothing [] [] "" cdefs)
-            | cnc <- allConcretes cg abs, let (cflags,cdefs) = concr cnc])
+genCncFuns gr am cm cdefs fid_cnt cnccats =
+  let (fid_cnt1,funs_cnt1,seqs1,funs1,lindefs) = mkCncCats cdefs fid_cnt  0 Map.empty [] IntMap.empty
+      (fid_cnt2,funs_cnt2,seqs2,funs2,prods)   = mkCncFuns cdefs fid_cnt1 funs_cnt1 seqs1 funs1 lindefs Map.empty IntMap.empty
+  in (fid_cnt2,prods,lindefs,mkSetArray seqs2,array (0,funs_cnt2-1) funs2)
   where
-    aflags = 
-      concatOptions (reverse [mflags mo | (_,mo) <- modules cg, isModAbs mo])
+    mkCncCats []                                                        fid_cnt funs_cnt seqs funs lindefs =
+      (fid_cnt,funs_cnt,seqs,funs,lindefs)
+    mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs =
+      let !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
+                           in funs_cnt+(e_funid-s_funid+1)
+          lindefs'       = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
+          !(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0)
+      in mkCncCats cdefs fid_cnt funs_cnt' seqs' funs' lindefs'
+    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt seqs funs lindefs = 
+      mkCncCats cdefs fid_cnt funs_cnt seqs funs lindefs
 
-    adefs = 
-      Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
+    mkCncFuns []                                                        fid_cnt funs_cnt seqs funs lindefs crc prods =
+      (fid_cnt,funs_cnt,seqs,funs,prods)
+    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods =
+      let Ok ty_C        = fmap GM.typeForm (Look.lookupFunType gr am id)
+          !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
+                           in funs_cnt+(e_funid-s_funid+1)
+          !(fid_cnt',crc',prods') 
+                         = foldl' (toProd lindefs ty_C funs_cnt)
+                                  (fid_cnt,crc,prods) prods0
+          !(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0)
+      in mkCncFuns cdefs fid_cnt' funs_cnt' seqs' funs' lindefs crc' prods'
+    mkCncFuns (_                                                :cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods = 
+      mkCncFuns cdefs fid_cnt funs_cnt seqs funs lindefs crc prods
+
+    toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
+      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) 
+          set0    = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
+          fid     = mkFId res_C fid0
+          !prods' = case IntMap.lookup fid prods of
+                     Just set -> IntMap.insert fid (Set.union set0 set) prods
+                     Nothing  -> IntMap.insert fid set0 prods
+      in (fid_cnt,crc,prods')
       where
-        predefADefs = 
-           [(c, AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]]
-
-    concr la = (flags, Map.fromList (predefCDefs ++ jments))
-      where 
-        flags  = concatOptions [mflags mo | (i,mo) <- modules cg, isModCnc mo, 
-                                                Just r <- [lookup i (allExtendSpecs cg la)]]
-        jments = Look.allOrigInfos cg la
-        predefCDefs = 
-           [(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
+        mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
+          case fid0s of
+            [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
+            fid0s  -> case Map.lookup fids crc of
+                        Just fid -> (st,map (flip C.PArg fid) ctxt)
+                        Nothing  -> let !crc'   = Map.insert fids fid_cnt crc
+                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
+                                    in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
+          where
+            (hargs_C,arg_C) = GM.catSkeleton ty
+            ctxt = mapM (mkCtxt lindefs) hargs_C
+            fids = map (mkFId arg_C) fid0s
+
+    toLinDef res offs lindefs (Production fid0 funid0 _) =
+      IntMap.insertWith (++) fid [offs+funid0] lindefs
+      where
+        fid = mkFId res fid0
+
+    mkFId (_,cat) fid0 =
+      case Map.lookup (i2i cat) cnccats of
+        Just (C.CncCat s e _) -> s+fid0
+        Nothing               -> error "GrammarToPGF.mkFId failed"
+
+    mkCtxt lindefs (_,cat) =
+      case Map.lookup (i2i cat) cnccats of
+        Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
+        Nothing               -> error "GrammarToPGF.mkCtxt failed"
+
+    toCncFun offs (m,id) (seqs,funs) (funid0,lins0) =
+      let Ok (ModInfo{mseqs=Just mseqs}) = lookupModule gr m
+          !(!seqs',lins) = mapAccumL (mkLin mseqs) seqs (elems lins0)
+      in (seqs',(offs+funid0,C.CncFun (i2i id) (mkArray lins)):funs)
+      where
+        mkLin mseqs seqs seqid =
+          let seq = mseqs ! seqid
+          in case Map.lookup seq seqs of
+               Just seqid -> (seqs,seqid)
+               Nothing    -> let !seqid = Map.size seqs
+                                 !seqs' = Map.insert seq seqid seqs
+                             in (seqs',seqid)
+
+genPrintNames cdefs =
+  Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
+  where
+    prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
+    prn (CncCat _ _ (Just (L _ tr)) _) = [flatten tr]
+    prn _                              = []
+
+    flatten (K s)      = s
+    flatten (Alts x _) = flatten x
+    flatten (C x y)    = flatten x +++ flatten y
+
+mkArray    lst = listArray (0,length lst-1) lst
+mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs
index 303bdb8d0..33632f5bf 100644
--- a/src/compiler/GF/Compile/Optimize.hs
+++ b/src/compiler/GF/Compile/Optimize.hs
@@ -61,7 +61,7 @@ evalInfo opts ms m c info = do
 
  errIn ("optimizing " ++ showIdent c) $ case info of
 
-  CncCat ptyp pde ppr -> do
+  CncCat ptyp pde ppr mpmcfg -> do
     pde' <- case (ptyp,pde) of
       (Just (L _ typ), Just (L loc de)) -> do
         de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
@@ -74,16 +74,16 @@ evalInfo opts ms m c info = do
 
     ppr' <- evalPrintname gr ppr
 
-    return (CncCat ptyp pde' ppr')
+    return (CncCat ptyp pde' ppr' mpmcfg)
 
-  CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $
+  CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
        eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
     pde' <- case pde of
       Just (L loc de) -> do de <- partEval opts gr (cont,val) de
                             return (Just (L loc (factor param c 0 de)))
       Nothing -> return pde
     ppr' <-  evalPrintname gr ppr
-    return $ CncFun mt pde' ppr' -- only cat in type actually needed
+    return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
 
   ResOper pty pde 
     | OptExpand `Set.member` optim -> do
diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs
index 86e423317..b66e88aa3 100644
--- a/src/compiler/GF/Compile/Refresh.hs
+++ b/src/compiler/GF/Compile/Refresh.hs
@@ -124,12 +124,12 @@ refreshModule (k,ms) mi@(i,mo)
       (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ 
                     appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k)
       return $ (k', (c, ResOverload os tyts'):cs)
-    CncCat mt (Just (L loc trm)) pn -> do   ---- refresh mt, pn
+    CncCat mt (Just (L loc trm)) mn mpmcfg-> do   ---- refresh mt, pn
       (k',trm') <- refreshTermKN k trm
-      return $ (k', (c, CncCat mt (Just (L loc trm')) pn):cs)
-    CncFun mt (Just (L loc trm)) pn -> do   ---- refresh pn
+      return $ (k', (c, CncCat mt (Just (L loc trm')) mn mpmcfg):cs)
+    CncFun mt (Just (L loc trm)) mn mpmcfg -> do   ---- refresh pn
       (k',trm') <- refreshTermKN k trm
-      return $ (k', (c, CncFun mt (Just (L loc trm')) pn):cs)
+      return $ (k', (c, CncFun mt (Just (L loc trm')) mn mpmcfg):cs)
     _ -> return (k, ci:cs)
 
 
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 805e85464..336e8f946 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -158,8 +158,8 @@ renameInfo status (m,mi) i info =
     ResValue t -> do
       t <- renLoc (renameTerm status []) t
       return (ResValue t)
-    CncCat pty ptr ppr -> liftM3 CncCat (renTerm pty) (renTerm ptr) (renTerm ppr)
-    CncFun mt  ptr ppr -> liftM2 (CncFun mt)          (renTerm ptr) (renTerm ppr)
+    CncCat mty mtr mpr mpmcfg -> liftM4 CncCat (renTerm mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
+    CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty)         (renTerm mtr) (renTerm mpr) (return mpmcfg)
     _ -> return info
   where
     renTerm = renPerh (renameTerm status [])
diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs
index 453c8e3ca..bfa2a1334 100644
--- a/src/compiler/GF/Compile/SubExOpt.hs
+++ b/src/compiler/GF/Compile/SubExOpt.hs
@@ -52,7 +52,7 @@ unsubexpModule sm@(i,mo)
     -- perform this iff the module has opers
     hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
     unparInfo (c,info) = case info of
-      CncFun xs (Just (L loc t)) m -> [(c, CncFun xs (Just (L loc (unparTerm t))) m)]
+      CncFun xs (Just (L loc t)) m pf -> [(c, CncFun xs (Just (L loc (unparTerm t))) m pf)]
       ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
       ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
       _ -> [(c,info)]
@@ -75,9 +75,9 @@ addSubexpConsts mo tree lins = do
   mapM mkOne $ opers ++ lins
  where
    mkOne (f,def) = case def of
-     CncFun xs (Just (L loc trm)) pn -> do
+     CncFun xs (Just (L loc trm)) pn pf -> do
        trm' <- recomp f trm
-       return (f,CncFun xs (Just (L loc trm')) pn)
+       return (f,CncFun xs (Just (L loc trm')) pn pf)
      ResOper ty (Just (L loc trm)) -> do
        trm' <- recomp f trm
        return (f,ResOper ty (Just (L loc trm')))
@@ -98,7 +98,7 @@ getSubtermsMod mo js = do
   return $ Map.filter (\ (nu,_) -> nu > 1) tree0
  where
    getInfo get fi@(f,i) = case i of
-     CncFun xs (Just (L _ trm)) pn -> do
+     CncFun xs (Just (L _ trm)) pn _ -> do
        get trm
        return $ fi
      ResOper ty (Just (L _ trm)) -> do
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 2a95df4d5..6eb88b272 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -76,7 +76,7 @@ extendModule gr (name,m)
 -- | rebuilding instance + interface, and "with" modules, prior to renaming. 
 -- AR 24/10/2003
 rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
-rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
+rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) = do
 ----  deps <- moduleDeps ms
 ----  is   <- openInterfaces deps i
   let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
@@ -109,7 +109,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
                     [i | i <- is, notElem i infs]
       testErr (stat' == MSComplete || stat == MSIncomplete) 
               ("module" +++ showIdent i +++ "remains incomplete")
-      ModInfo mt0 _ fs me' _ ops0 _ _ js <- lookupModule gr ext
+      ModInfo mt0 _ fs me' _ ops0 _ _ _ js <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
                    [OQualif i j | (i,j) <- ops] ++
@@ -122,7 +122,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
       let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
       let js1 = buildTree (tree2list js_ ++ js0)
       let med1= nub (ext : infs ++ insts ++ med_)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ js1
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ env_ js1
 
   return (i,mi')
 
@@ -173,8 +173,8 @@ globalizeLoc fpath i =
     ResValue t            -> ResValue (gl t)
     ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
     ResOverload ms os     -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
-    CncCat mc mf mp       -> CncCat (fmap gl mc)  (fmap gl mf) (fmap gl mp)
-    CncFun m mt md        -> CncFun m (fmap gl mt) (fmap gl md)
+    CncCat mc mf mp mpmcfg-> CncCat (fmap gl mc)  (fmap gl mf) (fmap gl mp) mpmcfg
+    CncFun m  mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg
     AnyInd b m            -> AnyInd b m
   where
     gl (L loc0 x) = loc `seq` L (External fpath loc) x
@@ -200,10 +200,10 @@ unifyAnyInfo m i j = case (i,j) of
   (ResOper mt1 m1, ResOper mt2 m2) -> 
     liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2)
 
-  (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
-    liftM3 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2)
-  (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
-    liftM2 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) ---- adding defs
+  (CncCat mc1 mf1 mp1 mpmcfg1, CncCat mc2 mf2 mp2 mpmcfg2) -> 
+    liftM4 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2)  (unifMaybe mpmcfg1 mpmcfg2)
+  (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> 
+    liftM3 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) (unifMaybe mpmcfg1 mpmcfg2)
 
   (AnyInd b1 m1, AnyInd b2 m2) -> do
     testErr (b1 == b2) $ "indirection status"
diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 1c9358816..38d3d9bcc 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -31,8 +31,8 @@ stripInfo i = case i of
   ResValue lt -> i ----
   ResOper mt md -> ResOper mt Nothing
   ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
-  CncCat mty mte mtf -> CncCat mty Nothing Nothing
-  CncFun mict mte mtf -> CncFun mict Nothing Nothing
+  CncCat mty mte mtf mpmcfg -> CncCat mty Nothing Nothing Nothing
+  CncFun mict mte mtf mpmcfg -> CncFun mict Nothing Nothing Nothing
   AnyInd b f -> i
 
 constantsInTerm :: Term -> [QIdent]
@@ -110,8 +110,8 @@ sizeInfo i = case i of
   ResValue lt -> 0
   ResOper mt md -> 1 + msize mt + msize md
   ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
-  CncCat mty mte mtf -> 1 + msize mty   -- ignoring lindef and printname
-  CncFun mict mte mtf -> 1 + msize mte  -- ignoring type and printname
+  CncCat mty mte mtf _ -> 1 + msize mty   -- ignoring lindef and printname
+  CncFun mict mte mtf _ -> 1 + msize mte  -- ignoring type and printname
   AnyInd b f -> -1  -- just to ignore these in the size
   _ -> 0
  where 
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 2298ed018..d1a3ac413 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -18,6 +18,8 @@ import GF.Infra.Ident
 import GF.Infra.Option

 import GF.Grammar.Grammar

 

+import PGF.Binary hiding (decodingError)

+

 instance Binary Ident where

   put id = put (ident2bs id)

   get    = do bs <- get

@@ -30,9 +32,9 @@ instance Binary SourceGrammar where
   get = fmap mGrammar get

 

 instance Binary SourceModInfo where

-  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)

-  get    = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get

-              return (ModInfo mtype mstatus flags extend mwith opens med src jments)

+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)

+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get

+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)

 

 instance Binary ModuleType where

   put MTAbstract       = putWord8 0

@@ -85,6 +87,19 @@ instance Binary Options where
              Ok  x   -> return x

              Bad msg -> fail msg

 

+instance Binary Production where

+  put (Production res funid args) = put (res,funid,args)

+  get = do res   <- get

+           funid <- get

+           args  <- get

+           return (Production res funid args)

+

+instance Binary PMCFG where

+  put (PMCFG prods funs) = put (prods,funs)

+  get = do prods <- get

+           funs  <- get

+           return (PMCFG prods funs)

+

 instance Binary Info where

   put (AbsCat x)       = putWord8 0 >> put x

   put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)

@@ -92,8 +107,8 @@ instance Binary Info where
   put (ResValue x)     = putWord8 3 >> put x

   put (ResOper x y)    = putWord8 4 >> put (x,y)

   put (ResOverload x y)= putWord8 5 >> put (x,y)

-  put (CncCat x y z)   = putWord8 6 >> put (x,y,z)

-  put (CncFun x y z)   = putWord8 7 >> put (x,y,z)

+  put (CncCat w x y z) = putWord8 6 >> put (w,x,y,z)

+  put (CncFun w x y z) = putWord8 7 >> put (w,x,y,z)

   put (AnyInd x y)     = putWord8 8 >> put (x,y)

   get = do tag <- getWord8

            case tag of

@@ -103,8 +118,8 @@ instance Binary Info where
              3 -> get >>= \x         -> return (ResValue x)

              4 -> get >>= \(x,y)     -> return (ResOper x y)

              5 -> get >>= \(x,y)     -> return (ResOverload x y)

-             6 -> get >>= \(x,y,z)   -> return (CncCat x y z)

-             7 -> get >>= \(x,y,z)   -> return (CncFun x y z)

+             6 -> get >>= \(w,x,y,z) -> return (CncCat w x y z)

+             7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)

              8 -> get >>= \(x,y)     -> return (AnyInd x y)

              _ -> decodingError

 

@@ -122,15 +137,6 @@ instance Binary a => Binary (L a) where
   put (L x y) = put (x,y)

   get = get >>= \(x,y) -> return (L x y)

 

-instance Binary BindType where

-  put Explicit = putWord8 0

-  put Implicit = putWord8 1

-  get = do tag <- getWord8

-           case tag of

-             0 -> return Explicit

-             1 -> return Implicit

-             _ -> decodingError

-

 instance Binary Term where

   put (Vr x)        = putWord8 0  >> put x

   put (Cn x)        = putWord8 1  >> put x

@@ -270,7 +276,7 @@ instance Binary Label where
 

 decodeModHeader :: FilePath -> IO SourceModule

 decodeModHeader fpath = do

-  (m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath

-  return (m,ModInfo mtype mstatus flags extend mwith opens med src Map.empty)

+  (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) <- decodeFile fpath

+  return (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)

 

 decodingError = fail "This GFO file was compiled with different version of GF"

diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index 5a10612ec..2ef625131 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -83,8 +83,8 @@ type CFFun = String
 
 cf2gf :: FilePath -> CF -> SourceGrammar
 cf2gf fpath cf = mGrammar [
-  (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath abs),
-  (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath cnc)
+  (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath Nothing abs),
+  (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath Nothing cnc)
   ]
  where
    name = justModuleName fpath
@@ -102,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
             _ -> error "empty CF" 
   cats  = [(cat, AbsCat (Just (L NoLoc []))) | 
              cat <- nub (concat (map cf2cat rules))] ----notPredef cat
-  lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
+  lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
   (funs,lins) = unzip (map cf2rule rules)
 
 cf2cat :: CFRule -> [Ident]
@@ -119,6 +119,7 @@ cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
                Nothing 
                (Just (L loc (mkAbs (map fst args) 
                       (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
+               Nothing
                Nothing)
   mkIt (v, Left _) = P (Vr v) theLinLabel
   mkIt (_, Right a) = K a
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index acf2153bc..5174b1695 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -32,7 +32,9 @@ module GF.Grammar.Grammar (
         abstractOfConcrete,
 
         ModuleStatus(..),
-
+        
+        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence,
+        
         Info(..),
         Location(..), L(..), unLoc,
         Type,
@@ -64,18 +66,25 @@ import GF.Infra.Option ---
 
 import GF.Data.Operations
 
+import PGF.Data (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
+
 import Data.List
+import Data.Array.IArray
+import Data.Array.Unboxed
 import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntMap as IntMap
 import qualified Data.ByteString.Char8 as BS
 import Text.PrettyPrint
 import System.FilePath
+import Control.Monad.Identity
+
 
 
 data SourceGrammar = MGrammar { 
     moduleMap :: Map.Map Ident SourceModInfo,
     modules :: [(Ident,SourceModInfo)]
   }
-  deriving Show
 
 data SourceModInfo = ModInfo {
     mtype   :: ModuleType,
@@ -86,9 +95,9 @@ data SourceModInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [Ident],
     msrc    :: FilePath,
+    mseqs   :: Maybe (Array SeqId Sequence),
     jments  :: Map.Map Ident Info
   }
-  deriving Show
 
 type SourceModule = (Ident, SourceModInfo)
 
@@ -116,9 +125,6 @@ isInherited c i = case c of
 inheritAll :: Ident -> (Ident,MInclude)
 inheritAll i = (i,MIAll)
 
-addOpenQualif :: Ident -> Ident -> SourceModInfo -> SourceModInfo
-addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js
-
 data OpenSpec = 
    OSimple Ident
  | OQualif Ident Ident
@@ -313,6 +319,14 @@ allConcreteModules gr =
   [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
 
 
+data Production = Production {-# UNPACK #-} !FId
+                             {-# UNPACK #-} !FunId
+                             [[FId]]
+                  deriving (Eq,Ord,Show)
+
+data PMCFG = PMCFG [Production]
+                   (Array FunId (UArray LIndex SeqId)) 
+             deriving (Eq,Show)
 
 -- | the constructors are judgements in 
 --
@@ -336,8 +350,8 @@ data Info =
  | ResOverload [Ident] [(L Type,L Term)]         -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe (L Type))             (Maybe (L Term)) (Maybe (L Term))  -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term))  -- ^ (/CNC/) type info added at 'TC'
+ | CncCat  (Maybe (L Type))             (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool Ident                         -- ^ (/INDIR/) the 'Bool' says if canonical
@@ -364,11 +378,6 @@ type Fun  = QIdent
 
 type QIdent = (Ident,Ident)
 
-data BindType = 
-    Explicit
-  | Implicit
-  deriving (Eq,Ord,Show)
-
 data Term =
    Vr Ident                      -- ^ variable
  | Cn Ident                      -- ^ constant
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 7e743dd16..0a06347d6 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -71,11 +71,11 @@ lookupResDef gr (m,c)
       case info of
         ResOper _ (Just (L _ t)) -> return t
         ResOper _ Nothing  -> return (Q (m,c))
-        CncCat (Just (L _ ty)) _ _ -> lock c ty
-        CncCat _ _ _         -> lock c defLinType
+        CncCat (Just (L _ ty)) _ _ _ -> lock c ty
+        CncCat _ _ _ _         -> lock c defLinType
       
-        CncFun (Just (cat,_,_)) (Just (L _ tr)) _ -> unlock cat tr
-        CncFun _                (Just (L _ tr)) _ -> return tr
+        CncFun (Just (cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
+        CncFun _                (Just (L _ tr)) _ _ -> return tr
 
         AnyInd _ n        -> look n c
         ResParam _ _      -> return (QC (m,c))
@@ -89,8 +89,8 @@ lookupResType gr (m,c) = do
     ResOper (Just (L _ t)) _ -> return t
 
     -- used in reused concrete
-    CncCat _ _ _ -> return typeType
-    CncFun (Just (cat,cont,val)) _ _ -> do
+    CncCat _ _ _ _ -> return typeType
+    CncFun (Just (cat,cont,val)) _ _ _ -> do
           val' <- lock cat val 
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
@@ -119,10 +119,10 @@ lookupOrigInfo gr (m,c) = do
     AnyInd _ n  -> lookupOrigInfo gr (n,c)
     i           -> return (m,i)
 
-allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
+allOrigInfos :: SourceGrammar -> Ident -> [(QIdent,Info)]
 allOrigInfos gr m = errVal [] $ do
   mo <- lookupModule gr m
-  return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [lookupOrigInfo gr (m,c)]]
+  return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
 
 lookupParamValues :: SourceGrammar -> QIdent -> Err [Term]
 lookupParamValues gr c = do
@@ -163,9 +163,9 @@ lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
 lookupLincat gr m c = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
-    CncCat (Just (L _ t)) _ _ -> return t
-    AnyInd _ n                -> lookupLincat gr n c
-    _                         -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+    CncCat (Just (L _ t)) _ _ _ -> return t
+    AnyInd _ n                  -> lookupLincat gr n c
+    _                           -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
 
 -- | this is needed at compile time
 lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 8af343fc6..e8842375d 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -69,9 +69,8 @@ valTypeCnc typ = snd (typeFormCnc typ)
 
 typeSkeleton :: Type -> ([(Int,Cat)],Cat)
 typeSkeleton typ =
-  let (cont,cat,_) = typeForm typ
-      args = map (\(b,x,t) -> typeSkeleton t) cont
-  in ([(length c, v) | (c,v) <- args], cat)
+  let (ctxt,cat,_) = typeForm typ
+  in ([(length c, v) | (b,x,t) <- ctxt, let (c,v) = typeSkeleton t], cat)
 
 catSkeleton :: Type -> ([Cat],Cat)
 catSkeleton typ =
@@ -560,8 +559,8 @@ allDependencies ism b =
       ResOper pty pt -> [pty,pt]
       ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
       ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
-      CncCat pty _ _ -> [pty]
-      CncFun _   pt _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
+      CncCat pty _ _ _ -> [pty]
+      CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
       AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
       AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
       _              -> []
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 6c83d72a0..530795974 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -117,14 +117,14 @@ ModDef
                                       defs <- case buildAnyTree id jments of
                                                 Ok x    -> return x
                                                 Bad msg -> fail msg
-                                      return (id, ModInfo mtype mstat opts extends with opens [] "" defs)  }
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs)  }
 
 ModHeader :: { SourceModule }
 ModHeader
   : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                                (mtype,id) = $2 ;
                                                (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" emptyBinTree) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing emptyBinTree) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 
@@ -219,11 +219,11 @@ TopDef
   | 'data'            ListDataDef     { Left  $2 }
   | 'param'           ListParamDef    { Left  $2 }
   | 'oper'            ListOperDef     { Left  $2 }
-  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing    Nothing   ) | (f,e) <- $2] }
-  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing    (Just e) Nothing   ) | (f,e) <- $2] }
+  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing    Nothing Nothing) | (f,e) <- $2] }
+  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing    (Just e) Nothing Nothing) | (f,e) <- $2] }
   | 'lin'             ListLinDef      { Left  $2 }
-  | 'printname' 'cat' ListTermDef     { Left  [(f, CncCat Nothing    Nothing (Just e)) | (f,e) <- $3] }
-  | 'printname' 'fun' ListTermDef     { Left  [(f, CncFun Nothing Nothing (Just e)) | (f,e) <- $3] }
+  | 'printname' 'cat' ListTermDef     { Left  [(f, CncCat Nothing    Nothing (Just e) Nothing) | (f,e) <- $3] }
+  | 'printname' 'fun' ListTermDef     { Left  [(f, CncFun Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
   | 'flags'           ListFlagDef     { Right $2 }
 
 CatDef :: { [(Ident,Info)] }
@@ -263,8 +263,8 @@ OperDef
 
 LinDef :: { [(Ident,Info)] }
 LinDef
-  : Posn ListName '=' Exp         Posn { [(f,  CncFun Nothing (Just (mkL $1 $5 $4)) Nothing) | f <- $2] }
-  | Posn Name ListArg '=' Exp     Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing)] }
+  : Posn ListName '=' Exp         Posn { [(f,  CncFun Nothing (Just (mkL $1 $5 $4)) Nothing Nothing) | f <- $2] }
+  | Posn Name ListArg '=' Exp     Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing Nothing)] }
 
 TermDef :: { [(Ident,L Term)] }
 TermDef
@@ -674,14 +674,14 @@ isOverloading t =
 
 checkInfoType mt jment@(id,info) =
   case info of
-    AbsCat pcont       -> ifAbstract mt (locPerh pcont)
-    AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
-    CncCat pty pd ppn  -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
-    CncFun _   pd ppn  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
-    ResParam pparam _  -> ifResource mt (locPerh pparam)
-    ResValue ty        -> ifResource mt (locL ty)
-    ResOper  pty pt    -> ifOper mt pty pt
-    ResOverload _ xs   -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
+    AbsCat pcont         -> ifAbstract mt (locPerh pcont)
+    AbsFun pty _ pde _   -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
+    CncCat pty pd ppn _  -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
+    CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
+    ResParam pparam _    -> ifResource mt (locPerh pparam)
+    ResValue ty          -> ifResource mt (locL ty)
+    ResOper  pty pt      -> ifOper mt pty pt
+    ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
   where
     locPerh = maybe [] locL
     locAll xs = [loc | L loc x <- xs]
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index f65d26f89..cf0bbf6e9 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -26,10 +26,15 @@ import GF.Infra.Option
 import GF.Grammar.Values

 import GF.Grammar.Grammar

 

+import PGF.Printer (ppFId, ppFunId, ppSeqId, ppSeq)

+

 import Text.PrettyPrint

 import Data.Maybe (maybe, isNothing)

 import Data.List  (intersperse)

 import qualified Data.Map as Map

+import qualified Data.IntMap as IntMap

+import qualified Data.Set as Set

+import qualified Data.Array.IArray as Array

 

 data TermPrintQual = Qualified | Unqualified

 

@@ -37,11 +42,13 @@ ppGrammar :: SourceGrammar -> Doc
 ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr

 

 ppModule :: TermPrintQual -> SourceModule -> Doc

-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =

-    hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr

+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =

+    hdr $$ 

+    nest 2 (ppOptions opts $$ 

+            vcat (map (ppJudgement q) (Map.toList jments)) $$

+            maybe empty ppSequences mseqs) $$

+    ftr

     where

-      defs = Map.toList jments

-

       hdr = complModDoc <+> modTypeDoc <+> equals <+> 

             hsep (intersperse (text "**") $

                   filter (not . isEmpty)  $ [ commaPunct ppExtends exts

@@ -108,7 +115,7 @@ ppJudgement q (id, ResOverload ids defs) =
   (text "overload" <+> lbrace $$

    nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$

    rbrace) <+> semi

-ppJudgement q (id, CncCat  ptype pexp pprn) =

+ppJudgement q (id, CncCat  ptype pexp pprn mpmcfg) =

   (case ptype of

      Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi

      Nothing        -> empty) $$

@@ -116,17 +123,37 @@ ppJudgement q (id, CncCat  ptype pexp pprn) =
      Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi

      Nothing        -> empty) $$

   (case pprn of

-     Just (L _ prn) -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Nothing        -> empty) $$

+  (case mpmcfg of

+     Just (PMCFG prods funs)

+                    -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$

+                       nest 2 (vcat (map ppProduction prods) $$

+                               space $$

+                               vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+> 

+                                                          parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))

+                                         (Array.assocs funs))) $$

+                       char '}'

      Nothing        -> empty)

-ppJudgement q (id, CncFun  ptype pdef pprn) =

+ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =

   (case pdef of

      Just (L _ e) -> let (xs,e') = getAbs e

                      in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi

      Nothing      -> empty) $$

   (case pprn of

-     Just (L _ prn) -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Nothing        -> empty) $$

+  (case mpmcfg of

+     Just (PMCFG prods funs)

+                    -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$

+                       nest 2 (vcat (map ppProduction prods) $$

+                               space $$

+                               vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+> 

+                                                          parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))

+                                         (Array.assocs funs))) $$

+                       char '}'

      Nothing        -> empty)

-ppJudgement q (id, AnyInd cann mid) = text "-- ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi

+ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi

 

 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)

                            in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')

@@ -277,6 +304,18 @@ ppLocation fpath (Local b e)
   | b == e    = text fpath <> colon <> int b

   | otherwise = text fpath <> colon <> int b <> text "-" <> int e

 

+ppProduction (Production fid funid args) =

+  ppFId fid <+> text "->" <+> ppFunId funid <> 

+  brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args)))

+

+ppSequences seqsArr

+  | null seqs = empty

+  | otherwise = text "sequences" <+> char '{' $$

+                nest 2 (vcat (map ppSeq seqs)) $$

+                char '}'

+  where

+    seqs = Array.assocs seqsArr

+

 commaPunct f ds = (hcat (punctuate comma (map f ds)))

 

 prec d1 d2 doc

@@ -299,3 +338,4 @@ getLet :: Term -> ([LocalDef], Term)
 getLet (Let l e) = let (ls,e') = getLet e

                    in (l:ls,e')

 getLet e         = ([],e)

+

diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 6fbc91d91..6a468d157 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -140,7 +140,6 @@ data Flags = Flags {
       optMode            :: Mode,
       optStopAfterPhase  :: Phase,
       optVerbosity       :: Verbosity,
-      optProf            :: Bool,
       optShowCPUTime     :: Bool,
       optOutputFormats   :: [OutputFormat],
       optSISR            :: Maybe SISRFormat,
@@ -157,9 +156,10 @@ data Flags = Flags {
       optName            :: Maybe String,
       optPreprocessors   :: [String],
       optEncoding        :: String,
+      optPMCFG           :: Bool,
       optOptimizations   :: Set Optimization,
       optOptimizePGF     :: Bool,
-      optMkIndexPGF     :: Bool,
+      optMkIndexPGF      :: Bool,
       optCFGTransforms   :: Set CFGTransform,
       optLibraryPath     :: [FilePath],
       optStartCat        :: Maybe String,
@@ -236,7 +236,6 @@ defaultFlags = Flags {
       optMode            = ModeInteractive,
       optStopAfterPhase  = Compile,
       optVerbosity       = Normal,
-      optProf            = False,
       optShowCPUTime     = False,
       optOutputFormats   = [],
       optSISR            = Nothing,
@@ -254,6 +253,7 @@ defaultFlags = Flags {
       optName            = Nothing,
       optPreprocessors   = [],
       optEncoding        = "latin1",
+      optPMCFG           = True,
 -- #ifdef CC_LAZY
 --       optOptimizations   = Set.fromList [OptStem,OptCSE],
 -- #else
@@ -290,7 +290,6 @@ optDescr =
      Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
      Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
      Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
-     Option [] ["prof"] (NoArg (prof True)) "Dump profiling information when compiling to PMCFG",
      Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
      Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
      Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
@@ -338,6 +337,8 @@ optDescr =
      Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
      Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
      Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
+     Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
+     Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
      Option [] ["optimize"] (ReqArg optimize "OPT") 
                 "Select an optimization package. OPT = all | values | parametrize | none",
      Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
@@ -364,7 +365,6 @@ optDescr =
                            Just v  -> case readMaybe v >>= toEnumBounded of
                                         Just i  -> set $ \o -> o { optVerbosity = i }
                                         Nothing -> fail $ "Bad verbosity: " ++ show v
-       prof        x = set $ \o -> o { optProf = x }
        cpu         x = set $ \o -> o { optShowCPUTime = x }
        gfoDir      x = set $ \o -> o { optGFODir = Just x }
        outFmt      x = readOutputFormat x >>= \f ->
@@ -395,6 +395,8 @@ optDescr =
        lexer       x = set $ \o -> o { optLexer = Just x }
        unlexer     x = set $ \o -> o { optUnlexer = Just x }
 
+       pmcfg       x = set $ \o -> o { optPMCFG = x }
+
        optimize    x = case lookup x optimizationPackages of
                          Just p  -> set $ \o -> o { optOptimizations = p }
                          Nothing -> fail $ "Unknown optimization package: " ++ x
diff --git a/src/compiler/GFTags.hs b/src/compiler/GFTags.hs
index 1fad82b99..15f85e351 100644
--- a/src/compiler/GFTags.hs
+++ b/src/compiler/GFTags.hs
@@ -31,11 +31,11 @@ getTags x (m,mi) =
                                                   maybe (loc "oper-def")     mb_def
     getLocations (ResOverload _ defs)           = list (\(x,y) -> ltype "overload-type" x ++ 
                                                                   loc   "overload-def"  y) defs
-    getLocations (CncCat mb_type mb_def mb_prn) = maybe (loc "lincat")       mb_type ++ 
-                                                  maybe (loc "lindef")       mb_def  ++ 
-                                                  maybe (loc "printname")    mb_prn
-    getLocations (CncFun _ mb_lin mb_prn)       = maybe (loc "lin")          mb_lin ++
-                                                  maybe (loc "printname")    mb_prn
+    getLocations (CncCat mty mdef mprn _)       = maybe (loc "lincat")       mty ++ 
+                                                  maybe (loc "lindef")       mdef  ++ 
+                                                  maybe (loc "printname")    mprn
+    getLocations (CncFun _ mlin mprn _)         = maybe (loc "lin")          mlin ++
+                                                  maybe (loc "printname")    mprn
     getLocations _                              = []
 
     loc kind (L loc _) = [(kind,render (ppLocation (msrc mi) loc),"")]
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index a7a34bc00..980b5dcdf 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -1,4 +1,4 @@
-module PGF.Printer (ppPGF,ppCat,ppFun) where
+module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where
 
 import PGF.CId
 import PGF.Data