module Language.Core.Interp ( evalProgram ) where
import Control.Monad.Error
import Control.Monad.State
import Data.Char
import Data.List
import qualified Data.Map as M
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]
| Hclos Venv Var Exp
| Hthunk Venv Exp
deriving (Show)
type Ptr = Int
data Value =
Vheap Ptr
| Vimm PrimValue
| Vutuple [Value]
deriving (Show)
instance Error Value where
strMsg s = error s
type Venv = M.Map Var Value
data PrimValue =
PCharzh Integer
| PIntzh Integer
| PWordzh Integer
| PAddrzh Integer
| PFloatzh Rational
| PDoublezh Rational
| PString String
deriving (Eq,Show)
type Menv = M.Map AnMname Venv
initialGlobalEnv :: Menv
initialGlobalEnv =
efromlist
[(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]
data Heap = Heap Ptr (M.Map Ptr HeapValue)
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
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)
evalProgram :: [Module] -> IO Value
evalProgram modules = runE $ do
globalEnv' <- foldM evalModule initialGlobalEnv modules
globalEnv <- evalModule globalEnv' (rootModule modules)
Vutuple [_,v] <- evalExp globalEnv eempty (App (Var mainVar)
stateToken)
return v
rootModule :: [Module] -> Module
rootModule ms = case ms of
[] -> error "eval: you didn't give me any modules!"
(m:_) -> m
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) <-
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
case z of
Hthunk env' e -> do
hremoveE p
w <- evalExp globalEnv env' e
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 v
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
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 =
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
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
evalPrimop "indexCharOffAddrzh" = primIndexChar
evalPrimop "eqCharzh" = primCharCmpOp (==)
evalPrimop "leCharzh" = primCharCmpOp (<)
evalPrimop "ordzh" = primOrd
evalPrimop "chrzh" = primChr
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"
primIndexChar :: [Value] -> Eval Value
primIndexChar [(Vimm (PString s)), (Vimm (PIntzh i))] =
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"
evalExternal :: String -> [Value] -> Eval Value
evalExternal "extcore_hPutChar" [Vimm (PCharzh i), _] =
liftIO (hPutChar stdout (chr (fromIntegral i))) >>
returnOneTupleState
evalExternal s vs = error $ "evalExternal undefined for now: " ++ show s ++ " and " ++ show vs
returnOneTupleState :: Eval Value
returnOneTupleState = do
p <- hallocateE (Hconstr (snd (dcUtuple 1)) [Vimm (PIntzh 0)])
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
_ -> error ("evalLit: strange combination of literal "
++ show l ++ " and type " ++ show t)
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 => M.Map a b -> [a] -> M.Map a b
thin env vars = efilter env (`elem` vars)
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")