git.iko.soy/Idris-dev
on d1663cc help sign in
Idris-dev/src/IRTS/Bytecode.hs
128 lines 4.3 kB history raw
1module IRTS.Bytecode where
3-- Bytecode for a stack based VM (e.g. for generating C code with an accurate
4-- hand written GC)
6import IRTS.Lang
7import IRTS.Simplified
8import Core.TT
9import Data.Maybe
11{- We have:
13BASE: Current stack frame's base
14TOP: Top of stack
15OLDBASE: Passed in to each function, the previous stack frame's base
17L i refers to the stack item at BASE + i
18T i refers to the stack item at TOP + i
20RVal is a register in which computed values (essentially, what a function
21returns) are stored.
23-}
25data Reg = RVal | L Int | T Int | Tmp
26 deriving (Show, Eq)
28data BC = ASSIGN Reg Reg
29 | ASSIGNCONST Reg Const
30 | UPDATE Reg Reg
31 | MKCON Reg Int [Reg]
32 | CASE Bool -- definitely a constructor, no need to check, if true
33 Reg [(Int, [BC])] (Maybe [BC])
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
36 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
37 | CALL Name
38 | TAILCALL Name
39 | FOREIGNCALL Reg FLang FType String [(FType, Reg)]
40 | SLIDE Int -- move this number from TOP to BASE
41 | REBASE -- set BASE = OLDBASE
42 | RESERVE Int -- reserve n more stack items
43 -- (i.e. check there's space, grow if necessary)
44 | ADDTOP Int -- move the top of stack up
45 | TOPBASE Int -- set TOP = BASE + n
46 | BASETOP Int -- set BASE = TOP + n
47 | STOREOLD -- set OLDBASE = BASE
48 | OP Reg PrimFn [Reg]
49 | NULL Reg -- clear reg
50 | ERROR String
51 deriving Show
53toBC :: (Name, SDecl) -> (Name, [BC])
54toBC (n, SFun n' args locs exp)
55 = (n, reserve locs ++ bc RVal exp True)
56 where reserve 0 = []
57 reserve n = [RESERVE n, ADDTOP n]
59clean True = [TOPBASE 0, REBASE]
60clean False = []
62bc :: Reg -> SExp -> Bool -> -- returning
63 [BC]
64bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
65bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
66bc 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
74bc reg (SApp True f vs) r
75 = RESERVE (length vs) : moveReg 0 vs
76 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
77bc reg (SForeign l t fname args) r
78 = FOREIGNCALL reg l t fname (map farg args) : clean r
79 where farg (ty, Loc i) = (ty, L i)
80bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
81bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]
82 ++ clean r
83-- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it
84bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
85 where getL (Loc x) = L x
86bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r
87bc reg (SConst i) r = ASSIGNCONST reg i : clean r
88bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
89 where getL (Loc x) = L x
90bc reg (SError str) r = [ERROR str]
91bc reg SNothing r = NULL reg : clean r
92bc reg (SCase (Loc l) alts) r
93 | isConst alts = constCase reg (L l) alts r
94 | otherwise = conCase True reg (L l) alts r
95bc reg (SChkCase (Loc l) alts) r
96 = conCase False reg (L l) alts r
97bc reg t r = error $ "Can't compile " ++ show t
99isConst [] = False
100isConst (SConstCase _ _ : xs) = True
101isConst (SConCase _ _ _ _ _ : xs) = False
102isConst (_ : xs) = False
104moveReg off [] = []
105moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs
107assign r1 r2 | r1 == r2 = []
108 | otherwise = [ASSIGN r1 r2]
110conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)
111 (defaultAlt reg xs r)]
113constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
114 (defaultAlt reg xs r)]
116caseAlt l reg r (SConCase lvar tag _ args e)
117 = Just (tag, PROJECT l lvar (length args) : bc reg e r)
118caseAlt l reg r _ = Nothing
120constAlt l reg r (SConstCase c e)
121 = Just (c, bc reg e r)
122constAlt l reg r _ = Nothing
124defaultAlt reg [] r = Nothing
125defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r)
126defaultAlt reg (_ : xs) r = defaultAlt reg xs r