@@ -20,6 +20,7 @@ data BAtom = BP Name | BL Local | BC Const
2020
2121data Bytecode = BAtom BAtom
2222 | BApp BAtom [BAtom]
23+ | BTailApp BAtom [BAtom]
2324 | BLazy BAtom [BAtom]
2425 | BLet Local Bytecode Bytecode
2526 | BEval Local Bytecode
@@ -43,7 +44,7 @@ bcdefs = map (\ (n, s) -> (n, bc s))
4344bc (SCDef args max c) = GetArgs (map fst args) (bcExp max (length args) c)
4445
4546bcExp v arity x
46− = let (code, max) = runState (bc' x) v
47+ = let (code, max) = runState (bc' True x) v
4748 space = max - arity in
4849 if (space > 0) then Reserve space code else code
4950 where
@@ -53,31 +54,34 @@ bcExp v arity x
5354 put (s + 1)
5455 return s
5556
56− bc' :: SCExp -> State Int Bytecode
57− bc' (SRef n) = return $ BAtom (BP n)
58− bc' (SLoc i) = do ref i; return $ BAtom (BL i)
59− bc' (SApp f args) = do f' <- bc' f
60− args' <- mapM bc' args
61− case f' of
62− BAtom r -> mkApp (\x -> BApp r x) args' []
63− bc -> do v <- next
64− mkApp (\x -> BLet v bc (BApp (BL v) x)) args' []
65− bc' (SLazyApp f args) = do args' <- mapM bc' args
66− mkApp (\x -> BApp (BP f) x) args' []
67− bc' (SCon t args) = do args' <- mapM bc' args
68− mkApp (\x -> BCon t x) args' []
69− bc' (SFCall c t args) = do args' <- mapM bc' (map fst args)
70− mkFApp c t (zip args' (map snd args)) []
71− bc' (SConst c) = return $ BAtom (BC c)
72− bc' (SError s) = return $ BError s
73− bc' (SCase e alts) = do e' <- bc' e
74− alts' <- mapM bcAlt alts
75− case e' of
76− BAtom (BL i) -> return $ BCase i alts'
77− bc -> do v <- next
78− return $ BLet v bc (BCase v alts')
79− bc' (SPrimOp p args) = do args' <- mapM bc' args
80− mkApp (\x -> BPrimOp p x) args' []
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
63+ let bapp = if tl then BTailApp else BApp
64+ case f' of
65+ BAtom r -> mkApp (\x -> bapp r x) args' []
66+ bc -> do v <- next
67+ 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' []
8185
8286 mkApp ap [] locs = return $ ap locs
8387 mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])
@@ -85,12 +89,12 @@ bcExp v arity x
8589 app <- mkApp ap as (locs ++ [BL v])
8690 return $ BLet v a app
8791
88− bcAlt (SConCase t args e) = do e' <- bc' e
89− return $ BConCase t args e'
90− bcAlt (SConstCase i e) = do e' <- bc' e
91− return $ BConstCase i e'
92− bcAlt (SDefaultCase e) = do e' <- bc' e
93− return $ BDefaultCase e'
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'
9498
9599 mkFApp c ty [] locs = return $ BFCall c ty locs
96100 mkFApp c ty ((BAtom (BL i), t) : as) locs = mkFApp c ty as (locs ++ [(BL i, t)])