@@ -23,17 +23,16 @@ data Bytecode = BAtom BAtom
2323 | BTailApp BAtom [BAtom]
2424 | BLazy BAtom [BAtom]
2525 | BLet Local Bytecode Bytecode
26− | BEval Local Bytecode
2726 | BFCall String CType [(BAtom, CType)]
2827 | BCon Tag [BAtom]
2928 | BCase Local [BAlt]
3029 | BPrimOp SPrim [BAtom]
3130 | BError String
32− | GetArgs [Name] Bytecode -- get function arguments
33− | Reserve Int Bytecode -- reserve stack space, clear on exit
31+ | BGetArgs [Name] Bytecode -- get function arguments
32+ | BReserve Int Bytecode -- reserve stack space, clear on exit
3433 deriving Show
3534
36−data BAlt = BConCase Tag [Name] Bytecode
35+data BAlt = BConCase Tag [Name] Int Bytecode
3736 | BConstCase Const Bytecode
3837 | BDefaultCase Bytecode
3938 deriving Show
@@ -41,12 +40,12 @@ data BAlt = BConCase Tag [Name] Bytecode
4140bcdefs :: [(Name, SCDef)] -> [(Name, Bytecode)]
4241bcdefs = map (\ (n, s) -> (n, bc s))
4342
44−bc (SCDef args max c) = GetArgs (map fst args) (bcExp max (length args) c)
43+bc (SCDef args max c) = BGetArgs (map fst args) (bcExp max (length args) c)
4544
4645bcExp v arity x
47− = let (code, max) = runState (bc' True x) v
46+ = let (code, max) = runState (bc' True arity x) v
4847 space = max - arity in
49− if (space > 0) then Reserve space code else code
48+ if (space > 0) then BReserve space code else code
5049 where
5150 ref i = do s <- get
5251 when (i > s) $ put i
@@ -54,34 +53,37 @@ bcExp v arity x
5453 put (s + 1)
5554 return s
5655
57− bc' :: Bool -> SCExp -> State Int Bytecode
58− bc' tl (SRef n) = return $ BAtom (BP n)
59− bc' tl (SLoc i) = do ref i; return $ BAtom (BL i)
60− bc' tl (SApp f args)
61− = do f' <- bc' False f
62− args' <- mapM (bc' False) args
56+ bc' :: Bool -> Int -> SCExp -> State Int Bytecode
57+ bc' tl d (SRef n) = return $ BAtom (BP n)
58+ bc' tl d (SLoc i) = do ref i; return $ BAtom (BL i)
59+ bc' tl d (SApp f args)
60+ = do f' <- bc' False d f
61+ args' <- mapM (bc' False d) args
6362 let bapp = if tl then BTailApp else BApp
6463 case f' of
6564 BAtom r -> mkApp (\x -> bapp r x) args' []
6665 bc -> do v <- next
6766 mkApp (\x -> BLet v bc (bapp (BL v) x)) args' []
68− bc' tl (SLazyApp f args) = do args' <- mapM (bc' False) args
69− let bapp = if tl then BTailApp else BApp
70− mkApp (\x -> bapp (BP f) x) args' []
71− bc' tl (SCon t args) = do args' <- mapM (bc' False) args
72− mkApp (\x -> BCon t x) args' []
73− bc' tl (SFCall c t args) = do args' <- mapM (bc' False) (map fst args)
74− mkFApp c t (zip args' (map snd args)) []
75− bc' tl (SConst c) = return $ BAtom (BC c)
76− bc' tl (SError s) = return $ BError s
77− bc' tl (SCase e alts) = do e' <- bc' False e
78− alts' <- mapM (bcAlt tl) alts
79− case e' of
80− BAtom (BL i) -> return $ BCase i alts'
81− bc -> do v <- next
82− return $ BLet v bc (BCase v alts')
83− bc' tl (SPrimOp p args) = do args' <- mapM (bc' tl) args
84− mkApp (\x -> BPrimOp p x) args' []
67+ bc' tl d (SLazyApp f args) = do args' <- mapM (bc' False d) args
68+ let bapp = if tl then BTailApp else BApp
69+ mkApp (\x -> bapp (BP f) x) args' []
70+ bc' tl d (SLet n val sc) = do v' <- bc' False d val
71+ sc' <- bc' False (d + 1) sc
72+ return $ BLet d v' sc'
73+ bc' tl d (SCon t args) = do args' <- mapM (bc' False d) args
74+ mkApp (\x -> BCon t x) args' []
75+ bc' tl d (SFCall c t args) = do args' <- mapM (bc' False d) (map fst args)
76+ mkFApp c t (zip args' (map snd args)) []
77+ bc' tl d (SConst c) = return $ BAtom (BC c)
78+ bc' tl d (SError s) = return $ BError s
79+ bc' tl d (SCase e alts) = do e' <- bc' False d e
80+ alts' <- mapM (bcAlt tl d) alts
81+ case e' of
82+ BAtom (BL i) -> return $ BCase i alts'
83+ bc -> do v <- next
84+ return $ BLet v bc (BCase v alts')
85+ bc' tl d (SPrimOp p args) = do args' <- mapM (bc' tl d) args
86+ mkApp (\x -> BPrimOp p x) args' []
8587
8688 mkApp ap [] locs = return $ ap locs
8789 mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])
@@ -89,16 +91,18 @@ bcExp v arity x
8991 app <- mkApp ap as (locs ++ [BL v])
9092 return $ BLet v a app
9193
92− bcAlt tl (SConCase t args e) = do e' <- bc' tl e
93− return $ BConCase t args e'
94− bcAlt tl (SConstCase i e) = do e' <- bc' tl e
95− return $ BConstCase i e'
96− bcAlt tl (SDefaultCase e) = do e' <- bc' tl e
97− return $ BDefaultCase e'
94+ bcAlt tl d (SConCase t args e) = do e' <- bc' tl (d + length args) e
95+ return $ BConCase t args d e'
96+ bcAlt tl d (SConstCase i e) = do e' <- bc' tl d e
97+ return $ BConstCase i e'
98+ bcAlt tl d (SDefaultCase e) = do e' <- bc' tl d e
99+ return $ BDefaultCase e'
98100
99101 mkFApp c ty [] locs = return $ BFCall c ty locs
100− mkFApp c ty ((BAtom (BL i), t) : as) locs = mkFApp c ty as (locs ++ [(BL i, t)])
101− mkFApp c ty ((a, t) : as) locs = do v <- next
102− app <- mkFApp c ty as (locs ++ [(BL v, t)])
103− return $ BLet v a app
102+ mkFApp c ty ((BAtom (BL i), t) : as) locs
103+ = mkFApp c ty as (locs ++ [(BL i, t)])
104+ mkFApp c ty ((a, t) : as) locs
105+ = do v <- next
106+ app <- mkFApp c ty as (locs ++ [(BL v, t)])
107+ return $ BLet v a app
104108