git.iko.soy/Idris-dev
on master help sign in
Deal with applications and stack management in bytecode
1a7ae4dEdwin Brady
iif/testvm.iif+6−1
compare with master
unifiedsplit
@@ -3,7 +3,7 @@ data S 1
3
3
4fun plus(x, y) = case x of {
4fun plus(x, y) = case x of {
5 O => y
5 O => y
6− | S(k) => S(plus(k, y))
6+ | S(k) => S (plus(k, y))
7 }
7 }
8
8
9fun natToInt(x) = case x of {
9fun natToInt(x) = case x of {
@@ -11,4 +11,9 @@ fun natToInt(x) = case x of {
11 | S(k) => let y = natToInt(k) in y + 1
11 | S(k) => let y = natToInt(k) in y + 1
12 }
12 }
13
13
14+fun intToNat(x) = case x of {
15+ 0 => O
16+ | _ => S (intToNat (x - 1))
17+ }
18+
14fun main() = printNum(natToInt(plus(S(S(O)), S(S(O)))))
19fun main() = printNum(natToInt(plus(S(S(O)), S(S(O)))))
src/IRTS/Bytecode.hs+65−32
@@ -5,8 +5,19 @@ import IRTS.Simplified
5import Core.TT
5import Core.TT
6import Data.Maybe
6import Data.Maybe
7
7
8−-- TODO: Need L to refer from the bottom of the current stack frame,
8+{- We have:
9−-- T from the top.
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+-}
10
21
11data Reg = RVal | L Int | T Int
22data Reg = RVal | L Int | T Int
12 deriving (Show, Eq)
23 deriving (Show, Eq)
@@ -17,39 +28,49 @@ data BC = ASSIGN Reg Reg
17 | CASE Reg [(Int, [BC])] (Maybe [BC])
28 | CASE Reg [(Int, [BC])] (Maybe [BC])
18 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
29 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
19 | GETARGS Int -- discards afterwards
30 | GETARGS Int -- discards afterwards
20− | CONSTCASE [(Const, [BC])] (Maybe [BC])
31+ | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
21 | CALL Name
32 | CALL Name
22 | TAILCALL Name
33 | 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
28 | OP Reg PrimFn [Reg]
42 | OP Reg PrimFn [Reg]
29 deriving Show
43 deriving Show
30
44
31toBC :: (Name, SDecl) -> (Name, [BC])
45toBC :: (Name, SDecl) -> (Name, [BC])
32toBC (n, SFun n' args locs exp)
46toBC (n, SFun n' args locs exp)
33− = (n, GROWSTACK locs : bc RVal exp (length args + locs))
47+ = (n, reserve locs ++ bc RVal exp True)
34−
48+ where reserve 0 = []
35−clean 0 = []
49+ reserve n = [RESERVE n, ADDTOP n]
36−clean c = [DROPSTACK c]
50+
37−
51+clean True = [TOPBASE 0, REBASE]
52+clean False = []
53+
38−bc :: Reg -> SExp -> Int -> [BC]
54+bc :: Reg -> SExp -> Bool -> -- returning
39−bc reg (SV (Glob n)) c = [CALL n] ++ assign reg RVal ++ clean c
55+ [BC]
56+bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
40−bc reg (SV (Loc i)) c = assign reg (L i) ++ clean c
57+bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
41−bc reg (SApp tc f vs) c
58+bc reg (SApp False f vs) r
42− = GROWSTACK (length vs) : moveReg (c + length vs) vs
59+ = RESERVE (length vs) : moveReg 0 vs
60+ ++ [STOREOLD, BASETOP 0, ADDTOP (length vs), CALL f] ++
43− ++ [CALL f] ++ assign reg RVal ++ clean c
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]
44−bc reg (SLet (Loc i) e sc) c = bc (L i) e 0 ++ bc reg sc c
65+bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
45−bc reg (SCon i _ vs) c = MKCON reg i (map getL vs) : clean c
66+bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
46 where getL (Loc x) = L x
67 where getL (Loc x) = L x
47−bc reg (SConst i) c = ASSIGNCONST reg i : clean c
68+bc reg (SConst i) r = ASSIGNCONST reg i : clean r
48−bc reg (SOp p vs) c = OP reg p (map getL vs) : clean c
69+bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
49 where getL (Loc x) = L x
70 where getL (Loc x) = L x
50−bc reg (SCase (Loc l) alts) c
71+bc reg (SCase (Loc l) alts) r
51− | isConst alts = undefined -- constCase reg c l alts
72+ | isConst alts = constCase reg (L l) alts r
52− | otherwise = conCase reg c (L l) alts : clean c
73+ | otherwise = conCase reg (L l) alts r
53
74
54isConst [] = False
75isConst [] = False
55isConst (SConstCase _ _ : xs) = True
76isConst (SConstCase _ _ : xs) = True
@@ -57,15 +78,27 @@ isConst (SConCase _ _ _ _ _ : xs) = False
57isConst (_ : xs) = False
78isConst (_ : xs) = False
58
79
59moveReg off [] = []
80moveReg 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
61
82
62assign r1 r2 | r1 == r2 = []
83assign r1 r2 | r1 == r2 = []
63 | otherwise = [ASSIGN r1 r2]
84 | otherwise = [ASSIGN r1 r2]
64
85
65−conCase reg c l xs = CASE l (mapMaybe (caseAlt l reg c) xs)
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+
66− Nothing
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
67
103
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
71
104