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

Compute/ConcreteNew.hs: eliminate selections from wildcard tables

Browse Source 
This patch also includes some commented out code that was used to search for
the source of code size explosions and an eta expansion bug.
This commit is contained in:
hallgren
2014-06-17 14:47:55 +00:00
parent 6f8e52c944
commit 050d435278
2 changed files with 21 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -298,6 +298,7 @@ select env vv =
--let vs = map (value0 env) ats
i <- maybeErr "no match" $ findIndex (==v2) vs
return (ix (gloc env) "select" rs i)
(VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b []
(v1@(VT _ _ cs),v2) ->
err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $
match (gloc env) cs v2

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

@@ -39,6 +39,7 @@ import Data.Array.Unboxed
import Control.Monad
import Control.Monad.Identity
--import Control.Exception
--import Debug.Trace(trace)
----------------------------------------------------------------------
-- main conversion function
@@ -67,6 +68,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
let pres = protoFCat gr res val
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
@@ -85,7 +87,8 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
!funs_cnt = e-s+1
in (prods_cnt,funs_cnt)
when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
when (verbAtLeast opts Verbose) $
ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
seqs1 `seq` stats `seq` return ()
when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
@@ -146,12 +149,19 @@ floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
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,[])
_ -> do {-when (verbAtLeast opts Verbose) $
ePutStrLn $
"\n"++take 10000 (renderStyle style{mode=OneLineMode}
(text "term:"<+>ppU 0 term $$
text "eta expanded:"<+>ppU 0 eterm $$
text "normalized:"<+>ppU 0 term'))--}
return $ runCnvMonad gr (conv term') (pargs,[])
where
conv t = convertTerm opts CNil val =<< unfactor t
eterm = expand ty term
term' = {-if flag optNewComp opts
then-} normalForm cenv loc (expand ty term) -- new evaluator
then-} normalForm cenv loc eterm -- new evaluator
--else term -- old evaluator is invoked from GF.Compile.Optimize
expand (context,val) = mkAbs pars . recordExpand val . flip mkApp args
@@ -175,12 +185,16 @@ recordExpand typ trm =
unfactor :: Term -> CnvMonad Term
unfactor t = CM (\gr c -> c (unfac gr t))
where
unfac gr t =
unfac gr t =
case t of
T (TTyped ty) [(PV x,u)] -> let u' = unfac gr u
in V ty [restore x v u' | v <- allparams ty]
vs = allparams ty
in --trace ("expand single variable table into "++show (length vs)++" branches.\n"++render (ppU 0 t)) $
V ty [restore x v u' | v <- vs]
T (TTyped ty) [(PW ,u)] -> let u' = unfac gr u
in V ty [u' | _ <- allparams ty]
vs = allparams ty
in --trace ("expand wildcard table into "++show (length vs)++ "branches.\n"++render (ppU 0 t)) $
V ty [u' | _ <- vs]
T (TTyped ty) _ -> -- convertTerm doesn't handle these tables
ppbug $
sep [text "unfactor"<+>ppU 10 t,