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