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

Adding a new experimental partial evalutator

Browse Source 
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
2012-11-13 14:09:15 +00:00
parent 468464faca
commit 27e675910a
12 changed files with 659 additions and 125 deletions
Download Patch File Download Diff File Expand all files Collapse all files

108
src/compiler/GF/Compile/Compute/ConcreteNew1.hs Normal file
View File

@@ -0,0 +1,108 @@
module GF.Compile.Compute.ConcreteNew1
( normalForm
, Value(..), Env, eval, apply, value2term
) where
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Data.Operations
import Data.List (intersect)
import Text.PrettyPrint
import qualified Data.ByteString.Char8 as BS
normalForm :: SourceGrammar -> Term -> Term
normalForm gr t = value2term gr [] (eval gr [] t)
data Value
= VApp QIdent [Value]
| VGen Int [Value]
| VMeta MetaId Env [Value]
| VClosure Env Term
| VInt Int
| VFloat Double
| VString String
| VSort Ident
| VImplArg Value
| VTblType Value Value
| VRecType [(Label,Value)]
| VRec [(Label,Value)]
| VTbl Type [Value]
-- | VC Value Value
| VPatt Patt
| VPattType Value
| VFV [Value]
| VAlts Value [(Value, Value)]
| VError String
deriving Show
type Env = [(Ident,Value)]
eval :: SourceGrammar -> Env -> Term -> Value
eval gr env (Vr x) = case lookup x env of
Just v -> v
Nothing -> error ("Unknown variable "++showIdent x)
eval gr env (Q x)
| x == (cPredef,cErrorType) -- to be removed
= let varP = identC (BS.pack "P")
in eval gr [] (mkProd [(Implicit,varP,typeType)] (Vr varP) [])
| fst x == cPredef = VApp x []
| otherwise = case lookupResDef gr x of
Ok t -> eval gr [] t
Bad err -> error err
eval gr env (QC x) = VApp x []
eval gr env (App e1 e2) = apply gr env e1 [eval gr env e2]
eval gr env (Meta i) = VMeta i env []
eval gr env t@(Prod _ _ _ _) = VClosure env t
eval gr env t@(Abs _ _ _) = VClosure env t
eval gr env (EInt n) = VInt n
eval gr env (EFloat f) = VFloat f
eval gr env (K s) = VString s
eval gr env Empty = VString ""
eval gr env (Sort s)
| s == cTok = VSort cStr -- to be removed
| otherwise = VSort s
eval gr env (ImplArg t) = VImplArg (eval gr env t)
eval gr env (Table p res) = VTblType (eval gr env p) (eval gr env res)
eval gr env (RecType rs) = VRecType [(l,eval gr env ty) | (l,ty) <- rs]
eval gr env t@(ExtR t1 t2) =
let error = VError (show (text "The term" <+> ppTerm Unqualified 0 t <+> text "is not reducible"))
in case (eval gr env t1, eval gr env t2) of
(VRecType rs1, VRecType rs2) -> case intersect (map fst rs1) (map fst rs2) of
[] -> VRecType (rs1 ++ rs2)
_ -> error
(VRec rs1, VRec rs2) -> case intersect (map fst rs1) (map fst rs2) of
[] -> VRec (rs1 ++ rs2)
_ -> error
_ -> error
eval gr env (FV ts) = VFV (map (eval gr env) ts)
eval gr env t = error ("unimplemented: eval "++show t)
apply gr env t [] = eval gr env t
apply gr env (Q x) vs
| fst x == cPredef = VApp x vs -- hmm
| otherwise = case lookupResDef gr x of
Ok t -> apply gr [] t vs
Bad err -> error err
apply gr env (App t1 t2) vs = apply gr env t1 (eval gr env t2 : vs)
apply gr env (Abs b x t) (v:vs) = case (b,v) of
(Implicit,VImplArg v) -> apply gr ((x,v):env) t vs
(Explicit, v) -> apply gr ((x,v):env) t vs
apply gr env t vs = error ("apply "++show t)
value2term :: SourceGrammar -> [Ident] -> Value -> Term
value2term gr xs (VApp f vs) = foldl App (Q f) (map (value2term gr xs) vs)
value2term gr xs (VGen j vs) = foldl App (Vr (reverse xs !! j)) (map (value2term gr xs) vs)
value2term gr xs (VMeta j env vs) = foldl App (Meta j) (map (value2term gr xs) vs)
value2term gr xs (VClosure env (Prod bt x t1 t2)) = Prod bt x (value2term gr xs (eval gr env t1))
(value2term gr (x:xs) (eval gr ((x,VGen (length xs) []) : env) t2))
value2term gr xs (VClosure env (Abs bt x t)) = Abs bt x (value2term gr (x:xs) (eval gr ((x,VGen (length xs) []) : env) t))
value2term gr xs (VInt n) = EInt n
value2term gr xs (VFloat f) = EFloat f
value2term gr xs (VString s) = if null s then Empty else K s
value2term gr xs (VSort s) = Sort s
value2term gr xs (VImplArg v) = ImplArg (value2term gr xs v)
value2term gr xs (VTblType p res) = Table (value2term gr xs p) (value2term gr xs res)
value2term gr xs (VRecType rs) = RecType [(l,value2term gr xs v) | (l,v) <- rs]
value2term gr xs (VFV vs) = FV (map (value2term gr xs) vs)
value2term gr xs v = error ("unimplemented: value2term "++show v)