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

the compiler now sorts the list of sequences in the PGF files

Browse Source
This commit is contained in:
kr.angelov
2013-09-23 13:13:59 +00:00
parent c4f68adca9
commit 5dca1b7cfc
1 changed files with 50 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -34,7 +34,6 @@ import Data.Array.IArray
import Text.PrettyPrint import Text.PrettyPrint
import Control.Monad.Identity import Control.Monad.Identity
mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF
mkCanon2pgf opts gr am = do mkCanon2pgf opts gr am = do
(an,abs) <- mkAbstr am (an,abs) <- mkAbstr am
@@ -66,23 +65,28 @@ mkCanon2pgf opts gr am = do
mkConcr cm = do mkConcr cm = do
let cflags = err (const noOptions) mflags (lookupModule gr cm) let cflags = err (const noOptions) mflags (lookupModule gr cm)
(seqs,cdefs) <- addMissingPMCFGs (ex_seqs,cdefs) <- addMissingPMCFGs
Map.empty Map.empty
([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++ ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
Look.allOrigInfos gr cm) 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] 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_cnt1,!cnccats) = genCncCats gr am cm cdefs
!(!fid_cnt2,!productions,!lindefs,!sequences,!cncfuns) !(!fid_cnt2,!productions,!lindefs,!cncfuns)
= genCncFuns gr am cm seqs cdefs fid_cnt1 cnccats = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
printnames = genPrintNames cdefs printnames = genPrintNames cdefs
return (i2i cm, D.Concr flags return (i2i cm, D.Concr flags
printnames printnames
cncfuns cncfuns
lindefs lindefs
sequences seqs
productions productions
IntMap.empty IntMap.empty
Map.empty Map.empty
@@ -194,25 +198,25 @@ genCncCats gr am cm cdefs =
mkCncCats index (_ :cdefs) = mkCncCats index cdefs mkCncCats index (_ :cdefs) = mkCncCats index cdefs
genCncFuns gr am cm seqs0 cdefs fid_cnt cnccats = genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
let (fid_cnt1,funs_cnt1,seqs1,funs1,lindefs) = mkCncCats cdefs fid_cnt 0 seqs0 [] IntMap.empty let (fid_cnt1,funs_cnt1,funs1,lindefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty
(fid_cnt2,funs_cnt2,seqs2,funs2,prods) = mkCncFuns cdefs fid_cnt1 funs_cnt1 seqs1 funs1 lindefs Map.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,mkSetArray seqs2,array (0,funs_cnt2-1) funs2) in (fid_cnt2,prods,lindefs,array (0,funs_cnt2-1) funs2)
where where
mkCncCats [] fid_cnt funs_cnt seqs funs lindefs = mkCncCats [] fid_cnt funs_cnt funs lindefs =
(fid_cnt,funs_cnt,seqs,funs,lindefs) (fid_cnt,funs_cnt,funs,lindefs)
mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs = mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs =
let !funs_cnt' = let (s_funid, e_funid) = bounds funs0 let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
in funs_cnt+(e_funid-s_funid+1) in funs_cnt+(e_funid-s_funid+1)
lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0 lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
!(seqs',funs') = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) (seqs,funs) (assocs funs0) funs' = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
in mkCncCats cdefs fid_cnt funs_cnt' seqs' funs' lindefs' in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs'
mkCncCats (_ :cdefs) fid_cnt funs_cnt seqs funs lindefs = mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs =
mkCncCats cdefs fid_cnt funs_cnt seqs funs lindefs mkCncCats cdefs fid_cnt funs_cnt funs lindefs
mkCncFuns [] fid_cnt funs_cnt seqs funs lindefs crc prods = mkCncFuns [] fid_cnt funs_cnt funs lindefs crc prods =
(fid_cnt,funs_cnt,seqs,funs,prods) (fid_cnt,funs_cnt,funs,prods)
mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs crc 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) 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) ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
!funs_cnt' = let (s_funid, e_funid) = bounds funs0 !funs_cnt' = let (s_funid, e_funid) = bounds funs0
@@ -220,10 +224,10 @@ genCncFuns gr am cm seqs0 cdefs fid_cnt cnccats =
!(fid_cnt',crc',prods') !(fid_cnt',crc',prods')
= foldl' (toProd lindefs ty_C funs_cnt) = foldl' (toProd lindefs ty_C funs_cnt)
(fid_cnt,crc,prods) prods0 (fid_cnt,crc,prods) prods0
!(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0) funs' = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
in mkCncFuns cdefs fid_cnt' funs_cnt' seqs' funs' lindefs crc' prods' in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
mkCncFuns (_ :cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods = mkCncFuns (_ :cdefs) fid_cnt funs_cnt funs lindefs crc prods =
mkCncFuns cdefs fid_cnt funs_cnt seqs 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) = 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) let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
@@ -264,21 +268,22 @@ genCncFuns gr am cm seqs0 cdefs fid_cnt cnccats =
Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]] Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
Nothing -> error "GrammarToPGF.mkCtxt failed" Nothing -> error "GrammarToPGF.mkCtxt failed"
toCncFun offs (m,id) (seqs,funs) (funid0,lins0) = toCncFun offs (m,id) funs (funid0,lins0) =
case lookupModule gr m of let mseqs = case lookupModule gr m of
Ok (ModInfo{mseqs=Just mseqs}) -> let !(!seqs',lins) = mapAccumL (mkLin mseqs) seqs (elems lins0) Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
in (seqs',(offs+funid0,C.CncFun (i2i id) (mkArray lins)):funs) _ -> ex_seqs
_ -> -- this function should have been compiled during the linking phase in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs
-- so its sequences must be in seqs already
(seqs,(offs+funid0,C.CncFun (i2i id) lins0):funs)
where where
mkLin mseqs seqs seqid = newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
let seq = mseqs ! seqid
in case Map.lookup seq seqs of binSearch v arr (i,j)
Just seqid -> (seqs,seqid) | i <= j = case compare v (arr ! k) of
Nothing -> let !seqid = Map.size seqs LT -> binSearch v arr (i,k-1)
!seqs' = Map.insert seq seqid seqs EQ -> k
in (seqs',seqid) GT -> binSearch v arr (k+1,j)
| otherwise = error "binSearch"
where
k = (i+j) `div` 2
genPrintNames cdefs = genPrintNames cdefs =
Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info] Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
@@ -292,4 +297,5 @@ genPrintNames cdefs =
flatten (C x y) = flatten x +++ flatten y flatten (C x y) = flatten x +++ flatten y
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] 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]