1 {-# OPTIONS -Wall -fno-warn-name-shadowing -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
20 import Control.Monad.Error
21 import Control.Monad.State
25 import GHC.Exts hiding (Ptr)
33 Hconstr Dcon [Value] -- constructed value (note: no qualifier needed!)
34 | Hclos Venv Var Exp -- function closure
35 | Hthunk Venv Exp -- unevaluated thunk
41 Vheap Ptr -- heap pointer (boxed)
42 | Vimm PrimValue -- immediate primitive value (unboxed)
43 | Vutuple [Value] -- unboxed tuples
46 instance Error Value where
50 type Venv = Env Var Value -- values of vars
52 data PrimValue = -- values of the (unboxed) primitive types
53 PCharzh Integer -- actually 31-bit unsigned
54 | PIntzh Integer -- actually WORD_SIZE_IN_BITS-bit signed
55 | PWordzh Integer -- actually WORD_SIZE_IN_BITS-bit unsigned
56 | PAddrzh Integer -- actually native pointer size
57 | PFloatzh Rational -- actually 32-bit
58 | PDoublezh Rational -- actually 64-bit
63 type Menv = Env AnMname Venv -- modules
65 initialGlobalEnv :: Menv
68 [(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]
70 {- Heap management. -}
71 {- Nothing is said about garbage collection. -}
73 data Heap = Heap Ptr (Env Ptr HeapValue)
74 -- last cell allocated; environment of allocated cells
77 hallocate :: Heap -> HeapValue -> (Heap,Ptr)
78 hallocate (Heap last contents) v =
80 in (Heap next (eextend contents (next,v)),next)
82 hupdate :: Heap -> Ptr -> HeapValue -> Heap
83 hupdate (Heap last contents) p v =
84 Heap last (eextend contents (p,v))
86 hlookup:: Heap -> Ptr -> HeapValue
87 hlookup (Heap _ contents) p =
88 case elookup contents p of
90 Nothing -> error "Missing heap entry (black hole?)"
92 hremove :: Heap -> Ptr -> Heap
93 hremove (Heap last contents) p =
94 Heap last (eremove contents p)
97 hempty = Heap 0 eempty
99 {- The evaluation monad manages the heap and the possiblity
104 type Eval a = ErrorT Exn (StateT Heap IO) a
106 hallocateE :: HeapValue -> Eval Ptr
109 let (h', p) = hallocate h v
113 hupdateE :: Ptr -> HeapValue -> Eval ()
114 hupdateE p v = modify (\ h -> hupdate h p v)
116 hlookupE :: Ptr -> Eval HeapValue
117 hlookupE p = get >>= (\h -> return (hlookup h p))
119 hremoveE :: Ptr -> Eval ()
120 hremoveE p = modify (\h -> hremove h p)
122 raiseE :: Exn -> Eval a
125 catchE :: Show a => Eval a -> (Exn -> Eval a) -> Eval a
128 runE :: Eval a -> IO a
130 resultOrError <- evalStateT (runErrorT m) hempty
131 case resultOrError of
134 ("evaluation failed with uncaught exception: " ++ show exn)
136 {- Main entry point -}
137 -- TODO: This is in the IO monad because primitive I/O ops
138 -- actually perform the IO. It might be better to model it
139 -- instead (by having the interpreter return a ([Char] -> (Value, [Char])))
140 evalProgram :: [Module] -> IO Value
141 evalProgram modules = runE $ do
142 -- We do two passes: one to slurp in all the definitions *except*
143 -- for :Main.main, and then one to look for the Main module
144 -- and extract out just the :Main.main defn.
145 -- It's kind of annoying.
146 globalEnv' <- foldM evalModule initialGlobalEnv modules
147 globalEnv <- evalModule globalEnv' (rootModule modules)
148 Vutuple [_,v] <- evalExp globalEnv eempty (App (Var wrapperMainVar)
152 rootModule :: [Module] -> Module
153 -- This looks for the Main module, and constructs
154 -- a fake module containing only the defn of
157 case find (\ (Module mn _ _) -> mn == mainMname) ms of
158 Just (Module _ _ [Rec bs]) ->
159 Module wrapperMainMname []
160 [Rec (filter isWrapperMainVdef bs)]
161 _ -> error "eval: missing main module"
162 where isWrapperMainVdef (Vdef (v,_,_)) | v == wrapperMainVar = True
163 isWrapperMainVdef _ = False
167 Evaluating a module just fills an environment with suspensions for all
168 the external top-level values; it doesn't actually do any evaluation
171 By the time we actually evaluate an expression, all external values from
172 all modules will be in globalEnv. So evaluation just maintains an environment
173 of non-external values (top-level or local). In particular, only non-external
174 values end up in closures (all other values are accessible from globalEnv.)
178 - globalEnv contains external values (all top-level) from all modules seen so far.
182 - e_venv contains external values (all top-level) seen so far in current module
183 - l_venv contains non-external values (top-level or local)
184 seen so far in current module.
187 - env contains non-external values (top-level or local) seen so far
188 in current expression.
192 evalModule :: Menv -> Module -> Eval Menv
193 evalModule globalEnv (Module mn _ vdefgs) =
194 do (e_venv,_) <- foldM evalVdef (eempty,eempty) vdefgs
195 return (eextend globalEnv (mn,e_venv))
197 evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
198 evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),_,e))) =
199 do p <- hallocateE (suspendExp l_env e)
202 Nothing -> (e_env,eextend l_env (x,Vheap p))
203 _ -> (eextend e_env (x,Vheap p),l_env)
205 evalVdef (e_env,l_env) (Rec vdefs) =
206 do l_vs0 <- mapM preallocate l_xs
207 let l_env' = foldl eextend l_env (zip l_xs (map Vheap l_vs0))
208 let l_hs = map (suspendExp l_env') l_es
209 mapM_ reallocate (zip l_vs0 l_hs)
210 let e_hs = map (suspendExp l_env') e_es
211 e_vs <- (liftM (map Vheap)) $ mapM allocate e_hs
212 let e_env' = foldl eextend e_env (zip e_xs e_vs)
213 return (e_env',l_env')
215 (l_xs,l_es) = unzip [(x,e) | Vdef((Nothing,x),_,e) <- vdefs]
216 (e_xs,e_es) = unzip [(x,e) | Vdef ((Just _,x),_,e) <-
217 -- Do not dump the defn for :Main.main into
218 -- the environment for Main!
219 filter inHomeModule vdefs]
220 inHomeModule (Vdef ((Just m,_),_,_)) | m == mn = True
221 inHomeModule _ = False
223 do p <- hallocateE undefined
231 suspendExp:: Venv -> Exp -> HeapValue
232 suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
233 where env' = thin env (delete x (freevarsExp e))
234 suspendExp env e = Hthunk env' e
235 where env' = thin env (freevarsExp e)
237 evalExp :: Menv -> Venv -> Exp -> Eval Value
238 evalExp globalEnv env = eval
239 where eval (Var qv) =
240 let v = qlookup globalEnv env qv
243 z <- hlookupE p -- can fail due to black-holing
246 hremoveE p -- black-hole
247 w <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
253 _ -> error ("eval: w was not boxed: " ++ show w)
254 _ -> return v -- return pointer to Hclos or Hconstr
255 _ -> return v -- return Vimm or Vutuple
256 eval (Lit l) = return (Vimm (evalLit l))
257 eval (Dcon (_,c)) = do
258 p <- hallocateE (Hconstr c [])
263 evalApp :: Venv -> Exp -> [Exp] -> Eval Value
264 evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
265 evalApp env (Dcon (qdc@(_,c))) es =
266 do vs <- suspendExps globalEnv env es
271 {- allocate a thunk -}
272 do p <- hallocateE (Hconstr c vs)
274 evalApp env (Var(v@(_,p))) es | isPrimVar v =
275 do vs <- evalExps globalEnv env es
277 ("raisezh",[exn]) -> raiseE exn
278 ("catchzh",[body,handler,rws]) ->
279 catchE (apply body [rws])
280 (\exn -> apply handler [exn,rws])
282 evalApp env (External s _) es =
283 do vs <- evalExps globalEnv env es
285 evalApp env (Appt e _) es = evalApp env e es
286 evalApp env (Lam (Tb _) e) es = evalApp env e es
287 evalApp env (Cast e _) es = evalApp env e es
288 evalApp env (Note _ e) es = evalApp env e es
290 {- e must now evaluate to a closure -}
291 do vs <- suspendExps globalEnv env es
292 vop <- evalExp globalEnv env e
295 apply :: Value -> [Value] -> Eval Value
296 apply vop [] = return vop
297 apply (Vheap p) (v:vs) =
298 do Hclos env' x b <- hlookupE p
299 v' <- evalExp globalEnv (eextend env' (x,v)) b
301 apply _ _ = error ("apply: operator is not a closure")
303 eval (Appt e _) = evalExp globalEnv env e
304 eval (Lam (Vb(x,_)) e) = do
305 p <- hallocateE (Hclos env' x e)
307 where env' = thin env (delete x (freevarsExp e))
308 eval (Lam _ e) = evalExp globalEnv env e
310 do env' <- evalVdef globalEnv env vdef
311 evalExp globalEnv env' e
313 evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
314 evalVdef globalEnv env (Nonrec(Vdef((_,x),_,e))) =
315 do v <- suspendExp globalEnv env e
316 return (eextend env (x,v))
317 evalVdef globalEnv env (Rec vdefs) =
318 do vs0 <- mapM preallocate xs
319 let env' = foldl eextend env (zip xs (map Vheap vs0))
320 vs <- suspendExps globalEnv env' es
321 mapM_ reallocate (zip vs0 vs)
324 (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
326 do p <- hallocateE (Hconstr "UGH" [])
328 reallocate (p0,Vheap p) =
331 reallocate (_,_) = error "reallocate: expected a heap value"
332 eval (Case e (x,_) _ alts) =
333 do z <- evalExp globalEnv env e
334 let env' = eextend env (x,z)
337 h <- hlookupE p -- can fail due to black-holing
339 Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
340 _ -> evalDefaultAlt env' alts
342 evalUtupleAlt env' vs (reverse alts)
344 evalLitAlt env' pv (reverse alts)
346 evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
347 evalDcAlt env dcon vs = f
349 f ((Acon (_,dcon') _ xs e):as) =
350 if dcon == dcon' then
352 (foldl eextend env (zip (map fst xs) vs)) e
355 evalExp globalEnv env e
356 f _ = error $ "impossible Case-evalDcAlt"
358 evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
359 evalUtupleAlt env vs [Acon _ _ xs e] =
360 evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
361 evalUtupleAlt _ _ _ = error ("impossible Case: evalUtupleAlt")
363 evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
364 evalLitAlt env pv alts =
367 f ((Alit lit e):as) =
368 let pv' = evalLit lit
370 evalExp globalEnv env e
373 evalExp globalEnv env e
374 f _ = error "impossible Case-evalLitAlt"
376 evalDefaultAlt :: Venv -> [Alt] -> Eval Value
377 evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
378 evalDefaultAlt _ _ = error "evalDefaultAlt: impossible case"
380 eval (Cast e _) = evalExp globalEnv env e
381 eval (Note _ e) = evalExp globalEnv env e
382 eval (External s _) = evalExternal s []
384 evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
385 evalExps globalEnv env = mapM (evalExp globalEnv env)
387 suspendExp:: Menv -> Venv -> Exp -> Eval Value
388 suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
389 suspendExp _ _ (Lit l) = return (Vimm (evalLit l))
390 suspendExp _ env (Lam (Vb(x,_)) e) =
391 do p <- hallocateE (Hclos env' x e)
393 where env' = thin env (delete x (freevarsExp e))
394 suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
395 suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
396 suspendExp globalEnv env (Cast e _) = suspendExp globalEnv env e
397 suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
398 suspendExp _ _ (External s _) = evalExternal s []
400 do p <- hallocateE (Hthunk env' e)
402 where env' = thin env (freevarsExp e)
404 suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
405 suspendExps globalEnv env = mapM (suspendExp globalEnv env)
407 mlookup :: Menv -> Venv -> Mname -> Venv
408 mlookup _ env Nothing = env
409 mlookup globalEnv _ (Just m) =
410 case elookup globalEnv m of
412 Nothing -> error ("Interp: undefined module name: " ++ show m)
414 qlookup :: Menv -> Venv -> (Mname,Var) -> Value
415 qlookup globalEnv env (m,k) =
416 case elookup (mlookup globalEnv env m) k of
418 Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
420 evalPrimop :: Var -> [Value] -> Eval Value
421 evalPrimop "zpzh" = primIntBinop (+)
422 evalPrimop "zpzhzh" = primDoubleBinop (+)
423 evalPrimop "zmzh" = primIntBinop (-)
424 evalPrimop "zmzhzh" = primDoubleBinop (-)
425 evalPrimop "ztzh" = primIntBinop (*)
426 evalPrimop "ztzhzh" = primDoubleBinop (*)
427 evalPrimop "zgzh" = primIntCmpOp (>)
428 evalPrimop "zlzh" = primIntCmpOp (<)
429 evalPrimop "zlzhzh" = primDoubleCmpOp (<)
430 evalPrimop "zezezh" = primIntCmpOp (==)
431 evalPrimop "zlzezh" = primIntCmpOp (<=)
432 evalPrimop "zlzezhzh" = primDoubleCmpOp (<=)
433 evalPrimop "zgzezh" = primIntCmpOp (>=)
434 evalPrimop "zszezh" = primIntCmpOp (/=)
435 evalPrimop "zszhzh" = primDoubleCmpOp (/=)
436 evalPrimop "negateIntzh" = primIntUnop (\ i -> -i)
437 evalPrimop "quotIntzh" = primIntBinop quot
438 evalPrimop "remIntzh" = primIntBinop rem
439 evalPrimop "subIntCzh" = primSubIntC
440 evalPrimop "addIntCzh" = primAddIntC
441 evalPrimop "mulIntMayOflozh" = primIntBinop
443 case (fromIntegral i, fromIntegral j) of
445 case x `mulIntMayOflo#` y of
446 k -> fromIntegral (I# k))
447 evalPrimop "narrow32Intzh" = primIntUnop
449 case fromIntegral i of
450 (I# j) -> case narrow32Int# j of
451 k -> fromIntegral (I# k))
452 evalPrimop "int2Doublezh" = primInt2Double
453 -- single-threaded, so, it's a no-op
454 --evalPrimop "noDuplicatezh" [state] = return state
455 evalPrimop "indexCharOffAddrzh" = primIndexChar
456 evalPrimop "eqCharzh" = primCharCmpOp (==)
457 evalPrimop "leCharzh" = primCharCmpOp (<)
458 evalPrimop "ordzh" = primOrd
459 evalPrimop "chrzh" = primChr
460 evalPrimop "isSpacezh" = primCharUnop isSpace
461 evalPrimop "isAlphazh" = primCharUnop isAlpha
462 evalPrimop "hPutCharzh" = primHPutChar
464 evalPrimop p = error ("undefined primop: " ++ p)
466 primIntUnop :: (Integer -> Integer) -> [Value] -> Eval Value
467 primIntUnop op [Vimm (PIntzh i)] = return (Vimm (PIntzh (op i)))
468 primIntUnop _ _ = error "primIntUnop: wrong number of arguments"
470 primIntBinop :: (Integer -> Integer -> Integer) -> [Value] -> Eval Value
471 primIntBinop op [Vimm (PIntzh i), Vimm (PIntzh j)] =
472 return (Vimm (PIntzh (i `op` j)))
473 primIntBinop _ _ = error "primIntBinop: wrong number of arguments"
475 primDoubleBinop :: (Rational -> Rational -> Rational) -> [Value] -> Eval Value
476 primDoubleBinop op [Vimm (PDoublezh i), Vimm (PDoublezh j)] =
477 return (Vimm (PDoublezh (i `op` j)))
478 primDoubleBinop _ _ = error "primDoubleBinop: wrong number of arguments"
480 primIntCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
481 primIntCmpOp op [Vimm (PIntzh i), Vimm (PIntzh j)] = mkBool (i `op` j)
482 primIntCmpOp _ _ = error "primIntCmpOp: wrong number of arguments"
484 primDoubleCmpOp :: (Rational -> Rational -> Bool) -> [Value] -> Eval Value
485 primDoubleCmpOp op [Vimm (PDoublezh i), Vimm (PDoublezh j)] = mkBool (i `op` j)
486 primDoubleCmpOp _ _ = error "primDoubleCmpOp: wrong number of arguments"
488 primCharCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
489 primCharCmpOp op [Vimm (PCharzh c), Vimm (PCharzh d)] = mkBool (c `op` d)
490 primCharCmpOp _ _ = error "primCharCmpOp: wrong number of arguments"
492 primSubIntC :: [Value] -> Eval Value
493 primSubIntC vs = carryOp subIntC# vs
495 primAddIntC :: [Value] -> Eval Value
496 primAddIntC vs = carryOp addIntC# vs
498 carryOp :: (Int# -> Int# -> (# Int#, Int# #)) -> [Value] -> Eval Value
499 carryOp op [Vimm (PIntzh i1), Vimm (PIntzh i2)] =
500 case (fromIntegral i1, fromIntegral i2) of
501 (I# int1, I# int2) ->
502 case (int1 `op` int2) of
504 return $ Vutuple [Vimm (PIntzh (fromIntegral (I# res1))),
505 Vimm (PIntzh (fromIntegral (I# res2)))]
506 carryOp _ _ = error "carryOp: wrong number of arguments"
508 primInt2Double :: [Value] -> Eval Value
509 primInt2Double [Vimm (PIntzh i)] =
510 return (Vimm (PDoublezh (fromIntegral i)))
511 primInt2Double _ = error "primInt2Double: wrong number of arguments"
513 primOrd :: [Value] -> Eval Value
514 primOrd [Vimm (PCharzh c)] = return $ Vimm (PIntzh c)
515 primOrd _ = error "primOrd: wrong number of arguments"
517 primChr :: [Value] -> Eval Value
518 primChr [Vimm (PIntzh c)] = return $ Vimm (PCharzh c)
519 primChr _ = error "primChr: wrong number of arguments"
521 primCharUnop :: (Char -> Bool) -> [Value] -> Eval Value
522 primCharUnop op [Vimm (PCharzh c)] = mkBool (op (chr (fromIntegral c)))
523 primCharUnop _ _ = error "primCharUnop: wrong number of arguments"
525 primIndexChar :: [Value] -> Eval Value
526 primIndexChar [(Vimm (PString s)), (Vimm (PIntzh i))] =
527 -- String is supposed to be null-terminated, so if i == length(s),
528 -- we return null. (If i > length(s), emit nasal demons.)
529 return $ let len = fromIntegral $ length s in
531 then Vimm (PCharzh (fromIntegral (ord (s !! fromIntegral i))))
533 then Vimm (PCharzh 0)
534 else error "indexCharOffAddr#: index too large"
535 primIndexChar _ = error "primIndexChar: wrong number of arguments"
537 primHPutChar :: [Value] -> Eval Value
538 primHPutChar [Vimm (PIntzh hdl), Vimm (PCharzh c)] =
545 stderr) (chr (fromIntegral c))) >>
547 primHPutChar _ = error "primHPutChar: wrong number of arguments"
549 evalExternal :: String -> [Value] -> Eval Value
551 evalExternal s _ = error $ "evalExternal undefined for now: " ++ show s -- etc.,etc.
553 returnUnit :: Eval Value
555 p <- hallocateE (Hclos eempty "_"
556 (App (App (Dcon (dcUtuple 2)) stateToken) unitCon))
559 evalLit :: Lit -> PrimValue
560 evalLit (Literal l t) =
562 Lint i | (Tcon(_,"Intzh")) <- t -> PIntzh i
563 Lint i | (Tcon(_,"Wordzh")) <- t -> PWordzh i
564 Lint i | (Tcon(_,"Addrzh")) <- t -> PAddrzh i
565 Lint i | (Tcon(_,"Charzh"))<- t -> PCharzh i
566 Lrational r | (Tcon(_,"Floatzh")) <- t -> PFloatzh r
567 Lrational r | (Tcon(_,"Doublezh")) <- t -> PDoublezh r
568 Lchar c | (Tcon(_,"Charzh")) <- t -> PCharzh (toEnum (ord c))
569 Lstring s | (Tcon(_,"Addrzh")) <- t -> PString s
570 -- should really be address of non-heap copy of C-format string s
571 -- tjc: I am ignoring this comment
572 _ -> error ("evalLit: strange combination of literal "
573 ++ show l ++ " and type " ++ show t)
577 mkBool :: Bool -> Eval Value
579 do p <- hallocateE (Hconstr "True" [])
582 do p <- hallocateE (Hconstr "False" [])
585 thin :: Ord a => Env a b -> [a] -> Env a b
586 thin env vars = efilter env (`elem` vars)
588 {- Return the free non-external variables in an expression. -}
590 freevarsExp :: Exp -> [Var]
591 freevarsExp (Var (Nothing,v)) = [v]
592 freevarsExp (Var _) = []
593 freevarsExp (Dcon _) = []
594 freevarsExp (Lit _) = []
595 freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
596 freevarsExp (Appt e _) = freevarsExp e
597 freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
598 freevarsExp (Lam _ e) = freevarsExp e
599 freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
600 where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
601 where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
602 freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
603 freevarsExp (Case e (v,_) _ as) = freevarsExp e `union` [v] `union` freevarsAlts as
604 where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
605 freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
606 freevarsAlt (Alit _ e) = freevarsExp e
607 freevarsAlt (Adefault e) = freevarsExp e
608 freevarsExp (Cast e _) = freevarsExp e
609 freevarsExp (Note _ e) = freevarsExp e
610 freevarsExp (External _ _) = []
613 stateToken = Var (qual primMname "realWorldzh")
616 unitCon = Dcon (qual baseMname "Z0T")