@@ -20,6 +20,7 @@ data BAtom = BP Name | BL Local | BC Const
21data Bytecode = BAtom BAtom
21data Bytecode = BAtom BAtom
22 | BApp BAtom [BAtom]
22 | BApp BAtom [BAtom]
23+ | BTailApp BAtom [BAtom]
23 | BLazy BAtom [BAtom]
24 | BLazy BAtom [BAtom]
24 | BLet Local Bytecode Bytecode
25 | BLet Local Bytecode Bytecode
25 | BEval Local Bytecode
26 | BEval Local Bytecode
@@ -43,7 +44,7 @@ bcdefs = map (\ (n, s) -> (n, bc s))
43bc (SCDef args max c) = GetArgs (map fst args) (bcExp max (length args) c)
44bc (SCDef args max c) = GetArgs (map fst args) (bcExp max (length args) c)
45bcExp v arity x
46bcExp v arity x
46− = let (code, max) = runState (bc' x) v
47+ = let (code, max) = runState (bc' True x) v
47 space = max - arity in
48 space = max - arity in
48 if (space > 0) then Reserve space code else code
49 if (space > 0) then Reserve space code else code
@@ -53,31 +54,34 @@ bcExp v arity x
53 put (s + 1)
54 put (s + 1)
56− bc' :: SCExp -> State Int Bytecode
57+ bc' :: Bool -> SCExp -> State Int Bytecode
57− bc' (SRef n) = return $ BAtom (BP n)
58+ bc' tl (SRef n) = return $ BAtom (BP n)
58− bc' (SLoc i) = do ref i; return $ BAtom (BL i)
59+ bc' tl (SLoc i) = do ref i; return $ BAtom (BL i)
59− bc' (SApp f args) = do f' <- bc' f
60+ bc' tl (SApp f args)
61+ = do f' <- bc' False f
60− args' <- mapM bc' args
62+ args' <- mapM (bc' False) args
63+ let bapp = if tl then BTailApp else BApp
61− case f' of
64+ case f' of
62− BAtom r -> mkApp (\x -> BApp r x) args' []
65+ BAtom r -> mkApp (\x -> bapp r x) args' []
63− bc -> do v <- next
66+ bc -> do v <- next
64− mkApp (\x -> BLet v bc (BApp (BL v) x)) args' []
67+ mkApp (\x -> BLet v bc (bapp (BL v) x)) args' []
65− bc' (SLazyApp f args) = do args' <- mapM bc' args
68+ bc' tl (SLazyApp f args) = do args' <- mapM (bc' False) args
69+ let bapp = if tl then BTailApp else BApp
66− mkApp (\x -> BApp (BP f) x) args' []
70+ mkApp (\x -> bapp (BP f) x) args' []
67− bc' (SCon t args) = do args' <- mapM bc' args
71+ bc' tl (SCon t args) = do args' <- mapM (bc' False) args
68− mkApp (\x -> BCon t x) args' []
72+ mkApp (\x -> BCon t x) args' []
69− bc' (SFCall c t args) = do args' <- mapM bc' (map fst args)
73+ bc' tl (SFCall c t args) = do args' <- mapM (bc' False) (map fst args)
70− mkFApp c t (zip args' (map snd args)) []
74+ mkFApp c t (zip args' (map snd args)) []
71− bc' (SConst c) = return $ BAtom (BC c)
75+ bc' tl (SConst c) = return $ BAtom (BC c)
72− bc' (SError s) = return $ BError s
76+ bc' tl (SError s) = return $ BError s
73− bc' (SCase e alts) = do e' <- bc' e
77+ bc' tl (SCase e alts) = do e' <- bc' False e
74− alts' <- mapM bcAlt alts
78+ alts' <- mapM (bcAlt tl) alts
75− case e' of
79+ case e' of
76− BAtom (BL i) -> return $ BCase i alts'
80+ BAtom (BL i) -> return $ BCase i alts'
77− bc -> do v <- next
81+ bc -> do v <- next
78− return $ BLet v bc (BCase v alts')
82+ return $ BLet v bc (BCase v alts')
79− bc' (SPrimOp p args) = do args' <- mapM bc' args
83+ bc' tl (SPrimOp p args) = do args' <- mapM (bc' tl) args
80− mkApp (\x -> BPrimOp p x) args' []
84+ mkApp (\x -> BPrimOp p x) args' []
82 mkApp ap [] locs = return $ ap locs
86 mkApp ap [] locs = return $ ap locs
83 mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])
87 mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])
@@ -85,12 +89,12 @@ bcExp v arity x
85 app <- mkApp ap as (locs ++ [BL v])
89 app <- mkApp ap as (locs ++ [BL v])
86 return $ BLet v a app
90 return $ BLet v a app
88− bcAlt (SConCase t args e) = do e' <- bc' e
92+ bcAlt tl (SConCase t args e) = do e' <- bc' tl e
89− return $ BConCase t args e'
93+ return $ BConCase t args e'
90− bcAlt (SConstCase i e) = do e' <- bc' e
94+ bcAlt tl (SConstCase i e) = do e' <- bc' tl e
91− return $ BConstCase i e'
95+ return $ BConstCase i e'
92− bcAlt (SDefaultCase e) = do e' <- bc' e
96+ bcAlt tl (SDefaultCase e) = do e' <- bc' tl e
93− return $ BDefaultCase e'
97+ return $ BDefaultCase e'
95 mkFApp c ty [] locs = return $ BFCall c ty locs
99 mkFApp c ty [] locs = return $ BFCall c ty locs
96 mkFApp c ty ((BAtom (BL i), t) : as) locs = mkFApp c ty as (locs ++ [(BL i, t)])
100 mkFApp c ty ((BAtom (BL i), t) : as) locs = mkFApp c ty as (locs ++ [(BL i, t)])