ajhc-0.8.0.1: src/Grin/Interpret.hs
module Grin.Interpret(evaluate) where
import C.Prims
import Char
import CharIO
import Control.Monad.Identity
import Data.IORef
import Data.Map as Map hiding(map)
import Data.Monoid
import Doc.DocLike
import Doc.Pretty
import GenUtil hiding(putErrLn,putErr)
import Grin.Grin
import Grin.Show
import Name.VConsts
import Options
import StringTable.Atom
import Support.CanType
import qualified FlagDump as FD
import qualified Stats
type Builtin = [Val] -> IO Val
builtins = []
builtinMap = Map.fromList [ (x,y) | (x,y) <- builtins ]
createCafMap as = f vars [] >>= return . Map.fromList where
f [] xs = return xs
f ((x,y):xs) ys = newIORef y >>= \y -> f xs ((x,Addr y):ys)
vars = as
evaluate :: Grin -> IO (Val,Stats.Stats)
evaluate Grin { grinTypeEnv = tyEnv, grinFunctions = ts, grinCafs = cafs } = do
stats <- Stats.new
cafMap <- createCafMap cafs
let f x = interpret stats tyEnv cafMap builtinMap (fromList ts) x
g (App t [l@Lit {}] _) | t == funcEval = return l
g (App t [Const n] _) | t == funcEval = return n
g e = f e >>= \x -> case x of
NodeC t xs -> do
xs <- mapM (g . gEval) xs
return $ NodeC t xs
z -> return z
v <- g (App funcMain [] tyUnit)
return (v,stats)
funcCalls = toAtom "Function Calls"
primCalls = toAtom "Primitive Calls"
prettyEnv env = vcat [ text ('v':show x) <+> text "->" <+> prettyVal y | (V x,y) <- Map.toList env ]
interpret :: Stats.Stats -> TyEnv -> Map Var Val -> Map Atom Builtin -> Map Atom Lam -> Exp -> IO Val
interpret stats te cafMap primMap scMap e = f mempty e where
f :: Map Var Val -> Exp -> IO Val
f env (e1 :>>= (v :-> e2)) = do
r <- f env e1
be <- bind v r
f (be `mappend` env) e2
f env (App a xs ty) = do
wdump FD.Steps $ do
putErrLn $ render (prettyExp mempty $ App a xs' ty)
Stats.tick stats funcCalls
Stats.tick stats (toAtom $ "Function." ++ fromAtom a)
case Map.lookup a scMap of
Nothing -> error $ "Unknown App: " ++ show (App a xs' ty)
Just ((Tup as :-> e)) -> f (Map.fromList (zip [ v | Var v _ <- as] xs')) e
where xs' = map (le env) xs
f env (Prim Primitive { primAPrim = APrim CCast {} _, primType = (_,t)} [x]) = return $ (Lit n t)
where (Lit n _) = le env x
f env (Prim Primitive { primAPrim = APrim Func { funcName = "putwchar" } _} [x]) = putChar (chr $ fromIntegral n) >> return unit
where (Lit n _) = le env x
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "<=" } _, primType = (_,t)} [x,y]) = if x' <= y' then return (Lit 1 t) else return (Lit 0 t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = ">=" } _, primType = (_,t)} [x,y]) = if x' >= y' then return (Lit 1 t) else return (Lit 0 t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = ">" } _, primType = (_,t)} [x,y]) = if x' > y' then return (Lit 1 t) else return (Lit 0 t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "<" } _, primType = (_,t)} [x,y]) = if x' < y' then return (Lit 1 t) else return (Lit 0 t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "==" } _, primType = (_,t)} [x,y]) = if x' == y' then return (Lit 1 t) else return (Lit 0 t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "+" } _, primType = (_,t)} [x,y]) = return (Lit (x' + y') t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "/" } _, primType = (_,t)} [x,y]) = return (Lit (x' `div` y') t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "%" } _, primType = (_,t)} [x,y]) = return (Lit (x' `mod` y') t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "-" } _, primType = (_,t)} [x,y]) = return (Lit (x' - y') t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "*" } _, primType = (_,t)} [x,y]) = return (Lit (x' * y') t)
where (Lit x' _) = le env x
(Lit y' _) = le env y
f env (Prim Primitive { primAPrim = APrim Operator { primOp = "-" } _, primType = (_,t)} [x]) = return (Lit (negate x') t)
where (Lit x' _) = le env x
f env (Prim p xs) = do
let a = primName p
xs' = map (le env) xs
wdump FD.Steps $ do
putErrLn $ render (prettyExp mempty $ Prim p xs')
Stats.tick stats primCalls
Stats.tick stats (toAtom $ "Primitive." ++ fromAtom a)
case Map.lookup a primMap of
Nothing -> error $ "Unknown Primitive: " ++ show (Prim p xs')
Just action -> do action xs'
f env (Return v) = return (le env v)
f env (Store v) = do
Stats.tick stats (toAtom "Allocations Performed")
fmap Addr $ newIORef (le env v)
f env (Fetch x)
| (Addr x) <- le env x = readIORef x
| (Const x) <- le env x = return x
f env (Update x v) | (Addr x) <- le env x = do
Stats.tick stats (toAtom "Updates Performed")
(writeIORef x $! (le env v)) >> return unit
f env (Update x v) | (Const x) <- le env x, x == le env v = return unit
f env (Update x v) = fail $ "Bad update: " ++ show (le env x,le env v)
f env (Error s t) = fail $ render $ tshow (s,t) <$> (prettyEnv env)
-- f env (Eval x)
-- | otherwise = f env $ App funcEval [x]
-- | Const x <- lx = doEval x
-- | (Addr ref) <- lx = do
-- v <- readIORef ref
-- nv <- doEval v
-- writeIORef ref nv
-- return nv
-- where
-- lx = le env x
-- f env (Apply x y)
-- | True = f env $ App funcApply [x,y]
-- | False = doApply (le env x) (le env y)
f env (Case v ps) = match (le env v) ps where
match s ((p :-> e):ps) = case bind p s of
Nothing -> match s ps
Just env' -> f (env' `mappend` env) e
match e [] = fail $ "end of match: " ++ show e <+> show env
f env z = fail $ "cannot interpret: " ++ show (toList env,z)
le env (Tup vs) = Tup (map (le env) vs)
le env (NodeC t vs) = NodeC t (map (le env) vs)
le env z@(NodeV t vs) = NodeC (lt t) (map (le env) vs) where
lt x = case Map.lookup x env of
Just (Tag t) -> t
z' -> error $ "Invalid tag variable in NodeV: " ++ show (z,z')
le env z@(Var v _) = case Map.lookup v env `mplus` Map.lookup v cafMap of
Just x -> le env x
Nothing -> error $ "le" ++ show (z,env)
le _ x = x
doApply (NodeC t xs) y
| n == (1::Int) = f mempty (App (toAtom $ 'f':rs) (xs ++ [y]) TyNode) -- TODO, right?
| n > 1 = return $ NodeC (toAtom $ 'P':show (n - 1) ++ "_" ++ rs) (xs ++ [y])
where
('P':cs) = fromAtom t
(n','_':rs) = span isDigit cs
n = read n'
doApply x y = error $ "doApply " ++ show (x,y)
doEval x@(NodeC t xs)
| 'P':_ <- t' = return x
| 'T':_ <- t' = return x
| 'C':_ <- t' = return x
| 'F':rs <- t' = f mempty (App (toAtom $ 'f':rs) xs TyNode) -- TODO, right?
| 'B':rs <- t' = f mempty (App (toAtom $ 'b':rs) xs TyNode) -- TODO, right?
where
t' = fromAtom t
doEval x = error $ "doEval " ++ show x
bind :: Monad m => Val -> Val -> m (Map Var Val)
bind (Var (V 0) _) _ = return mempty
bind (Var v _) r = return $ singleton v r
bind (Lit i _) (Lit i' _) | i == i' = return mempty
bind (Tup xs) (Tup ys) = liftM mconcat $ sequence $ zipWith bind xs ys
bind (Tag i) (Tag i') | i == i' = return mempty
bind (NodeV v vs) (NodeC t vs') = do
be <- liftM mconcat $ sequence $ zipWith bind vs vs'
return (be `mappend` singleton v (Tag t))
bind (NodeC t vs) (NodeC t' vs') | t == t' = do
liftM mconcat $ sequence $ zipWith bind vs vs'
bind v r | getType v == getType r = fail $ "unbindable: " ++ show (v,r,getType v,getType r) -- check type to be sure
bind x y = error $ "bad bind: " ++ show (x,y)