diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/compiler/GF/Compile/CheckGrammar.hs | 10 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteNew.hs | 418 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteNew1.hs | 108 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/Predef.hs | 88 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/Value.hs | 44 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/GeneratePMCFG.hs | 45 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Optimize.hs | 16 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs | 6 | ||||
| -rw-r--r-- | src/compiler/GF/Infra/BuildInfo.hs | 3 | ||||
| -rw-r--r-- | src/compiler/GF/Infra/Option.hs | 13 | ||||
| -rw-r--r-- | src/compiler/GFI.hs | 19 |
11 files changed, 646 insertions, 124 deletions
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 0c72c67fe..50af38add 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -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')) diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index d614c022a..49752aebb 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -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) - -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) +eval gr env t = value (gr,env) 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 diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew1.hs b/src/compiler/GF/Compile/Compute/ConcreteNew1.hs new file mode 100644 index 000000000..59c9ef6b4 --- /dev/null +++ b/src/compiler/GF/Compile/Compute/ConcreteNew1.hs @@ -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) diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs new file mode 100644 index 000000000..1647b2a92 --- /dev/null +++ b/src/compiler/GF/Compile/Compute/Predef.hs @@ -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 diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs new file mode 100644 index 000000000..c47c67acb --- /dev/null +++ b/src/compiler/GF/Compile/Compute/Value.hs @@ -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)] diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 7c3d7fce5..feb26c38f 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -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 diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index 635a1732c..0599ed85b 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -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 diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index 26308d945..e2473aae8 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -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 diff --git a/src/compiler/GF/Infra/BuildInfo.hs b/src/compiler/GF/Infra/BuildInfo.hs index 8fdfe8779..cba57cf2a 100644 --- a/src/compiler/GF/Infra/BuildInfo.hs +++ b/src/compiler/GF/Infra/BuildInfo.hs @@ -16,6 +16,9 @@ buildInfo = #ifdef SERVER_MODE ++" server" #endif +#ifdef NEW_COMP + ++" new-comp" +#endif where details = either (const no_info) info darcs_info no_info = "No detailed version info available" diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 560b5832b..da2b6e5b0 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -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, diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs index fcd97c503..cccbbce39 100644 --- a/src/compiler/GFI.hs +++ b/src/compiler/GFI.hs @@ -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 |