git.iko.soy/Idris-dev
on 79e6bf7 help sign in
Idris-dev/src/IRTS/Bytecode.hs
104 lines 3.3 kB history raw
1module IRTS.Bytecode where
3import IRTS.Lang
4import IRTS.Simplified
5import Core.TT
6import Data.Maybe
8{- We have:
10BASE: Current stack frame's base
11TOP: Top of stack
12OLDBASE: Passed in to each function, the previous stack frame's base
14L i refers to the stack item at BASE + i
15T i refers to the stack item at TOP + i
17RVal is a register in which computed values (essentially, what a function
18returns) are stored.
20-}
22data Reg = RVal | L Int | T Int
23 deriving (Show, Eq)
25data BC = ASSIGN Reg Reg
26 | ASSIGNCONST Reg Const
27 | MKCON Reg Int [Reg]
28 | CASE Reg [(Int, [BC])] (Maybe [BC])
29 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
30 | GETARGS Int -- discards afterwards
31 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
32 | CALL Name
33 | TAILCALL Name
34 | SLIDE Int -- move this number from TOP to BASE
35 | REBASE -- set BASE = OLDBASE
36 | RESERVE Int -- reserve n more stack items
37 -- (i.e. check there's space, grow if necessary)
38 | ADDTOP Int -- move the top of stack up
39 | TOPBASE Int -- set TOP = BASE + n
40 | BASETOP Int -- set BASE = TOP + n
41 | STOREOLD -- set OLDBASE = BASE
42 | OP Reg PrimFn [Reg]
43 deriving Show
45toBC :: (Name, SDecl) -> (Name, [BC])
46toBC (n, SFun n' args locs exp)
47 = (n, reserve locs ++ bc RVal exp True)
48 where reserve 0 = []
49 reserve n = [RESERVE n, ADDTOP n]
51clean True = [TOPBASE 0, REBASE]
52clean False = []
54bc :: Reg -> SExp -> Bool -> -- returning
55 [BC]
56bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
57bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
58bc reg (SApp False f vs) r
59 = RESERVE (length vs) : moveReg 0 vs
60 ++ [STOREOLD, BASETOP 0, ADDTOP (length vs), CALL f] ++
61 assign reg RVal ++ clean r
62bc reg (SApp True f vs) r
63 = RESERVE (length vs) : moveReg 0 vs
64 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
65bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
66bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
67 where getL (Loc x) = L x
68bc reg (SConst i) r = ASSIGNCONST reg i : clean r
69bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
70 where getL (Loc x) = L x
71bc reg (SCase (Loc l) alts) r
72 | isConst alts = constCase reg (L l) alts r
73 | otherwise = conCase reg (L l) alts r
75isConst [] = False
76isConst (SConstCase _ _ : xs) = True
77isConst (SConCase _ _ _ _ _ : xs) = False
78isConst (_ : xs) = False
80moveReg off [] = []
81moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs
83assign r1 r2 | r1 == r2 = []
84 | otherwise = [ASSIGN r1 r2]
86conCase reg l xs r = [CASE l (mapMaybe (caseAlt l reg r) xs)
87 (defaultAlt reg xs r)]
89constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
90 (defaultAlt reg xs r)]
92caseAlt l reg r (SConCase lvar tag _ args e)
93 = Just (tag, PROJECT l lvar (length args) : bc reg e r)
94caseAlt l reg r _ = Nothing
96constAlt l reg r (SConstCase c e)
97 = Just (c, bc reg e r)
98constAlt l reg r _ = Nothing
100defaultAlt reg [] r = Nothing
101defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r)
102defaultAlt reg (_ : xs) r = defaultAlt reg xs r