1 {-# OPTIONS -XPatternGuards #-}
3 Interprets the subset of well-typed Core programs for which
4 (a) All constructor and primop applications are saturated
5 (b) All non-trivial expressions of unlifted kind ('#') are
6 scrutinized in a Case expression.
8 This is by no means a "minimal" interpreter, in the sense that considerably
9 simpler machinary could be used to run programs and get the right answers.
10 However, it attempts to mirror the intended use of various Core constructs,
11 particularly with respect to heap usage. So considerations such as unboxed
12 tuples, sharing, trimming, black-holing, etc. are all covered.
13 The only major omission is garbage collection.
15 Just a sampling of primitive types and operators are included.
18 module Interp ( evalProgram ) where
29 Hconstr Dcon [Value] -- constructed value (note: no qualifier needed!)
30 | Hclos Venv Var Exp -- function closure
31 | Hthunk Venv Exp -- unevaluated thunk
37 Vheap Ptr -- heap pointer (boxed)
38 | Vimm PrimValue -- immediate primitive value (unboxed)
39 | Vutuple [Value] -- unboxed tuples
42 type Venv = Env Var Value -- values of vars
44 data PrimValue = -- values of the (unboxed) primitive types
45 PCharzh Integer -- actually 31-bit unsigned
46 | PIntzh Integer -- actually WORD_SIZE_IN_BITS-bit signed
47 | PWordzh Integer -- actually WORD_SIZE_IN_BITS-bit unsigned
48 | PAddrzh Integer -- actually native pointer size
49 | PFloatzh Rational -- actually 32-bit
50 | PDoublezh Rational -- actually 64-bit
54 type Menv = Env AnMname Venv -- modules
56 initialGlobalEnv :: Menv
59 [(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]
61 {- Heap management. -}
62 {- Nothing is said about garbage collection. -}
64 data Heap = Heap Ptr (Env Ptr HeapValue)
65 -- last cell allocated; environment of allocated cells
68 hallocate :: Heap -> HeapValue -> (Heap,Ptr)
69 hallocate (Heap last contents) v =
71 in (Heap next (eextend contents (next,v)),next)
73 hupdate :: Heap -> Ptr -> HeapValue -> Heap
74 hupdate (Heap last contents) p v =
75 Heap last (eextend contents (p,v))
77 hlookup:: Heap -> Ptr -> HeapValue
78 hlookup (Heap _ contents) p =
79 case elookup contents p of
81 Nothing -> error "Missing heap entry (black hole?)"
83 hremove :: Heap -> Ptr -> Heap
84 hremove (Heap last contents) p =
85 Heap last (eremove contents p)
88 hempty = Heap 0 eempty
90 {- The evaluation monad manages the heap and the possiblity
95 newtype Eval a = Eval (Heap -> (Heap,Either a Exn))
97 instance Monad Eval where
98 (Eval m) >>= k = Eval (
100 (h',Left x) -> case k x of
102 (h',Right exn) -> (h',Right exn))
103 return x = Eval (\h -> (h,Left x))
105 hallocateE :: HeapValue -> Eval Ptr
106 hallocateE v = Eval (\ h ->
107 let (h',p) = hallocate h v
110 hupdateE :: Ptr -> HeapValue -> Eval ()
111 hupdateE p v = Eval (\h -> (hupdate h p v,Left ()))
113 hlookupE :: Ptr -> Eval HeapValue
114 hlookupE p = Eval (\h -> (h,Left (hlookup h p)))
116 hremoveE :: Ptr -> Eval ()
117 hremoveE p = Eval (\h -> (hremove h p, Left ()))
119 raiseE :: Exn -> Eval a
120 raiseE exn = Eval (\h -> (h,Right exn))
122 catchE :: Eval a -> (Exn -> Eval a) -> Eval a
123 catchE (Eval m) f = Eval
125 (h',Left x) -> (h',Left x)
134 (_,Right exn) -> error ("evaluation failed with uncaught exception: " ++ show exn)
137 {- Main entry point -}
138 evalProgram :: [Module] -> Value
139 evalProgram modules =
141 do globalEnv <- foldM evalModule initialGlobalEnv modules
142 Vutuple [_,v] <- evalExp globalEnv eempty (App (Var mainVar)
143 (Var (qual primMname "realWorldzh")))
148 Evaluating a module just fills an environment with suspensions for all
149 the external top-level values; it doesn't actually do any evaluation
152 By the time we actually evaluate an expression, all external values from
153 all modules will be in globalEnv. So evaluation just maintains an environment
154 of non-external values (top-level or local). In particular, only non-external
155 values end up in closures (all other values are accessible from globalEnv.)
159 - globalEnv contains external values (all top-level) from all modules seen so far.
163 - e_venv contains external values (all top-level) seen so far in current module
164 - l_venv contains non-external values (top-level or local)
165 seen so far in current module.
168 - env contains non-external values (top-level or local) seen so far
169 in current expression.
173 evalModule :: Menv -> Module -> Eval Menv
174 evalModule globalEnv (Module mn tdefs vdefgs) =
175 do (e_venv,l_venv) <- foldM evalVdef (eempty,eempty) vdefgs
176 return (eextend globalEnv (mn,e_venv))
178 evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
179 evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),t,e))) =
180 do p <- hallocateE (suspendExp l_env e)
183 Nothing -> (e_env,eextend l_env (x,Vheap p))
184 _ -> (eextend e_env (x,Vheap p),l_env)
186 evalVdef (e_env,l_env) (Rec vdefs) =
187 do l_vs0 <- mapM preallocate l_xs
188 let l_env' = foldl eextend l_env (zip l_xs l_vs0)
189 let l_hs = map (suspendExp l_env') l_es
190 mapM_ reallocate (zip l_vs0 l_hs)
191 let e_hs = map (suspendExp l_env') e_es
192 e_vs <- mapM allocate e_hs
193 let e_env' = foldl eextend e_env (zip e_xs e_vs)
194 return (e_env',l_env')
196 (l_xs,l_es) = unzip [(x,e) | Vdef((Nothing,x),_,e) <- vdefs]
197 (e_xs,e_es) = unzip [(x,e) | Vdef((Just m,x),_,e) <- vdefs]
199 do p <- hallocateE undefined
201 reallocate (Vheap p0,h) =
207 suspendExp:: Venv -> Exp -> HeapValue
208 suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
209 where env' = thin env (delete x (freevarsExp e))
210 suspendExp env e = Hthunk env' e
211 where env' = thin env (freevarsExp e)
214 evalExp :: Menv -> Venv -> Exp -> Eval Value
215 evalExp globalEnv env (Var qv) =
216 let v = qlookup globalEnv env qv
219 do z <- hlookupE p -- can fail due to black-holing
222 do hremoveE p -- black-hole
223 w@(Vheap p') <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
227 _ -> return v -- return pointer to Hclos or Hconstr
228 _ -> return v -- return Vimm or Vutuple
229 evalExp globalEnv env (Lit l) = return (Vimm (evalLit l))
230 evalExp globalEnv env (Dcon (_,c)) =
231 do p <- hallocateE (Hconstr c [])
234 evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
236 evalApp :: Venv -> Exp -> [Exp] -> Eval Value
237 evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
238 evalApp env (op @(Dcon (qdc@(m,c)))) es =
239 do vs <- suspendExps globalEnv env es
240 if isUtupleDc qdc then
243 {- allocate a thunk -}
244 do p <- hallocateE (Hconstr c vs)
246 evalApp env (op @ (Var(v@(_,p)))) es | isPrimVar v =
247 do vs <- evalExps globalEnv env es
249 ("raisezh",[exn]) -> raiseE exn
250 ("catchzh",[body,handler,rws]) ->
251 catchE (apply body [rws])
252 (\exn -> apply handler [exn,rws])
254 evalApp env (External s _) es =
255 do vs <- evalExps globalEnv env es
257 evalApp env (Appt e _) es = evalApp env e es
258 evalApp env (Lam (Tb _) e) es = evalApp env e es
259 evalApp env (Cast e _) es = evalApp env e es
260 evalApp env (Note _ e) es = evalApp env e es
262 {- e must now evaluate to a closure -}
263 do vs <- suspendExps globalEnv env es
264 vop <- evalExp globalEnv env e
267 apply :: Value -> [Value] -> Eval Value
268 apply vop [] = return vop
269 apply (Vheap p) (v:vs) =
270 do Hclos env' x b <- hlookupE p
271 v' <- evalExp globalEnv (eextend env' (x,v)) b
275 evalExp globalEnv env (Appt e _) = evalExp globalEnv env e
276 evalExp globalEnv env (Lam (Vb(x,_)) e) =
277 do p <- hallocateE (Hclos env' x e)
279 where env' = thin env (delete x (freevarsExp e))
280 evalExp globalEnv env (Lam _ e) = evalExp globalEnv env e
281 evalExp globalEnv env (Let vdef e) =
282 do env' <- evalVdef globalEnv env vdef
283 evalExp globalEnv env' e
285 evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
286 evalVdef globalEnv env (Nonrec(Vdef((m,x),t,e))) =
287 do v <- suspendExp globalEnv env e
288 return (eextend env (x,v))
289 evalVdef globalEnv env (Rec vdefs) =
290 do vs0 <- mapM preallocate xs
291 let env' = foldl eextend env (zip xs vs0)
292 vs <- suspendExps globalEnv env' es
293 mapM_ reallocate (zip vs0 vs)
296 (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
298 do p <- hallocateE (Hconstr "UGH" [])
300 reallocate (Vheap p0,Vheap p) =
304 evalExp globalEnv env (Case e (x,_) _ alts) =
305 do z <- evalExp globalEnv env e
306 let env' = eextend env (x,z)
309 do h <- hlookupE p -- can fail due to black-holing
311 Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
312 _ -> evalDefaultAlt env' alts
314 evalUtupleAlt env' vs (reverse alts)
316 evalLitAlt env' pv (reverse alts)
318 evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
319 evalDcAlt env dcon vs alts =
322 f ((Acon (_,dcon') _ xs e):as) =
323 if dcon == dcon' then
324 evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
327 evalExp globalEnv env e
328 f _ = error "impossible Case-evalDcAlt"
330 evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
331 evalUtupleAlt env vs [Acon _ _ xs e] =
332 evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
334 evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
335 evalLitAlt env pv alts =
338 f ((Alit lit e):as) =
339 let pv' = evalLit lit
341 evalExp globalEnv env e
344 evalExp globalEnv env e
345 f _ = error "impossible Case-evalLitAlt"
347 evalDefaultAlt :: Venv -> [Alt] -> Eval Value
348 evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
350 evalExp globalEnv env (Cast e _) = evalExp globalEnv env e
351 evalExp globalEnv env (Note _ e) = evalExp globalEnv env e
352 evalExp globalEnv env (External s t) = evalExternal s []
354 evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
355 evalExps globalEnv env = mapM (evalExp globalEnv env)
357 suspendExp:: Menv -> Venv -> Exp -> Eval Value
358 suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
359 suspendExp globalEnv env (Lit l) = return (Vimm (evalLit l))
360 suspendExp globalEnv env (Lam (Vb(x,_)) e) =
361 do p <- hallocateE (Hclos env' x e)
363 where env' = thin env (delete x (freevarsExp e))
364 suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
365 suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
366 suspendExp globalEnv env (Cast e _) = suspendExp globalEnv env e
367 suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
368 suspendExp globalEnv env (External s _) = evalExternal s []
369 suspendExp globalEnv env e =
370 do p <- hallocateE (Hthunk env' e)
372 where env' = thin env (freevarsExp e)
374 suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
375 suspendExps globalEnv env = mapM (suspendExp globalEnv env)
377 mlookup :: Menv -> Venv -> Mname -> Venv
378 mlookup _ env Nothing = env
379 mlookup globalEnv _ (Just m) =
380 case elookup globalEnv m of
382 Nothing -> error ("Interp: undefined module name: " ++ show m)
384 qlookup :: Menv -> Venv -> (Mname,Var) -> Value
385 qlookup globalEnv env (m,k) =
386 case elookup (mlookup globalEnv env m) k of
388 Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
390 evalPrimop :: Var -> [Value] -> Eval Value
391 evalPrimop "zpzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1+i2)))
392 evalPrimop "zmzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1-i2)))
393 evalPrimop "ztzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1*i2)))
394 evalPrimop "zgzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = mkBool (i1 > i2)
395 evalPrimop "remIntzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1 `rem` i2)))
397 evalPrimop p vs = error ("undefined primop: " ++ p)
399 evalExternal :: String -> [Value] -> Eval Value
401 evalExternal s vs = error "evalExternal undefined for now" -- etc.,etc.
403 evalLit :: Lit -> PrimValue
404 evalLit (Literal l t) =
406 Lint i | (Tcon(_,"Intzh")) <- t -> PIntzh i
407 Lint i | (Tcon(_,"Wordzh")) <- t -> PWordzh i
408 Lint i | (Tcon(_,"Addrzh")) <- t -> PAddrzh i
409 Lint i | (Tcon(_,"Charzh"))<- t -> PCharzh i
410 Lrational r | (Tcon(_,"Floatzh")) <- t -> PFloatzh r
411 Lrational r | (Tcon(_,"Doublezh")) <- t -> PDoublezh r
412 Lchar c | (Tcon(_,"Charzh")) <- t -> PCharzh (toEnum (ord c))
413 Lstring s | (Tcon(_,"Addrzh")) <- t -> PAddrzh 0 -- should really be address of non-heap copy of C-format string s
418 do p <- hallocateE (Hconstr "ZdwTrue" [])
421 do p <- hallocateE (Hconstr "ZdwFalse" [])
424 thin env vars = efilter env (`elem` vars)
426 {- Return the free non-external variables in an expression. -}
428 freevarsExp :: Exp -> [Var]
429 freevarsExp (Var (Nothing,v)) = [v]
430 freevarsExp (Var qv) = []
431 freevarsExp (Dcon _) = []
432 freevarsExp (Lit _) = []
433 freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
434 freevarsExp (Appt e t) = freevarsExp e
435 freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
436 freevarsExp (Lam _ e) = freevarsExp e
437 freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
438 where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
439 where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
440 freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
441 freevarsExp (Case e (v,_) _ as) = freevarsExp e `union` [v] `union` freevarsAlts as
442 where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
443 freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
444 freevarsAlt (Alit _ e) = freevarsExp e
445 freevarsAlt (Adefault e) = freevarsExp e
446 freevarsExp (Cast e _) = freevarsExp e
447 freevarsExp (Note _ e) = freevarsExp e
448 freevarsExp (External _ _) = []