git.iko.soy/Idris-dev
on c4e7ba2 help sign in
Idris-dev/src/IRTS/Bytecode.hs
119 lines 3.9 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 Reg [(Int, [BC])] (Maybe [BC])
33 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
34 | PROJECTINTO Reg Reg Int -- project argument from one reg into another
35 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
36 | CALL Name
37 | TAILCALL Name
38 | FOREIGNCALL Reg FLang FType String [(FType, Reg)]
39 | SLIDE Int -- move this number from TOP to BASE
40 | REBASE -- set BASE = OLDBASE
41 | RESERVE Int -- reserve n more stack items
42 -- (i.e. check there's space, grow if necessary)
43 | ADDTOP Int -- move the top of stack up
44 | TOPBASE Int -- set TOP = BASE + n
45 | BASETOP Int -- set BASE = TOP + n
46 | STOREOLD -- set OLDBASE = BASE
47 | OP Reg PrimFn [Reg]
48 | NULL Reg -- clear reg
49 | ERROR String
50 deriving Show
52toBC :: (Name, SDecl) -> (Name, [BC])
53toBC (n, SFun n' args locs exp)
54 = (n, reserve locs ++ bc RVal exp True)
55 where reserve 0 = []
56 reserve n = [RESERVE n, ADDTOP n]
58clean True = [TOPBASE 0, REBASE]
59clean False = []
61bc :: Reg -> SExp -> Bool -> -- returning
62 [BC]
63bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
64bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
65bc reg (SApp False f vs) r
66 = RESERVE (length vs) : moveReg 0 vs
67 ++ [STOREOLD, BASETOP 0, ADDTOP (length vs), CALL f] ++
68 assign reg RVal ++ clean r
69bc reg (SApp True f vs) r
70 = RESERVE (length vs) : moveReg 0 vs
71 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
72bc reg (SForeign l t fname args) r
73 = FOREIGNCALL reg l t fname (map farg args) : clean r
74 where farg (ty, Loc i) = (ty, L i)
75bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
76bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]
77 ++ clean r
78bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
79 where getL (Loc x) = L x
80bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r
81bc reg (SConst i) r = ASSIGNCONST reg i : clean r
82bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
83 where getL (Loc x) = L x
84bc reg (SError str) r = [ERROR str]
85bc reg SNothing r = NULL reg : clean r
86bc reg (SCase (Loc l) alts) r
87 | isConst alts = constCase reg (L l) alts r
88 | otherwise = conCase reg (L l) alts r
90isConst [] = False
91isConst (SConstCase _ _ : xs) = True
92isConst (SConCase _ _ _ _ _ : xs) = False
93isConst (_ : xs) = False
95moveReg off [] = []
96moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs
98assign r1 r2 | r1 == r2 = []
99 | otherwise = [ASSIGN r1 r2]
101conCase reg l xs r = [CASE l (mapMaybe (caseAlt l reg r) xs)
102 (defaultAlt reg xs r)]
104constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
105 (defaultAlt reg xs r)]
107caseAlt l reg r (SConCase lvar tag _ args e)
108 = Just (tag, PROJECT l lvar (length args) : bc reg e r)
109caseAlt l reg r _ = Nothing
111constAlt l reg r (SConstCase c e)
112 = Just (c, bc reg e r)
113constAlt l reg r _ = Nothing
115defaultAlt reg [] r = Nothing
116defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r)
117defaultAlt reg (_ : xs) r = defaultAlt reg xs r