msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

new-comp: delay eta expansion until just before partial evaluation

Browse Source 
This seems to work for the most part, but a problem showed up in WordsCat.gf in
the phrasebook.
This commit is contained in:
hallgren
2013-05-30 16:01:12 +00:00
parent 1846e6bf65
commit 72fd7e821f
2 changed files with 25 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -73,8 +73,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
pmcfgEnv0 = emptyPMCFGEnv
b <- convert opts gr cenv (floc opath loc id) term val pargs
b <- convert opts gr cenv (floc opath loc id) term (cont,val) pargs
let (seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addRule
pmcfgEnv0
@@ -106,8 +105,8 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
parg = protoFCat gr (identW,cVar) typeStr
pmcfgEnv0 = emptyPMCFGEnv
b <- convert opts gr cenv (floc opath loc id) term lincat [parg]
lincont = [(Explicit, varStr, typeStr)]
b <- convert opts gr cenv (floc opath loc id) term (lincont,lincat) [parg]
let (seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addRule
pmcfgEnv0
@@ -126,7 +125,7 @@ addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info)
floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
convert opts gr cenv loc term val pargs =
convert opts gr cenv loc term ty@(_,val) pargs =
case term' of
Error s -> fail $ render $ ppL loc (text $ "Predef.error: "++s)
_ -> return $ runCnvMonad gr (conv term') (pargs,[])
@@ -134,9 +133,16 @@ convert opts gr cenv loc term val pargs =
conv t = convertTerm opts CNil val =<< unfactor t
term' = if flag optNewComp opts
then normalForm cenv loc (recordExpand val term) -- new evaluator
then normalForm cenv loc (expand ty term) -- new evaluator
else term -- old evaluator is invoked from GF.Compile.Optimize
expand ty@(context,val) = recordExpand val . etaExpand ty
etaExpand (context,val) = mkAbs pars . flip mkApp args
where pars = [(Explicit,v) | v <- vars]
args = map Vr vars
vars = map (\(bt,x,t) -> x) context
recordExpand :: Type -> Term -> Term
recordExpand typ trm =
case typ of

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

@@ -104,22 +104,26 @@ evalInfo opts sgr m c info = do
-- | the main function for compiling linearizations
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
partEval opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
partEval opts = if flag optNewComp opts
then partEvalNew opts
else partEvalOld opts
partEvalNew opts gr (context, val) trm =
errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $
checkPredefError gr trm
partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
let vars = map (\(bt,x,t) -> x) context
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
trm1 = mkApp trm args
trm2 <- if new then return trm1 else computeTerm gr subst trm1
trm3 <- if new
then return trm2
else if rightType trm2
then computeTerm gr subst trm2 -- compute twice??
else recordExpand val trm2 >>= computeTerm gr subst
trm2 <- computeTerm gr subst trm1
trm3 <- if rightType trm2
then computeTerm gr subst trm2 -- compute twice??
else recordExpand val trm2 >>= computeTerm gr subst
trm4 <- checkPredefError gr trm3
return $ mkAbs [(Explicit,v) | v <- vars] trm4
where
new = flag optNewComp opts -- computations moved to GF.Compile.GeneratePMCFG
-- don't eta expand records of right length (correct by type checking)
rightType (R rs) = case val of
RecType ts -> length rs == length ts