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