64d9ecf548b2d37e5fa0a38a099f033ed26e6e07
[packages/hoopl.git] / testing / EvalMonad.hs
1 {-# OPTIONS_GHC -Wall #-}
2 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
3
4 module EvalMonad (ErrorM, VarEnv, B, State,
5 EvalM, runProg, inNewFrame, get_proc, get_block,
6 get_var, set_var, get_heap, set_heap,
7 Event (..), event) where
8
9 import Control.Monad.Error
10 import qualified Data.Map as M
11 import Prelude hiding (succ)
12
13 #if CABAL
14 #if !MIN_VERSION_base(4,8,0)
15 import Control.Applicative (Applicative(..))
16 #endif
17 #else
18 import Control.Applicative (Applicative(..))
19 #endif
20
21 import Compiler.Hoopl hiding ((<*>))
22 import IR
23
24 type ErrorM = Either String
25 type InnerErrorM v = Either (State v, String)
26 instance Error (State v, String) where
27 noMsg = (undefined, "")
28 strMsg str = (undefined, str)
29
30 data EvalM v a = EvalM (State v -> InnerErrorM v (State v, a))
31
32 instance Monad (EvalM v) where
33 return x = EvalM (\s -> return (s, x))
34 EvalM f >>= k = EvalM $ \s -> do (s', x) <- f s
35 let EvalM f' = k x
36 f' s'
37
38 instance Functor (EvalM v) where
39 fmap = liftM
40
41 instance Applicative (EvalM v) where
42 pure = return
43 (<*>) = ap
44
45
46 instance MonadError String (EvalM v) where
47 throwError e = EvalM (\s -> throwError (s, e))
48 catchError (EvalM f) handler =
49 EvalM $ \s -> f s `catchError` handler'
50 where handler' (s', e) = let EvalM f' = handler e
51 in f' s'
52
53 -- Shorthands for frequently used types
54 type VarEnv v = M.Map Var v
55 type HeapEnv v = M.Map Addr v -- word addressed heap
56 type Addr = Integer
57 type B = Block Insn C C
58 type PEnv = M.Map String Proc
59 type G = Graph Insn C C
60
61 runProg :: [Proc] -> [v] -> EvalM v x -> ErrorM (State v, x)
62 runProg procs vs (EvalM f) =
63 case f init_state of
64 Left (_, e) -> throwError e
65 Right x -> return x
66 where
67 init_state = State { frames = [], heap = M.empty, events = [],
68 vsupply = vs, procs = procMap }
69 procMap = M.fromList $ zip (map name procs) procs
70
71 get_state :: EvalM v (State v)
72 get_state = EvalM f
73 where f state = return (state, state)
74
75 upd_state :: (State v -> State v) -> EvalM v ()
76 upd_state upd = EvalM (\state -> return (upd state, ()))
77
78 event :: Event v -> EvalM v ()
79 event e = upd_state (\s -> s {events = e : events s})
80
81 ----------------------------------
82 -- State of the machine
83 data State v = State { frames :: [(VarEnv v, G)]
84 , heap :: HeapEnv v
85 , procs :: PEnv
86 , vsupply :: [v]
87 , events :: [Event v]
88 }
89 data Event v = CallEvt String [v]
90 | RetEvt [v]
91 | StoreEvt Addr v
92 | ReadEvt Addr v
93
94 get_var :: Var -> EvalM v v
95 get_var var = get_state >>= k
96 where k (State {frames = (vars, _):_}) = mlookup "var" var vars
97 k _ = throwError "can't get vars from empty stack"
98
99 set_var :: Var -> v -> EvalM v ()
100 set_var var val = upd_state f
101 where f s@(State {frames = (vars, blocks):vs}) =
102 s { frames = (M.insert var val vars, blocks):vs }
103 f _ = error "can't set var with empty stack"
104
105 -- Special treatment for the heap:
106 -- If a heap location doesn't have a value, we give it one.
107 get_heap :: Addr -> EvalM v v
108 get_heap addr =
109 do State {heap, vsupply} <- get_state
110 (v, vs) <- case vsupply of v:vs -> return (v, vs)
111 _ -> throwError "hlookup hit end of value supply"
112 upd_state (\s -> s {heap = M.insert addr v heap, vsupply = vs})
113 event $ ReadEvt addr v
114 return v
115
116 set_heap :: Addr -> v -> EvalM v ()
117 set_heap addr val =
118 do event $ StoreEvt addr val
119 upd_state $ \ s -> s { heap = M.insert addr val (heap s) }
120
121 get_block :: Label -> EvalM v B
122 get_block lbl = get_state >>= k
123 where k (State {frames = (_, graph):_}) = blookup "block" graph lbl
124 k _ = error "can't get blocks from empty stack"
125
126 get_proc :: String -> EvalM v Proc
127 get_proc name = get_state >>= mlookup "proc" name . procs
128
129 newFrame :: VarEnv v -> G -> EvalM v ()
130 newFrame vars graph = upd_state $ \s -> s { frames = (vars, graph) : frames s}
131
132 popFrame :: EvalM v ()
133 popFrame = upd_state f
134 where f s@(State {frames = _:fs}) = s { frames = fs }
135 f _ = error "popFrame: no frame to pop..." -- implementation error
136
137 inNewFrame :: VarEnv v -> G -> EvalM v x -> EvalM v x
138 inNewFrame vars graph runFrame =
139 do newFrame vars graph
140 x <- runFrame
141 popFrame
142 return x
143
144 mlookup :: Ord k => String -> k -> M.Map k v -> EvalM v' v
145 mlookup blame k m =
146 case M.lookup k m of
147 Just v -> return v
148 Nothing -> throwError ("unknown lookup for " ++ blame)
149
150 blookup :: String -> G -> Label -> EvalM v B
151 blookup blame (GMany _ blks _) lbl =
152 case mapLookup lbl blks of
153 Just b -> return b
154 Nothing -> throwError ("unknown lookup for " ++ blame)