Fix all warnings in testing/
[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.Except
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
27 data EvalM v a = EvalM (State v -> InnerErrorM v (State v, a))
28
29 instance Monad (EvalM v) where
30 return x = EvalM (\s -> return (s, x))
31 EvalM f >>= k = EvalM $ \s -> do (s', x) <- f s
32 let EvalM f' = k x
33 f' s'
34
35 instance Functor (EvalM v) where
36 fmap = liftM
37
38 instance Applicative (EvalM v) where
39 pure = return
40 (<*>) = ap
41
42
43 instance MonadError String (EvalM v) where
44 throwError e = EvalM (\s -> throwError (s, e))
45 catchError (EvalM f) handler =
46 EvalM $ \s -> f s `catchError` handler'
47 where handler' (s', e) = let EvalM f' = handler e
48 in f' s'
49
50 -- Shorthands for frequently used types
51 type VarEnv v = M.Map Var v
52 type HeapEnv v = M.Map Addr v -- word addressed heap
53 type Addr = Integer
54 type B = Block Insn C C
55 type PEnv = M.Map String Proc
56 type G = Graph Insn C C
57
58 runProg :: [Proc] -> [v] -> EvalM v x -> ErrorM (State v, x)
59 runProg procs vs (EvalM f) =
60 case f init_state of
61 Left (_, e) -> throwError e
62 Right x -> return x
63 where
64 init_state = State { frames = [], heap = M.empty, events = [],
65 vsupply = vs, procs = procMap }
66 procMap = M.fromList $ zip (map name procs) procs
67
68 get_state :: EvalM v (State v)
69 get_state = EvalM f
70 where f state = return (state, state)
71
72 upd_state :: (State v -> State v) -> EvalM v ()
73 upd_state upd = EvalM (\state -> return (upd state, ()))
74
75 event :: Event v -> EvalM v ()
76 event e = upd_state (\s -> s {events = e : events s})
77
78 ----------------------------------
79 -- State of the machine
80 data State v = State { frames :: [(VarEnv v, G)]
81 , heap :: HeapEnv v
82 , procs :: PEnv
83 , vsupply :: [v]
84 , events :: [Event v]
85 }
86 data Event v = CallEvt String [v]
87 | RetEvt [v]
88 | StoreEvt Addr v
89 | ReadEvt Addr v
90
91 get_var :: Var -> EvalM v v
92 get_var var = get_state >>= k
93 where k (State {frames = (vars, _):_}) = mlookup "var" var vars
94 k _ = throwError "can't get vars from empty stack"
95
96 set_var :: Var -> v -> EvalM v ()
97 set_var var val = upd_state f
98 where f s@(State {frames = (vars, blocks):vs}) =
99 s { frames = (M.insert var val vars, blocks):vs }
100 f _ = error "can't set var with empty stack"
101
102 -- Special treatment for the heap:
103 -- If a heap location doesn't have a value, we give it one.
104 get_heap :: Addr -> EvalM v v
105 get_heap addr =
106 do State {heap, vsupply} <- get_state
107 (v, vs) <- case vsupply of v:vs -> return (v, vs)
108 _ -> throwError "hlookup hit end of value supply"
109 upd_state (\s -> s {heap = M.insert addr v heap, vsupply = vs})
110 event $ ReadEvt addr v
111 return v
112
113 set_heap :: Addr -> v -> EvalM v ()
114 set_heap addr val =
115 do event $ StoreEvt addr val
116 upd_state $ \ s -> s { heap = M.insert addr val (heap s) }
117
118 get_block :: Label -> EvalM v B
119 get_block lbl = get_state >>= k
120 where k (State {frames = (_, graph):_}) = blookup "block" graph lbl
121 k _ = error "can't get blocks from empty stack"
122
123 get_proc :: String -> EvalM v Proc
124 get_proc name = get_state >>= mlookup "proc" name . procs
125
126 newFrame :: VarEnv v -> G -> EvalM v ()
127 newFrame vars graph = upd_state $ \s -> s { frames = (vars, graph) : frames s}
128
129 popFrame :: EvalM v ()
130 popFrame = upd_state f
131 where f s@(State {frames = _:fs}) = s { frames = fs }
132 f _ = error "popFrame: no frame to pop..." -- implementation error
133
134 inNewFrame :: VarEnv v -> G -> EvalM v x -> EvalM v x
135 inNewFrame vars graph runFrame =
136 do newFrame vars graph
137 x <- runFrame
138 popFrame
139 return x
140
141 mlookup :: Ord k => String -> k -> M.Map k v -> EvalM v' v
142 mlookup blame k m =
143 case M.lookup k m of
144 Just v -> return v
145 Nothing -> throwError ("unknown lookup for " ++ blame)
146
147 blookup :: String -> G -> Label -> EvalM v B
148 blookup blame (GMany _ blks _) lbl =
149 case mapLookup lbl blks of
150 Just b -> return b
151 Nothing -> throwError ("unknown lookup for " ++ blame)