X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fext-core%2FInterp.hs;h=e730012687aa237c7130cf24364c45c183d1c571;hb=8f1192a43e20954c368b466be6af8410a9860d14;hp=1988ae9cf374af2236b8d3dc302520803a1f4b22;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/utils/ext-core/Interp.hs b/utils/ext-core/Interp.hs index 1988ae9..e730012 100644 --- a/utils/ext-core/Interp.hs +++ b/utils/ext-core/Interp.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -XPatternGuards #-} {- Interprets the subset of well-typed Core programs for which (a) All constructor and primop applications are saturated @@ -14,7 +15,7 @@ The only major omission is garbage collection. Just a sampling of primitive types and operators are included. -} -module Interp where +module Interp ( evalProgram ) where import Core import Printer @@ -50,7 +51,7 @@ data PrimValue = -- values of the (unboxed) primitive types -- etc., etc. deriving (Eq,Show) -type Menv = Env Mname Venv -- modules +type Menv = Env AnMname Venv -- modules initialGlobalEnv :: Menv initialGlobalEnv = @@ -60,8 +61,9 @@ initialGlobalEnv = {- Heap management. -} {- Nothing is said about garbage collection. -} -data Heap = Heap Ptr (Env Ptr HeapValue) -- last cell allocated; environment of allocated cells - deriving (Show) +data Heap = Heap Ptr (Env Ptr HeapValue) + -- last cell allocated; environment of allocated cells + deriving Show hallocate :: Heap -> HeapValue -> (Heap,Ptr) hallocate (Heap last contents) v = @@ -137,7 +139,8 @@ evalProgram :: [Module] -> Value evalProgram modules = runE( do globalEnv <- foldM evalModule initialGlobalEnv modules - Vutuple [_,v] <- evalExp globalEnv eempty (App (Var ("Main","main")) (Var (primMname,"realWorldzh"))) + Vutuple [_,v] <- evalExp globalEnv eempty (App (Var mainVar) + (Var (qual primMname "realWorldzh"))) return v) {- Environments: @@ -175,11 +178,10 @@ evalModule globalEnv (Module mn tdefs vdefgs) = evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv) evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),t,e))) = do p <- hallocateE (suspendExp l_env e) - let heaps = - if m == "" then - (e_env,eextend l_env (x,Vheap p)) - else - (eextend e_env (x,Vheap p),l_env) + let heaps = + case m of + Nothing -> (e_env,eextend l_env (x,Vheap p)) + _ -> (eextend e_env (x,Vheap p),l_env) return heaps evalVdef (e_env,l_env) (Rec vdefs) = do l_vs0 <- mapM preallocate l_xs @@ -191,8 +193,8 @@ evalModule globalEnv (Module mn tdefs vdefgs) = let e_env' = foldl eextend e_env (zip e_xs e_vs) return (e_env',l_env') where - (l_xs,l_es) = unzip [(x,e) | Vdef(("",x),_,e) <- vdefs] - (e_xs,e_es) = unzip [(x,e) | Vdef((m,x),_,e) <- vdefs, m /= ""] + (l_xs,l_es) = unzip [(x,e) | Vdef((Nothing,x),_,e) <- vdefs] + (e_xs,e_es) = unzip [(x,e) | Vdef((Just m,x),_,e) <- vdefs] preallocate _ = do p <- hallocateE undefined return (Vheap p) @@ -241,7 +243,7 @@ evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2] {- allocate a thunk -} do p <- hallocateE (Hconstr c vs) return (Vheap p) - evalApp env (op @ (Var(m,p))) es | m == primMname = + evalApp env (op @ (Var(v@(_,p)))) es | isPrimVar v = do vs <- evalExps globalEnv env es case (p,vs) of ("raisezh",[exn]) -> raiseE exn @@ -254,7 +256,7 @@ evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2] evalExternal s vs evalApp env (Appt e _) es = evalApp env e es evalApp env (Lam (Tb _) e) es = evalApp env e es - evalApp env (Coerce _ e) es = evalApp env e es + evalApp env (Cast e _) es = evalApp env e es evalApp env (Note _ e) es = evalApp env e es evalApp env e es = {- e must now evaluate to a closure -} @@ -299,7 +301,7 @@ evalExp globalEnv env (Let vdef e) = do h <- hlookupE p hupdateE p0 h -evalExp globalEnv env (Case e (x,_) alts) = +evalExp globalEnv env (Case e (x,_) _ alts) = do z <- evalExp globalEnv env e let env' = eextend env (x,z) case z of @@ -345,7 +347,7 @@ evalExp globalEnv env (Case e (x,_) alts) = evalDefaultAlt :: Venv -> [Alt] -> Eval Value evalDefaultAlt env [Adefault e] = evalExp globalEnv env e -evalExp globalEnv env (Coerce _ e) = evalExp globalEnv env e +evalExp globalEnv env (Cast e _) = evalExp globalEnv env e evalExp globalEnv env (Note _ e) = evalExp globalEnv env e evalExp globalEnv env (External s t) = evalExternal s [] @@ -361,7 +363,7 @@ suspendExp globalEnv env (Lam (Vb(x,_)) e) = where env' = thin env (delete x (freevarsExp e)) suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e -suspendExp globalEnv env (Coerce _ e) = suspendExp globalEnv env e +suspendExp globalEnv env (Cast e _) = suspendExp globalEnv env e suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e suspendExp globalEnv env (External s _) = evalExternal s [] suspendExp globalEnv env e = @@ -373,11 +375,11 @@ suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value] suspendExps globalEnv env = mapM (suspendExp globalEnv env) mlookup :: Menv -> Venv -> Mname -> Venv -mlookup _ env "" = env -mlookup globalEnv _ m = +mlookup _ env Nothing = env +mlookup globalEnv _ (Just m) = case elookup globalEnv m of Just env' -> env' - Nothing -> error ("undefined module name: " ++ m) + Nothing -> error ("Interp: undefined module name: " ++ show m) qlookup :: Menv -> Venv -> (Mname,Var) -> Value qlookup globalEnv env (m,k) = @@ -399,16 +401,16 @@ evalExternal :: String -> [Value] -> Eval Value evalExternal s vs = error "evalExternal undefined for now" -- etc.,etc. evalLit :: Lit -> PrimValue -evalLit l = +evalLit (Literal l t) = case l of - Lint i (Tcon(_,"Intzh")) -> PIntzh i - Lint i (Tcon(_,"Wordzh")) -> PWordzh i - Lint i (Tcon(_,"Addrzh")) -> PAddrzh i - Lint i (Tcon(_,"Charzh")) -> PCharzh i - Lrational r (Tcon(_,"Floatzh")) -> PFloatzh r - Lrational r (Tcon(_,"Doublezh")) -> PDoublezh r - Lchar c (Tcon(_,"Charzh")) -> PCharzh (toEnum (ord c)) - Lstring s (Tcon(_,"Addrzh")) -> PAddrzh 0 -- should really be address of non-heap copy of C-format string s + Lint i | (Tcon(_,"Intzh")) <- t -> PIntzh i + Lint i | (Tcon(_,"Wordzh")) <- t -> PWordzh i + Lint i | (Tcon(_,"Addrzh")) <- t -> PAddrzh i + Lint i | (Tcon(_,"Charzh"))<- t -> PCharzh i + Lrational r | (Tcon(_,"Floatzh")) <- t -> PFloatzh r + Lrational r | (Tcon(_,"Doublezh")) <- t -> PDoublezh r + Lchar c | (Tcon(_,"Charzh")) <- t -> PCharzh (toEnum (ord c)) + Lstring s | (Tcon(_,"Addrzh")) <- t -> PAddrzh 0 -- should really be address of non-heap copy of C-format string s {- Utilities -} @@ -424,7 +426,7 @@ thin env vars = efilter env (`elem` vars) {- Return the free non-external variables in an expression. -} freevarsExp :: Exp -> [Var] -freevarsExp (Var ("",v)) = [v] +freevarsExp (Var (Nothing,v)) = [v] freevarsExp (Var qv) = [] freevarsExp (Dcon _) = [] freevarsExp (Lit _) = [] @@ -436,12 +438,12 @@ freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs] freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e -freevarsExp (Case e (v,_) as) = freevarsExp e `union` [v] `union` freevarsAlts as +freevarsExp (Case e (v,_) _ as) = freevarsExp e `union` [v] `union` freevarsAlts as where freevarsAlts alts = foldl union [] (map freevarsAlt alts) freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs) freevarsAlt (Alit _ e) = freevarsExp e freevarsAlt (Adefault e) = freevarsExp e -freevarsExp (Coerce _ e) = freevarsExp e +freevarsExp (Cast e _) = freevarsExp e freevarsExp (Note _ e) = freevarsExp e freevarsExp (External _ _) = []