mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-29 22:42:52 -06:00
Adding a new experimental partial evalutator
GF.Compile.Compute.ConcreteNew + two new modules contain a new
partial evaluator intended to solve some performance problems with the old
partial evalutator in GF.Compile.Compute.ConcreteLazy. It has been around for
a while, but is now complete enough to compile the RGL and the Phrasebook.
The old partial evaluator is still used by default. The new one can be activated
in two ways:
- by using the command line option -new-comp when invoking GF.
- by using cabal configure -fnew-comp to make -new-comp the default. In this
case you can also use the command line option -old-comp to revert to the old
partial evaluator.
In the GF shell, the cc command uses the old evaluator regardless of -new-comp
for now, but you can use "cc -new ..." to invoke the new evaluator.
With -new-comp, computations happen in GF.Compile.GeneratePMCFG instead of
GF.Compile.Optimize. This is implemented by testing the flag optNewComp in
both modules, to omit calls to the old partial evaluator from GF.Compile.Optimize
and add calls to the new partial evaluator in GF.Compile.GeneratePMCFG.
This also means that -new-comp effectively implies -noexpand.
In GF.Compile.CheckGrammar, there is a check that restricted inheritance is used
correctly. However, when -noexpand is used, this check causes unexpected errors,
so it has been converted to generate warnings, for now.
-new-comp no longer enables the new type checker in
GF.Compile.Typeckeck.ConcreteNew.
The GF version number has been bumped to 3.3.10-darcs
This commit is contained in:
hallgren
@@ -23,8 +23,8 @@ import GF.Grammar.Predef
|
||||
import GF.Data.BacktrackM
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Utilities (updateNthM, updateNth)
|
||||
|
||||
import System.IO
|
||||
import GF.Compile.Compute.ConcreteNew(normalForm)
|
||||
import System.IO(hPutStr,hPutStrLn,stderr)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.List as List
|
||||
@@ -71,7 +71,7 @@ addPMCFG opts gr am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin
|
||||
|
||||
pmcfgEnv0 = emptyPMCFGEnv
|
||||
|
||||
b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil val) (pargs,[])
|
||||
b = convert opts gr term val pargs
|
||||
(seqs1,b1) = addSequencesB seqs b
|
||||
pmcfgEnv1 = foldBM addRule
|
||||
pmcfgEnv0
|
||||
@@ -104,7 +104,7 @@ addPMCFG opts gr am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(
|
||||
|
||||
pmcfgEnv0 = emptyPMCFGEnv
|
||||
|
||||
b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil lincat) ([parg],[])
|
||||
b = convert opts gr term lincat [parg]
|
||||
(seqs1,b1) = addSequencesB seqs b
|
||||
pmcfgEnv1 = foldBM addRule
|
||||
pmcfgEnv0
|
||||
@@ -121,12 +121,34 @@ addPMCFG opts gr am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(
|
||||
|
||||
addPMCFG opts gr am cm seqs id info = return (seqs, info)
|
||||
|
||||
convert opts gr term val pargs =
|
||||
runCnvMonad gr conv (pargs,[])
|
||||
where
|
||||
conv = convertTerm opts CNil val =<< unfactor term'
|
||||
term' = if flag optNewComp opts
|
||||
then normalForm gr (recordExpand val term) -- new evaluator
|
||||
else term -- old evaluator is invoked from GF.Compile.Optimize
|
||||
|
||||
recordExpand :: Type -> Term -> Term
|
||||
recordExpand typ trm =
|
||||
case typ of
|
||||
RecType tys -> expand trm
|
||||
where
|
||||
n = length tys
|
||||
expand trm =
|
||||
case trm of
|
||||
FV ts -> FV (map expand ts)
|
||||
R rs | length rs==n -> trm
|
||||
_ -> R [assign lab (P trm lab) | (lab,_) <- tys]
|
||||
_ -> trm
|
||||
|
||||
unfactor :: Term -> CnvMonad Term
|
||||
unfactor t = CM (\gr c -> c (unfac gr t))
|
||||
where
|
||||
unfac gr t =
|
||||
case t of
|
||||
T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac gr u) | v <- err bug id (allParamValues gr ty)]
|
||||
T (TTyped ty) _ -> ppbug $ text "unfactor"<+>ppTerm Unqualified 10 t
|
||||
_ -> composSafeOp (unfac gr) t
|
||||
where
|
||||
restore x u t = case t of
|
||||
@@ -329,9 +351,16 @@ convertTerm opts sel ctype (Alts s alts)
|
||||
strings (K s) = [s]
|
||||
strings (C u v) = strings u ++ strings v
|
||||
strings (Strs ss) = concatMap strings ss
|
||||
strings Empty = [] -- ??
|
||||
strings t = bug $ "strings "++show t
|
||||
|
||||
convertTerm opts sel@(CProj l _) ctype (ExtR t1 t2@(R rs2))
|
||||
| l `elem` map fst rs2 = convertTerm opts sel ctype t2
|
||||
| otherwise = convertTerm opts sel ctype t1
|
||||
|
||||
convertTerm opts CNil ctype t = do v <- evalTerm CNil t
|
||||
return (CPar v)
|
||||
convertTerm _ _ _ t = ppbug (text "convertTerm" <+> parens (ppTerm Unqualified 0 t))
|
||||
convertTerm _ sel _ t = ppbug (text "convertTerm" <+> sep [parens (text (show sel)),ppTerm Unqualified 10 t])
|
||||
|
||||
convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
|
||||
convertArg opts (RecType rs) nr path =
|
||||
@@ -460,7 +489,7 @@ evalTerm path (V pt ts) = case path of
|
||||
(CSel trm path) -> do vs <- getAllParamValues pt
|
||||
case lookup trm (zip vs ts) of
|
||||
Just t -> evalTerm path t
|
||||
Nothing -> bug "evalTerm: missing value"
|
||||
Nothing -> ppbug $ text "evalTerm: missing value:"<+>ppTerm Unqualified 0 trm $$ text "among:"<+>fsep (map (ppTerm Unqualified 10) vs)
|
||||
CNil -> do ts <- mapM (evalTerm path) ts
|
||||
return (V pt ts)
|
||||
evalTerm path (S term sel) = do v <- evalTerm CNil sel
|
||||
@@ -468,10 +497,12 @@ evalTerm path (S term sel) = do v <- evalTerm CNil sel
|
||||
evalTerm path (FV terms) = variants terms >>= evalTerm path
|
||||
evalTerm path (EInt n) = return (EInt n)
|
||||
evalTerm path t = ppbug (text "evalTerm" <+> parens (ppTerm Unqualified 0 t))
|
||||
--evalTerm path t = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])
|
||||
|
||||
getVarIndex (IA _ i) = i
|
||||
getVarIndex (IAV _ _ i) = i
|
||||
getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd isDigit) s
|
||||
getVarIndex x = bug ("getVarIndex "++show x)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- GrammarEnv
|
||||
@@ -545,4 +576,4 @@ mkArray lst = listArray (0,length lst-1) lst
|
||||
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
|
||||
|
||||
bug msg = ppbug (text msg)
|
||||
ppbug doc = error $ render $ text "Internal error:" <+> doc
|
||||
ppbug = error . render . hang (text "Internal error in GeneratePMCFG:") 4
|
||||
|
||||
Reference in New Issue
Block a user