-evalExp globalEnv env (Var qv) =
- let v = qlookup globalEnv env qv
- in case v of
- Vheap p ->
- do z <- hlookupE p -- can fail due to black-holing
- case z of
- Hthunk env' e ->
- do hremoveE p -- black-hole
- w@(Vheap p') <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
- h <- hlookupE p'
- hupdateE p h
- return w
- _ -> return v -- return pointer to Hclos or Hconstr
- _ -> return v -- return Vimm or Vutuple
-evalExp globalEnv env (Lit l) = return (Vimm (evalLit l))
-evalExp globalEnv env (Dcon (_,c)) =
- do p <- hallocateE (Hconstr c [])
- return (Vheap p)
-
-evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
- where
- evalApp :: Venv -> Exp -> [Exp] -> Eval Value
- evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
- evalApp env (op @(Dcon (qdc@(m,c)))) es =
- do vs <- suspendExps globalEnv env es
- if isUtupleDc qdc then
- return (Vutuple vs)
- else
- {- allocate a thunk -}
- do p <- hallocateE (Hconstr c vs)
- return (Vheap p)
- evalApp env (op @ (Var(v@(_,p)))) es | isPrimVar v =
- do vs <- evalExps globalEnv env es
- case (p,vs) of
- ("raisezh",[exn]) -> raiseE exn
- ("catchzh",[body,handler,rws]) ->
- catchE (apply body [rws])
- (\exn -> apply handler [exn,rws])
- _ -> evalPrimop p vs
- evalApp env (External s _) es =
- do vs <- evalExps globalEnv env es
- evalExternal s vs
- evalApp env (Appt e _) es = evalApp env e es
- evalApp env (Lam (Tb _) e) es = evalApp env e es
- evalApp env (Cast e _) es = evalApp env e es
- evalApp env (Note _ e) es = evalApp env e es
- evalApp env e es =
- {- e must now evaluate to a closure -}
- do vs <- suspendExps globalEnv env es
- vop <- evalExp globalEnv env e
- apply vop vs
-
- apply :: Value -> [Value] -> Eval Value
- apply vop [] = return vop
- apply (Vheap p) (v:vs) =
- do Hclos env' x b <- hlookupE p
- v' <- evalExp globalEnv (eextend env' (x,v)) b
- apply v' vs
-
-
-evalExp globalEnv env (Appt e _) = evalExp globalEnv env e
-evalExp globalEnv env (Lam (Vb(x,_)) e) =
- do p <- hallocateE (Hclos env' x e)
- return (Vheap p)
- where env' = thin env (delete x (freevarsExp e))
-evalExp globalEnv env (Lam _ e) = evalExp globalEnv env e
-evalExp globalEnv env (Let vdef e) =
- do env' <- evalVdef globalEnv env vdef
- evalExp globalEnv env' e
- where
- evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
- evalVdef globalEnv env (Nonrec(Vdef((m,x),t,e))) =
- do v <- suspendExp globalEnv env e
- return (eextend env (x,v))
- evalVdef globalEnv env (Rec vdefs) =
- do vs0 <- mapM preallocate xs
- let env' = foldl eextend env (zip xs vs0)
- vs <- suspendExps globalEnv env' es
- mapM_ reallocate (zip vs0 vs)
- return env'
- where
- (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
- preallocate _ =
- do p <- hallocateE (Hconstr "UGH" [])
- return (Vheap p)
- reallocate (Vheap p0,Vheap p) =
- do h <- hlookupE p
- hupdateE p0 h
-
-evalExp globalEnv env (Case e (x,_) _ alts) =
- do z <- evalExp globalEnv env e
- let env' = eextend env (x,z)
- case z of
- Vheap p ->
- do h <- hlookupE p -- can fail due to black-holing
- case h of
- Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
- _ -> evalDefaultAlt env' alts
- Vutuple vs ->
- evalUtupleAlt env' vs (reverse alts)
- Vimm pv ->
- evalLitAlt env' pv (reverse alts)
- where
- evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
- evalDcAlt env dcon vs alts =
- f alts
- where
- f ((Acon (_,dcon') _ xs e):as) =
- if dcon == dcon' then
- evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
- else f as
- f [Adefault e] =
- evalExp globalEnv env e
- f _ = error "impossible Case-evalDcAlt"
-
- evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
- evalUtupleAlt env vs [Acon _ _ xs e] =
- evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
-
- evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
- evalLitAlt env pv alts =
- f alts
- where
- f ((Alit lit e):as) =
- let pv' = evalLit lit
- in if pv == pv' then
- evalExp globalEnv env e
- else f as
- f [Adefault e] =
- evalExp globalEnv env e
- f _ = error "impossible Case-evalLitAlt"
+evalExp globalEnv env = eval
+ where eval (Var qv) =
+ let v = qlookup globalEnv env qv
+ in case v of
+ Vheap p -> do
+ z <- hlookupE p -- can fail due to black-holing
+ case z of
+ Hthunk env' e -> do
+ hremoveE p -- black-hole
+ w <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
+ case w of
+ Vheap p' -> do
+ h <- hlookupE p'
+ hupdateE p h
+ return w
+ _ -> error ("eval: w was not boxed: " ++ show w)
+ _ -> return v -- return pointer to Hclos or Hconstr
+ _ -> return v -- return Vimm or Vutuple
+ eval (Lit l) = return (Vimm (evalLit l))
+ eval (Dcon (_,c)) = do
+ p <- hallocateE (Hconstr c [])
+ return (Vheap p)
+ eval (App e1 e2) =
+ evalApp env e1 [e2]
+ where
+ evalApp :: Venv -> Exp -> [Exp] -> Eval Value
+ evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
+ evalApp env (Dcon (qdc@(_,c))) es =
+ do vs <- suspendExps globalEnv env es
+ if isUtupleDc qdc
+ then
+ return (Vutuple vs)
+ else
+ {- allocate a thunk -}
+ do p <- hallocateE (Hconstr c vs)
+ return (Vheap p)
+ evalApp env (Var(v@(_,p))) es | isPrimVar v =
+ do vs <- evalExps globalEnv env es
+ case (p,vs) of
+ ("raisezh",[exn]) -> raiseE exn
+ ("catchzh",[body,handler,rws]) ->
+ catchE (apply body [rws])
+ (\exn -> apply handler [exn,rws])
+ _ -> evalPrimop p vs
+ evalApp env (External s _) es =
+ do vs <- evalExps globalEnv env es
+ evalExternal s vs
+ evalApp env (Appt e _) es = evalApp env e es
+ evalApp env (Lam (Tb _) e) es = evalApp env e es
+ evalApp env (Cast e _) es = evalApp env e es
+ evalApp env (Note _ e) es = evalApp env e es
+ evalApp env e es =
+ {- e must now evaluate to a closure -}
+ do vs <- suspendExps globalEnv env es
+ vop <- evalExp globalEnv env e
+ apply vop vs
+
+ apply :: Value -> [Value] -> Eval Value
+ apply vop [] = return vop
+ apply (Vheap p) (v:vs) =
+ do Hclos env' x b <- hlookupE p
+ v' <- evalExp globalEnv (eextend env' (x,v)) b
+ apply v' vs
+ apply _ _ = error ("apply: operator is not a closure")
+
+ eval (Appt e _) = evalExp globalEnv env e
+ eval (Lam (Vb(x,_)) e) = do
+ p <- hallocateE (Hclos env' x e)
+ return (Vheap p)
+ where env' = thin env (delete x (freevarsExp e))
+ eval (Lam _ e) = evalExp globalEnv env e
+ eval (Let vdef e) =
+ do env' <- evalVdef globalEnv env vdef
+ evalExp globalEnv env' e
+ where
+ evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
+ evalVdef globalEnv env (Nonrec(Vdef((_,x),_,e))) =
+ do v <- suspendExp globalEnv env e
+ return (eextend env (x,v))
+ evalVdef globalEnv env (Rec vdefs) =
+ do vs0 <- mapM preallocate xs
+ let env' = foldl eextend env (zip xs (map Vheap vs0))
+ vs <- suspendExps globalEnv env' es
+ mapM_ reallocate (zip vs0 vs)
+ return env'
+ where
+ (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
+ preallocate _ =
+ do p <- hallocateE (Hconstr "UGH" [])
+ return p
+ reallocate (p0,Vheap p) =
+ do h <- hlookupE p
+ hupdateE p0 h
+ reallocate (_,_) = error "reallocate: expected a heap value"
+ eval (Case e (x,_) _ alts) =
+ do z <- evalExp globalEnv env e
+ let env' = eextend env (x,z)
+ case z of
+ Vheap p -> do
+ h <- hlookupE p -- can fail due to black-holing
+ case h of
+ Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
+ _ -> evalDefaultAlt env' alts
+ Vutuple vs ->
+ evalUtupleAlt env' vs (reverse alts)
+ Vimm pv ->
+ evalLitAlt env' pv (reverse alts)
+ where
+ evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
+ evalDcAlt env dcon vs = f
+ where
+ f ((Acon (_,dcon') _ xs e):as) =
+ if dcon == dcon' then
+ evalExp globalEnv
+ (foldl eextend env (zip (map fst xs) vs)) e
+ else f as
+ f [Adefault e] =
+ evalExp globalEnv env e
+ f _ = error $ "impossible Case-evalDcAlt"
+
+ evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
+ evalUtupleAlt env vs [Acon _ _ xs e] =
+ evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
+ evalUtupleAlt _ _ _ = error ("impossible Case: evalUtupleAlt")
+
+ evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
+ evalLitAlt env pv alts =
+ f alts
+ where
+ f ((Alit lit e):as) =
+ let pv' = evalLit lit
+ in if pv == pv' then
+ evalExp globalEnv env e
+ else f as
+ f [Adefault e] =
+ evalExp globalEnv env e
+ f _ = error "impossible Case-evalLitAlt"