git.iko.soy/Idris-dev
on cf47310 help sign in
Idris-dev/src/IRTS/Bytecode.hs
188 lines 5.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 IRTS.Defunctionalise
9import Idris.Core.TT
10import Data.Maybe
12{- We have:
14BASE: Current stack frame's base
15TOP: Top of stack
16OLDBASE: Passed in to each function, the previous stack frame's base
18L i refers to the stack item at BASE + i
19T i refers to the stack item at TOP + i
21RVal is a register in which computed values (essentially, what a function
22returns) are stored.
24-}
26data Reg = RVal | L Int | T Int | Tmp
27 deriving (Show, Eq)
29data BC =
30 -- reg1 = reg2
31 ASSIGN Reg Reg
33 -- reg = const
34 | ASSIGNCONST Reg Const
36 -- reg1 = reg2 (same as assign, it seems)
37 | UPDATE Reg Reg
39 -- reg = constructor, where constructor consists of a tag and
40 -- values from registers, e.g. (cons tag args)
41 -- the 'Maybe Reg', if set, is a register which can be overwritten
42 -- (i.e. safe for mutable update), though this can be ignored
43 | MKCON Reg (Maybe Reg) Int [Reg]
45 -- Matching on value of reg: usually (but not always) there are
46 -- constructors, hence "Int" for patterns (that's a tag on which
47 -- we should match), and the following [BC] is just a list of
48 -- instructions for the corresponding case. The last argument is
49 -- for default case. When it's not necessary a constructor in the
50 -- reg, the Bool should be False, indicating that it's not safe to
51 -- work with that as with a constructor, so a check should be
52 -- added. If it's not a constructor, default case should be used.
53 | CASE Bool
54 Reg [(Int, [BC])] (Maybe [BC])
56 -- get a value from register, which should be a constructor, and
57 -- put its arguments into the stack, starting from (base + int1)
58 -- and onwards; second Int provides arity
59 | PROJECT Reg Int Int
61 -- probably not used
62 | PROJECTINTO Reg Reg Int -- project argument from one reg into another
64 -- same as CASE, but there's an exact value (not constructor) in reg
65 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
67 -- just call a function, passing MYOLDBASE (see below) to it
68 | CALL Name
70 -- same, perhaps exists just for TCO
71 | TAILCALL Name
73 -- set reg to (apply string args),
74 | FOREIGNCALL Reg FDesc FDesc [(FDesc, Reg)]
76 -- move this number of elements from TOP to BASE
77 | SLIDE Int
79 -- set BASE = OLDBASE
80 | REBASE
82 -- reserve n more stack items (i.e. check there's space, grow if
83 -- necessary)
84 | RESERVE Int
86 -- move the top of stack up
87 | ADDTOP Int
89 -- set TOP = BASE + n
90 | TOPBASE Int
92 -- set BASE = TOP + n
93 | BASETOP Int
95 -- set MYOLDBASE = BASE, where MYOLDBASE is a function-local
96 -- variable, set to OLDBASE by default, and passed on function
97 -- call to called functions as their OLDBASE
98 | STOREOLD
100 -- reg = apply primitive_function args
101 | OP Reg PrimFn [Reg]
103 -- clear reg
104 | NULL Reg
106 -- throw an error
107 | ERROR String
108 deriving Show
110toBC :: (Name, SDecl) -> (Name, [BC])
111toBC (n, SFun n' args locs exp)
112 = (n, reserve locs ++ bc RVal exp True)
113 where reserve 0 = []
114 reserve n = [RESERVE n, ADDTOP n]
116clean True = [TOPBASE 0, REBASE]
117clean False = []
119bc :: Reg -> SExp -> Bool -> -- returning
120 [BC]
121bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
122bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
123bc reg (SApp False f vs) r =
124 if argCount == 0
125 then moveReg 0 vs ++ [STOREOLD, BASETOP 0, CALL f] ++ ret
126 else RESERVE argCount : moveReg 0 vs ++
127 [STOREOLD, BASETOP 0, ADDTOP argCount, CALL f] ++ ret
128 where
129 ret = assign reg RVal ++ clean r
130 argCount = length vs
131bc reg (SApp True f vs) r
132 = RESERVE (length vs) : moveReg 0 vs
133 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
134bc reg (SForeign t fname args) r
135 = FOREIGNCALL reg t fname (map farg args) : clean r
136 where farg (ty, Loc i) = (ty, L i)
137bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
138bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]
139 ++ clean r
140-- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it
141bc reg (SCon atloc i _ vs) r
142 = MKCON reg (getAllocLoc atloc) i (map getL vs) : clean r
143 where getL (Loc x) = L x
144 getAllocLoc (Just (Loc x)) = Just (L x)
145 getAllocLoc _ = Nothing
146bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r
147bc reg (SConst i) r = ASSIGNCONST reg i : clean r
148bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
149 where getL (Loc x) = L x
150bc reg (SError str) r = [ERROR str]
151bc reg SNothing r = NULL reg : clean r
152bc reg (SCase up (Loc l) alts) r
153 | isConst alts = constCase reg (L l) alts r
154 | otherwise = conCase True reg (L l) alts r
155bc reg (SChkCase (Loc l) alts) r
156 = conCase False reg (L l) alts r
157bc reg t r = error $ "Can't compile " ++ show t
159isConst [] = False
160isConst (SConstCase _ _ : xs) = True
161isConst (SConCase _ _ _ _ _ : xs) = False
162isConst (_ : xs) = False
164moveReg off [] = []
165moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs
167assign r1 r2 | r1 == r2 = []
168 | otherwise = [ASSIGN r1 r2]
170conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)
171 (defaultAlt reg xs r)]
173constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
174 (defaultAlt reg xs r)]
176caseAlt l reg r (SConCase lvar tag _ args e)
177 = Just (tag, PROJECT l lvar (length args) : bc reg e r)
178caseAlt l reg r _ = Nothing
180constAlt l reg r (SConstCase c e)
181 = Just (c, bc reg e r)
182constAlt l reg r _ = Nothing
184defaultAlt reg [] r = Nothing
185defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r)
186defaultAlt reg (_ : xs) r = defaultAlt reg xs r