@@ -8,7 +8,7 @@ import IRTS.Simplified
88import Core.TT
99import Data.Maybe
1010
11−{- We have:
11+{- We have:
1212
1313BASE: Current stack frame's base
1414TOP: Top of stack
@@ -32,14 +32,14 @@ data BC = ASSIGN Reg Reg
3232 | CASE Bool -- definitely a constructor, no need to check, if true
3333 Reg [(Int, [BC])] (Maybe [BC])
3434 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
35− | PROJECTINTO Reg Reg Int -- project argument from one reg into another
35+ | PROJECTINTO Reg Reg Int -- project argument from one reg into another
3636 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
3737 | CALL Name
3838 | TAILCALL Name
39− | FOREIGNCALL Reg FLang FType String [(FType, Reg)]
40− | SLIDE Int -- move this number from TOP to BASE
39+ | FOREIGNCALL Reg FLang FType String [(FType, Reg)]
40+ | SLIDE Int -- move this number from TOP to BASE
4141 | REBASE -- set BASE = OLDBASE
42− | RESERVE Int -- reserve n more stack items
42+ | RESERVE Int -- reserve n more stack items
4343 -- (i.e. check there's space, grow if necessary)
4444 | ADDTOP Int -- move the top of stack up
4545 | TOPBASE Int -- set TOP = BASE + n
@@ -51,7 +51,7 @@ data BC = ASSIGN Reg Reg
5151 deriving Show
5252
5353toBC :: (Name, SDecl) -> (Name, [BC])
54−toBC (n, SFun n' args locs exp)
54+toBC (n, SFun n' args locs exp)
5555 = (n, reserve locs ++ bc RVal exp True)
5656 where reserve 0 = []
5757 reserve n = [RESERVE n, ADDTOP n]
@@ -63,10 +63,14 @@ bc :: Reg -> SExp -> Bool -> -- returning
6363 [BC]
6464bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
6565bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
66−bc reg (SApp False f vs) r
67− = RESERVE (length vs) : moveReg 0 vs
68− ++ [STOREOLD, BASETOP 0, ADDTOP (length vs), CALL f] ++
69− assign reg RVal ++ clean r
66+bc reg (SApp False f vs) r =
67+ if argCount == 0
68+ then moveReg 0 vs ++ [STOREOLD, BASETOP 0, CALL f] ++ ret
69+ else RESERVE argCount : moveReg 0 vs ++
70+ [STOREOLD, BASETOP 0, ADDTOP argCount, CALL f] ++ ret
71+ where
72+ ret = assign reg RVal ++ clean r
73+ argCount = length vs
7074bc reg (SApp True f vs) r
7175 = RESERVE (length vs) : moveReg 0 vs
7276 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
@@ -78,16 +82,16 @@ bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]
7882 ++ clean r
7983bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
8084 where getL (Loc x) = L x
81−bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r
85+bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r
8286bc reg (SConst i) r = ASSIGNCONST reg i : clean r
8387bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
8488 where getL (Loc x) = L x
8589bc reg (SError str) r = [ERROR str]
8690bc reg SNothing r = NULL reg : clean r
87−bc reg (SCase (Loc l) alts) r
91+bc reg (SCase (Loc l) alts) r
8892 | isConst alts = constCase reg (L l) alts r
8993 | otherwise = conCase True reg (L l) alts r
90−bc reg (SChkCase (Loc l) alts) r
94+bc reg (SChkCase (Loc l) alts) r
9195 = conCase False reg (L l) alts r
9296
9397isConst [] = False
@@ -107,12 +111,12 @@ conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)
107111constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
108112 (defaultAlt reg xs r)]
109113
110−caseAlt l reg r (SConCase lvar tag _ args e)
111− = Just (tag, PROJECT l lvar (length args) : bc reg e r)
114+caseAlt l reg r (SConCase lvar tag _ args e)
115+ = Just (tag, PROJECT l lvar (length args) : bc reg e r)
112116caseAlt l reg r _ = Nothing
113117
114−constAlt l reg r (SConstCase c e)
115− = Just (c, bc reg e r)
118+constAlt l reg r (SConstCase c e)
119+ = Just (c, bc reg e r)
116120constAlt l reg r _ = Nothing
117121
118122defaultAlt reg [] r = Nothing