GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-12 06:19:33 -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
concrete AllRon of AllRonAbs =

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

@@ -1,3 +1,4 @@
--# -no-pmcfg
--# -path=.:../abstract:../common:../prelude
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.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

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

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

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

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

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

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

@@ -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]

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

@@ -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]

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

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

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

@@ -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 [])

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

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

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.
-- 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"

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

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

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

@@ -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"

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

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

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

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

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

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

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

@@ -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]
_ -> []

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

@@ -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]

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

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

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

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

10
src/compiler/GFTags.hs
View File

@@ -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),"")]

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.Data