git.iko.soy/Idris-dev
on 0af107c help sign in
Idris-dev/src/IRTS/Bytecode.hs
107 lines 3.4 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 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
31 | CALL Name
32 | TAILCALL Name
33 | FOREIGNCALL Reg FLang FType String [(FType, Reg)]
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 (SForeign l t fname args) r
66 = FOREIGNCALL reg l t fname (map farg args) : clean r
67 where farg (ty, Loc i) = (ty, L i)
68bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
69bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
70 where getL (Loc x) = L x
71bc reg (SConst i) r = ASSIGNCONST reg i : clean r
72bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
73 where getL (Loc x) = L x
74bc reg (SCase (Loc l) alts) r
75 | isConst alts = constCase reg (L l) alts r
76 | otherwise = conCase reg (L l) alts r
78isConst [] = False
79isConst (SConstCase _ _ : xs) = True
80isConst (SConCase _ _ _ _ _ : xs) = False
81isConst (_ : xs) = False
83moveReg off [] = []
84moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs
86assign r1 r2 | r1 == r2 = []
87 | otherwise = [ASSIGN r1 r2]
89conCase reg l xs r = [CASE l (mapMaybe (caseAlt l reg r) xs)
90 (defaultAlt reg xs r)]
92constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
93 (defaultAlt reg xs r)]
95caseAlt l reg r (SConCase lvar tag _ args e)
96 = Just (tag, PROJECT l lvar (length args) : bc reg e r)
97caseAlt l reg r _ = Nothing
99constAlt l reg r (SConstCase c e)
100 = Just (c, bc reg e r)
101constAlt l reg r _ = Nothing
103defaultAlt reg [] r = Nothing
104defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r)
105defaultAlt reg (_ : xs) r = defaultAlt reg xs r