msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity
Files
3814841d7d3b77b3f033cb98c1c0a04ac39435d7
gf-core/src/compiler/GF/Compile/GrammarToPGF.hs
hallgren 3814841d7d Eliminate mutual dependencies between the GF compiler and the PGF library 
+ References to modules under src/compiler have been eliminated from the PGF
  library (under src/runtime/haskell). Only two functions had to be moved (from
  GF.Data.Utilities to PGF.Utilities) to make this possible, other apparent
  dependencies turned out to be vacuous.

+ In gf.cabal, the GF executable no longer directly depends on the PGF library
  source directory, but only on the exposed library modules. This means that
  there is less duplication in gf.cabal and that the 30 modules in the
  PGF library will no longer be compiled twice while building GF.

  To make this possible, additional PGF library modules have been exposed, even
  though they should probably be considered for internal use only. They could
  be collected in a PGF.Internal module, or marked as "unstable", to make
  this explicit.

+ Also, by using the -fwarn-unused-imports flag, ~220 redundant imports were
  found and removed, reducing the total number of imports by ~15%.
2013-11-05 13:11:10 +00:00

324 lines
14 KiB
Haskell
Raw Blame History

{-# LANGUAGE BangPatterns #-}
module GF.Compile.GrammarToPGF (mkCanon2pgf) where
--import GF.Compile.Export
import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import PGF(CId,mkCId,bsCId)
import PGF.Data(fidInt,fidFloat,fidString,fidVar)
import PGF.Optimize(updateProductionIndices)
--import qualified PGF.Macros as CM
import qualified PGF.Data as C
import qualified PGF.Data as D
import GF.Grammar.Predef
--import GF.Grammar.Printer
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 GF.Compile.GeneratePMCFG
import GF.Infra.Ident
import GF.Infra.Option
import GF.Infra.UseIO (IOE)
import GF.Data.Operations
import Data.List
--import Data.Char (isDigit,isSpace)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Array.IArray
--import Text.PrettyPrint
--import Control.Monad.Identity
mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF
mkCanon2pgf opts gr am = do
(an,abs) <- mkAbstr am
cncs <- mapM mkConcr (allConcretes gr am)
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
where
cenv = resourceValues gr
mkAbstr am = return (i2i am, D.Abstr flags funs cats bcode)
where
aflags = err (const noOptions) mflags (lookupModule gr am)
(adefs,bcode) =
generateByteCode $
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
flags = Map.fromList [(mkCId f,if f == "beam_size" then C.LFlt (read x) else C.LStr x) | (f,x) <- optionsPGF aflags]
funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0, addr)) |
((m,f),AbsFun (Just (L _ ty)) ma pty _,addr) <- adefs]
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, addr)) |
((m,c),AbsCat (Just (L _ cont)),addr) <- adefs]
catfuns cat =
[(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True),_) <- adefs, snd (GM.valCat ty) == cat]
mkConcr cm = do
let cflags = err (const noOptions) mflags (lookupModule gr cm)
(ex_seqs,cdefs) <- addMissingPMCFGs
Map.empty
([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
Look.allOrigInfos gr cm)
let flags = Map.fromList [(mkCId f,if f == "beam_size" then C.LFlt (read x) else C.LStr x) | (f,x) <- optionsPGF cflags]
seqs = (mkSetArray . Set.fromList . concat) $
(Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
!(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
!(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
= genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
printnames = genPrintNames cdefs
return (i2i cm, D.Concr flags
printnames
cncfuns
lindefs
linrefs
seqs
productions
IntMap.empty
Map.empty
cnccats
IntMap.empty
fid_cnt2)
where
-- if some module was compiled with -no-pmcfg, then
-- we have to create the PMCFG code just before linking
addMissingPMCFGs seqs [] = return (seqs,[])
addMissingPMCFGs seqs (((m,id), info):is) = do
(seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
(seqs,is ) <- addMissingPMCFGs seqs is
return (seqs, ((m,id), info) : is)
i2i :: Ident -> CId
i2i = bsCId . ident2bs
mkType :: [Ident] -> A.Type -> C.Type
mkType scope t =
case GM.typeForm t of
(hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
mkExp :: [Ident] -> A.Term -> C.Expr
mkExp scope t =
case t of
Q (_,c) -> C.EFun (i2i c)
QC (_,c) -> C.EFun (i2i c)
Vr x -> case lookup x (zip scope [0..]) of
Just i -> C.EVar i
Nothing -> C.EMeta 0
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)
K s -> C.ELit (C.LStr s)
Meta i -> C.EMeta i
_ -> C.EMeta 0
mkPatt scope p =
case p of
A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
in (scope',C.PApp (i2i c) ps')
A.PV x -> (x:scope,C.PVar (i2i x))
A.PAs x p -> let (scope',p') = mkPatt scope p
in (x:scope',C.PAs (i2i x) p')
A.PW -> ( scope,C.PWild)
A.PInt i -> ( scope,C.PLit (C.LInt (fromIntegral i)))
A.PFloat f -> ( scope,C.PLit (C.LFlt f))
A.PString s -> ( scope,C.PLit (C.LStr s))
A.PImplArg p-> let (scope',p') = mkPatt scope p
in (scope',C.PImplArg p')
A.PTilde t -> ( scope,C.PTilde (mkExp scope t))
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,(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
mkArrity (Just a) = a
mkArrity Nothing = 0
data PattTree
= Ret C.Expr
| Case (Map.Map QIdent [PattTree]) [PattTree]
compilePatt :: [Equation] -> [PattTree]
compilePatt (([],t):_) = [Ret (mkExp [] t)]
compilePatt eqs = whilePP eqs Map.empty
where
whilePP [] cns = [mkCase cns []]
whilePP (((PP c ps' : ps), t):eqs) cns = whilePP eqs (Map.insertWith (++) c [(ps'++ps,t)] cns)
whilePP eqs cns = whilePV eqs cns []
whilePV [] cns vrs = [mkCase cns (reverse vrs)]
whilePV (((PV x : ps), t):eqs) cns vrs = whilePV eqs cns ((ps,t) : vrs)
whilePV eqs cns vrs = mkCase cns (reverse vrs) : compilePatt eqs
mkCase cns vrs = Case (fmap compilePatt cns) (compilePatt vrs)
genCncCats gr am cm cdefs =
let (index,cats) = mkCncCats 0 cdefs
in (index, Map.fromList cats)
where
mkCncCats index [] = (index,[])
mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs)
| id == cInt =
let cc = pgfCncCat gr lincat fidInt
(index',cats) = mkCncCats index cdefs
in (index', (i2i id,cc) : cats)
| id == cFloat =
let cc = pgfCncCat gr lincat fidFloat
(index',cats) = mkCncCats index cdefs
in (index', (i2i id,cc) : cats)
| id == cString =
let cc = pgfCncCat gr lincat fidString
(index',cats) = mkCncCats index cdefs
in (index', (i2i id,cc) : cats)
| otherwise =
let cc@(C.CncCat s e _) = pgfCncCat gr lincat index
(index',cats) = mkCncCats (e+1) cdefs
in (index', (i2i id,cc) : cats)
mkCncCats index (_ :cdefs) = mkCncCats index cdefs
genCncFuns :: SourceGrammar
-> Ident
-> Ident
-> Array SeqId Sequence
-> Array SeqId Sequence
-> [(QIdent, Info)]
-> FId
-> Map.Map CId D.CncCat
-> (FId,
IntMap.IntMap (Set.Set D.Production),
IntMap.IntMap [FunId],
IntMap.IntMap [FunId],
Array FunId D.CncFun)
genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty IntMap.empty
(fid_cnt2,funs_cnt2,funs2,prods) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
where
mkCncCats [] fid_cnt funs_cnt funs lindefs linrefs =
(fid_cnt,funs_cnt,funs,lindefs,linrefs)
mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
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
linrefs' = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
funs' = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
mkCncFuns [] fid_cnt funs_cnt funs lindefs crc prods =
(fid_cnt,funs_cnt,funs,prods)
mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
let ---Ok ty_C = fmap GM.typeForm (Look.lookupFunType gr am id)
ty_C = err error (\x -> x) $ 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
funs' = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
mkCncFuns (_ :cdefs) fid_cnt funs_cnt funs lindefs crc prods =
mkCncFuns cdefs fid_cnt funs_cnt 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
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
mkLinDefId id = prefixIdent "lindef " id
toLinDef res offs lindefs (Production fid0 funid0 args) =
if args == [[fidVar]]
then IntMap.insertWith (++) fid [offs+funid0] lindefs
else lindefs
where
fid = mkFId res fid0
toLinRef res offs linrefs (Production fid0 funid0 [fargs]) =
if fid0 == fidVar
then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
else linrefs
where
fids = map (mkFId res) fargs
mkFId (_,cat) fid0 =
case Map.lookup (i2i cat) cnccats of
Just (C.CncCat s e _) -> s+fid0
Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
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) funs (funid0,lins0) =
let mseqs = case lookupModule gr m of
Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
_ -> ex_seqs
in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs
where
newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
binSearch v arr (i,j)
| i <= j = case compare v (arr ! k) of
LT -> binSearch v arr (i,k-1)
EQ -> k
GT -> binSearch v arr (k+1,j)
| otherwise = error "binSearch"
where
k = (i+j) `div` 2
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
mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
mkSetArray set = listArray (0,Set.size set-1) [v | v <- Set.toList set]
View Git Blame Copy Permalink