@@ -5,8 +5,19 @@ import IRTS.Simplified
55import Core.TT
66import Data.Maybe
77
8−-- TODO: Need L to refer from the bottom of the current stack frame,
9−-- T from the top.
8+{- We have:
9+
10+BASE: Current stack frame's base
11+TOP: Top of stack
12+OLDBASE: Passed in to each function, the previous stack frame's base
13+
14+L i refers to the stack item at BASE + i
15+T i refers to the stack item at TOP + i
16+
17+RVal is a register in which computed values (essentially, what a function
18+returns) are stored.
19+
20+-}
1021
1122data Reg = RVal | L Int | T Int
1223 deriving (Show, Eq)
@@ -17,39 +28,49 @@ data BC = ASSIGN Reg Reg
1728 | CASE Reg [(Int, [BC])] (Maybe [BC])
1829 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
1930 | GETARGS Int -- discards afterwards
20− | CONSTCASE [(Const, [BC])] (Maybe [BC])
31+ | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
2132 | CALL Name
2233 | TAILCALL Name
23− | PRINTNUM
24− | PRINTSTR
25− | GROWSTACK Int
26− | DROPSTACK Int
27− | SLIDE Int Int -- number to drop, number to keep
34+ | SLIDE Int -- move this number from TOP to BASE
35+ | REBASE -- set BASE = OLDBASE
36+ | RESERVE Int -- reserve n more stack items
37+ -- (i.e. check there's space, grow if necessary)
38+ | ADDTOP Int -- move the top of stack up
39+ | TOPBASE Int -- set TOP = BASE + n
40+ | BASETOP Int -- set BASE = TOP + n
41+ | STOREOLD -- set OLDBASE = BASE
2842 | OP Reg PrimFn [Reg]
2943 deriving Show
3044
3145toBC :: (Name, SDecl) -> (Name, [BC])
3246toBC (n, SFun n' args locs exp)
33− = (n, GROWSTACK locs : bc RVal exp (length args + locs))
34−
35−clean 0 = []
36−clean c = [DROPSTACK c]
37−
38−bc :: Reg -> SExp -> Int -> [BC]
39−bc reg (SV (Glob n)) c = [CALL n] ++ assign reg RVal ++ clean c
40−bc reg (SV (Loc i)) c = assign reg (L i) ++ clean c
41−bc reg (SApp tc f vs) c
42− = GROWSTACK (length vs) : moveReg (c + length vs) vs
43− ++ [CALL f] ++ assign reg RVal ++ clean c
44−bc reg (SLet (Loc i) e sc) c = bc (L i) e 0 ++ bc reg sc c
45−bc reg (SCon i _ vs) c = MKCON reg i (map getL vs) : clean c
47+ = (n, reserve locs ++ bc RVal exp True)
48+ where reserve 0 = []
49+ reserve n = [RESERVE n, ADDTOP n]
50+
51+clean True = [TOPBASE 0, REBASE]
52+clean False = []
53+
54+bc :: Reg -> SExp -> Bool -> -- returning
55+ [BC]
56+bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
57+bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
58+bc reg (SApp False f vs) r
59+ = RESERVE (length vs) : moveReg 0 vs
60+ ++ [STOREOLD, BASETOP 0, ADDTOP (length vs), CALL f] ++
61+ assign reg RVal ++ clean r
62+bc reg (SApp True f vs) r
63+ = RESERVE (length vs) : moveReg 0 vs
64+ ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
65+bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
66+bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
4667 where getL (Loc x) = L x
47−bc reg (SConst i) c = ASSIGNCONST reg i : clean c
48−bc reg (SOp p vs) c = OP reg p (map getL vs) : clean c
68+bc reg (SConst i) r = ASSIGNCONST reg i : clean r
69+bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
4970 where getL (Loc x) = L x
50−bc reg (SCase (Loc l) alts) c
51− | isConst alts = undefined -- constCase reg c l alts
52− | otherwise = conCase reg c (L l) alts : clean c
71+bc reg (SCase (Loc l) alts) r
72+ | isConst alts = constCase reg (L l) alts r
73+ | otherwise = conCase reg (L l) alts r
5374
5475isConst [] = False
5576isConst (SConstCase _ _ : xs) = True
@@ -57,15 +78,27 @@ isConst (SConCase _ _ _ _ _ : xs) = False
5778isConst (_ : xs) = False
5879
5980moveReg off [] = []
60−moveReg off (Loc x : xs) = assign (L off) (L x) ++ moveReg (off + 1) xs
81+moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs
6182
6283assign r1 r2 | r1 == r2 = []
6384 | otherwise = [ASSIGN r1 r2]
6485
65−conCase reg c l xs = CASE l (mapMaybe (caseAlt l reg c) xs)
66− Nothing
86+conCase reg l xs r = [CASE l (mapMaybe (caseAlt l reg r) xs)
87+ (defaultAlt reg xs r)]
88+
89+constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
90+ (defaultAlt reg xs r)]
91+
92+caseAlt l reg r (SConCase lvar tag _ args e)
93+ = Just (tag, PROJECT l lvar (length args) : bc reg e r)
94+caseAlt l reg r _ = Nothing
95+
96+constAlt l reg r (SConstCase c e)
97+ = Just (c, bc reg e r)
98+constAlt l reg r _ = Nothing
99+
100+defaultAlt reg [] r = Nothing
101+defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r)
102+defaultAlt reg (_ : xs) r = defaultAlt reg xs r
67103
68−caseAlt l reg c (SConCase lvar tag _ args e)
69− = Just (tag, PROJECT l lvar (length args) : bc reg e c)
70−caseAlt l reg c _ = Nothing
71104