FlexibleContexts extension is required 7.10. Add this to play nice with 7.10.
[packages/hoopl.git] / testing / Eval.hs
1 {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2 {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts #-}
3
4 module Eval (evalProg, ErrorM) where
5
6 import Control.Monad.Error
7 import qualified Data.Map as M
8 import Prelude hiding (succ)
9
10 import EvalMonad
11 import Compiler.Hoopl
12 import IR
13
14 -- Evaluation functions
15 evalProg :: EvalTarget v => [Proc] -> [v] -> String -> [v] -> ErrorM (State v, [v])
16 evalProg procs vs main args = runProg procs vs $ evalProc main args
17
18 evalProc :: EvalTarget v => String -> [v] -> EvalM v [v]
19 evalProc proc_name actuals =
20 do event $ CallEvt proc_name actuals
21 proc <- get_proc proc_name
22 evalProc' proc actuals
23 evalProc' :: EvalTarget v => Proc -> [v] -> EvalM v [v]
24 evalProc' (Proc {name=_, args, body, entry}) actuals =
25 if length args == length actuals then
26 evalBody (M.fromList $ zip args actuals) body entry
27 else throwError $ "Param/actual mismatch: " ++ show args ++ " = " ++ show actuals
28
29 -- Responsible for allocating and deallocating its own stack frame.
30 evalBody :: EvalTarget v => VarEnv v -> Graph Insn C C -> Label -> EvalM v [v]
31 evalBody vars graph entry = inNewFrame vars graph $ get_block entry >>= evalB
32
33 evalB :: forall v . EvalTarget v => Block Insn C C -> EvalM v [v]
34 evalB b = foldBlockNodesF3 (lift evalF, lift evalM, lift evalL) b $ return ()
35 where
36 lift :: forall e x y . (Insn e x -> EvalM v y) -> Insn e x -> EvalM v () -> EvalM v y
37 lift f n z = z >> f n
38
39
40 evalF :: EvalTarget v => Insn C O -> EvalM v ()
41 evalF (Label _) = return ()
42
43 evalM :: EvalTarget v => Insn O O -> EvalM v ()
44 evalM (Assign var e) =
45 do v_e <- eval e
46 set_var var v_e
47 evalM (Store addr e) =
48 do v_addr <- eval addr >>= toAddr
49 v_e <- eval e
50 -- StoreEvt recorded in set_heap
51 set_heap v_addr v_e
52
53 evalL :: EvalTarget v => Insn O C -> EvalM v [v]
54 evalL (Branch bid) =
55 do b <- get_block bid
56 evalB b
57 evalL (Cond e t f) =
58 do v_e <- eval e >>= toBool
59 evalL $ Branch $ if v_e then t else f
60 evalL (Call ress f args succ) =
61 do v_args <- mapM eval args
62 -- event is recorded in evalProc
63 f_ress <- evalProc f v_args
64 if length ress == length f_ress then return ()
65 else throwError $ "function " ++ f ++ " returned unexpected # of args"
66 _ <- mapM (uncurry set_var) $ zip ress f_ress
67 evalL $ Branch succ
68 evalL (Return es) =
69 do vs <- mapM eval es
70 event $ RetEvt vs
71 return vs
72
73 class Show v => EvalTarget v where
74 toAddr :: v -> EvalM v Integer
75 toBool :: v -> EvalM v Bool
76 eval :: Expr -> EvalM v v
77
78 instance EvalTarget Value where
79 toAddr (I i) = return i
80 toAddr (B _) = throwError "conversion to address failed"
81 toBool (B b) = return b
82 toBool (I _) = throwError "conversion to bool failed"
83 eval (Lit (Int i)) = return $ I i
84 eval (Lit (Bool b)) = return $ B b
85 eval (Var var) = get_var var
86 eval (Load addr) =
87 do v_addr <- eval addr >>= toAddr
88 get_heap v_addr
89 eval (Binop bop e1 e2) =
90 do v1 <- eval e1
91 v2 <- eval e2
92 liftBinOp bop v1 v2
93 where
94 liftBinOp = liftOp
95 where liftOp Add = i (+)
96 liftOp Sub = i (-)
97 liftOp Mul = i (*)
98 liftOp Div = i div
99 liftOp Eq = b (==)
100 liftOp Ne = b (/=)
101 liftOp Gt = b (>)
102 liftOp Lt = b (<)
103 liftOp Gte = b (>=)
104 liftOp Lte = b (<=)
105 i = liftX I fromI
106 b = liftX B fromB
107
108 liftX :: Monad m => (a -> b) -> (b -> m a) -> (a -> a -> a) -> b -> b -> m b
109 liftX up dwn = \ op x y -> do v_x <- dwn x
110 v_y <- dwn y
111 return $ up $ op v_x v_y
112 fromI (I x) = return x
113 fromI (B _) = throwError "fromI: got a B"
114
115 fromB (I _) = throwError "fromB: got an I"
116 fromB (B x) = return x
117
118 -- I'm under no delusion that the following example is useful,
119 -- but it demonstrates how the evaluator can use a new kind
120 -- of evaluator.
121 instance EvalTarget Integer where
122 toAddr i = return i
123 toBool i = return $ i /= 0
124 eval (Lit (Int i)) = return i
125 eval (Lit (Bool True)) = return 1
126 eval (Lit (Bool False)) = return 0
127 eval (Var var) = get_var var
128 eval (Load addr) =
129 do v_addr <- eval addr >>= toAddr
130 get_heap v_addr
131 eval (Binop bop e1 e2) =
132 do v1 <- eval e1
133 v2 <- eval e2
134 return $ liftBinOp bop v1 v2
135 where
136 liftBinOp = liftOp
137 where liftOp Add = i (+)
138 liftOp Sub = i (-)
139 liftOp Mul = i (*)
140 liftOp Div = i div
141 liftOp Eq = b (==)
142 liftOp Ne = b (/=)
143 liftOp Gt = b (>)
144 liftOp Lt = b (<)
145 liftOp Gte = b (>=)
146 liftOp Lte = b (<=)
147 i = id
148 b opr x y = if opr x y then 1 else 0
149
150
151 -- Symbolic evaluation.
152 -- Hard questions:
153 -- - how do we get heap addresses?
154 -- - how do we get conditionals?
155 -- - how do we compare symbolic expressions?
156 data Sym = L Lit
157 | In Integer -- In x indicates a value on entry to the program
158 | Ld Sym
159 | BO BinOp Sym Sym
160 deriving Show
161 -- sym_vsupply :: [Sym]
162 -- sym_vsupply = [In n | n <- [0..]]
163
164 instance EvalTarget Sym where
165 toAddr _ = undefined
166 toBool _ = undefined
167 eval (Lit l) = return $ L l
168 eval (Var var) = get_var var
169 eval (Load addr) =
170 do v_addr <- eval addr >>= toAddr
171 get_heap v_addr
172 eval (Binop bop e1 e2) =
173 do v1 <- eval e1
174 v2 <- eval e2
175 return $ BO bop v1 v2