--- /dev/null
+{-# OPTIONS -Wall -fno-warn-name-shadowing -XPatternGuards -fglasgow-exts #-}
+{-
+Interprets the subset of well-typed Core programs for which
+ (a) All constructor and primop applications are saturated
+ (b) All non-trivial expressions of unlifted kind ('#') are
+ scrutinized in a Case expression.
+
+This is by no means a "minimal" interpreter, in the sense that considerably
+simpler machinary could be used to run programs and get the right answers.
+However, it attempts to mirror the intended use of various Core constructs,
+particularly with respect to heap usage. So considerations such as unboxed
+tuples, sharing, trimming, black-holing, etc. are all covered.
+The only major omission is garbage collection.
+
+Just a sampling of primitive types and operators are included.
+-}
+
+module Language.Core.Interp ( evalProgram ) where
+
+import Control.Monad.Error
+import Control.Monad.State
+import Data.Char
+import Data.List
+
+import GHC.Exts hiding (Ptr)
+import System.IO
+
+import Language.Core.Core
+import Language.Core.Env
+import Language.Core.Printer()
+
+data HeapValue =
+ Hconstr Dcon [Value] -- constructed value (note: no qualifier needed!)
+ | Hclos Venv Var Exp -- function closure
+ | Hthunk Venv Exp -- unevaluated thunk
+ deriving (Show)
+
+type Ptr = Int
+
+data Value =
+ Vheap Ptr -- heap pointer (boxed)
+ | Vimm PrimValue -- immediate primitive value (unboxed)
+ | Vutuple [Value] -- unboxed tuples
+ deriving (Show)
+
+instance Error Value where
+ -- TODO: ??
+ strMsg s = error s
+
+type Venv = Env Var Value -- values of vars
+
+data PrimValue = -- values of the (unboxed) primitive types
+ PCharzh Integer -- actually 31-bit unsigned
+ | PIntzh Integer -- actually WORD_SIZE_IN_BITS-bit signed
+ | PWordzh Integer -- actually WORD_SIZE_IN_BITS-bit unsigned
+ | PAddrzh Integer -- actually native pointer size
+ | PFloatzh Rational -- actually 32-bit
+ | PDoublezh Rational -- actually 64-bit
+-- etc., etc.
+ | PString String
+ deriving (Eq,Show)
+
+type Menv = Env AnMname Venv -- modules
+
+initialGlobalEnv :: Menv
+initialGlobalEnv =
+ efromlist
+ [(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]
+
+{- Heap management. -}
+{- Nothing is said about garbage collection. -}
+
+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 =
+ let next = last+1
+ in (Heap next (eextend contents (next,v)),next)
+
+hupdate :: Heap -> Ptr -> HeapValue -> Heap
+hupdate (Heap last contents) p v =
+ Heap last (eextend contents (p,v))
+
+hlookup:: Heap -> Ptr -> HeapValue
+hlookup (Heap _ contents) p =
+ case elookup contents p of
+ Just v -> v
+ Nothing -> error "Missing heap entry (black hole?)"
+
+hremove :: Heap -> Ptr -> Heap
+hremove (Heap last contents) p =
+ Heap last (eremove contents p)
+
+hempty :: Heap
+hempty = Heap 0 eempty
+
+{- The evaluation monad manages the heap and the possiblity
+ of exceptions. -}
+
+type Exn = Value
+
+type Eval a = ErrorT Exn (StateT Heap IO) a
+
+hallocateE :: HeapValue -> Eval Ptr
+hallocateE v = do
+ h <- get
+ let (h', p) = hallocate h v
+ put h'
+ return p
+
+hupdateE :: Ptr -> HeapValue -> Eval ()
+hupdateE p v = modify (\ h -> hupdate h p v)
+
+hlookupE :: Ptr -> Eval HeapValue
+hlookupE p = get >>= (\h -> return (hlookup h p))
+
+hremoveE :: Ptr -> Eval ()
+hremoveE p = modify (\h -> hremove h p)
+
+raiseE :: Exn -> Eval a
+raiseE = throwError
+
+catchE :: Show a => Eval a -> (Exn -> Eval a) -> Eval a
+catchE = catchError
+
+runE :: Eval a -> IO a
+runE m = do
+ resultOrError <- evalStateT (runErrorT m) hempty
+ case resultOrError of
+ Right v -> return v
+ Left exn -> error
+ ("evaluation failed with uncaught exception: " ++ show exn)
+
+{- Main entry point -}
+-- TODO: This is in the IO monad because primitive I/O ops
+-- actually perform the IO. It might be better to model it
+-- instead (by having the interpreter return a ([Char] -> (Value, [Char])))
+evalProgram :: [Module] -> IO Value
+evalProgram modules = runE $ do
+ -- We do two passes: one to slurp in all the definitions *except*
+ -- for :Main.main, and then one to look for the Main module
+ -- and extract out just the :Main.main defn.
+ -- It's kind of annoying.
+ globalEnv' <- foldM evalModule initialGlobalEnv modules
+ globalEnv <- evalModule globalEnv' (rootModule modules)
+ Vutuple [_,v] <- evalExp globalEnv eempty (App (Var wrapperMainVar)
+ stateToken)
+ return v
+
+rootModule :: [Module] -> Module
+-- This looks for the Main module, and constructs
+-- a fake module containing only the defn of
+-- :Main.main.
+rootModule ms =
+ case find (\ (Module mn _ _) -> mn == mainMname) ms of
+ Just (Module _ _ [Rec bs]) ->
+ Module wrapperMainMname []
+ [Rec (filter isWrapperMainVdef bs)]
+ _ -> error "eval: missing main module"
+ where isWrapperMainVdef (Vdef (v,_,_)) | v == wrapperMainVar = True
+ isWrapperMainVdef _ = False
+
+{- Environments:
+
+Evaluating a module just fills an environment with suspensions for all
+the external top-level values; it doesn't actually do any evaluation
+or look anything up.
+
+By the time we actually evaluate an expression, all external values from
+all modules will be in globalEnv. So evaluation just maintains an environment
+of non-external values (top-level or local). In particular, only non-external
+values end up in closures (all other values are accessible from globalEnv.)
+
+Throughout:
+
+- globalEnv contains external values (all top-level) from all modules seen so far.
+
+In evalModule:
+
+- e_venv contains external values (all top-level) seen so far in current module
+- l_venv contains non-external values (top-level or local)
+ seen so far in current module.
+In evalExp:
+
+- env contains non-external values (top-level or local) seen so far
+ in current expression.
+-}
+
+
+evalModule :: Menv -> Module -> Eval Menv
+evalModule globalEnv (Module mn _ vdefgs) =
+ do (e_venv,_) <- foldM evalVdef (eempty,eempty) vdefgs
+ return (eextend globalEnv (mn,e_venv))
+ where
+ evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
+ evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),_,e))) =
+ do p <- hallocateE (suspendExp l_env e)
+ 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
+ let l_env' = foldl eextend l_env (zip l_xs (map Vheap l_vs0))
+ let l_hs = map (suspendExp l_env') l_es
+ mapM_ reallocate (zip l_vs0 l_hs)
+ let e_hs = map (suspendExp l_env') e_es
+ e_vs <- (liftM (map Vheap)) $ mapM allocate e_hs
+ 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((Nothing,x),_,e) <- vdefs]
+ (e_xs,e_es) = unzip [(x,e) | Vdef ((Just _,x),_,e) <-
+ -- Do not dump the defn for :Main.main into
+ -- the environment for Main!
+ filter inHomeModule vdefs]
+ inHomeModule (Vdef ((Just m,_),_,_)) | m == mn = True
+ inHomeModule _ = False
+ preallocate _ =
+ do p <- hallocateE undefined
+ return p
+ reallocate (p0,h) =
+ hupdateE p0 h
+ allocate h =
+ do p <- hallocateE h
+ return p
+
+ suspendExp:: Venv -> Exp -> HeapValue
+ suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
+ where env' = thin env (delete x (freevarsExp e))
+ suspendExp env e = Hthunk env' e
+ where env' = thin env (freevarsExp e)
+
+evalExp :: Menv -> Venv -> Exp -> Eval Value
+evalExp globalEnv env = eval
+ where eval (Var qv) =
+ let v = qlookup globalEnv env qv
+ in case v of
+ Vheap p -> do
+ z <- hlookupE p -- can fail due to black-holing
+ case z of
+ Hthunk env' e -> do
+ hremoveE p -- black-hole
+ w <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
+ case w of
+ Vheap p' -> do
+ h <- hlookupE p'
+ hupdateE p h
+ return w
+ _ -> error ("eval: w was not boxed: " ++ show w)
+ _ -> return v -- return pointer to Hclos or Hconstr
+ _ -> return v -- return Vimm or Vutuple
+ eval (Lit l) = return (Vimm (evalLit l))
+ eval (Dcon (_,c)) = do
+ p <- hallocateE (Hconstr c [])
+ return (Vheap p)
+ eval (App e1 e2) =
+ evalApp env e1 [e2]
+ where
+ evalApp :: Venv -> Exp -> [Exp] -> Eval Value
+ evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
+ evalApp env (Dcon (qdc@(_,c))) es =
+ do vs <- suspendExps globalEnv env es
+ if isUtupleDc qdc
+ then
+ return (Vutuple vs)
+ else
+ {- allocate a thunk -}
+ do p <- hallocateE (Hconstr c vs)
+ return (Vheap p)
+ evalApp env (Var(v@(_,p))) es | isPrimVar v =
+ do vs <- evalExps globalEnv env es
+ case (p,vs) of
+ ("raisezh",[exn]) -> raiseE exn
+ ("catchzh",[body,handler,rws]) ->
+ catchE (apply body [rws])
+ (\exn -> apply handler [exn,rws])
+ _ -> evalPrimop p vs
+ evalApp env (External s _) es =
+ do vs <- evalExps globalEnv env es
+ evalExternal s vs
+ evalApp env (Appt e _) es = evalApp env e es
+ evalApp env (Lam (Tb _) 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 -}
+ do vs <- suspendExps globalEnv env es
+ vop <- evalExp globalEnv env e
+ apply vop vs
+
+ apply :: Value -> [Value] -> Eval Value
+ apply vop [] = return vop
+ apply (Vheap p) (v:vs) =
+ do Hclos env' x b <- hlookupE p
+ v' <- evalExp globalEnv (eextend env' (x,v)) b
+ apply v' vs
+ apply _ _ = error ("apply: operator is not a closure")
+
+ eval (Appt e _) = evalExp globalEnv env e
+ eval (Lam (Vb(x,_)) e) = do
+ p <- hallocateE (Hclos env' x e)
+ return (Vheap p)
+ where env' = thin env (delete x (freevarsExp e))
+ eval (Lam _ e) = evalExp globalEnv env e
+ eval (Let vdef e) =
+ do env' <- evalVdef globalEnv env vdef
+ evalExp globalEnv env' e
+ where
+ evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
+ evalVdef globalEnv env (Nonrec(Vdef((_,x),_,e))) =
+ do v <- suspendExp globalEnv env e
+ return (eextend env (x,v))
+ evalVdef globalEnv env (Rec vdefs) =
+ do vs0 <- mapM preallocate xs
+ let env' = foldl eextend env (zip xs (map Vheap vs0))
+ vs <- suspendExps globalEnv env' es
+ mapM_ reallocate (zip vs0 vs)
+ return env'
+ where
+ (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
+ preallocate _ =
+ do p <- hallocateE (Hconstr "UGH" [])
+ return p
+ reallocate (p0,Vheap p) =
+ do h <- hlookupE p
+ hupdateE p0 h
+ reallocate (_,_) = error "reallocate: expected a heap value"
+ eval (Case e (x,_) _ alts) =
+ do z <- evalExp globalEnv env e
+ let env' = eextend env (x,z)
+ case z of
+ Vheap p -> do
+ h <- hlookupE p -- can fail due to black-holing
+ case h of
+ Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
+ _ -> evalDefaultAlt env' alts
+ Vutuple vs ->
+ evalUtupleAlt env' vs (reverse alts)
+ Vimm pv ->
+ evalLitAlt env' pv (reverse alts)
+ where
+ evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
+ evalDcAlt env dcon vs = f
+ where
+ f ((Acon (_,dcon') _ xs e):as) =
+ if dcon == dcon' then
+ evalExp globalEnv
+ (foldl eextend env (zip (map fst xs) vs)) e
+ else f as
+ f [Adefault e] =
+ evalExp globalEnv env e
+ f _ = error $ "impossible Case-evalDcAlt"
+
+ evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
+ evalUtupleAlt env vs [Acon _ _ xs e] =
+ evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
+ evalUtupleAlt _ _ _ = error ("impossible Case: evalUtupleAlt")
+
+ evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
+ evalLitAlt env pv alts =
+ f alts
+ where
+ f ((Alit lit e):as) =
+ let pv' = evalLit lit
+ in if pv == pv' then
+ evalExp globalEnv env e
+ else f as
+ f [Adefault e] =
+ evalExp globalEnv env e
+ f _ = error "impossible Case-evalLitAlt"
+
+ evalDefaultAlt :: Venv -> [Alt] -> Eval Value
+ evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
+ evalDefaultAlt _ _ = error "evalDefaultAlt: impossible case"
+
+ eval (Cast e _) = evalExp globalEnv env e
+ eval (Note _ e) = evalExp globalEnv env e
+ eval (External s _) = evalExternal s []
+
+evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
+evalExps globalEnv env = mapM (evalExp globalEnv env)
+
+suspendExp:: Menv -> Venv -> Exp -> Eval Value
+suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
+suspendExp _ _ (Lit l) = return (Vimm (evalLit l))
+suspendExp _ env (Lam (Vb(x,_)) e) =
+ do p <- hallocateE (Hclos env' x e)
+ return (Vheap p)
+ 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 (Cast e _) = suspendExp globalEnv env e
+suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
+suspendExp _ _ (External s _) = evalExternal s []
+suspendExp _ env e =
+ do p <- hallocateE (Hthunk env' e)
+ return (Vheap p)
+ where env' = thin env (freevarsExp e)
+
+suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
+suspendExps globalEnv env = mapM (suspendExp globalEnv env)
+
+mlookup :: Menv -> Venv -> Mname -> Venv
+mlookup _ env Nothing = env
+mlookup globalEnv _ (Just m) =
+ case elookup globalEnv m of
+ Just env' -> env'
+ Nothing -> error ("Interp: undefined module name: " ++ show m)
+
+qlookup :: Menv -> Venv -> (Mname,Var) -> Value
+qlookup globalEnv env (m,k) =
+ case elookup (mlookup globalEnv env m) k of
+ Just v -> v
+ Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
+
+evalPrimop :: Var -> [Value] -> Eval Value
+evalPrimop "zpzh" = primIntBinop (+)
+evalPrimop "zpzhzh" = primDoubleBinop (+)
+evalPrimop "zmzh" = primIntBinop (-)
+evalPrimop "zmzhzh" = primDoubleBinop (-)
+evalPrimop "ztzh" = primIntBinop (*)
+evalPrimop "ztzhzh" = primDoubleBinop (*)
+evalPrimop "zgzh" = primIntCmpOp (>)
+evalPrimop "zlzh" = primIntCmpOp (<)
+evalPrimop "zlzhzh" = primDoubleCmpOp (<)
+evalPrimop "zezezh" = primIntCmpOp (==)
+evalPrimop "zlzezh" = primIntCmpOp (<=)
+evalPrimop "zlzezhzh" = primDoubleCmpOp (<=)
+evalPrimop "zgzezh" = primIntCmpOp (>=)
+evalPrimop "zszezh" = primIntCmpOp (/=)
+evalPrimop "zszhzh" = primDoubleCmpOp (/=)
+evalPrimop "negateIntzh" = primIntUnop (\ i -> -i)
+evalPrimop "quotIntzh" = primIntBinop quot
+evalPrimop "remIntzh" = primIntBinop rem
+evalPrimop "subIntCzh" = primSubIntC
+evalPrimop "addIntCzh" = primAddIntC
+evalPrimop "mulIntMayOflozh" = primIntBinop
+ (\ i j ->
+ case (fromIntegral i, fromIntegral j) of
+ (I# x, I# y) ->
+ case x `mulIntMayOflo#` y of
+ k -> fromIntegral (I# k))
+evalPrimop "narrow32Intzh" = primIntUnop
+ (\ i ->
+ case fromIntegral i of
+ (I# j) -> case narrow32Int# j of
+ k -> fromIntegral (I# k))
+evalPrimop "int2Doublezh" = primInt2Double
+-- single-threaded, so, it's a no-op
+--evalPrimop "noDuplicatezh" [state] = return state
+evalPrimop "indexCharOffAddrzh" = primIndexChar
+evalPrimop "eqCharzh" = primCharCmpOp (==)
+evalPrimop "leCharzh" = primCharCmpOp (<)
+evalPrimop "ordzh" = primOrd
+evalPrimop "chrzh" = primChr
+evalPrimop "isSpacezh" = primCharUnop isSpace
+evalPrimop "isAlphazh" = primCharUnop isAlpha
+evalPrimop "hPutCharzh" = primHPutChar
+-- etc.
+evalPrimop p = error ("undefined primop: " ++ p)
+
+primIntUnop :: (Integer -> Integer) -> [Value] -> Eval Value
+primIntUnop op [Vimm (PIntzh i)] = return (Vimm (PIntzh (op i)))
+primIntUnop _ _ = error "primIntUnop: wrong number of arguments"
+
+primIntBinop :: (Integer -> Integer -> Integer) -> [Value] -> Eval Value
+primIntBinop op [Vimm (PIntzh i), Vimm (PIntzh j)] =
+ return (Vimm (PIntzh (i `op` j)))
+primIntBinop _ _ = error "primIntBinop: wrong number of arguments"
+
+primDoubleBinop :: (Rational -> Rational -> Rational) -> [Value] -> Eval Value
+primDoubleBinop op [Vimm (PDoublezh i), Vimm (PDoublezh j)] =
+ return (Vimm (PDoublezh (i `op` j)))
+primDoubleBinop _ _ = error "primDoubleBinop: wrong number of arguments"
+
+primIntCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
+primIntCmpOp op [Vimm (PIntzh i), Vimm (PIntzh j)] = mkBool (i `op` j)
+primIntCmpOp _ _ = error "primIntCmpOp: wrong number of arguments"
+
+primDoubleCmpOp :: (Rational -> Rational -> Bool) -> [Value] -> Eval Value
+primDoubleCmpOp op [Vimm (PDoublezh i), Vimm (PDoublezh j)] = mkBool (i `op` j)
+primDoubleCmpOp _ _ = error "primDoubleCmpOp: wrong number of arguments"
+
+primCharCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
+primCharCmpOp op [Vimm (PCharzh c), Vimm (PCharzh d)] = mkBool (c `op` d)
+primCharCmpOp _ _ = error "primCharCmpOp: wrong number of arguments"
+
+primSubIntC :: [Value] -> Eval Value
+primSubIntC vs = carryOp subIntC# vs
+
+primAddIntC :: [Value] -> Eval Value
+primAddIntC vs = carryOp addIntC# vs
+
+carryOp :: (Int# -> Int# -> (# Int#, Int# #)) -> [Value] -> Eval Value
+carryOp op [Vimm (PIntzh i1), Vimm (PIntzh i2)] =
+ case (fromIntegral i1, fromIntegral i2) of
+ (I# int1, I# int2) ->
+ case (int1 `op` int2) of
+ (# res1, res2 #) ->
+ return $ Vutuple [Vimm (PIntzh (fromIntegral (I# res1))),
+ Vimm (PIntzh (fromIntegral (I# res2)))]
+carryOp _ _ = error "carryOp: wrong number of arguments"
+
+primInt2Double :: [Value] -> Eval Value
+primInt2Double [Vimm (PIntzh i)] =
+ return (Vimm (PDoublezh (fromIntegral i)))
+primInt2Double _ = error "primInt2Double: wrong number of arguments"
+
+primOrd :: [Value] -> Eval Value
+primOrd [Vimm (PCharzh c)] = return $ Vimm (PIntzh c)
+primOrd _ = error "primOrd: wrong number of arguments"
+
+primChr :: [Value] -> Eval Value
+primChr [Vimm (PIntzh c)] = return $ Vimm (PCharzh c)
+primChr _ = error "primChr: wrong number of arguments"
+
+primCharUnop :: (Char -> Bool) -> [Value] -> Eval Value
+primCharUnop op [Vimm (PCharzh c)] = mkBool (op (chr (fromIntegral c)))
+primCharUnop _ _ = error "primCharUnop: wrong number of arguments"
+
+primIndexChar :: [Value] -> Eval Value
+primIndexChar [(Vimm (PString s)), (Vimm (PIntzh i))] =
+ -- String is supposed to be null-terminated, so if i == length(s),
+ -- we return null. (If i > length(s), emit nasal demons.)
+ return $ let len = fromIntegral $ length s in
+ if i < len
+ then Vimm (PCharzh (fromIntegral (ord (s !! fromIntegral i))))
+ else if i == len
+ then Vimm (PCharzh 0)
+ else error "indexCharOffAddr#: index too large"
+primIndexChar _ = error "primIndexChar: wrong number of arguments"
+
+primHPutChar :: [Value] -> Eval Value
+primHPutChar [Vimm (PIntzh hdl), Vimm (PCharzh c)] =
+ liftIO (hPutChar
+ (if hdl == 0
+ then stdin
+ else if hdl == 1
+ then stdout
+ else -- lol
+ stderr) (chr (fromIntegral c))) >>
+ returnUnit
+primHPutChar _ = error "primHPutChar: wrong number of arguments"
+
+evalExternal :: String -> [Value] -> Eval Value
+-- etc.
+evalExternal s _ = error $ "evalExternal undefined for now: " ++ show s -- etc.,etc.
+
+returnUnit :: Eval Value
+returnUnit = do
+ p <- hallocateE (Hclos eempty "_"
+ (App (App (Dcon (dcUtuple 2)) stateToken) unitCon))
+ return $ Vheap p
+
+evalLit :: Lit -> PrimValue
+evalLit (Literal l t) =
+ case l of
+ 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 -> PString s
+ -- should really be address of non-heap copy of C-format string s
+ -- tjc: I am ignoring this comment
+ _ -> error ("evalLit: strange combination of literal "
+ ++ show l ++ " and type " ++ show t)
+
+{- Utilities -}
+
+mkBool :: Bool -> Eval Value
+mkBool True =
+ do p <- hallocateE (Hconstr "True" [])
+ return (Vheap p)
+mkBool False =
+ do p <- hallocateE (Hconstr "False" [])
+ return (Vheap p)
+
+thin :: Ord a => Env a b -> [a] -> Env a b
+thin env vars = efilter env (`elem` vars)
+
+{- Return the free non-external variables in an expression. -}
+
+freevarsExp :: Exp -> [Var]
+freevarsExp (Var (Nothing,v)) = [v]
+freevarsExp (Var _) = []
+freevarsExp (Dcon _) = []
+freevarsExp (Lit _) = []
+freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
+freevarsExp (Appt e _) = freevarsExp e
+freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
+freevarsExp (Lam _ e) = freevarsExp e
+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
+ 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 (Cast e _) = freevarsExp e
+freevarsExp (Note _ e) = freevarsExp e
+freevarsExp (External _ _) = []
+
+stateToken :: Exp
+stateToken = Var (qual primMname "realWorldzh")
+
+unitCon :: Exp
+unitCon = Dcon (qual baseMname "Z0T")
projects / ghc-hetmet.git / blobdiff