GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
kr.angelov
2011-11-10 14:09:41 +00:00
parent b3390e43bd
commit bbe42d1e90
24 changed files with 604 additions and 517 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
lib/src/romanian/AllRon.gf
View File

@@ -1,3 +1,4 @@
--# -no-pmcfg
--# -path=.:../abstract:../common:../prelude --# -path=.:../abstract:../common:../prelude
concrete AllRon of AllRonAbs = concrete AllRon of AllRonAbs =

1
lib/src/romanian/LangRon.gf
View File

@@ -1,3 +1,4 @@
--# -no-pmcfg
--# -path=.:../abstract:../common:../prelude --# -path=.:../abstract:../common:../prelude
concrete LangRon of Lang = concrete LangRon of Lang =

36
src/compiler/GF/Compile.hs
View File

@@ -6,6 +6,7 @@ import GF.Compile.Rename
import GF.Compile.CheckGrammar import GF.Compile.CheckGrammar
import GF.Compile.Optimize import GF.Compile.Optimize
import GF.Compile.SubExOpt import GF.Compile.SubExOpt
import GF.Compile.GeneratePMCFG
import GF.Compile.GrammarToPGF import GF.Compile.GrammarToPGF
import GF.Compile.ReadFiles import GF.Compile.ReadFiles
import GF.Compile.Update import GF.Compile.Update
@@ -55,7 +56,8 @@ link :: Options -> Ident -> SourceGrammar -> IOE PGF
link opts cnc gr = do link opts cnc gr = do
let isv = (verbAtLeast opts Normal) let isv = (verbAtLeast opts Normal)
putPointE Normal opts "linking ... " $ do 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) probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK" ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK"
return $ setProbabilities probs return $ setProbabilities probs
@@ -183,9 +185,9 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
(_,n) | not (isCompleteModule n) -> do (_,n) | not (isCompleteModule n) -> do
case mb_gfo of case mb_gfo of
Just gfo -> if flag optMode opts /= ModeTags Just gfo -> if flag optMode opts /= ModeTags
then putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo1b then writeGFO opts gfo mo1b
else putStrLnE "" >> return mo1b else putStrLnE ""
Nothing -> return mo1b Nothing -> return ()
extendCompileEnvInt env k mb_gfo mo1b extendCompileEnvInt env k mb_gfo mo1b
_ -> do _ -> do
@@ -206,22 +208,26 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r
intermOut opts DumpOptimize (ppModule Qualified mo4) 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 case mb_gfo of
Just gfo -> putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo4 Just gfo -> writeGFO opts gfo mo5
Nothing -> return mo4 Nothing -> return ()
extendCompileEnvInt env k' mb_gfo mo4 extendCompileEnvInt env k' mb_gfo mo5
else do putStrLnE "" else do putStrLnE ""
extendCompileEnvInt env k mb_gfo mo3 extendCompileEnvInt env k mb_gfo mo3
generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
generateModuleCode opts file minfo = do writeGFO opts file mo = do
let minfo1 = subexpModule minfo let mo1 = subexpModule mo
minfo2 = case minfo1 of mo2 = case mo1 of
(m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)}) (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 putPointE Normal opts (" write file" +++ file) $ ioeIO $ encodeFile file mo2
return minfo1
-- auxiliaries -- auxiliaries

97
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -102,52 +102,52 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return info return info
_ -> return info _ -> return info
case info of case info of
CncCat (Just (L loc (RecType []))) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt) CncCat (Just (L loc (RecType []))) _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
_ -> Bad "no def lin" _ -> Bad "no def lin"
case lookupIdent c js of case lookupIdent c js of
Ok (AnyInd _ _) -> return js Ok (AnyInd _ _) -> return js
Ok (CncFun ty (Just def) pn) -> Ok (CncFun ty (Just def) mn mf) ->
return $ updateTree (c,CncFun ty (Just def) pn) js return $ updateTree (c,CncFun ty (Just def) mn mf) js
Ok (CncFun ty Nothing pn) -> Ok (CncFun ty Nothing mn mf) ->
case mb_def of 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 Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js return js
_ -> do _ -> do
case mb_def of case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty Ok def -> do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) 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 Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js return js
AbsCat (Just _) -> case lookupIdent c js of AbsCat (Just _) -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _) -> return js Ok (CncCat (Just _) _ _ _) -> return js
Ok (CncCat _ mt mp) -> do Ok (CncCat _ mt mp mpmcfg) -> do
checkWarn $ checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" 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 _ -> do
checkWarn $ checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" 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 _ -> return js
checkCnc js i@(c,info) = checkCnc js i@(c,info) =
case info of case info of
CncFun _ d pn -> case lookupOrigInfo gr (am,c) of CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
do (cont,val) <- linTypeOfType gr cm ty do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) d pn) js return $ updateTree (c,CncFun (Just linty) d mn mf) js
_ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract" _ -> 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 return js
CncCat _ _ _ -> case lookupOrigInfo gr (am,c) of _ -> return $ updateTree i js
Ok _ -> return $ updateTree i js
_ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
return js
_ -> return $ updateTree i js
-- | General Principle: only Just-values are checked. -- | General Principle: only Just-values are checked.
@@ -170,21 +170,41 @@ checkInfo ms (m,mo) c info = do
Nothing -> return () Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper) 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 CncCat mty mdef mpr mpmcfg -> do
(trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars mty <- case mty of
mpr <- checkPrintname gr mpr Just (L loc typ) -> chIn loc "linearization type of" $ do
return (CncFun linty (Just (L loc trm')) mpr) (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 CncFun mty mt mpr mpmcfg -> do
(typ,_) <- checkLType gr [] typ typeType mt <- case (mty,mt) of
typ <- computeLType gr [] typ (Just (cat,cont,val),Just (L loc trm)) ->
mdef <- case mdef of chIn loc "linearization of" $ do
Just (L loc def) -> do (trm,_) <- checkLType gr [] trm (mkProd cont val [])
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ) return (Just (L loc trm))
return $ Just (L loc def) _ -> return mt
_ -> return mdef mpr <- case mpr of
mpr <- checkPrintname gr mpr (Just (L loc t)) ->
return (CncCat (Just (L loc typ)) mdef mpr) 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 ResOper pty pde -> do
(pty', pde') <- case (pty,pde) of (pty', pde') <- case (pty,pde) of
@@ -252,11 +272,6 @@ checkInfo ms (m,mo) c info = do
_ -> composOp (compAbsTyp g) t _ -> 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!! -- | for grammars obtained otherwise than by parsing ---- update!!
checkReservedId :: Ident -> Check () checkReservedId :: Ident -> Check ()
checkReservedId x checkReservedId x

8
src/compiler/GF/Compile/Coding.hs
View File

@@ -20,10 +20,10 @@ codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)}) codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
where where
codj (c,info) = case info of codj (c,info) = case info of
ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt) ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt)
ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts] 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) CncCat mty mt mpr mpmcfg -> CncCat mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
CncFun mty pt mpr -> CncFun mty (codeLTerms co pt) (codeLTerms co mpr) CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
_ -> info _ -> info
codeLTerms co = fmap (codeLTerm co) codeLTerms co = fmap (codeLTerm co)

2
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

@@ -45,7 +45,7 @@ arrityPredefined f = do ty <- typPredefined f
return (length ctxt) return (length ctxt)
predefModInfo :: SourceModInfo predefModInfo :: SourceModInfo
predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives
primitives = Map.fromList primitives = Map.fromList
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing) [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)

466
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -10,10 +10,11 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Compile.GeneratePMCFG module GF.Compile.GeneratePMCFG
(convertConcrete) where (generatePMCFG, pgfCncCat
) where
import PGF.CId import PGF.CId
import PGF.Data hiding (Type) import PGF.Data hiding (Type, Production)
import GF.Infra.Option import GF.Infra.Option
import GF.Grammar hiding (Env, mkRecord, mkTable) 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.Set as Set
import qualified Data.List as List import qualified Data.List as List
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint hiding (Str) import Text.PrettyPrint hiding (Str)
import Data.Array.IArray import Data.Array.IArray
import Data.Array.Unboxed
import Data.Maybe import Data.Maybe
import Data.Char (isDigit) import Data.Char (isDigit)
import Control.Monad import Control.Monad
@@ -40,155 +43,83 @@ import Control.Exception
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- main conversion function -- main conversion function
generatePMCFG :: Options -> [SourceModule] -> SourceModule -> IO SourceModule
convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr generatePMCFG opts mos cmo@(cm,cmi) = do
convertConcrete opts0 gr am cm = do (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr am cm) Map.empty (jments cmi)
let env = emptyGrammarEnv gr cm when (verbAtLeast opts Verbose) $ hPutStrLn stderr ""
when (flag optProf opts) $ do return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
profileGrammar cm env pfrules
env <- foldM (convertLinDef gr opts) env pflindefs
env <- foldM (convertRule gr opts) env pfrules
return $ getConcr flags printnames env
where where
(m,mo) = cm gr = mGrammar (cmo:mos)
MTConcrete am = mtype cmi
opts = addOptions (mflags (snd am)) opts0
pflindefs = [ mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a
((m,id),term,lincat) | -> Map.Map k b -> m (a,Map.Map k c)
(id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (jments mo)] mapAccumWithKeyM f a m = do let xs = Map.toAscList m
(a,ys) <- mapAccumM f a xs
pfrules = [ return (a,Map.fromAscList ys)
(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 "--------------------------------"
where where
profileCat (cid,(fcat1,fcat2,_)) = do mapAccumM f a [] = return (a,[])
hPutStrLn stderr (lformat 23 (showIdent cid) ++ rformat 9 (show (fcat2-fcat1+1))) 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 addPMCFG :: Options -> SourceGrammar -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
lformat n s = s ++ replicate (n-length s) ' ' 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 pmcfgEnv0 = emptyPMCFGEnv
rformat n s = replicate (n-length s) ' ' ++ s
data ProtoFRule = PFRule Ident {- function -} b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil val) (pargs,[])
[([Cat],Cat)] {- argument types: context size and category -} (seqs1,b1) = addSequencesB seqs b
([Cat],Cat) {- result type : context size (always 0) and category -} pmcfgEnv1 = foldBM addRule
[Type] {- argument lin-types representation -} pmcfgEnv0
Type {- result lin-type representation -} (goB b1 CNil [])
Term {- body -} (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 when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
optimize pargs (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) = seqs1 `seq` stats `seq` return ()
IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet IntMap.empty prodSet) appSet when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats)
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
where where
optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | (funid,args) <- Set.toList ps]) (ctxt,res,_) = err error typeForm (lookupFunType gr am id)
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))
addRule lins (newCat', newArgs') env0 = addRule lins (newCat', newArgs') env0 =
let [newCat] = getFIds env0 newCat' let [newCat] = getFIds newCat'
(env1,funid) = addCncFun env0 (PGF.Data.CncFun lindefCId (mkArray lins)) !fun = mkArray lins
in addLinDef env1 newCat funid 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 :: Term -> CnvMonad Term
unfactor t = CM (\gr c -> c (unfac gr t)) 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 Vr y | y == x -> u
_ -> composSafeOp (restore x u) t _ -> 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 -- CnvMonad monad
-- --
@@ -248,7 +195,7 @@ variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
choices :: Int -> Path -> CnvMonad Term choices :: Int -> Path -> CnvMonad Term
choices nr path = do (args,_) <- get choices nr path = do (args,_) <- get
let PFCat _ _ schema = args !! nr let PFCat _ _ schema = args !! nr
descend schema path CNil descend schema path CNil
where where
descend (CRec rs) (CProj lbl path) rpath = case lookup lbl rs of descend (CRec rs) (CProj lbl path) rpath = case lookup lbl rs of
Just (Identity t) -> descend t path (CProj lbl rpath) 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 -- The annotations are as follows: the strings are annotated with
-- their index in the PMCFG tuple, the parameters are annotated -- their index in the PMCFG tuple, the parameters are annotated
-- with their value both as term and as index. -- 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]) type Env = (ProtoFCat, [ProtoFCat])
protoFCat :: GrammarEnv -> ([Cat],Cat) -> ProtoFCat protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat
protoFCat (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (ctxt,(_,cat)) = protoFCat gr cat lincat =
case Map.lookup cat catSet of case computeCatRange gr lincat of
Just (_,_,proto) -> PFCat (map snd ctxt) cat proto ((_,f),schema) -> PFCat (snd cat) f schema
Nothing -> error "unknown category"
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 (CProj lbl path) = ppLabel lbl <+> ppPath path
ppPath (CSel trm path) = ppTerm Unqualified 5 trm <+> ppPath path ppPath (CSel trm path) = ppTerm Unqualified 5 trm <+> ppPath path
ppPath CNil = empty 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) mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
convertArg opts (Sort _) nr path = do convertArg opts (Sort _) nr path = do
(args,_) <- get (args,_) <- get
let PFCat _ cat schema = args !! nr let PFCat cat _ schema = args !! nr
l = index (reversePath path) schema l = index (reversePath path) schema
sym | CProj (LVar i) CNil <- path = SymVar nr i sym | CProj (LVar i) CNil <- path = SymVar nr i
| isLiteralCat opts cat = SymLit nr l | 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 (CStr seqid) rpath ss = return (seqid : ss)
goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return 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 -- SeqSet
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)
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 [] = []
optimizeLin lin@(SymKS _ : _) = optimizeLin lin@(SymKS _ : _) =
@@ -442,6 +422,15 @@ optimizeLin lin@(SymKS _ : _) =
getRest lin = ([],lin) getRest lin = ([],lin)
optimizeLin (sym : lin) = sym : optimizeLin 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 -- eval a term to ground terms
@@ -478,124 +467,36 @@ getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- GrammarEnv -- GrammarEnv
data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet LinDefSet CoerceSet AppSet ProdSet data PMCFGEnv = PMCFGEnv !ProdSet !FunSet
type Proto = Schema Identity Int (Int,[(Term,Int)]) type ProdSet = Set.Set Production
type CatSet = Map.Map Ident (FId,FId,Proto) type FunSet = Map.Map (UArray LIndex SeqId) FunId
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) = emptyPMCFGEnv =
let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats PMCFGEnv Set.empty Map.empty
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..]))
lincats = addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv
Map.insert cVar (Sort cStr) $ addFunction (PMCFGEnv prodSet funSet) !fid fun args =
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 =
case Map.lookup fun funSet of case Map.lookup fun funSet of
Just id -> (env,id) Just !funid -> PMCFGEnv (Set.insert (Production fid funid args) prodSet)
Nothing -> let !last_funid = Map.size funSet funSet
in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) lindefSet crcSet appSet prodSet,last_funid) 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) getPMCFG :: PMCFGEnv -> PMCFG
addCoercion env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) sub_fcats = getPMCFG (PMCFGEnv prodSet funSet) =
case sub_fcats of PMCFG (optimize prodSet) (mkSetArray funSet)
[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
}
where where
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] optimize ps = Map.foldWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps])
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 []
where where
collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production]
collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs ff (fid,funid) xs prods
collect path paths (CStr _) = reversePath path : paths | product (map IntSet.size ys) == count
collect path paths (CPar _) = paths = (Production fid funid (map IntSet.toList ys)) : prods
| otherwise = map (Production fid funid) xs ++ prods
where
getFIds :: GrammarEnv -> ProtoFCat -> [FId] count = sum (map (product . map length) xs)
getFIds (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (PFCat ctxt cat schema) = ys = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
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)
------------------------------------------------------------ ------------------------------------------------------------
-- updating the MCF rule -- updating the MCF rule
@@ -613,9 +514,9 @@ restrictHead path term = do
put (head, args) put (head, args)
restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat 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 schema <- addConstraint path v schema
return (PFCat ctxt cat schema) return (PFCat cat f schema)
where where
addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs 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 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 | otherwise = do xs <- update k0 f xs
return (x: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]

227
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -1,10 +1,11 @@
{-# LANGUAGE PatternGuards #-} {-# LANGUAGE BangPatterns #-}
module GF.Compile.GrammarToPGF (mkCanon2pgf) where module GF.Compile.GrammarToPGF (mkCanon2pgf) where
import GF.Compile.Export import GF.Compile.Export
import GF.Compile.GeneratePMCFG import GF.Compile.GeneratePMCFG
import PGF.CId import PGF.CId
import PGF.Data(fidInt,fidFloat,fidString)
import PGF.Optimize(updateProductionIndices) import PGF.Optimize(updateProductionIndices)
import qualified PGF.Macros as CM import qualified PGF.Macros as CM
import qualified PGF.Data as C 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.Lookup as Look
import qualified GF.Grammar as A import qualified GF.Grammar as A
import qualified GF.Grammar.Macros as GM import qualified GF.Grammar.Macros as GM
--import qualified GF.Compile.Compute.Concrete as Compute ----
import qualified GF.Infra.Option as O import qualified GF.Infra.Option as O
import GF.Compile.GeneratePMCFG
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Option import GF.Infra.Option
@@ -25,61 +26,72 @@ import GF.Data.Operations
import Data.List import Data.List
import Data.Function import Data.Function
import Data.Char (isDigit,isSpace) import Data.Char (isDigit,isSpace)
import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.Array.IArray
import Text.PrettyPrint import Text.PrettyPrint
--import Debug.Trace ---- import Control.Monad.Identity
-- when developing, swap commenting
--traceD s t = trace s t
traceD s t = t
-- the main function: generate PGF from GF. mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IO D.PGF
mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF mkCanon2pgf opts gr am = do
mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr (an,abs) <- mkAbstr gr am
where cncs <- mapM (mkConcr gr) (allConcretes gr am)
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
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs)) return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
where where
mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats) mkAbstr gr am = return (i2i am, D.Abstr flags funs cats)
where 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)) | 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)) | 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 = catfuns cat =
(map (\x -> (0,snd x)) . sortBy (compare `on` fst)) (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 mkConcr gr cm = do
cnc <- convertConcrete opts gr am cm return (i2i cm, D.Concr flags
return (i2i lang, cnc) 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 :: Ident -> CId
i2i = CId . ident2bs 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 :: [Ident] -> A.Type -> C.Type
mkType scope t = mkType scope t =
case GM.typeForm t of case GM.typeForm t of
@@ -94,7 +106,7 @@ mkExp scope t =
Vr x -> case lookup x (zip scope [0..]) of Vr x -> case lookup x (zip scope [0..]) of
Just i -> C.EVar i Just i -> C.EVar i
Nothing -> C.EMeta 0 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) App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
EInt i -> C.ELit (C.LInt (fromIntegral i)) EInt i -> C.ELit (C.LInt (fromIntegral i))
EFloat f -> C.ELit (C.LFlt f) EFloat f -> C.ELit (C.LFlt f)
@@ -120,8 +132,8 @@ mkPatt scope p =
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo]) mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
in if x == identW in if x == identW
then ( scope,(b2b bt,i2i x,ty')) then ( scope,(bt,i2i x,ty'))
else (x:scope,(b2b bt,i2i x,ty'))) scope hyps 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 (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
mkDef Nothing = Nothing mkDef Nothing = Nothing
@@ -148,28 +160,121 @@ compilePatt eqs = whilePP eqs Map.empty
mkCase cns vrs = Case (fmap compilePatt cns) (compilePatt vrs) 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
reorder :: Ident -> SourceGrammar -> AbsConcsGrammar in (index, Map.fromList cats)
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])
where where
aflags = mkCncCats index [] = (index,[])
concatOptions (reverse [mflags mo | (_,mo) <- modules cg, isModAbs mo]) 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 where
predefADefs = mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
[(c, AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] 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)) toLinDef res offs lindefs (Production fid0 funid0 _) =
where IntMap.insertWith (++) fid [offs+funid0] lindefs
flags = concatOptions [mflags mo | (i,mo) <- modules cg, isModCnc mo, where
Just r <- [lookup i (allExtendSpecs cg la)]] fid = mkFId res fid0
jments = Look.allOrigInfos cg la
predefCDefs = mkFId (_,cat) fid0 =
[(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]] 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]

8
src/compiler/GF/Compile/Optimize.hs
View File

@@ -61,7 +61,7 @@ evalInfo opts ms m c info = do
errIn ("optimizing " ++ showIdent c) $ case info of errIn ("optimizing " ++ showIdent c) $ case info of
CncCat ptyp pde ppr -> do CncCat ptyp pde ppr mpmcfg -> do
pde' <- case (ptyp,pde) of pde' <- case (ptyp,pde) of
(Just (L _ typ), Just (L loc de)) -> do (Just (L _ typ), Just (L loc de)) -> do
de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
@@ -74,16 +74,16 @@ evalInfo opts ms m c info = do
ppr' <- evalPrintname gr ppr 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 eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
pde' <- case pde of pde' <- case pde of
Just (L loc de) -> do de <- partEval opts gr (cont,val) de Just (L loc de) -> do de <- partEval opts gr (cont,val) de
return (Just (L loc (factor param c 0 de))) return (Just (L loc (factor param c 0 de)))
Nothing -> return pde Nothing -> return pde
ppr' <- evalPrintname gr ppr 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 ResOper pty pde
| OptExpand `Set.member` optim -> do | OptExpand `Set.member` optim -> do

8
src/compiler/GF/Compile/Refresh.hs
View File

@@ -124,12 +124,12 @@ refreshModule (k,ms) mi@(i,mo)
(k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $
appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k) appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k)
return $ (k', (c, ResOverload os tyts'):cs) 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 (k',trm') <- refreshTermKN k trm
return $ (k', (c, CncCat mt (Just (L loc trm')) pn):cs) return $ (k', (c, CncCat mt (Just (L loc trm')) mn mpmcfg):cs)
CncFun mt (Just (L loc trm)) pn -> do ---- refresh pn CncFun mt (Just (L loc trm)) mn mpmcfg -> do ---- refresh pn
(k',trm') <- refreshTermKN k trm (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) _ -> return (k, ci:cs)

4
src/compiler/GF/Compile/Rename.hs
View File

@@ -158,8 +158,8 @@ renameInfo status (m,mi) i info =
ResValue t -> do ResValue t -> do
t <- renLoc (renameTerm status []) t t <- renLoc (renameTerm status []) t
return (ResValue t) return (ResValue t)
CncCat pty ptr ppr -> liftM3 CncCat (renTerm pty) (renTerm ptr) (renTerm ppr) CncCat mty mtr mpr mpmcfg -> liftM4 CncCat (renTerm mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
CncFun mt ptr ppr -> liftM2 (CncFun mt) (renTerm ptr) (renTerm ppr) CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
_ -> return info _ -> return info
where where
renTerm = renPerh (renameTerm status []) renTerm = renPerh (renameTerm status [])

8
src/compiler/GF/Compile/SubExOpt.hs
View File

@@ -52,7 +52,7 @@ unsubexpModule sm@(i,mo)
-- perform this iff the module has opers -- perform this iff the module has opers
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
unparInfo (c,info) = case info of 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 (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))] ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
_ -> [(c,info)] _ -> [(c,info)]
@@ -75,9 +75,9 @@ addSubexpConsts mo tree lins = do
mapM mkOne $ opers ++ lins mapM mkOne $ opers ++ lins
where where
mkOne (f,def) = case def of 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 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 ResOper ty (Just (L loc trm)) -> do
trm' <- recomp f trm trm' <- recomp f trm
return (f,ResOper ty (Just (L loc trm'))) return (f,ResOper ty (Just (L loc trm')))
@@ -98,7 +98,7 @@ getSubtermsMod mo js = do
return $ Map.filter (\ (nu,_) -> nu > 1) tree0 return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where where
getInfo get fi@(f,i) = case i of getInfo get fi@(f,i) = case i of
CncFun xs (Just (L _ trm)) pn -> do CncFun xs (Just (L _ trm)) pn _ -> do
get trm get trm
return $ fi return $ fi
ResOper ty (Just (L _ trm)) -> do ResOper ty (Just (L _ trm)) -> do

18
src/compiler/GF/Compile/Update.hs
View File

@@ -76,7 +76,7 @@ extendModule gr (name,m)
-- | rebuilding instance + interface, and "with" modules, prior to renaming. -- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003 -- AR 24/10/2003
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule 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 ---- deps <- moduleDeps ms
---- is <- openInterfaces deps i ---- is <- openInterfaces deps i
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 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] [i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete) testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ showIdent i +++ "remains incomplete") ("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 $ let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already ops_ ++ -- N.B. js has been name-resolved already
[OQualif i j | (i,j) <- ops] ++ [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 js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0) let js1 = buildTree (tree2list js_ ++ js0)
let med1= nub (ext : infs ++ insts ++ med_) 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') return (i,mi')
@@ -173,8 +173,8 @@ globalizeLoc fpath i =
ResValue t -> ResValue (gl t) ResValue t -> ResValue (gl t)
ResOper mt m -> ResOper (fmap gl mt) (fmap gl m) ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os) 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) CncCat mc mf mp mpmcfg-> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp) mpmcfg
CncFun m mt md -> CncFun m (fmap gl mt) (fmap gl md) CncFun m mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg
AnyInd b m -> AnyInd b m AnyInd b m -> AnyInd b m
where where
gl (L loc0 x) = loc `seq` L (External fpath loc) x 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) -> (ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2) liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2)
(CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> (CncCat mc1 mf1 mp1 mpmcfg1, CncCat mc2 mf2 mp2 mpmcfg2) ->
liftM3 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2) liftM4 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2) (unifMaybe mpmcfg1 mpmcfg2)
(CncFun m mt1 md1, CncFun _ mt2 md2) -> (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
liftM2 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) ---- adding defs liftM3 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) (unifMaybe mpmcfg1 mpmcfg2)
(AnyInd b1 m1, AnyInd b2 m2) -> do (AnyInd b1 m1, AnyInd b2 m2) -> do
testErr (b1 == b2) $ "indirection status" testErr (b1 == b2) $ "indirection status"

8
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -31,8 +31,8 @@ stripInfo i = case i of
ResValue lt -> i ---- ResValue lt -> i ----
ResOper mt md -> ResOper mt Nothing ResOper mt md -> ResOper mt Nothing
ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs] ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
CncCat mty mte mtf -> CncCat mty Nothing Nothing CncCat mty mte mtf mpmcfg -> CncCat mty Nothing Nothing Nothing
CncFun mict mte mtf -> CncFun mict Nothing Nothing CncFun mict mte mtf mpmcfg -> CncFun mict Nothing Nothing Nothing
AnyInd b f -> i AnyInd b f -> i
constantsInTerm :: Term -> [QIdent] constantsInTerm :: Term -> [QIdent]
@@ -110,8 +110,8 @@ sizeInfo i = case i of
ResValue lt -> 0 ResValue lt -> 0
ResOper mt md -> 1 + msize mt + msize md ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs] 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 CncCat mty mte mtf _ -> 1 + msize mty -- ignoring lindef and printname
CncFun mict mte mtf -> 1 + msize mte -- ignoring type and printname CncFun mict mte mtf _ -> 1 + msize mte -- ignoring type and printname
AnyInd b f -> -1 -- just to ignore these in the size AnyInd b f -> -1 -- just to ignore these in the size
_ -> 0 _ -> 0
where where

42
src/compiler/GF/Grammar/Binary.hs
View File

@@ -18,6 +18,8 @@ import GF.Infra.Ident
import GF.Infra.Option import GF.Infra.Option
import GF.Grammar.Grammar import GF.Grammar.Grammar
import PGF.Binary hiding (decodingError)
instance Binary Ident where instance Binary Ident where
put id = put (ident2bs id) put id = put (ident2bs id)
get = do bs <- get get = do bs <- get
@@ -30,9 +32,9 @@ instance Binary SourceGrammar where
get = fmap mGrammar get get = fmap mGrammar get
instance Binary SourceModInfo where 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) 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,flags,extend,mwith,opens,med,src,jments) <- get get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
return (ModInfo mtype mstatus flags extend mwith opens med src jments) return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
instance Binary ModuleType where instance Binary ModuleType where
put MTAbstract = putWord8 0 put MTAbstract = putWord8 0
@@ -85,6 +87,19 @@ instance Binary Options where
Ok x -> return x Ok x -> return x
Bad msg -> fail msg 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 instance Binary Info where
put (AbsCat x) = putWord8 0 >> put x put (AbsCat x) = putWord8 0 >> put x
put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z) 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 (ResValue x) = putWord8 3 >> put x
put (ResOper x y) = putWord8 4 >> put (x,y) put (ResOper x y) = putWord8 4 >> put (x,y)
put (ResOverload x y)= putWord8 5 >> put (x,y) put (ResOverload x y)= putWord8 5 >> put (x,y)
put (CncCat x y z) = putWord8 6 >> put (x,y,z) put (CncCat w x y z) = putWord8 6 >> put (w,x,y,z)
put (CncFun x y z) = putWord8 7 >> put (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) put (AnyInd x y) = putWord8 8 >> put (x,y)
get = do tag <- getWord8 get = do tag <- getWord8
case tag of case tag of
@@ -103,8 +118,8 @@ instance Binary Info where
3 -> get >>= \x -> return (ResValue x) 3 -> get >>= \x -> return (ResValue x)
4 -> get >>= \(x,y) -> return (ResOper x y) 4 -> get >>= \(x,y) -> return (ResOper x y)
5 -> get >>= \(x,y) -> return (ResOverload x y) 5 -> get >>= \(x,y) -> return (ResOverload x y)
6 -> get >>= \(x,y,z) -> return (CncCat x y z) 6 -> get >>= \(w,x,y,z) -> return (CncCat w x y z)
7 -> get >>= \(x,y,z) -> return (CncFun x y z) 7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)
8 -> get >>= \(x,y) -> return (AnyInd x y) 8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError _ -> decodingError
@@ -122,15 +137,6 @@ instance Binary a => Binary (L a) where
put (L x y) = put (x,y) put (L x y) = put (x,y)
get = get >>= \(x,y) -> return (L 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 instance Binary Term where
put (Vr x) = putWord8 0 >> put x put (Vr x) = putWord8 0 >> put x
put (Cn x) = putWord8 1 >> put x put (Cn x) = putWord8 1 >> put x
@@ -270,7 +276,7 @@ instance Binary Label where
decodeModHeader :: FilePath -> IO SourceModule decodeModHeader :: FilePath -> IO SourceModule
decodeModHeader fpath = do decodeModHeader fpath = do
(m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) <- decodeFile fpath
return (m,ModInfo mtype mstatus flags extend mwith opens med src Map.empty) 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" decodingError = fail "This GFO file was compiled with different version of GF"

7
src/compiler/GF/Grammar/CF.hs
View File

@@ -83,8 +83,8 @@ type CFFun = String
cf2gf :: FilePath -> CF -> SourceGrammar cf2gf :: FilePath -> CF -> SourceGrammar
cf2gf fpath cf = mGrammar [ cf2gf fpath cf = mGrammar [
(aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath abs), (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath Nothing abs),
(cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath cnc) (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath Nothing cnc)
] ]
where where
name = justModuleName fpath name = justModuleName fpath
@@ -102,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
_ -> error "empty CF" _ -> error "empty CF"
cats = [(cat, AbsCat (Just (L NoLoc []))) | cats = [(cat, AbsCat (Just (L NoLoc []))) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat 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) (funs,lins) = unzip (map cf2rule rules)
cf2cat :: CFRule -> [Ident] cf2cat :: CFRule -> [Ident]
@@ -119,6 +119,7 @@ cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
Nothing Nothing
(Just (L loc (mkAbs (map fst args) (Just (L loc (mkAbs (map fst args)
(mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))) (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
Nothing
Nothing) Nothing)
mkIt (v, Left _) = P (Vr v) theLinLabel mkIt (v, Left _) = P (Vr v) theLinLabel
mkIt (_, Right a) = K a mkIt (_, Right a) = K a

35
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -32,7 +32,9 @@ module GF.Grammar.Grammar (
abstractOfConcrete, abstractOfConcrete,
ModuleStatus(..), ModuleStatus(..),
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence,
Info(..), Info(..),
Location(..), L(..), unLoc, Location(..), L(..), unLoc,
Type, Type,
@@ -64,18 +66,25 @@ import GF.Infra.Option ---
import GF.Data.Operations import GF.Data.Operations
import PGF.Data (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
import Data.List import Data.List
import Data.Array.IArray
import Data.Array.Unboxed
import qualified Data.Map as Map 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 qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint import Text.PrettyPrint
import System.FilePath import System.FilePath
import Control.Monad.Identity
data SourceGrammar = MGrammar { data SourceGrammar = MGrammar {
moduleMap :: Map.Map Ident SourceModInfo, moduleMap :: Map.Map Ident SourceModInfo,
modules :: [(Ident,SourceModInfo)] modules :: [(Ident,SourceModInfo)]
} }
deriving Show
data SourceModInfo = ModInfo { data SourceModInfo = ModInfo {
mtype :: ModuleType, mtype :: ModuleType,
@@ -86,9 +95,9 @@ data SourceModInfo = ModInfo {
mopens :: [OpenSpec], mopens :: [OpenSpec],
mexdeps :: [Ident], mexdeps :: [Ident],
msrc :: FilePath, msrc :: FilePath,
mseqs :: Maybe (Array SeqId Sequence),
jments :: Map.Map Ident Info jments :: Map.Map Ident Info
} }
deriving Show
type SourceModule = (Ident, SourceModInfo) type SourceModule = (Ident, SourceModInfo)
@@ -116,9 +125,6 @@ isInherited c i = case c of
inheritAll :: Ident -> (Ident,MInclude) inheritAll :: Ident -> (Ident,MInclude)
inheritAll i = (i,MIAll) 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 = data OpenSpec =
OSimple Ident OSimple Ident
| OQualif Ident Ident | OQualif Ident Ident
@@ -313,6 +319,14 @@ allConcreteModules gr =
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m] [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 -- | the constructors are judgements in
-- --
@@ -336,8 +350,8 @@ data Info =
| ResOverload [Ident] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited | ResOverload [Ident] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax -- judgements in concrete syntax
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) lindef ini'zed, | 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)) -- ^ (/CNC/) type info added at 'TC' | CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident -- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
@@ -364,11 +378,6 @@ type Fun = QIdent
type QIdent = (Ident,Ident) type QIdent = (Ident,Ident)
data BindType =
Explicit
| Implicit
deriving (Eq,Ord,Show)
data Term = data Term =
Vr Ident -- ^ variable Vr Ident -- ^ variable
| Cn Ident -- ^ constant | Cn Ident -- ^ constant

22
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -71,11 +71,11 @@ lookupResDef gr (m,c)
case info of case info of
ResOper _ (Just (L _ t)) -> return t ResOper _ (Just (L _ t)) -> return t
ResOper _ Nothing -> return (Q (m,c)) ResOper _ Nothing -> return (Q (m,c))
CncCat (Just (L _ ty)) _ _ -> lock c ty CncCat (Just (L _ ty)) _ _ _ -> lock c ty
CncCat _ _ _ -> lock c defLinType CncCat _ _ _ _ -> lock c defLinType
CncFun (Just (cat,_,_)) (Just (L _ tr)) _ -> unlock cat tr CncFun (Just (cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
CncFun _ (Just (L _ tr)) _ -> return tr CncFun _ (Just (L _ tr)) _ _ -> return tr
AnyInd _ n -> look n c AnyInd _ n -> look n c
ResParam _ _ -> return (QC (m,c)) ResParam _ _ -> return (QC (m,c))
@@ -89,8 +89,8 @@ lookupResType gr (m,c) = do
ResOper (Just (L _ t)) _ -> return t ResOper (Just (L _ t)) _ -> return t
-- used in reused concrete -- used in reused concrete
CncCat _ _ _ -> return typeType CncCat _ _ _ _ -> return typeType
CncFun (Just (cat,cont,val)) _ _ -> do CncFun (Just (cat,cont,val)) _ _ _ -> do
val' <- lock cat val val' <- lock cat val
return $ mkProd cont val' [] return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr (n,c) AnyInd _ n -> lookupResType gr (n,c)
@@ -119,10 +119,10 @@ lookupOrigInfo gr (m,c) = do
AnyInd _ n -> lookupOrigInfo gr (n,c) AnyInd _ n -> lookupOrigInfo gr (n,c)
i -> return (m,i) i -> return (m,i)
allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] allOrigInfos :: SourceGrammar -> Ident -> [(QIdent,Info)]
allOrigInfos gr m = errVal [] $ do allOrigInfos gr m = errVal [] $ do
mo <- lookupModule gr m 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 :: SourceGrammar -> QIdent -> Err [Term]
lookupParamValues gr c = do 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 lookupLincat gr m c = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
CncCat (Just (L _ t)) _ _ -> return t CncCat (Just (L _ t)) _ _ _ -> return t
AnyInd _ n -> lookupLincat gr n c AnyInd _ n -> lookupLincat gr n c
_ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time -- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type

9
src/compiler/GF/Grammar/Macros.hs
View File

@@ -69,9 +69,8 @@ valTypeCnc typ = snd (typeFormCnc typ)
typeSkeleton :: Type -> ([(Int,Cat)],Cat) typeSkeleton :: Type -> ([(Int,Cat)],Cat)
typeSkeleton typ = typeSkeleton typ =
let (cont,cat,_) = typeForm typ let (ctxt,cat,_) = typeForm typ
args = map (\(b,x,t) -> typeSkeleton t) cont in ([(length c, v) | (b,x,t) <- ctxt, let (c,v) = typeSkeleton t], cat)
in ([(length c, v) | (c,v) <- args], cat)
catSkeleton :: Type -> ([Cat],Cat) catSkeleton :: Type -> ([Cat],Cat)
catSkeleton typ = catSkeleton typ =
@@ -560,8 +559,8 @@ allDependencies ism b =
ResOper pty pt -> [pty,pt] ResOper pty pt -> [pty,pt]
ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts] ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont] ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
CncCat pty _ _ -> [pty] CncCat pty _ _ _ -> [pty]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) CncFun _ pt _ _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co] AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
_ -> [] _ -> []

32
src/compiler/GF/Grammar/Parser.y
View File

@@ -117,14 +117,14 @@ ModDef
defs <- case buildAnyTree id jments of defs <- case buildAnyTree id jments of
Ok x -> return x Ok x -> return x
Bad msg -> fail msg 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 :: { SourceModule }
ModHeader ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ; (mtype,id) = $2 ;
(extends,with,opens) = $4 } (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 :: { ModuleStatus }
ComplMod ComplMod
@@ -219,11 +219,11 @@ TopDef
| 'data' ListDataDef { Left $2 } | 'data' ListDataDef { Left $2 }
| 'param' ListParamDef { Left $2 } | 'param' ListParamDef { Left $2 }
| 'oper' ListOperDef { Left $2 } | 'oper' ListOperDef { Left $2 }
| 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing 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 ) | (f,e) <- $2] } | 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing Nothing) | (f,e) <- $2] }
| 'lin' ListLinDef { Left $2 } | 'lin' ListLinDef { Left $2 }
| 'printname' 'cat' ListTermDef { Left [(f, CncCat 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)) | (f,e) <- $3] } | 'printname' 'fun' ListTermDef { Left [(f, CncFun Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
| 'flags' ListFlagDef { Right $2 } | 'flags' ListFlagDef { Right $2 }
CatDef :: { [(Ident,Info)] } CatDef :: { [(Ident,Info)] }
@@ -263,8 +263,8 @@ OperDef
LinDef :: { [(Ident,Info)] } LinDef :: { [(Ident,Info)] }
LinDef LinDef
: Posn ListName '=' Exp Posn { [(f, CncFun Nothing (Just (mkL $1 $5 $4)) Nothing) | f <- $2] } : 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)] } | Posn Name ListArg '=' Exp Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing Nothing)] }
TermDef :: { [(Ident,L Term)] } TermDef :: { [(Ident,L Term)] }
TermDef TermDef
@@ -674,14 +674,14 @@ isOverloading t =
checkInfoType mt jment@(id,info) = checkInfoType mt jment@(id,info) =
case info of case info of
AbsCat pcont -> ifAbstract mt (locPerh pcont) AbsCat pcont -> ifAbstract mt (locPerh pcont)
AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde) AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
CncCat pty pd ppn -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn) CncCat pty pd ppn _ -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
CncFun _ pd ppn -> ifConcrete mt (locPerh pd ++ locPerh ppn) CncFun _ pd ppn _ -> ifConcrete mt (locPerh pd ++ locPerh ppn)
ResParam pparam _ -> ifResource mt (locPerh pparam) ResParam pparam _ -> ifResource mt (locPerh pparam)
ResValue ty -> ifResource mt (locL ty) ResValue ty -> ifResource mt (locL ty)
ResOper pty pt -> ifOper mt pty pt ResOper pty pt -> ifOper mt pty pt
ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs]) ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
where where
locPerh = maybe [] locL locPerh = maybe [] locL
locAll xs = [loc | L loc x <- xs] locAll xs = [loc | L loc x <- xs]

58
src/compiler/GF/Grammar/Printer.hs
View File

@@ -26,10 +26,15 @@ import GF.Infra.Option
import GF.Grammar.Values import GF.Grammar.Values
import GF.Grammar.Grammar import GF.Grammar.Grammar
import PGF.Printer (ppFId, ppFunId, ppSeqId, ppSeq)
import Text.PrettyPrint import Text.PrettyPrint
import Data.Maybe (maybe, isNothing) import Data.Maybe (maybe, isNothing)
import Data.List (intersperse) import Data.List (intersperse)
import qualified Data.Map as Map 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 data TermPrintQual = Qualified | Unqualified
@@ -37,11 +42,13 @@ ppGrammar :: SourceGrammar -> Doc
ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
ppModule :: TermPrintQual -> SourceModule -> Doc ppModule :: TermPrintQual -> SourceModule -> Doc
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) = ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr hdr $$
nest 2 (ppOptions opts $$
vcat (map (ppJudgement q) (Map.toList jments)) $$
maybe empty ppSequences mseqs) $$
ftr
where where
defs = Map.toList jments
hdr = complModDoc <+> modTypeDoc <+> equals <+> hdr = complModDoc <+> modTypeDoc <+> equals <+>
hsep (intersperse (text "**") $ hsep (intersperse (text "**") $
filter (not . isEmpty) $ [ commaPunct ppExtends exts filter (not . isEmpty) $ [ commaPunct ppExtends exts
@@ -108,7 +115,7 @@ ppJudgement q (id, ResOverload ids defs) =
(text "overload" <+> lbrace $$ (text "overload" <+> lbrace $$
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$ nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$
rbrace) <+> semi rbrace) <+> semi
ppJudgement q (id, CncCat ptype pexp pprn) = ppJudgement q (id, CncCat ptype pexp pprn mpmcfg) =
(case ptype of (case ptype of
Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$ 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 Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
Nothing -> empty) $$ Nothing -> empty) $$
(case pprn of (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) Nothing -> empty)
ppJudgement q (id, CncFun ptype pdef pprn) = ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
(case pdef of (case pdef of
Just (L _ e) -> let (xs,e') = getAbs e Just (L _ e) -> let (xs,e') = getAbs e
in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
Nothing -> empty) $$ Nothing -> empty) $$
(case pprn of (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) 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) 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') 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 | b == e = text fpath <> colon <> int b
| otherwise = text fpath <> colon <> int b <> text "-" <> int e | 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))) commaPunct f ds = (hcat (punctuate comma (map f ds)))
prec d1 d2 doc prec d1 d2 doc
@@ -299,3 +338,4 @@ getLet :: Term -> ([LocalDef], Term)
getLet (Let l e) = let (ls,e') = getLet e getLet (Let l e) = let (ls,e') = getLet e
in (l:ls,e') in (l:ls,e')
getLet e = ([],e) getLet e = ([],e)

12
src/compiler/GF/Infra/Option.hs
View File

@@ -140,7 +140,6 @@ data Flags = Flags {
optMode :: Mode, optMode :: Mode,
optStopAfterPhase :: Phase, optStopAfterPhase :: Phase,
optVerbosity :: Verbosity, optVerbosity :: Verbosity,
optProf :: Bool,
optShowCPUTime :: Bool, optShowCPUTime :: Bool,
optOutputFormats :: [OutputFormat], optOutputFormats :: [OutputFormat],
optSISR :: Maybe SISRFormat, optSISR :: Maybe SISRFormat,
@@ -157,9 +156,10 @@ data Flags = Flags {
optName :: Maybe String, optName :: Maybe String,
optPreprocessors :: [String], optPreprocessors :: [String],
optEncoding :: String, optEncoding :: String,
optPMCFG :: Bool,
optOptimizations :: Set Optimization, optOptimizations :: Set Optimization,
optOptimizePGF :: Bool, optOptimizePGF :: Bool,
optMkIndexPGF :: Bool, optMkIndexPGF :: Bool,
optCFGTransforms :: Set CFGTransform, optCFGTransforms :: Set CFGTransform,
optLibraryPath :: [FilePath], optLibraryPath :: [FilePath],
optStartCat :: Maybe String, optStartCat :: Maybe String,
@@ -236,7 +236,6 @@ defaultFlags = Flags {
optMode = ModeInteractive, optMode = ModeInteractive,
optStopAfterPhase = Compile, optStopAfterPhase = Compile,
optVerbosity = Normal, optVerbosity = Normal,
optProf = False,
optShowCPUTime = False, optShowCPUTime = False,
optOutputFormats = [], optOutputFormats = [],
optSISR = Nothing, optSISR = Nothing,
@@ -254,6 +253,7 @@ defaultFlags = Flags {
optName = Nothing, optName = Nothing,
optPreprocessors = [], optPreprocessors = [],
optEncoding = "latin1", optEncoding = "latin1",
optPMCFG = True,
-- #ifdef CC_LAZY -- #ifdef CC_LAZY
-- optOptimizations = Set.fromList [OptStem,OptCSE], -- optOptimizations = Set.fromList [OptStem,OptCSE],
-- #else -- #else
@@ -290,7 +290,6 @@ optDescr =
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .", 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 [] ["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 [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).", 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 = '.').", 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 [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.", Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.", 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") Option [] ["optimize"] (ReqArg optimize "OPT")
"Select an optimization package. OPT = all | values | parametrize | none", "Select an optimization package. OPT = all | values | parametrize | none",
Option [] ["optimize-pgf"] (NoArg (optimize_pgf True)) Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
@@ -364,7 +365,6 @@ optDescr =
Just v -> case readMaybe v >>= toEnumBounded of Just v -> case readMaybe v >>= toEnumBounded of
Just i -> set $ \o -> o { optVerbosity = i } Just i -> set $ \o -> o { optVerbosity = i }
Nothing -> fail $ "Bad verbosity: " ++ show v Nothing -> fail $ "Bad verbosity: " ++ show v
prof x = set $ \o -> o { optProf = x }
cpu x = set $ \o -> o { optShowCPUTime = x } cpu x = set $ \o -> o { optShowCPUTime = x }
gfoDir x = set $ \o -> o { optGFODir = Just x } gfoDir x = set $ \o -> o { optGFODir = Just x }
outFmt x = readOutputFormat x >>= \f -> outFmt x = readOutputFormat x >>= \f ->
@@ -395,6 +395,8 @@ optDescr =
lexer x = set $ \o -> o { optLexer = Just x } lexer x = set $ \o -> o { optLexer = Just x }
unlexer x = set $ \o -> o { optUnlexer = Just x } unlexer x = set $ \o -> o { optUnlexer = Just x }
pmcfg x = set $ \o -> o { optPMCFG = x }
optimize x = case lookup x optimizationPackages of optimize x = case lookup x optimizationPackages of
Just p -> set $ \o -> o { optOptimizations = p } Just p -> set $ \o -> o { optOptimizations = p }
Nothing -> fail $ "Unknown optimization package: " ++ x Nothing -> fail $ "Unknown optimization package: " ++ x

10
src/compiler/GFTags.hs
View File

@@ -31,11 +31,11 @@ getTags x (m,mi) =
maybe (loc "oper-def") mb_def maybe (loc "oper-def") mb_def
getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++ getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++
loc "overload-def" y) defs loc "overload-def" y) defs
getLocations (CncCat mb_type mb_def mb_prn) = maybe (loc "lincat") mb_type ++ getLocations (CncCat mty mdef mprn _) = maybe (loc "lincat") mty ++
maybe (loc "lindef") mb_def ++ maybe (loc "lindef") mdef ++
maybe (loc "printname") mb_prn maybe (loc "printname") mprn
getLocations (CncFun _ mb_lin mb_prn) = maybe (loc "lin") mb_lin ++ getLocations (CncFun _ mlin mprn _) = maybe (loc "lin") mlin ++
maybe (loc "printname") mb_prn maybe (loc "printname") mprn
getLocations _ = [] getLocations _ = []
loc kind (L loc _) = [(kind,render (ppLocation (msrc mi) loc),"")] loc kind (L loc _) = [(kind,render (ppLocation (msrc mi) loc),"")]

2
src/runtime/haskell/PGF/Printer.hs
View File

@@ -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.CId
import PGF.Data import PGF.Data