git.iko.soy/Idris-dev
on master help sign in
Merge pull request #490 from gabemc/issue/121
93ae498Edwin Brady
src/IRTS/Bytecode.hs+21−17
compare with master
unifiedsplit
@@ -8,7 +8,7 @@ import IRTS.Simplified
8import Core.TT
8import Core.TT
9import Data.Maybe
9import Data.Maybe
10
10
11−{- We have:
11+{- We have:
12
12
13BASE: Current stack frame's base
13BASE: Current stack frame's base
14TOP: Top of stack
14TOP: Top of stack
@@ -32,14 +32,14 @@ data BC = ASSIGN Reg Reg
32 | CASE Bool -- definitely a constructor, no need to check, if true
32 | CASE Bool -- definitely a constructor, no need to check, if true
33 Reg [(Int, [BC])] (Maybe [BC])
33 Reg [(Int, [BC])] (Maybe [BC])
34 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
34 | 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
36 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
36 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
37 | CALL Name
37 | CALL Name
38 | TAILCALL Name
38 | TAILCALL Name
39− | FOREIGNCALL Reg FLang FType String [(FType, Reg)]
39+ | FOREIGNCALL Reg FLang FType String [(FType, Reg)]
40− | SLIDE Int -- move this number from TOP to BASE
40+ | SLIDE Int -- move this number from TOP to BASE
41 | REBASE -- set BASE = OLDBASE
41 | REBASE -- set BASE = OLDBASE
42− | RESERVE Int -- reserve n more stack items
42+ | RESERVE Int -- reserve n more stack items
43 -- (i.e. check there's space, grow if necessary)
43 -- (i.e. check there's space, grow if necessary)
44 | ADDTOP Int -- move the top of stack up
44 | ADDTOP Int -- move the top of stack up
45 | TOPBASE Int -- set TOP = BASE + n
45 | TOPBASE Int -- set TOP = BASE + n
@@ -51,7 +51,7 @@ data BC = ASSIGN Reg Reg
51 deriving Show
51 deriving Show
52
52
53toBC :: (Name, SDecl) -> (Name, [BC])
53toBC :: (Name, SDecl) -> (Name, [BC])
54−toBC (n, SFun n' args locs exp)
54+toBC (n, SFun n' args locs exp)
55 = (n, reserve locs ++ bc RVal exp True)
55 = (n, reserve locs ++ bc RVal exp True)
56 where reserve 0 = []
56 where reserve 0 = []
57 reserve n = [RESERVE n, ADDTOP n]
57 reserve n = [RESERVE n, ADDTOP n]
@@ -63,10 +63,14 @@ bc :: Reg -> SExp -> Bool -> -- returning
63 [BC]
63 [BC]
64bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
64bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
65bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
65bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
66−bc reg (SApp False f vs) r
66+bc reg (SApp False f vs) r =
67+ if argCount == 0
68+ then moveReg 0 vs ++ [STOREOLD, BASETOP 0, CALL f] ++ ret
67− = RESERVE (length vs) : moveReg 0 vs
69+ else RESERVE argCount : moveReg 0 vs ++
68− ++ [STOREOLD, BASETOP 0, ADDTOP (length vs), CALL f] ++
70+ [STOREOLD, BASETOP 0, ADDTOP argCount, CALL f] ++ ret
71+ where
69− assign reg RVal ++ clean r
72+ ret = assign reg RVal ++ clean r
73+ argCount = length vs
70bc reg (SApp True f vs) r
74bc reg (SApp True f vs) r
71 = RESERVE (length vs) : moveReg 0 vs
75 = RESERVE (length vs) : moveReg 0 vs
72 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
76 ++ [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]
78 ++ clean r
82 ++ clean r
79bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
83bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
80 where getL (Loc x) = L x
84 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
82bc reg (SConst i) r = ASSIGNCONST reg i : clean r
86bc reg (SConst i) r = ASSIGNCONST reg i : clean r
83bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
87bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
84 where getL (Loc x) = L x
88 where getL (Loc x) = L x
85bc reg (SError str) r = [ERROR str]
89bc reg (SError str) r = [ERROR str]
86bc reg SNothing r = NULL reg : clean r
90bc reg SNothing r = NULL reg : clean r
87−bc reg (SCase (Loc l) alts) r
91+bc reg (SCase (Loc l) alts) r
88 | isConst alts = constCase reg (L l) alts r
92 | isConst alts = constCase reg (L l) alts r
89 | otherwise = conCase True reg (L l) alts r
93 | otherwise = conCase True reg (L l) alts r
90−bc reg (SChkCase (Loc l) alts) r
94+bc reg (SChkCase (Loc l) alts) r
91 = conCase False reg (L l) alts r
95 = conCase False reg (L l) alts r
92
96
93isConst [] = False
97isConst [] = False
@@ -107,12 +111,12 @@ conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)
107constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
111constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
108 (defaultAlt reg xs r)]
112 (defaultAlt reg xs r)]
109
113
110−caseAlt l reg r (SConCase lvar tag _ args e)
114+caseAlt l reg r (SConCase lvar tag _ args e)
111− = Just (tag, PROJECT l lvar (length args) : bc reg e r)
115+ = Just (tag, PROJECT l lvar (length args) : bc reg e r)
112caseAlt l reg r _ = Nothing
116caseAlt l reg r _ = Nothing
113
117
114−constAlt l reg r (SConstCase c e)
118+constAlt l reg r (SConstCase c e)
115− = Just (c, bc reg e r)
119+ = Just (c, bc reg e r)
116constAlt l reg r _ = Nothing
120constAlt l reg r _ = Nothing
117
121
118defaultAlt reg [] r = Nothing
122defaultAlt reg [] r = Nothing