2 % (c) The University of Glasgow 2000
4 \section[ByteCodeGen]{Generate bytecode from Core}
7 module ByteCodeGen ( byteCodeGen ) where
9 #include "HsVersions.h"
16 import Name ( Name, getName )
17 import Id ( Id, idType, isDataConId_maybe )
18 import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
19 nilOL, toOL, concatOL, fromOL )
20 import FiniteMap ( FiniteMap, addListToFM, listToFM,
21 addToFM, lookupFM, fmToList )
23 import Literal ( Literal(..) )
24 import PrimRep ( PrimRep(..) )
25 import CoreFVs ( freeVars )
26 import Type ( typePrimRep )
27 import DataCon ( DataCon, dataConTag, fIRST_TAG )
28 import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe )
29 import VarSet ( VarSet, varSetElems )
30 import PrimRep ( getPrimRepSize, isFollowableRep )
37 byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
39 = let flatBinds = concatMap getBind binds
40 getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
41 getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
42 final_state = runBc (BcM_State [] 0)
43 (mapBc schemeR flatBinds `thenBc_` returnBc ())
46 BcM_State bcos final_ctr -> bcos
55 -- Messing with the stack
57 | PUSH_L Int{-size-} Int{-offset-}
65 | SLIDE Int{-this many-} Int{-down by this much-}
66 -- To do with the heap
68 | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-}
71 -- For doing case trees
73 | TESTLT_I Int LocalLabel
74 | TESTEQ_I Int LocalLabel
75 | TESTLT_F Float LocalLabel
76 | TESTEQ_F Float LocalLabel
77 | TESTLT_D Double LocalLabel
78 | TESTEQ_D Double LocalLabel
79 | TESTLT_P Int LocalLabel
80 | TESTEQ_P Int LocalLabel
82 -- To Infinity And Beyond
86 The object format for this is: 16 bits for the opcode, and 16 for each
87 field -- so the code can be considered a sequence of 16-bit ints.
88 Each field denotes either a stack offset or number of items on the
89 stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
90 index into the literal table (eg PUSH_I/D/L), or a bytecode address in
95 --data BCO a = BCO [Word16] -- instructions
96 -- [Word8] -- literal pool
97 -- [a] -- Names or HValues
99 --assembleBCO :: ProtoBCO -> BCO
100 --assembleBCO (ProtoBCO nm instrs)
101 -- = -- pass 1: collect up the offsets of the local labels,
102 -- -- and also the literals and
105 instance Outputable BCInstr where
106 ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
107 ppr (PUSH_L sz offset) = text "PUSH_L " <+> int sz <+> int offset
108 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
109 ppr (PUSHT_I i) = text "PUSHT_I " <+> int i
110 ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
111 ppr (ALLOC sz) = text "ALLOC " <+> int sz
112 ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
113 ppr (UNPACK sz) = text "UNPACK " <+> int sz
114 ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
115 ppr ENTER = text "ENTER"
117 pprAltCode discrs_n_codes
118 = vcat (map f discrs_n_codes)
119 where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
122 type BCInstrList = OrdList BCInstr
124 data ProtoBCO a = ProtoBCO a BCInstrList
126 instance Outputable a => Outputable (ProtoBCO a) where
127 ppr (ProtoBCO name instrs)
128 = (text "ProtoBCO" <+> ppr name <> colon)
129 $$ nest 6 (vcat (map ppr (fromOL instrs)))
134 type Sequel = Int -- back off to this depth before ENTER
136 -- Maps Ids to the offset from the stack _base_ so we don't have
137 -- to mess with it after each push/pop.
138 type BCEnv = FiniteMap Id Int -- To find vars on the stack
140 lookupBCEnv :: BCEnv -> Id -> Int
142 = case lookupFM env nm of
143 Nothing -> pprPanic "lookupBCEnv"
144 (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
147 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
148 lookupBCEnv_maybe = lookupFM
151 -- Describes case alts
159 instance Outputable Discr where
160 ppr (DiscrI i) = int i
161 ppr (DiscrF f) = text (show f)
162 ppr (DiscrD d) = text (show d)
163 ppr (DiscrP i) = int i
164 ppr NoDiscr = text "DEF"
168 -- When I push one of these on the stack, how much does Sp move by?
169 taggedSizeW :: PrimRep -> Int
171 | isFollowableRep pr = 1
172 | otherwise = 1{-the tag-} + getPrimRepSize pr
174 -- The plain size of something, without tag.
175 untaggedSizeW :: PrimRep -> Int
177 | isFollowableRep pr = 1
178 | otherwise = getPrimRepSize pr
180 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
181 taggedIdSizeW = taggedSizeW . typePrimRep . idType
182 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
185 -- Compile code for the right hand side of a let binding.
186 -- Park the resulting BCO in the monad. Also requires the
187 -- variable to which this value was bound, so as to give the
188 -- resulting BCO a name.
189 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
190 schemeR (nm, rhs) = schemeR_wrk nm (collect [] rhs)
192 collect xs (_, AnnLam x e) = collect (x:xs) e
193 collect xs not_lambda = (reverse xs, not_lambda)
195 schemeR_wrk nm (args, body)
197 all_args = varSetElems fvs ++ args
198 szsw_args = map taggedIdSizeW all_args
199 szw_args = sum szsw_args
200 p_init = listToFM (zip all_args (scanl (+) 0 szsw_args))
201 argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
203 schemeE szw_args 0 p_init body `thenBc` \ body_code ->
204 emitBc (ProtoBCO (getName nm) (appOL argcheck body_code))
207 -- Compile code to apply the given expression to the remaining args
208 -- on the stack, returning a HNF.
209 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
211 -- Delegate tail-calls to schemeT.
212 schemeE d s p e@(fvs, AnnApp f a)
213 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
214 schemeE d s p e@(fvs, AnnVar v)
215 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
217 schemeE d s p (fvs, AnnLet binds b)
218 = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
219 AnnRec xs_n_rhss -> unzip xs_n_rhss
221 mapBc schemeR (zip xs rhss) `thenBc_`
223 fvss = map (varSetElems.fst) rhss
224 sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
225 p' = addListToFM p (zipE xs [d .. d+n-1])
227 infos = zipE4 fvss sizes xs [n, n-1 .. 1]
228 zipE = zipEqual "schemeE"
229 zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
231 -- ToDo: don't build thunks for things with no free variables
232 buildThunk (fvs, size, id, off)
233 = case unzip (map (pushAtom True d' p . AnnVar) (reverse fvs)) of
234 (push_codes, pushed_szsw)
235 -> ASSERT(sum pushed_szsw == size - 1)
236 (toOL push_codes `snocOL` PUSH_G (getName id)
237 `appOL` unitOL (MKAP off size))
239 thunkCode = concatOL (map buildThunk infos)
240 allocCode = toOL (map ALLOC sizes)
242 schemeE d' s p' b `thenBc` \ bodyCode ->
243 mapBc schemeR (zip xs rhss) `thenBc` \_ ->
244 returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
247 schemeE d s p (fvs, AnnCase scrut bndr alts)
249 -- Top of stack is the return itbl, as usual.
250 -- underneath it is the pointer to the alt_code BCO.
251 -- When an alt is entered, it assumes the returned value is
252 -- on top of the itbl.
255 -- Env and depth in which to compile the alts, not including
256 -- any vars bound by the alts themselves
257 d' = d + ret_frame_sizeW + taggedIdSizeW bndr
258 p' = addToFM p bndr d'
261 = case typePrimRep (idType bndr) of
262 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
264 other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
266 -- given an alt, return a discr and code for it.
267 codeAlt alt@(discr, binds, rhs)
269 = let binds_szsw = map untaggedIdSizeW binds
270 binds_szw = sum binds_szsw
271 p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw))
273 in schemeE d'' s p'' rhs `thenBc` \ rhs_code ->
274 returnBc (my_discr alt, UNPACK binds_szw `consOL` rhs_code)
277 schemeE d' s p' rhs `thenBc` \ rhs_code ->
278 returnBc (my_discr alt, rhs_code)
280 my_discr (DEFAULT, binds, rhs) = NoDiscr
281 my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
282 my_discr (LitAlt l, binds, rhs)
283 = case l of MachInt i -> DiscrI (fromInteger i)
284 MachFloat r -> DiscrF (fromRational r)
285 MachDouble r -> DiscrD (fromRational r)
288 mapBc codeAlt alts `thenBc` \ alt_stuff ->
289 mkMultiBranch alt_stuff `thenBc` \ alt_final ->
291 alt_bco_name = getName bndr
292 alt_bco = ProtoBCO alt_bco_name alt_final
294 schemeE (d + ret_frame_sizeW)
295 (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
297 emitBc alt_bco `thenBc_`
298 returnBc (PUSH_G alt_bco_name `consOL` scrut_code)
301 -- Compile code to do a tail call. Doesn't need to be monadic.
302 schemeT :: Bool -- do tagging?
303 -> Int -- Stack depth
304 -> Sequel -- Sequel depth
305 -> Int -- # arg words so far
306 -> BCEnv -- stack env
307 -> AnnExpr Id VarSet -> BCInstrList
309 schemeT enTag d s narg_words p (_, AnnApp f a)
310 = let (push, arg_words) = pushAtom enTag d p (snd a)
312 `consOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
314 schemeT enTag d s narg_words p (_, AnnVar f)
315 | Just con <- isDataConId_maybe f
316 = ASSERT(enTag == False)
317 PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
319 = ASSERT(enTag == True)
320 let (push, arg_words) = pushAtom True d p (AnnVar f)
322 `consOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
323 `consOL` unitOL ENTER
325 should_args_be_tagged (_, AnnVar v)
326 = case isDataConId_maybe v of
327 Just dcon -> False; Nothing -> True
328 should_args_be_tagged (_, AnnApp f a)
329 = should_args_be_tagged f
330 should_args_be_tagged (_, other)
331 = panic "should_args_be_tagged: tail call to non-con, non-var"
333 -- Push an atom onto the stack, returning suitable code & number of
334 -- stack words used. Pushes it either tagged or untagged, since
335 -- pushAtom is used to set up the stack prior to copying into the
336 -- heap for both APs (requiring tags) and constructors (which don't).
338 -- NB this means NO GC between pushing atoms for a constructor and
339 -- copying them into the heap. It probably also means that
340 -- tail calls MUST be of the form atom{atom ... atom} since if the
341 -- expression head was allowed to be arbitrary, there could be GC
342 -- in between pushing the arg atoms and completing the head.
343 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
344 -- isn't a problem; but only if arbitrary graph construction for the
345 -- head doesn't leave this BCO, since GC might happen at the start of
346 -- each BCO (we consult doYouWantToGC there).
348 -- Blargh. JRS 001206
350 pushAtom True{-tagged-} d p (AnnVar v)
351 = case lookupBCEnv_maybe p v of
352 Just offset -> (PUSH_L sz offset, sz)
353 Nothing -> ASSERT(sz == 1) (PUSH_G nm, sz)
358 pushAtom False{-not tagged-} d p (AnnVar v)
359 = case lookupBCEnv_maybe p v of
360 Just offset -> (PUSH_L sz (offset+1), sz-1)
361 Nothing -> ASSERT(sz == 1) (PUSH_G nm, sz)
364 sz = untaggedIdSizeW v
366 pushAtom True d p (AnnLit lit)
368 MachInt i -> (PUSHT_I (fromInteger i), taggedSizeW IntRep)
369 MachFloat r -> (PUSHT_F (fromRational r), taggedSizeW FloatRep)
370 MachDouble r -> (PUSHT_D (fromRational r), taggedSizeW DoubleRep)
372 pushAtom False d p (AnnLit lit)
374 MachInt i -> (PUSHU_I (fromInteger i), untaggedSizeW IntRep)
375 MachFloat r -> (PUSHU_F (fromRational r), untaggedSizeW FloatRep)
376 MachDouble r -> (PUSHU_D (fromRational r), untaggedSizeW DoubleRep)
378 -- Given a bunch of alts code and their discrs, do the donkey work
379 -- of making a multiway branch using a switch tree.
380 -- What a load of hassle!
381 mkMultiBranch :: [(Discr, BCInstrList)] -> BcM BCInstrList
382 mkMultiBranch raw_ways
383 = let d_way = filter (isNoDiscr.fst) raw_ways
384 notd_ways = naturalMergeSortLe
385 (\w1 w2 -> leAlt (fst w1) (fst w2))
386 (filter (not.isNoDiscr.fst) raw_ways)
388 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
389 mkTree [] range_lo range_hi = returnBc the_default
391 mkTree [val] range_lo range_hi
392 | range_lo `eqAlt` range_hi
395 = getLabelBc `thenBc` \ label_neq ->
396 returnBc (mkTestEQ (fst val) label_neq
398 `appOL` unitOL (LABEL label_neq)
399 `appOL` the_default))
401 mkTree vals range_lo range_hi
402 = let n = length vals `div` 2
403 vals_lo = take n vals
404 vals_hi = drop n vals
405 v_mid = fst (head vals_hi)
407 getLabelBc `thenBc` \ label_geq ->
408 mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
409 mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
410 returnBc (mkTestLT v_mid label_geq
412 `appOL` unitOL (LABEL label_geq)
416 = case d_way of [] -> unitOL CASEFAIL
419 -- None of these will be needed if there are no non-default alts
420 (mkTestLT, mkTestEQ, init_lo, init_hi)
422 = panic "mkMultiBranch: awesome foursome"
424 = case fst (head notd_ways) of {
425 DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
426 \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
429 DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
430 \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
433 DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
434 \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
437 DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
438 \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
443 (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
444 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
445 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
446 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
447 NoDiscr `eqAlt` NoDiscr = True
450 (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
451 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
452 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
453 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
454 NoDiscr `leAlt` NoDiscr = True
457 isNoDiscr NoDiscr = True
460 dec (DiscrI i) = DiscrI (i-1)
461 dec (DiscrP i) = DiscrP (i-1)
462 dec other = other -- not really right, but if you
463 -- do cases on floating values, you'll get what you deserve
465 -- same snotty comment applies to the following
473 mkTree notd_ways init_lo init_hi
476 The bytecode generator's monad.
480 = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
481 nextlabel :: Int } -- for generating local labels
483 type BcM result = BcM_State -> (result, BcM_State)
485 mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State
486 mkBcM_State = BcM_State
488 runBc :: BcM_State -> BcM () -> BcM_State
489 runBc init_st m = case m init_st of { (r,st) -> st }
491 thenBc :: BcM a -> (a -> BcM b) -> BcM b
493 = case expr st of { (result, st') -> cont result st' }
495 thenBc_ :: BcM a -> BcM b -> BcM b
497 = case expr st of { (result, st') -> cont st' }
499 returnBc :: a -> BcM a
500 returnBc result st = (result, st)
502 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
503 mapBc f [] = returnBc []
505 = f x `thenBc` \ r ->
506 mapBc f xs `thenBc` \ rs ->
509 emitBc :: ProtoBCO Name -> BcM ()
511 = ((), st{bcos = bco : bcos st})
513 getLabelBc :: BcM Int
515 = (nextlabel st, st{nextlabel = 1 + nextlabel st})