msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests 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

16
gf.cabal
View File

@@ -1,5 +1,5 @@
name: gf
version: 3.3.3-darcs
version: 3.3.10-darcs
cabal-version: >= 1.8
build-type: Custom
@@ -10,7 +10,7 @@ synopsis: Grammatical Framework
description: GF, Grammatical Framework, is a programming language for multilingual grammar applications
homepage: http://www.grammaticalframework.org/
bug-reports: http://code.google.com/p/grammatical-framework/issues/list
tested-with: GHC==6.12.3, GHC==7.0.4
tested-with: GHC==6.12.3, GHC==7.0.4, GHC==7.4.2
data-dir: src
data-files: www/*.html
@@ -45,6 +45,10 @@ flag server
Description: Include --server mode
Default: True
flag new-comp
Description: Make -new-comp the default
Default: False
library
build-depends: base >= 4.2 && <5,
array,
@@ -117,6 +121,9 @@ executable gf
other-modules: GFServer
hs-source-dirs: src/server src/server/transfer src/example-based
if flag(new-comp)
cpp-options: -DNEW_COMP
build-tools: happy
--, alex>=2 && <3 -- tricky to install in Ubuntu 12.04
if os(windows)
@@ -177,10 +184,15 @@ executable gf
GF.Compile.ToAPI
GF.Compile.TypeCheck.Abstract
GF.Compile.TypeCheck.Concrete
GF.Compile.TypeCheck.ConcreteNew
GF.Compile.TypeCheck.TC
GF.Compile.Compute.Abstract
GF.Compile.Compute.Concrete
GF.Compile.Compute.ConcreteNew1
GF.Compile.Compute.ConcreteNew
GF.Compile.Compute.AppPredefined
GF.Compile.Compute.Value
GF.Compile.Compute.Predef
GF.Compile.Optimize
GF.Compile.SubExOpt
GF.Compile.GetGrammar

10
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -78,7 +78,7 @@ checkRestrictedInheritance sgr (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <
(f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
case illegals of
[] -> return ()
cs -> checkError (text "In inherited module" <+> ppIdent i <> text ", dependence of excluded constants:" $$
cs -> checkWarn (text "In inherited module" <+> ppIdent i <> text ", dependence of excluded constants:" $$
nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs]))
allDeps = concatMap (allDependencies (const True) . jments . snd) mos
@@ -176,7 +176,7 @@ checkInfo opts sgr (m,mo) c info = do
CncCat mty mdef mpr mpmcfg -> do
mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $
(if flag optNewComp opts
(if False --flag optNewComp opts
then do (typ,_) <- CN.checkLType gr typ typeType
typ <- computeLType gr [] typ
return (Just (L loc typ))
@@ -217,17 +217,17 @@ checkInfo opts sgr (m,mo) c info = do
(pty', pde') <- case (pty,pde) of
(Just (L loct ty), Just (L locd de)) -> do
ty' <- chIn loct "operation" $
(if flag optNewComp opts
(if False --flag optNewComp opts
then CN.checkLType gr ty typeType >>= return . CN.normalForm gr . fst
else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
(de',_) <- chIn locd "operation" $
(if flag optNewComp opts
(if False -- flag optNewComp opts
then CN.checkLType gr de ty'
else checkLType gr [] de ty')
return (Just (L loct ty'), Just (L locd de'))
(Nothing , Just (L locd de)) -> do
(de',ty') <- chIn locd "operation" $
(if flag optNewComp opts
(if False -- flag optNewComp opts
then CN.inferLType gr de
else inferLType gr [] de)
return (Just (L locd ty'), Just (L locd de'))

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

@@ -1,108 +1,338 @@
-- | Functions for computing the values of terms in the concrete syntax, in
-- | preparation for PMCFG generation.
module GF.Compile.Compute.ConcreteNew
( 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 GF.Grammar.Lookup(lookupResDef,allParamValues)
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr)
import GF.Grammar.PatternMatch(matchPattern)
import GF.Grammar.Lockfield(unlockRecord,lockLabel,isLockLabel)
import GF.Compile.Compute.Value
import GF.Compile.Compute.Predef(predefs)
import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
import GF.Data.Operations(Err,err,maybeErr,combinations)
import GF.Data.Utilities(mapSnd,mapBoth,apBoth,apSnd)
import Control.Monad(liftM,liftM2,mplus)
import Data.List (findIndex,intersect,isInfixOf,nub)
import Data.Char (isUpper,toUpper,toLower)
import Text.PrettyPrint
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import Debug.Trace(trace)
-- * Main entry points
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)]
normalForm gr = nfx gr []
nfx gr env = value2term gr [] . eval gr env
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)
eval gr env t = value (gr,env) 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)
apply gr env = apply' (gr,env)
--------------------------------------------------------------------------------
-- * Environments
type CompleteEnv = (SourceGrammar,Env)
ext b (gr,env) = (gr,b:env)
var env x = maybe unbound id (lookup x (snd env))
where unbound = bug ("Unknown variable: "++showIdent x)
-- * Computing values
-- | Computing the value of a top-level term
value0 gr t = eval gr [] t
-- | Computing the value of a term
value :: CompleteEnv -> Term -> Value
value env t0 =
case t0 of
Vr x -> var env x
Q x@(m,f)
| m == cPredef -> if f==cErrorType -- to be removed
then let p = identC (BS.pack "P")
in value0 (fst env) (mkProd [(Implicit,p,typeType)] (Vr p) [])
else VApp x []
| otherwise -> err bug (value0 (fst env)) (lookupResDef (fst env) x)
QC x -> VCApp x []
App e1 e2 -> apply' env e1 [value env e2]
Let (x,(oty,t)) body -> value (ext (x,value env t) env) body
Meta i -> VMeta i (snd env) []
Prod bt x t1 t2 -> VProd bt (value env t1) x (Bind $ \ vx -> value (ext (x,vx) env) t2)
Abs bt x t -> VAbs bt x (Bind $ \ vx -> value (ext (x,vx) env) t)
EInt n -> VInt n
EFloat f -> VFloat f
K s -> VString s
Empty -> VString ""
Sort s | s == cTok -> VSort cStr -- to be removed
| otherwise -> VSort s
ImplArg t -> VImplArg (value env t)
Table p res -> VTblType (value env p) (value env res)
RecType rs -> VRecType [(l,value env ty) | (l,ty) <- rs]
t@(ExtR t1 t2) -> extR t (both (value env) (t1,t2))
FV ts -> vfv (map (value env) ts)
R as -> VRec [(lbl,value env t)|(lbl,(oty,t))<-as]
T i cs -> valueTable env i cs
V ty ts -> VV ty (map (value env) ts)
C t1 t2 -> vconcat (both (value env) (t1,t2))
S t1 t2 -> select (fst env) (both (value env) (t1,t2))
P t l -> --maybe (bug $ "project "++show l++" from "++show v) id $
maybe (VP v l) id $
proj l v where v = (value env t)
Alts t tts -> VAlts (value env t) (mapBoth (value env) tts)
Strs ts -> VStrs (map (value env) ts)
Glue t1 t2 -> glue (both (value env) (t1,t2))
ELin c r -> unlockVRec c (value env r)
t -> ppbug (text "value"<+>ppTerm Unqualified 10 t $$ text (show t))
vconcat vv@(v1,v2) =
case vv of
(VError _,_) -> v1
(VString "",_) -> v2
(_,VError _) -> v2
(_,VString "") -> v1
_ -> VC v1 v2
proj l v | isLockLabel l = return (VRec [])
---- a workaround 18/2/2005: take this away and find the reason
---- why earlier compilation destroys the lock field
proj l v =
case v of
VFV vs -> liftM vfv (mapM (proj l) vs)
VRec rs -> lookup l rs
VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm
_ -> return (ok1 VP v l)
ok1 f v1@(VError {}) _ = v1
ok1 f v1 v2 = f v1 v2
ok2 f v1@(VError {}) _ = v1
ok2 f _ v2@(VError {}) = v2
ok2 f v1 v2 = f v1 v2
unlockVRec ::Ident -> Value -> Value
unlockVRec c v =
case v of
-- VClosure env t -> err bug (VClosure env) (unlockRecord c t)
VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec c (f v))
VRec rs -> plusVRec rs lock
_ -> VExtR v (VRec lock) -- hmm
-- _ -> bug $ "unlock non-record "++show v
where
lock = [(lockLabel c,VRec [])]
-- suspicious, but backwards compatible
plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2)
where ls2 = map fst rs2
extR t vv =
case vv of
(VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs]
(v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs]
(VRecType rs1, VRecType rs2) ->
case intersect (map fst rs1) (map fst rs2) of
[] -> VRecType (rs1 ++ rs2)
ls -> error $ text "clash"<+>text (show ls)
(VRec rs1, VRec rs2) -> plusVRec rs1 rs2
(v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
(VS (VV t vs) s,v2) -> VS (VV t [extR t (v1,v2)|v1<-vs]) s
(v1,v2) -> ok2 VExtR v1 v2 -- hmm
-- (v1,v2) -> error $ text "not records" $$ text (show v1) $$ text (show v2)
where
error explain = ppbug $ text "The term" <+> ppTerm Unqualified 0 t
<+> text "is not reducible" $$ explain
glue vv = case vv of
(VFV vs,v2) -> vfv [glue (v1,v2)|v1<-vs]
(v1,VFV vs) -> vfv [glue (v1,v2)|v2<-vs]
(VString s1,VString s2) -> VString (s1++s2)
(v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs]
where glx v2 = glue (v1,v2)
(v1@(VAlts {}),v2) ->
--err (const (ok2 VGlue v1 v2)) id $
err bug id $
do y' <- strsFromValue v2
x' <- strsFromValue v1
return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
(VC va vb,v2) -> VC va (glue (vb,v2))
(v1,VC va vb) -> VC (glue (va,va)) vb
(VS (VV ty vs) vb,v2) -> VS (VV ty [glue (v,v2)|v<-vs]) vb
(v1,VS (VV ty vs) vb) -> VS (VV ty [glue (v1,v)|v<-vs]) vb
-- (v1,v2) -> ok2 VGlue v1 v2
(v1,v2) -> bug vv
where
bug vv = ppbug $ text "glue"<+>text (show vv)
-- | to get a string from a value that represents a sequence of terminals
strsFromValue :: Value -> Err [Str]
strsFromValue t = case t of
VString s -> return [str s]
VC s t -> do
s' <- strsFromValue s
t' <- strsFromValue t
return [plusStr x y | x <- s', y <- t']
{-
VGlue s t -> do
s' <- strsFromValue s
t' <- strsFromValue t
return [glueStr x y | x <- s', y <- t']
-}
VAlts d vs -> do
d0 <- strsFromValue d
v0 <- mapM (strsFromValue . fst) vs
c0 <- mapM (strsFromValue . snd) vs
let vs' = zip v0 c0
return [strTok (str2strings def) vars |
def <- d0,
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- combinations v0]
]
VFV ts -> mapM strsFromValue ts >>= return . concat
VStrs ts -> mapM strsFromValue ts >>= return . concat
_ -> fail "cannot get Str from value"
vfv vs = case nub vs of
[v] -> v
vs -> VFV vs
select gr vv =
case vv of
(v1,VFV vs) -> vfv [select gr (v1,v2)|v2<-vs]
(VFV vs,v2) -> vfv [select gr (v1,v2)|v1<-vs]
(v1@(VV pty rs),v2) ->
err (const (VS v1 v2)) id $
do ats <- allParamValues gr pty
let vs = map (value0 gr) ats
i <- maybeErr "no match" $ findIndex (==v2) vs
return (rs!!i)
(v1@(VT i cs),v2) ->
err bug (valueMatch gr) $ matchPattern cs (value2term gr [] v2)
(VS (VV pty rs) v12,v2) -> VS (VV pty [select gr (v11,v2)|v11<-rs]) v12
(v1,v2) -> ok2 VS v1 v2
valueMatch gr (Bind f,env') = f (mapSnd (value0 gr) env')
valueTable env@(gr,bs) i cs =
case i of
TComp ty -> VV ty (map (value env.snd) cs)
_ -> err keep id convert
where
keep _ = VT i (err bug id $ mapM valueCase cs)
valueCase (p,t) = do p' <- inlinePattMacro p
return (p',Bind $ \ bs' -> value (gr,bs'++bs) t)
convert = do ty <- getTableType i
let pty = nfx gr bs ty
vs <- allParamValues gr pty
cs' <- mapM valueCase cs
sts <- mapM (matchPattern cs') vs
return $ VV pty (map (valueMatch gr) sts)
inlinePattMacro p = case p of
PM qc -> do EPatt p' <- lookupResDef gr qc
inlinePattMacro p'
_ -> composPattOp inlinePattMacro p
apply' env t [] = value env t
apply' env t vs =
case t of
QC x -> VCApp x vs
Q x@(m,f) | m==cPredef -> let constr = --trace ("predef "++show x) .
VApp x
in maybe constr id (Map.lookup f predefs) vs
| otherwise -> err bug (\t->apply' (fst env,[]) t vs)
(lookupResDef (fst env) x)
App t1 t2 -> apply' env t1 (value env t2 : vs)
-- Abs b x t -> beta env b x t vs
_ -> vapply (value env t) vs
vapply v [] = v
vapply v vs =
case v of
VError {} -> v
-- VClosure env (Abs b x t) -> beta gr env b x t vs
VAbs bt _ (Bind f) -> vbeta bt f vs
VS (VV t fs) s -> VS (VV t [vapply f vs|f<-fs]) s
v -> bug $ "vapply "++show v++" "++show vs
vbeta bt f (v:vs) =
case (bt,v) of
(Implicit,VImplArg v) -> vapply (f v) vs
(Explicit, v) -> vapply (f v) vs
{-
beta env b x t (v:vs) =
case (b,v) of
(Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs
(Explicit, v) -> apply' (ext (x,v) env) t vs
-}
-- tr s f vs = trace (s++" "++show vs++" = "++show r) r where r = f vs
-- | Convert a value back to a term
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)
value2term gr xs v0 =
case v0 of
VApp f vs -> foldl App (Q f) (map v2t vs)
VCApp f vs -> foldl App (QC f) (map v2t vs)
VGen j vs -> foldl App (Vr (reverse xs !! j)) (map v2t vs)
VMeta j env vs -> foldl App (Meta j) (map v2t vs)
-- VClosure env (Prod bt x t1 t2) -> Prod bt x (v2t (eval gr env t1))
-- (nf gr (push x (env,xs)) t2)
-- VClosure env (Abs bt x t) -> Abs bt x (nf gr (push x (env,xs)) t)
VProd bt v x (Bind f) -> Prod bt x (v2t v) (v2t' x f)
VAbs bt x (Bind f) -> Abs bt x (v2t' x f)
VInt n -> EInt n
VFloat f -> EFloat f
VString s -> if null s then Empty else K s
VSort s -> Sort s
VImplArg v -> ImplArg (v2t v)
VTblType p res -> Table (v2t p) (v2t res)
VRecType rs -> RecType [(l,v2t v) | (l,v) <- rs]
VRec as -> R [(l,(Nothing,v2t v))|(l,v) <- as]
VV t vs -> V t (map v2t vs)
VT i cs -> T i (map nfcase cs)
VFV vs -> FV (map v2t vs)
VC v1 v2 -> C (v2t v1) (v2t v2)
VS v1 v2 -> S (v2t v1) (v2t v2)
VP v l -> P (v2t v) l
VAlts v vvs -> Alts (v2t v) (mapBoth v2t vvs)
VStrs vs -> Strs (map v2t vs)
-- VGlue v1 v2 -> Glue (v2t v1) (v2t v2)
VExtR v1 v2 -> ExtR (v2t v1) (v2t v2)
VError err -> Error err
_ -> bug ("value2term "++show v0)
where
v2t = value2term gr xs
v2t' x f = value2term gr (x:xs) (f (gen xs))
pushs xs e = foldr push e xs
push x (env,xs) = ((x,gen xs):env,x:xs)
gen xs = VGen (length xs) []
nfcase (p,Bind f) = (p,value2term gr xs' (f env'))
where (env',xs') = pushs (pattVars p) ([],xs)
-- nf gr (env,xs) = value2term gr xs . eval gr env
pattVars = nub . pv
where
pv p = case p of
PV i -> [i]
PAs i p -> i:pv p
_ -> collectPattOp pv p
---
both = apBoth
bug msg = ppbug (text msg)
ppbug doc = error $ render $
hang (text "Internal error in Compute.ConcreteNew2:") 4 doc

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)

88
src/compiler/GF/Compile/Compute/Predef.hs Normal file
View File

@@ -0,0 +1,88 @@
-- | Implementations of predefined functions
module GF.Compile.Compute.Predef where
import Text.PrettyPrint(render,hang,text)
import qualified Data.Map as Map
import Data.List (isInfixOf)
import Data.Char (isUpper,toLower,toUpper)
import GF.Data.Utilities (mapSnd,apBoth)
import GF.Compile.Compute.Value
import GF.Infra.Ident (Ident)
import GF.Grammar.Predef
predefs :: Map.Map Ident ([Value]->Value)
predefs = Map.fromList $ mapSnd strictf
[(cDrop,apISS drop),(cTake,apISS take),(cTk,apISS tk),(cDp,apISS dp),
(cEqStr,apSSB (==)),(cOccur,apSSB occur),(cOccurs,apSSB occurs),
(cToUpper,apSS (map toUpper)),(cToLower,apSS (map toLower)),
(cIsUpper,apSB (all isUpper)),(cLength,apSS' (VInt . length)),
(cPlus,apIII (+)),(cEqInt,apIIB (==)),(cLessInt,apIIB (<)),
(cShow,unimpl),(cRead,unimpl),(cToStr,unimpl),(cMapStr,unimpl),
(cEqVal,unimpl),(cError,apSS' VError)]
--- add more functions!!!
where
unimpl = bug "unimplemented predefined function"
tk i s = take (max 0 (length s - i)) s
dp i s = drop (max 0 (length s - i)) s
occur s t = isInfixOf s t
occurs s t = any (`elem` t) s
apIII f vs = case vs of
[VInt i1, VInt i2] -> VInt (f i1 i2)
_ -> bug $ "f::Int->Int->Int got "++show vs
apIIB f vs = case vs of
[VInt i1, VInt i2] -> boolV (f i1 i2)
_ -> bug $ "f::Int->Int->Bool got "++show vs
apISS f vs = case vs of
[VInt i, VString s] -> string (f i s)
_ -> bug $ "f::Int->Str->Str got "++show vs
apSSB f vs = case vs of
[VString s1, VString s2] -> boolV (f s1 s2)
_ -> bug $ "f::Str->Str->Bool got "++show vs
apSB f vs = case vs of
[VString s] -> boolV (f s)
_ -> bug $ "f::Str->Bool got "++show vs
apSS f vs = case vs of
[VString s] -> string (f s)
_ -> bug $ "f::Str->Str got "++show vs
apSS' f vs = case vs of
[VString s] -> f s
_ -> bug $ "f::Str->_ got "++show vs
boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
strictf f vs = case normvs vs of
Left err -> VError err
Right vs -> f vs
normvs = mapM (strict . norm)
norm v =
case v of
VC v1 v2 -> case apBoth norm (v1,v2) of
(VString s1,VString s2) -> VString (s1++" "++s2)
(v1,v2) -> VC v1 v2
_ -> v
strict v = case v of
VError err -> Left err
_ -> Right v
string s = case words s of
[] -> VString ""
ss -> foldr1 VC (map VString ss)
---
bug msg = ppbug (text msg)
ppbug doc = error $ render $
hang (text "Internal error in Compute.Predef:") 4 doc

44
src/compiler/GF/Compile/Compute/Value.hs Normal file
View File

@@ -0,0 +1,44 @@
module GF.Compile.Compute.Value where
import GF.Grammar.Grammar(Label,Type,TInfo,MetaId,Patt,QIdent)
import PGF.Data(BindType)
import GF.Infra.Ident(Ident)
import Text.Show.Functions
-- | Self-contained (not quite) representation of values
data Value
= VApp QIdent [Value] -- from Q, always Predef.x, has a built-in value
| VCApp QIdent [Value] -- from QC, constructors
| VGen Int [Value] -- for lambda bound variables, possibly applied
| VMeta MetaId Env [Value]
-- | VClosure Env Term -- used in Typecheck.ConcreteNew
| VAbs BindType Ident Binding -- used in Compute.ConcreteNew
| VProd BindType Value Ident Binding -- used in Compute.ConcreteNew
| VInt Int
| VFloat Double
| VString String
| VSort Ident
| VImplArg Value
| VTblType Value Value
| VRecType [(Label,Value)]
| VRec [(Label,Value)]
| VV Type [Value]
| VT TInfo [(Patt,Bind Env)]
| VC Value Value
| VS Value Value
| VP Value Label
| VPatt Patt
| VPattType Value
| VFV [Value]
| VAlts Value [(Value, Value)]
| VStrs [Value]
-- | VGlue Value Value -- hmm
| VExtR Value Value -- hmm
| VError String
deriving (Eq,Show)
type Binding = Bind Value
data Bind a = Bind (a->Value) deriving Show
instance Eq (Bind a) where x==y = False
type Env = [(Ident,Value)]

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

@@ -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

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

@@ -86,7 +86,7 @@ evalInfo opts sgr m c info = do
return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
ResOper pty pde
| OptExpand `Set.member` optim -> do
| not new && OptExpand `Set.member` optim -> do
pde' <- case pde of
Just (L loc de) -> do de <- computeConcrete gr de
return (Just (L loc (factor param c 0 de)))
@@ -95,6 +95,8 @@ evalInfo opts sgr m c info = do
_ -> return info
where
new = flag optNewComp opts -- computations moved to GF.Compile.GeneratePMCFG
gr = prependModule sgr m
optim = flag optOptimizations opts
param = OptParametrize `Set.member` optim
@@ -107,13 +109,17 @@ partEval opts gr (context, val) trm = errIn (render (text "partial evaluation" <
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
trm1 = mkApp trm args
trm2 <- computeTerm gr subst trm1
trm3 <- if rightType trm2
then computeTerm gr subst trm2
else recordExpand val trm2 >>= computeTerm gr subst
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
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

6
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -4,7 +4,7 @@ import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Grammar.Lockfield
import GF.Compile.Compute.ConcreteNew
import GF.Compile.Compute.ConcreteNew1
import GF.Compile.Compute.AppPredefined
import GF.Infra.CheckM
import GF.Infra.UseIO
@@ -245,7 +245,7 @@ tcPatt gr scope (PAlt p1 p2) ty0 = do
tcPatt gr scope p1 ty0
tcPatt gr scope p2 ty0
return scope
tcPatt gr scope p ty = error ("tcPatt "++show p)
tcPatt gr scope p ty = unimplemented ("tcPatt "++show p)
inferRecFields gr scope rs =
@@ -479,6 +479,8 @@ tcError msg = TcM (\ms msgs -> TcFail (msg : msgs))
tcWarn :: Message -> TcM ()
tcWarn msg = TcM (\ms msgs -> TcOk () ms ((text "Warning:" <+> msg) : msgs))
unimplemented str = fail ("Unimplemented: "++str)
runTcM :: TcM a -> Check a
runTcM f = case unTcM f IntMap.empty [] of
TcOk x _ msgs -> do checkWarnings msgs; return x

3
src/compiler/GF/Infra/BuildInfo.hs
View File

@@ -15,6 +15,9 @@ buildInfo =
#endif
#ifdef SERVER_MODE
++" server"
#endif
#ifdef NEW_COMP
++" new-comp"
#endif
where
details = either (const no_info) info darcs_info

13
src/compiler/GF/Infra/Option.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
module GF.Infra.Option
(
-- * Option types
@@ -256,11 +257,7 @@ defaultFlags = Flags {
optPreprocessors = [],
optEncoding = "latin1",
optPMCFG = True,
-- #ifdef CC_LAZY
-- optOptimizations = Set.fromList [OptStem,OptCSE],
-- #else
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
-- #endif
optOptimizePGF = False,
optMkIndexPGF = False,
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
@@ -273,7 +270,12 @@ defaultFlags = Flags {
optWarnings = [],
optDump = [],
optTagsOnly = False,
optNewComp = False
optNewComp =
#ifdef NEW_COMP
True
#else
False
#endif
}
-- Option descriptions
@@ -352,6 +354,7 @@ optDescr =
Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).",
Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
Option [] ["new-comp"] (NoArg (set $ \o -> o{optNewComp = True})) "Use the new experimental compiler.",
Option [] ["old-comp"] (NoArg (set $ \o -> o{optNewComp = False})) "Use old trusty compiler.",
dumpOption "source" Source,
dumpOption "rebuild" Rebuild,
dumpOption "extend" Extend,

19
src/compiler/GFI.hs
View File

@@ -18,6 +18,7 @@ import GF.Grammar.ShowTerm
import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError)
import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm)
import GF.Compile.TypeCheck.Concrete (inferLType,ppType)
import GF.Infra.Dependencies(depGraph)
import GF.Infra.CheckM
@@ -177,13 +178,16 @@ execute1 opts gfenv0 s0 =
pOpts style q ("-qual" :ws) = pOpts style Qualified ws
pOpts style q ws = (style,q,unwords ws)
(style,q,s) = pOpts TermPrintDefault Qualified ws
(style,q,s) = pOpts TermPrintDefault Qualified ws'
(new,ws') = case ws of
"-new":ws' -> (True,ws')
_ -> (False,ws)
case runP pExp (encodeUnicode utf8 s) of
Left (_,msg) -> putStrLn msg
Right t -> case checkComputeTerm sgr (codeTerm (decodeUnicode utf8 . BS.pack) t) of
Ok x -> putStrLn $ showTerm sgr style q x
Bad s -> putStrLn $ s
Right t -> putStrLn . err id (showTerm sgr style q)
. checkComputeTerm' new sgr
$ codeTerm (decodeUnicode utf8 . BS.pack) t
continue gfenv
show_deps ws = do
@@ -319,11 +323,14 @@ execute1 opts gfenv0 s0 =
printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
checkComputeTerm sgr t = do
checkComputeTerm = checkComputeTerm' False
checkComputeTerm' new sgr t = do
mo <- maybe (Bad "no source grammar in scope") return $ greatestResource sgr
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t
t1 <- computeConcrete sgr t
t1 <- if new
then return (CN.normalForm sgr t)
else computeConcrete sgr t
checkPredefError sgr t1
fetchCommand :: GFEnv -> IO String