From bbe42d1e9063e50ed836debb718dbd85ab96f05d Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Thu, 10 Nov 2011 14:09:41 +0000 Subject: [PATCH] Now PMCFG is compiled per module and at the end we only link it. The new compilation schema is few times faster. --- lib/src/romanian/AllRon.gf | 1 + lib/src/romanian/LangRon.gf | 1 + src/compiler/GF/Compile.hs | 36 +- src/compiler/GF/Compile/CheckGrammar.hs | 97 ++-- src/compiler/GF/Compile/Coding.hs | 8 +- .../GF/Compile/Compute/AppPredefined.hs | 2 +- src/compiler/GF/Compile/GeneratePMCFG.hs | 466 +++++++----------- src/compiler/GF/Compile/GrammarToPGF.hs | 227 ++++++--- src/compiler/GF/Compile/Optimize.hs | 8 +- src/compiler/GF/Compile/Refresh.hs | 8 +- src/compiler/GF/Compile/Rename.hs | 4 +- src/compiler/GF/Compile/SubExOpt.hs | 8 +- src/compiler/GF/Compile/Update.hs | 18 +- src/compiler/GF/Grammar/Analyse.hs | 8 +- src/compiler/GF/Grammar/Binary.hs | 42 +- src/compiler/GF/Grammar/CF.hs | 7 +- src/compiler/GF/Grammar/Grammar.hs | 35 +- src/compiler/GF/Grammar/Lookup.hs | 22 +- src/compiler/GF/Grammar/Macros.hs | 9 +- src/compiler/GF/Grammar/Parser.y | 32 +- src/compiler/GF/Grammar/Printer.hs | 58 ++- src/compiler/GF/Infra/Option.hs | 12 +- src/compiler/GFTags.hs | 10 +- src/runtime/haskell/PGF/Printer.hs | 2 +- 24 files changed, 604 insertions(+), 517 deletions(-) diff --git a/lib/src/romanian/AllRon.gf b/lib/src/romanian/AllRon.gf index 15d5c451d..041d8a927 100644 --- a/lib/src/romanian/AllRon.gf +++ b/lib/src/romanian/AllRon.gf @@ -1,3 +1,4 @@ +--# -no-pmcfg --# -path=.:../abstract:../common:../prelude concrete AllRon of AllRonAbs = diff --git a/lib/src/romanian/LangRon.gf b/lib/src/romanian/LangRon.gf index 304b0c87d..87b747502 100644 --- a/lib/src/romanian/LangRon.gf +++ b/lib/src/romanian/LangRon.gf @@ -1,3 +1,4 @@ +--# -no-pmcfg --# -path=.:../abstract:../common:../prelude concrete LangRon of Lang = 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 +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 - (m,mo) = cm - - opts = addOptions (mflags (snd am)) opts0 + gr = mGrammar (cmo:mos) + MTConcrete am = mtype cmi - 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 "--------------------------------" +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 - profileCat (cid,(fcat1,fcat2,_)) = do - hPutStrLn stderr (lformat 23 (showIdent cid) ++ rformat 9 (show (fcat2-fcat1+1))) + 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) - 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) ' ' +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] - rformat :: Int -> String -> String - rformat n s = replicate (n-length s) ' ' ++ s + pmcfgEnv0 = emptyPMCFGEnv -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 -} + 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) -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 + 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 - 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 - where - 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 - where - lindefCId = mkCId ("lindef "++showIdent (snd cat)) + (ctxt,res,_) = err error typeForm (lookupFunType gr am id) 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 + 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 + addRule lins (newCat', newArgs') env0 = + 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) +data PMCFGEnv = PMCFGEnv !ProdSet !FunSet +type ProdSet = Set.Set Production +type FunSet = Map.Map (UArray LIndex SeqId) FunId -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..])) +emptyPMCFGEnv = + PMCFGEnv Set.empty Map.empty - 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 - -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) + 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) -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 - } +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 am cm@(lang,mo) = do - cnc <- convertConcrete opts gr am cm - return (i2i lang, cnc) + 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 + + 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 - -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]) +genCncCats gr am cm cdefs = + let (index,cats) = mkCncCats 0 cdefs + in (index, Map.fromList cats) where - aflags = - concatOptions (reverse [mflags mo | (_,mo) <- modules cg, isModAbs mo]) + 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 - adefs = - Map.fromList (predefADefs ++ Look.allOrigInfos cg abs) + +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 + 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 + + 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]] + 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 - 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]] + 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