git.iko.soy/Idris-dev
on abc2002 help sign in
Idris-dev/src/IRTS/Bytecode.hs
189 lines 6.0 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 Idris.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 =
29 -- reg1 = reg2
30 ASSIGN Reg Reg
32 -- reg = const
33 | ASSIGNCONST Reg Const
35 -- reg1 = reg2 (same as assign, it seems)
36 | UPDATE Reg Reg
38 -- reg = constructor, where constructor consists of a tag and
39 -- values from registers, e.g. (cons tag args)
40 -- the 'Maybe Reg', if set, is a register which can be overwritten
41 -- (i.e. safe for mutable update), though this can be ignored
42 | MKCON Reg (Maybe Reg) Int [Reg]
44 -- Matching on value of reg: usually (but not always) there are
45 -- constructors, hence "Int" for patterns (that's a tag on which
46 -- we should match), and the following [BC] is just a list of
47 -- instructions for the corresponding case. The last argument is
48 -- for default case. When it's not necessary a constructor in the
49 -- reg, the Bool should be False, indicating that it's not safe to
50 -- work with that as with a constructor, so a check should be
51 -- added. If it's not a constructor, default case should be used.
52 | CASE Bool
53 Reg [(Int, [BC])] (Maybe [BC])
55 -- get a value from register, which should be a constructor, and
56 -- put its arguments into the stack, starting from (base + int1)
57 -- and onwards; second Int provides arity
58 | PROJECT Reg Int Int
60 -- probably not used
61 | PROJECTINTO Reg Reg Int -- project argument from one reg into another
63 -- same as CASE, but there's an exact value (not constructor) in reg
64 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
66 -- just call a function, passing MYOLDBASE (see below) to it
67 | CALL Name
69 -- same, perhaps exists just for TCO
70 | TAILCALL Name
72 -- set reg to (apply string args), FLang argument is the language to
73 -- be called. FType is the foreign language type, which may be used to
74 -- control marshaling.
75 | FOREIGNCALL Reg FLang FType String [(FType, Reg)]
77 -- move this number of elements from TOP to BASE
78 | SLIDE Int
80 -- set BASE = OLDBASE
81 | REBASE
83 -- reserve n more stack items (i.e. check there's space, grow if
84 -- necessary)
85 | RESERVE Int
87 -- move the top of stack up
88 | ADDTOP Int
90 -- set TOP = BASE + n
91 | TOPBASE Int
93 -- set BASE = TOP + n
94 | BASETOP Int
96 -- set MYOLDBASE = BASE, where MYOLDBASE is a function-local
97 -- variable, set to OLDBASE by default, and passed on function
98 -- call to called functions as their OLDBASE
99 | STOREOLD
101 -- reg = apply primitive_function args
102 | OP Reg PrimFn [Reg]
104 -- clear reg
105 | NULL Reg
107 -- throw an error
108 | ERROR String
109 deriving Show
111toBC :: (Name, SDecl) -> (Name, [BC])
112toBC (n, SFun n' args locs exp)
113 = (n, reserve locs ++ bc RVal exp True)
114 where reserve 0 = []
115 reserve n = [RESERVE n, ADDTOP n]
117clean True = [TOPBASE 0, REBASE]
118clean False = []
120bc :: Reg -> SExp -> Bool -> -- returning
121 [BC]
122bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
123bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
124bc reg (SApp False f vs) r =
125 if argCount == 0
126 then moveReg 0 vs ++ [STOREOLD, BASETOP 0, CALL f] ++ ret
127 else RESERVE argCount : moveReg 0 vs ++
128 [STOREOLD, BASETOP 0, ADDTOP argCount, CALL f] ++ ret
129 where
130 ret = assign reg RVal ++ clean r
131 argCount = length vs
132bc reg (SApp True f vs) r
133 = RESERVE (length vs) : moveReg 0 vs
134 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
135bc reg (SForeign l t fname args) r
136 = FOREIGNCALL reg l t fname (map farg args) : clean r
137 where farg (ty, Loc i) = (ty, L i)
138bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
139bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]
140 ++ clean r
141-- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it
142bc reg (SCon atloc i _ vs) r
143 = MKCON reg (getAllocLoc atloc) i (map getL vs) : clean r
144 where getL (Loc x) = L x
145 getAllocLoc (Just (Loc x)) = Just (L x)
146 getAllocLoc _ = Nothing
147bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r
148bc reg (SConst i) r = ASSIGNCONST reg i : clean r
149bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
150 where getL (Loc x) = L x
151bc reg (SError str) r = [ERROR str]
152bc reg SNothing r = NULL reg : clean r
153bc reg (SCase up (Loc l) alts) r
154 | isConst alts = constCase reg (L l) alts r
155 | otherwise = conCase True reg (L l) alts r
156bc reg (SChkCase (Loc l) alts) r
157 = conCase False reg (L l) alts r
158bc reg t r = error $ "Can't compile " ++ show t
160isConst [] = False
161isConst (SConstCase _ _ : xs) = True
162isConst (SConCase _ _ _ _ _ : xs) = False
163isConst (_ : xs) = False
165moveReg off [] = []
166moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs
168assign r1 r2 | r1 == r2 = []
169 | otherwise = [ASSIGN r1 r2]
171conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)
172 (defaultAlt reg xs r)]
174constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
175 (defaultAlt reg xs r)]
177caseAlt l reg r (SConCase lvar tag _ args e)
178 = Just (tag, PROJECT l lvar (length args) : bc reg e r)
179caseAlt l reg r _ = Nothing
181constAlt l reg r (SConstCase c e)
182 = Just (c, bc reg e r)
183constAlt l reg r _ = Nothing
185defaultAlt reg [] r = Nothing
186defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r)
187defaultAlt reg (_ : xs) r = defaultAlt reg xs r