2 Interprets the subset of well-typed Core programs for which
3 (a) All constructor and primop applications are saturated
4 (b) All non-trivial expressions of unlifted kind ('#') are
5 scrutinized in a Case expression.
7 This is by no means a "minimal" interpreter, in the sense that considerably
8 simpler machinary could be used to run programs and get the right answers.
9 However, it attempts to mirror the intended use of various Core constructs,
10 particularly with respect to heap usage. So considerations such as unboxed
11 tuples, sharing, trimming, black-holing, etc. are all covered.
12 The only major omission is garbage collection.
14 Just a sampling of primitive types and operators are included.
28 Hconstr Dcon [Value] -- constructed value (note: no qualifier needed!)
29 | Hclos Venv Var Exp -- function closure
30 | Hthunk Venv Exp -- unevaluated thunk
36 Vheap Ptr -- heap pointer (boxed)
37 | Vimm PrimValue -- immediate primitive value (unboxed)
38 | Vutuple [Value] -- unboxed tuples
41 type Venv = Env Var Value -- values of vars
43 data PrimValue = -- values of the (unboxed) primitive types
44 PCharzh Integer -- actually 31-bit unsigned
45 | PIntzh Integer -- actually WORD_SIZE_IN_BITS-bit signed
46 | PWordzh Integer -- actually WORD_SIZE_IN_BITS-bit unsigned
47 | PAddrzh Integer -- actually native pointer size
48 | PFloatzh Rational -- actually 32-bit
49 | PDoublezh Rational -- actually 64-bit
53 type Menv = Env AnMname Venv -- modules
55 initialGlobalEnv :: Menv
58 [(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]
60 {- Heap management. -}
61 {- Nothing is said about garbage collection. -}
63 data Heap = Heap Ptr (Env Ptr HeapValue)
64 -- last cell allocated; environment of allocated cells
67 hallocate :: Heap -> HeapValue -> (Heap,Ptr)
68 hallocate (Heap last contents) v =
70 in (Heap next (eextend contents (next,v)),next)
72 hupdate :: Heap -> Ptr -> HeapValue -> Heap
73 hupdate (Heap last contents) p v =
74 Heap last (eextend contents (p,v))
76 hlookup:: Heap -> Ptr -> HeapValue
77 hlookup (Heap _ contents) p =
78 case elookup contents p of
80 Nothing -> error "Missing heap entry (black hole?)"
82 hremove :: Heap -> Ptr -> Heap
83 hremove (Heap last contents) p =
84 Heap last (eremove contents p)
87 hempty = Heap 0 eempty
89 {- The evaluation monad manages the heap and the possiblity
94 newtype Eval a = Eval (Heap -> (Heap,Either a Exn))
96 instance Monad Eval where
97 (Eval m) >>= k = Eval (
99 (h',Left x) -> case k x of
101 (h',Right exn) -> (h',Right exn))
102 return x = Eval (\h -> (h,Left x))
104 hallocateE :: HeapValue -> Eval Ptr
105 hallocateE v = Eval (\ h ->
106 let (h',p) = hallocate h v
109 hupdateE :: Ptr -> HeapValue -> Eval ()
110 hupdateE p v = Eval (\h -> (hupdate h p v,Left ()))
112 hlookupE :: Ptr -> Eval HeapValue
113 hlookupE p = Eval (\h -> (h,Left (hlookup h p)))
115 hremoveE :: Ptr -> Eval ()
116 hremoveE p = Eval (\h -> (hremove h p, Left ()))
118 raiseE :: Exn -> Eval a
119 raiseE exn = Eval (\h -> (h,Right exn))
121 catchE :: Eval a -> (Exn -> Eval a) -> Eval a
122 catchE (Eval m) f = Eval
124 (h',Left x) -> (h',Left x)
133 (_,Right exn) -> error ("evaluation failed with uncaught exception: " ++ show exn)
136 {- Main entry point -}
137 evalProgram :: [Module] -> Value
138 evalProgram modules =
140 do globalEnv <- foldM evalModule initialGlobalEnv modules
141 Vutuple [_,v] <- evalExp globalEnv eempty (App (Var mainVar)
142 (Var (qual primMname "realWorldzh")))
147 Evaluating a module just fills an environment with suspensions for all
148 the external top-level values; it doesn't actually do any evaluation
151 By the time we actually evaluate an expression, all external values from
152 all modules will be in globalEnv. So evaluation just maintains an environment
153 of non-external values (top-level or local). In particular, only non-external
154 values end up in closures (all other values are accessible from globalEnv.)
158 - globalEnv contains external values (all top-level) from all modules seen so far.
162 - e_venv contains external values (all top-level) seen so far in current module
163 - l_venv contains non-external values (top-level or local)
164 seen so far in current module.
167 - env contains non-external values (top-level or local) seen so far
168 in current expression.
172 evalModule :: Menv -> Module -> Eval Menv
173 evalModule globalEnv (Module mn tdefs vdefgs) =
174 do (e_venv,l_venv) <- foldM evalVdef (eempty,eempty) vdefgs
175 return (eextend globalEnv (mn,e_venv))
177 evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
178 evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),t,e))) =
179 do p <- hallocateE (suspendExp l_env e)
182 Nothing -> (e_env,eextend l_env (x,Vheap p))
183 _ -> (eextend e_env (x,Vheap p),l_env)
185 evalVdef (e_env,l_env) (Rec vdefs) =
186 do l_vs0 <- mapM preallocate l_xs
187 let l_env' = foldl eextend l_env (zip l_xs l_vs0)
188 let l_hs = map (suspendExp l_env') l_es
189 mapM_ reallocate (zip l_vs0 l_hs)
190 let e_hs = map (suspendExp l_env') e_es
191 e_vs <- mapM allocate e_hs
192 let e_env' = foldl eextend e_env (zip e_xs e_vs)
193 return (e_env',l_env')
195 (l_xs,l_es) = unzip [(x,e) | Vdef((Nothing,x),_,e) <- vdefs]
196 (e_xs,e_es) = unzip [(x,e) | Vdef((Just m,x),_,e) <- vdefs]
198 do p <- hallocateE undefined
200 reallocate (Vheap p0,h) =
206 suspendExp:: Venv -> Exp -> HeapValue
207 suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
208 where env' = thin env (delete x (freevarsExp e))
209 suspendExp env e = Hthunk env' e
210 where env' = thin env (freevarsExp e)
213 evalExp :: Menv -> Venv -> Exp -> Eval Value
214 evalExp globalEnv env (Var qv) =
215 let v = qlookup globalEnv env qv
218 do z <- hlookupE p -- can fail due to black-holing
221 do hremoveE p -- black-hole
222 w@(Vheap p') <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
226 _ -> return v -- return pointer to Hclos or Hconstr
227 _ -> return v -- return Vimm or Vutuple
228 evalExp globalEnv env (Lit l) = return (Vimm (evalLit l))
229 evalExp globalEnv env (Dcon (_,c)) =
230 do p <- hallocateE (Hconstr c [])
233 evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
235 evalApp :: Venv -> Exp -> [Exp] -> Eval Value
236 evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
237 evalApp env (op @(Dcon (qdc@(m,c)))) es =
238 do vs <- suspendExps globalEnv env es
239 if isUtupleDc qdc then
242 {- allocate a thunk -}
243 do p <- hallocateE (Hconstr c vs)
245 evalApp env (op @ (Var(v@(_,p)))) es | isPrimVar v =
246 do vs <- evalExps globalEnv env es
248 ("raisezh",[exn]) -> raiseE exn
249 ("catchzh",[body,handler,rws]) ->
250 catchE (apply body [rws])
251 (\exn -> apply handler [exn,rws])
253 evalApp env (External s _) es =
254 do vs <- evalExps globalEnv env es
256 evalApp env (Appt e _) es = evalApp env e es
257 evalApp env (Lam (Tb _) e) es = evalApp env e es
258 evalApp env (Cast e _) es = evalApp env e es
259 evalApp env (Note _ e) es = evalApp env e es
261 {- e must now evaluate to a closure -}
262 do vs <- suspendExps globalEnv env es
263 vop <- evalExp globalEnv env e
266 apply :: Value -> [Value] -> Eval Value
267 apply vop [] = return vop
268 apply (Vheap p) (v:vs) =
269 do Hclos env' x b <- hlookupE p
270 v' <- evalExp globalEnv (eextend env' (x,v)) b
274 evalExp globalEnv env (Appt e _) = evalExp globalEnv env e
275 evalExp globalEnv env (Lam (Vb(x,_)) e) =
276 do p <- hallocateE (Hclos env' x e)
278 where env' = thin env (delete x (freevarsExp e))
279 evalExp globalEnv env (Lam _ e) = evalExp globalEnv env e
280 evalExp globalEnv env (Let vdef e) =
281 do env' <- evalVdef globalEnv env vdef
282 evalExp globalEnv env' e
284 evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
285 evalVdef globalEnv env (Nonrec(Vdef((m,x),t,e))) =
286 do v <- suspendExp globalEnv env e
287 return (eextend env (x,v))
288 evalVdef globalEnv env (Rec vdefs) =
289 do vs0 <- mapM preallocate xs
290 let env' = foldl eextend env (zip xs vs0)
291 vs <- suspendExps globalEnv env' es
292 mapM_ reallocate (zip vs0 vs)
295 (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
297 do p <- hallocateE (Hconstr "UGH" [])
299 reallocate (Vheap p0,Vheap p) =
303 evalExp globalEnv env (Case e (x,_) _ alts) =
304 do z <- evalExp globalEnv env e
305 let env' = eextend env (x,z)
308 do h <- hlookupE p -- can fail due to black-holing
310 Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
311 _ -> evalDefaultAlt env' alts
313 evalUtupleAlt env' vs (reverse alts)
315 evalLitAlt env' pv (reverse alts)
317 evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
318 evalDcAlt env dcon vs alts =
321 f ((Acon (_,dcon') _ xs e):as) =
322 if dcon == dcon' then
323 evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
326 evalExp globalEnv env e
327 f _ = error "impossible Case-evalDcAlt"
329 evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
330 evalUtupleAlt env vs [Acon _ _ xs e] =
331 evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
333 evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
334 evalLitAlt env pv alts =
337 f ((Alit lit e):as) =
338 let pv' = evalLit lit
340 evalExp globalEnv env e
343 evalExp globalEnv env e
344 f _ = error "impossible Case-evalLitAlt"
346 evalDefaultAlt :: Venv -> [Alt] -> Eval Value
347 evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
349 evalExp globalEnv env (Cast e _) = evalExp globalEnv env e
350 evalExp globalEnv env (Note _ e) = evalExp globalEnv env e
351 evalExp globalEnv env (External s t) = evalExternal s []
353 evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
354 evalExps globalEnv env = mapM (evalExp globalEnv env)
356 suspendExp:: Menv -> Venv -> Exp -> Eval Value
357 suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
358 suspendExp globalEnv env (Lit l) = return (Vimm (evalLit l))
359 suspendExp globalEnv env (Lam (Vb(x,_)) e) =
360 do p <- hallocateE (Hclos env' x e)
362 where env' = thin env (delete x (freevarsExp e))
363 suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
364 suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
365 suspendExp globalEnv env (Cast e _) = suspendExp globalEnv env e
366 suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
367 suspendExp globalEnv env (External s _) = evalExternal s []
368 suspendExp globalEnv env e =
369 do p <- hallocateE (Hthunk env' e)
371 where env' = thin env (freevarsExp e)
373 suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
374 suspendExps globalEnv env = mapM (suspendExp globalEnv env)
376 mlookup :: Menv -> Venv -> Mname -> Venv
377 mlookup _ env Nothing = env
378 mlookup globalEnv _ (Just m) =
379 case elookup globalEnv m of
381 Nothing -> error ("undefined module name: " ++ show m)
383 qlookup :: Menv -> Venv -> (Mname,Var) -> Value
384 qlookup globalEnv env (m,k) =
385 case elookup (mlookup globalEnv env m) k of
387 Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
389 evalPrimop :: Var -> [Value] -> Eval Value
390 evalPrimop "zpzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1+i2)))
391 evalPrimop "zmzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1-i2)))
392 evalPrimop "ztzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1*i2)))
393 evalPrimop "zgzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = mkBool (i1 > i2)
394 evalPrimop "remIntzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1 `rem` i2)))
396 evalPrimop p vs = error ("undefined primop: " ++ p)
398 evalExternal :: String -> [Value] -> Eval Value
400 evalExternal s vs = error "evalExternal undefined for now" -- etc.,etc.
402 evalLit :: Lit -> PrimValue
405 Lint i (Tcon(_,"Intzh")) -> PIntzh i
406 Lint i (Tcon(_,"Wordzh")) -> PWordzh i
407 Lint i (Tcon(_,"Addrzh")) -> PAddrzh i
408 Lint i (Tcon(_,"Charzh")) -> PCharzh i
409 Lrational r (Tcon(_,"Floatzh")) -> PFloatzh r
410 Lrational r (Tcon(_,"Doublezh")) -> PDoublezh r
411 Lchar c (Tcon(_,"Charzh")) -> PCharzh (toEnum (ord c))
412 Lstring s (Tcon(_,"Addrzh")) -> PAddrzh 0 -- should really be address of non-heap copy of C-format string s
417 do p <- hallocateE (Hconstr "ZdwTrue" [])
420 do p <- hallocateE (Hconstr "ZdwFalse" [])
423 thin env vars = efilter env (`elem` vars)
425 {- Return the free non-external variables in an expression. -}
427 freevarsExp :: Exp -> [Var]
428 freevarsExp (Var (Nothing,v)) = [v]
429 freevarsExp (Var qv) = []
430 freevarsExp (Dcon _) = []
431 freevarsExp (Lit _) = []
432 freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
433 freevarsExp (Appt e t) = freevarsExp e
434 freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
435 freevarsExp (Lam _ e) = freevarsExp e
436 freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
437 where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
438 where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
439 freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
440 freevarsExp (Case e (v,_) _ as) = freevarsExp e `union` [v] `union` freevarsAlts as
441 where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
442 freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
443 freevarsAlt (Alit _ e) = freevarsExp e
444 freevarsAlt (Adefault e) = freevarsExp e
445 freevarsExp (Cast e _) = freevarsExp e
446 freevarsExp (Note _ e) = freevarsExp e
447 freevarsExp (External _ _) = []