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 Mname 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) -- last cell allocated; environment of allocated cells
66 hallocate :: Heap -> HeapValue -> (Heap,Ptr)
67 hallocate (Heap last contents) v =
69 in (Heap next (eextend contents (next,v)),next)
71 hupdate :: Heap -> Ptr -> HeapValue -> Heap
72 hupdate (Heap last contents) p v =
73 Heap last (eextend contents (p,v))
75 hlookup:: Heap -> Ptr -> HeapValue
76 hlookup (Heap _ contents) p =
77 case elookup contents p of
79 Nothing -> error "Missing heap entry (black hole?)"
81 hremove :: Heap -> Ptr -> Heap
82 hremove (Heap last contents) p =
83 Heap last (eremove contents p)
86 hempty = Heap 0 eempty
88 {- The evaluation monad manages the heap and the possiblity
93 newtype Eval a = Eval (Heap -> (Heap,Either a Exn))
95 instance Monad Eval where
96 (Eval m) >>= k = Eval (
98 (h',Left x) -> case k x of
100 (h',Right exn) -> (h',Right exn))
101 return x = Eval (\h -> (h,Left x))
103 hallocateE :: HeapValue -> Eval Ptr
104 hallocateE v = Eval (\ h ->
105 let (h',p) = hallocate h v
108 hupdateE :: Ptr -> HeapValue -> Eval ()
109 hupdateE p v = Eval (\h -> (hupdate h p v,Left ()))
111 hlookupE :: Ptr -> Eval HeapValue
112 hlookupE p = Eval (\h -> (h,Left (hlookup h p)))
114 hremoveE :: Ptr -> Eval ()
115 hremoveE p = Eval (\h -> (hremove h p, Left ()))
117 raiseE :: Exn -> Eval a
118 raiseE exn = Eval (\h -> (h,Right exn))
120 catchE :: Eval a -> (Exn -> Eval a) -> Eval a
121 catchE (Eval m) f = Eval
123 (h',Left x) -> (h',Left x)
132 (_,Right exn) -> error ("evaluation failed with uncaught exception: " ++ show exn)
135 {- Main entry point -}
136 evalProgram :: [Module] -> Value
137 evalProgram modules =
139 do globalEnv <- foldM evalModule initialGlobalEnv modules
140 Vutuple [_,v] <- evalExp globalEnv eempty (App (Var ("Main","main")) (Var (primMname,"realWorldzh")))
145 Evaluating a module just fills an environment with suspensions for all
146 the external top-level values; it doesn't actually do any evaluation
149 By the time we actually evaluate an expression, all external values from
150 all modules will be in globalEnv. So evaluation just maintains an environment
151 of non-external values (top-level or local). In particular, only non-external
152 values end up in closures (all other values are accessible from globalEnv.)
156 - globalEnv contains external values (all top-level) from all modules seen so far.
160 - e_venv contains external values (all top-level) seen so far in current module
161 - l_venv contains non-external values (top-level or local)
162 seen so far in current module.
165 - env contains non-external values (top-level or local) seen so far
166 in current expression.
170 evalModule :: Menv -> Module -> Eval Menv
171 evalModule globalEnv (Module mn tdefs vdefgs) =
172 do (e_venv,l_venv) <- foldM evalVdef (eempty,eempty) vdefgs
173 return (eextend globalEnv (mn,e_venv))
175 evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
176 evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),t,e))) =
177 do p <- hallocateE (suspendExp l_env e)
180 (e_env,eextend l_env (x,Vheap p))
182 (eextend e_env (x,Vheap p),l_env)
184 evalVdef (e_env,l_env) (Rec vdefs) =
185 do l_vs0 <- mapM preallocate l_xs
186 let l_env' = foldl eextend l_env (zip l_xs l_vs0)
187 let l_hs = map (suspendExp l_env') l_es
188 mapM_ reallocate (zip l_vs0 l_hs)
189 let e_hs = map (suspendExp l_env') e_es
190 e_vs <- mapM allocate e_hs
191 let e_env' = foldl eextend e_env (zip e_xs e_vs)
192 return (e_env',l_env')
194 (l_xs,l_es) = unzip [(x,e) | Vdef(("",x),_,e) <- vdefs]
195 (e_xs,e_es) = unzip [(x,e) | Vdef((m,x),_,e) <- vdefs, m /= ""]
197 do p <- hallocateE undefined
199 reallocate (Vheap p0,h) =
205 suspendExp:: Venv -> Exp -> HeapValue
206 suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
207 where env' = thin env (delete x (freevarsExp e))
208 suspendExp env e = Hthunk env' e
209 where env' = thin env (freevarsExp e)
212 evalExp :: Menv -> Venv -> Exp -> Eval Value
213 evalExp globalEnv env (Var qv) =
214 let v = qlookup globalEnv env qv
217 do z <- hlookupE p -- can fail due to black-holing
220 do hremoveE p -- black-hole
221 w@(Vheap p') <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
225 _ -> return v -- return pointer to Hclos or Hconstr
226 _ -> return v -- return Vimm or Vutuple
227 evalExp globalEnv env (Lit l) = return (Vimm (evalLit l))
228 evalExp globalEnv env (Dcon (_,c)) =
229 do p <- hallocateE (Hconstr c [])
232 evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
234 evalApp :: Venv -> Exp -> [Exp] -> Eval Value
235 evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
236 evalApp env (op @(Dcon (qdc@(m,c)))) es =
237 do vs <- suspendExps globalEnv env es
238 if isUtupleDc qdc then
241 {- allocate a thunk -}
242 do p <- hallocateE (Hconstr c vs)
244 evalApp env (op @ (Var(m,p))) es | m == primMname =
245 do vs <- evalExps globalEnv env es
247 ("raisezh",[exn]) -> raiseE exn
248 ("catchzh",[body,handler,rws]) ->
249 catchE (apply body [rws])
250 (\exn -> apply handler [exn,rws])
252 evalApp env (External s _) es =
253 do vs <- evalExps globalEnv env es
255 evalApp env (Appt e _) es = evalApp env e es
256 evalApp env (Lam (Tb _) e) es = evalApp env e es
257 evalApp env (Coerce _ e) es = evalApp env e es
258 evalApp env (Note _ e) es = evalApp env e es
260 {- e must now evaluate to a closure -}
261 do vs <- suspendExps globalEnv env es
262 vop <- evalExp globalEnv env e
265 apply :: Value -> [Value] -> Eval Value
266 apply vop [] = return vop
267 apply (Vheap p) (v:vs) =
268 do Hclos env' x b <- hlookupE p
269 v' <- evalExp globalEnv (eextend env' (x,v)) b
273 evalExp globalEnv env (Appt e _) = evalExp globalEnv env e
274 evalExp globalEnv env (Lam (Vb(x,_)) e) =
275 do p <- hallocateE (Hclos env' x e)
277 where env' = thin env (delete x (freevarsExp e))
278 evalExp globalEnv env (Lam _ e) = evalExp globalEnv env e
279 evalExp globalEnv env (Let vdef e) =
280 do env' <- evalVdef globalEnv env vdef
281 evalExp globalEnv env' e
283 evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
284 evalVdef globalEnv env (Nonrec(Vdef((m,x),t,e))) =
285 do v <- suspendExp globalEnv env e
286 return (eextend env (x,v))
287 evalVdef globalEnv env (Rec vdefs) =
288 do vs0 <- mapM preallocate xs
289 let env' = foldl eextend env (zip xs vs0)
290 vs <- suspendExps globalEnv env' es
291 mapM_ reallocate (zip vs0 vs)
294 (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
296 do p <- hallocateE (Hconstr "UGH" [])
298 reallocate (Vheap p0,Vheap p) =
302 evalExp globalEnv env (Case e (x,_) alts) =
303 do z <- evalExp globalEnv env e
304 let env' = eextend env (x,z)
307 do h <- hlookupE p -- can fail due to black-holing
309 Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
310 _ -> evalDefaultAlt env' alts
312 evalUtupleAlt env' vs (reverse alts)
314 evalLitAlt env' pv (reverse alts)
316 evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
317 evalDcAlt env dcon vs alts =
320 f ((Acon (_,dcon') _ xs e):as) =
321 if dcon == dcon' then
322 evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
325 evalExp globalEnv env e
326 f _ = error "impossible Case-evalDcAlt"
328 evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
329 evalUtupleAlt env vs [Acon _ _ xs e] =
330 evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
332 evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
333 evalLitAlt env pv alts =
336 f ((Alit lit e):as) =
337 let pv' = evalLit lit
339 evalExp globalEnv env e
342 evalExp globalEnv env e
343 f _ = error "impossible Case-evalLitAlt"
345 evalDefaultAlt :: Venv -> [Alt] -> Eval Value
346 evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
348 evalExp globalEnv env (Coerce _ e) = evalExp globalEnv env e
349 evalExp globalEnv env (Note _ e) = evalExp globalEnv env e
350 evalExp globalEnv env (External s t) = evalExternal s []
352 evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
353 evalExps globalEnv env = mapM (evalExp globalEnv env)
355 suspendExp:: Menv -> Venv -> Exp -> Eval Value
356 suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
357 suspendExp globalEnv env (Lit l) = return (Vimm (evalLit l))
358 suspendExp globalEnv env (Lam (Vb(x,_)) e) =
359 do p <- hallocateE (Hclos env' x e)
361 where env' = thin env (delete x (freevarsExp e))
362 suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
363 suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
364 suspendExp globalEnv env (Coerce _ e) = suspendExp globalEnv env e
365 suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
366 suspendExp globalEnv env (External s _) = evalExternal s []
367 suspendExp globalEnv env e =
368 do p <- hallocateE (Hthunk env' e)
370 where env' = thin env (freevarsExp e)
372 suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
373 suspendExps globalEnv env = mapM (suspendExp globalEnv env)
375 mlookup :: Menv -> Venv -> Mname -> Venv
376 mlookup _ env "" = env
377 mlookup globalEnv _ m =
378 case elookup globalEnv m of
380 Nothing -> error ("undefined module name: " ++ m)
382 qlookup :: Menv -> Venv -> (Mname,Var) -> Value
383 qlookup globalEnv env (m,k) =
384 case elookup (mlookup globalEnv env m) k of
386 Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
388 evalPrimop :: Var -> [Value] -> Eval Value
389 evalPrimop "zpzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1+i2)))
390 evalPrimop "zmzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1-i2)))
391 evalPrimop "ztzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1*i2)))
392 evalPrimop "zgzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = mkBool (i1 > i2)
393 evalPrimop "remIntzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1 `rem` i2)))
395 evalPrimop p vs = error ("undefined primop: " ++ p)
397 evalExternal :: String -> [Value] -> Eval Value
399 evalExternal s vs = error "evalExternal undefined for now" -- etc.,etc.
401 evalLit :: Lit -> PrimValue
404 Lint i (Tcon(_,"Intzh")) -> PIntzh i
405 Lint i (Tcon(_,"Wordzh")) -> PWordzh i
406 Lint i (Tcon(_,"Addrzh")) -> PAddrzh i
407 Lint i (Tcon(_,"Charzh")) -> PCharzh i
408 Lrational r (Tcon(_,"Floatzh")) -> PFloatzh r
409 Lrational r (Tcon(_,"Doublezh")) -> PDoublezh r
410 Lchar c (Tcon(_,"Charzh")) -> PCharzh (toEnum (ord c))
411 Lstring s (Tcon(_,"Addrzh")) -> PAddrzh 0 -- should really be address of non-heap copy of C-format string s
416 do p <- hallocateE (Hconstr "ZdwTrue" [])
419 do p <- hallocateE (Hconstr "ZdwFalse" [])
422 thin env vars = efilter env (`elem` vars)
424 {- Return the free non-external variables in an expression. -}
426 freevarsExp :: Exp -> [Var]
427 freevarsExp (Var ("",v)) = [v]
428 freevarsExp (Var qv) = []
429 freevarsExp (Dcon _) = []
430 freevarsExp (Lit _) = []
431 freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
432 freevarsExp (Appt e t) = freevarsExp e
433 freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
434 freevarsExp (Lam _ e) = freevarsExp e
435 freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
436 where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
437 where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
438 freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
439 freevarsExp (Case e (v,_) as) = freevarsExp e `union` [v] `union` freevarsAlts as
440 where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
441 freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
442 freevarsAlt (Alit _ e) = freevarsExp e
443 freevarsAlt (Adefault e) = freevarsExp e
444 freevarsExp (Coerce _ e) = freevarsExp e
445 freevarsExp (Note _ e) = freevarsExp e
446 freevarsExp (External _ _) = []