2 % (c) The University of Glasgow 2000
4 \section[ByteCodeGen]{Generate bytecode from Core}
7 module ByteCodeGen ( byteCodeGen, assembleBCO ) where
9 #include "HsVersions.h"
12 import Name ( Name, getName )
13 import Id ( Id, idType, isDataConId_maybe )
14 import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
15 nilOL, toOL, concatOL, fromOL )
16 import FiniteMap ( FiniteMap, addListToFM, listToFM,
17 addToFM, lookupFM, fmToList, emptyFM )
19 import PprCore ( pprCoreExpr, pprCoreAlt )
20 import Literal ( Literal(..) )
21 import PrimRep ( PrimRep(..) )
22 import CoreFVs ( freeVars )
23 import Type ( typePrimRep )
24 import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon )
25 import TyCon ( tyConFamilySize )
26 import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
27 import Var ( isTyVar )
28 import VarSet ( VarSet, varSetElems )
29 import PrimRep ( getPrimRepSize, isFollowableRep )
30 import Constants ( wORD_SIZE )
32 import Monad ( foldM )
33 import Foreign ( Addr, Word16, Word32 )
35 --import MutableArray ( readWord32Array,
36 -- newFloatArray, writeFloatArray,
37 -- newDoubleArray, writeDoubleArray,
38 -- newIntArray, writeIntArray,
39 -- newAddrArray, writeAddrArray )
47 byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
49 = let flatBinds = concatMap getBind binds
50 getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
51 getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
52 final_state = runBc (BcM_State [] 0)
53 (mapBc schemeR flatBinds `thenBc_` returnBc ())
56 BcM_State bcos final_ctr -> bcos
60 %************************************************************************
62 \subsection{Bytecodes, and Outputery.}
64 %************************************************************************
70 data UnboxedLit = UnboxedI Int | UnboxedF Float | UnboxedD Double
73 -- Messing with the stack
75 -- Push locals (existing bits of the stack)
76 | PUSH_L Int{-offset-}
77 | PUSH_LL Int Int{-2 offsets-}
78 | PUSH_LLL Int Int Int{-3 offsets-}
81 -- Push an alt continuation
82 | PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info
83 -- PrimRep so we know which itbl
85 | PUSH_UBX Literal Int
86 -- push this int/float/double, NO TAG, on the stack
87 -- Int is # of items in literal pool to push
88 | PUSH_TAG Int -- push this tag on the stack
90 | SLIDE Int{-this many-} Int{-down by this much-}
91 -- To do with the heap
92 | ALLOC Int -- make an AP_UPD with this many payload words, zeroed
93 | MKAP Int{-ptr to AP_UPD is this far down stack-} Int{-# words-}
94 | UNPACK Int -- unpack N ptr words from t.o.s Constr
96 -- unpack N non-ptr words from offset M in constructor
97 -- K words down the stack
99 -- For doing case trees
101 | TESTLT_I Int LocalLabel
102 | TESTEQ_I Int LocalLabel
103 | TESTLT_F Float LocalLabel
104 | TESTEQ_F Float LocalLabel
105 | TESTLT_D Double LocalLabel
106 | TESTEQ_D Double LocalLabel
107 | TESTLT_P Int LocalLabel
108 | TESTEQ_P Int LocalLabel
110 -- To Infinity And Beyond
112 | RETURN -- unboxed value on TOS. Use tag to find underlying ret itbl
113 -- and return as per that.
116 instance Outputable BCInstr where
117 ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
118 ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
119 ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
120 ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
121 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
122 ppr (PUSH_AS nm pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk
123 ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
124 ppr (ALLOC sz) = text "ALLOC " <+> int sz
125 ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
126 ppr (UNPACK sz) = text "UNPACK " <+> int sz
127 ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
128 ppr (LABEL lab) = text "__" <> int lab <> colon
129 ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
130 ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
131 ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab
132 ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
133 ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab
134 ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
135 ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab
136 ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
137 ppr CASEFAIL = text "CASEFAIL"
138 ppr ENTER = text "ENTER"
139 ppr RETURN = text "RETURN"
141 pprAltCode discrs_n_codes
142 = vcat (map f discrs_n_codes)
143 where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
145 instance Outputable a => Outputable (ProtoBCO a) where
146 ppr (ProtoBCO name instrs origin)
147 = (text "ProtoBCO" <+> ppr name <> colon)
148 $$ nest 6 (vcat (map ppr instrs))
150 Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
151 Right rhs -> pprCoreExpr (deAnnotate rhs)
154 %************************************************************************
156 \subsection{Compilation schema for the bytecode generator.}
158 %************************************************************************
162 type BCInstrList = OrdList BCInstr
165 = ProtoBCO a -- name, in some sense
167 -- what the BCO came from
168 (Either [AnnAlt Id VarSet]
172 type Sequel = Int -- back off to this depth before ENTER
174 -- Maps Ids to the offset from the stack _base_ so we don't have
175 -- to mess with it after each push/pop.
176 type BCEnv = FiniteMap Id Int -- To find vars on the stack
179 -- Create a BCO and do a spot of peephole optimisation on the insns
181 mkProtoBCO nm instrs_ordlist origin
182 = ProtoBCO nm (peep (fromOL instrs_ordlist)) origin
184 peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
185 = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
186 peep (PUSH_L off1 : PUSH_L off2 : rest)
187 = PUSH_LL off1 off2 : peep rest
194 -- Compile code for the right hand side of a let binding.
195 -- Park the resulting BCO in the monad. Also requires the
196 -- variable to which this value was bound, so as to give the
197 -- resulting BCO a name.
198 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
199 schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs)
201 collect xs (_, AnnLam x e)
202 = collect (if isTyVar x then xs else (x:xs)) e
203 collect xs not_lambda
204 = (reverse xs, not_lambda)
206 schemeR_wrk original_body nm (args, body)
207 = let fvs = filter (not.isTyVar) (varSetElems (fst original_body))
208 all_args = fvs ++ reverse args
209 szsw_args = map taggedIdSizeW all_args
210 szw_args = sum szsw_args
211 p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
212 argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
214 schemeE szw_args 0 p_init body `thenBc` \ body_code ->
215 emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
217 -- Let szsw be the sizes in words of some items pushed onto the stack,
218 -- which has initial depth d'. Return the values which the stack environment
219 -- should map these items to.
220 mkStackOffsets :: Int -> [Int] -> [Int]
221 mkStackOffsets original_depth szsw
222 = map (subtract 1) (tail (scanl (+) original_depth szsw))
224 -- Compile code to apply the given expression to the remaining args
225 -- on the stack, returning a HNF.
226 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
228 -- Delegate tail-calls to schemeT.
229 schemeE d s p e@(fvs, AnnApp f a)
230 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
231 schemeE d s p e@(fvs, AnnVar v)
232 | isFollowableRep (typePrimRep (idType v))
233 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
235 = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN.
236 let (push, szw) = pushAtom True d p (AnnVar v)
237 in returnBc (push -- value onto stack
238 `snocOL` SLIDE szw (d-s) -- clear to sequel
239 `snocOL` RETURN) -- go
241 schemeE d s p (fvs, AnnLit literal)
242 = let (push, szw) = pushAtom True d p (AnnLit literal)
243 in returnBc (push -- value onto stack
244 `snocOL` SLIDE szw (d-s) -- clear to sequel
245 `snocOL` RETURN) -- go
247 schemeE d s p (fvs, AnnLet binds b)
248 = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
249 AnnRec xs_n_rhss -> unzip xs_n_rhss
251 fvss = map (filter (not.isTyVar).varSetElems.fst) rhss
252 sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
254 -- This p', d' defn is safe because all the items being pushed
255 -- are ptrs, so all have size 1. d' and p' reflect the stack
256 -- after the closures have been allocated in the heap (but not
257 -- filled in), and pointers to them parked on the stack.
258 p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
261 infos = zipE4 fvss sizes xs [n, n-1 .. 1]
262 zipE = zipEqual "schemeE"
263 zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
265 -- ToDo: don't build thunks for things with no free variables
266 buildThunk dd ([], size, id, off)
267 = PUSH_G (getName id)
268 `consOL` unitOL (MKAP (off+size-1) size)
269 buildThunk dd ((fv:fvs), size, id, off)
270 = case pushAtom True dd p' (AnnVar fv) of
271 (push_code, pushed_szw)
273 buildThunk (dd+pushed_szw) (fvs, size, id, off)
275 thunkCode = concatOL (map (buildThunk d') infos)
276 allocCode = toOL (map ALLOC sizes)
278 schemeE d' s p' b `thenBc` \ bodyCode ->
279 mapBc schemeR (zip xs rhss) `thenBc_`
280 returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
283 schemeE d s p (fvs, AnnCase scrut bndr alts)
285 -- Top of stack is the return itbl, as usual.
286 -- underneath it is the pointer to the alt_code BCO.
287 -- When an alt is entered, it assumes the returned value is
288 -- on top of the itbl.
291 -- Env and depth in which to compile the alts, not including
292 -- any vars bound by the alts themselves
293 d' = d + ret_frame_sizeW + taggedIdSizeW bndr
294 p' = addToFM p bndr (d' - 1)
296 scrut_primrep = typePrimRep (idType bndr)
298 = case scrut_primrep of
299 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
301 other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
303 -- given an alt, return a discr and code for it.
304 codeAlt alt@(discr, binds_f, rhs)
306 = let binds_r = reverse binds_f
307 binds_r_szsw = map untaggedIdSizeW binds_r
308 binds_szw = sum binds_r_szsw
310 p' (zip binds_r (mkStackOffsets d' binds_r_szsw))
312 unpack_code = mkUnpackCode 0 0 (map (typePrimRep.idType) binds_f)
313 in schemeE d'' s p'' rhs `thenBc` \ rhs_code ->
314 returnBc (my_discr alt, unpack_code `appOL` rhs_code)
316 = ASSERT(null binds_f)
317 schemeE d' s p' rhs `thenBc` \ rhs_code ->
318 returnBc (my_discr alt, rhs_code)
320 my_discr (DEFAULT, binds, rhs) = NoDiscr
321 my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc)
322 my_discr (LitAlt l, binds, rhs)
323 = case l of MachInt i -> DiscrI (fromInteger i)
324 MachFloat r -> DiscrF (fromRational r)
325 MachDouble r -> DiscrD (fromRational r)
328 | not isAlgCase = Nothing
330 = case [dc | (DataAlt dc, _, _) <- alts] of
332 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
335 mapBc codeAlt alts `thenBc` \ alt_stuff ->
336 mkMultiBranch maybe_ncons alt_stuff `thenBc` \ alt_final ->
338 alt_bco_name = getName bndr
339 alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
341 schemeE (d + ret_frame_sizeW)
342 (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
344 emitBc alt_bco `thenBc_`
345 returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
348 schemeE d s p (fvs, AnnNote note body)
352 = pprPanic "ByteCodeGen.schemeE: unhandled case"
353 (pprCoreExpr (deAnnotate other))
356 -- Compile code to do a tail call. Doesn't need to be monadic.
357 schemeT :: Bool -- do tagging?
358 -> Int -- Stack depth
359 -> Sequel -- Sequel depth
360 -> Int -- # arg words so far
361 -> BCEnv -- stack env
362 -> AnnExpr Id VarSet -> BCInstrList
364 schemeT enTag d s narg_words p (_, AnnApp f a)
366 AnnType _ -> schemeT enTag d s narg_words p f
368 -> let (push, arg_words) = pushAtom enTag d p (snd a)
370 `appOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
372 schemeT enTag d s narg_words p (_, AnnVar f)
373 | Just con <- isDataConId_maybe f
374 = ASSERT(enTag == False)
375 PACK con narg_words `consOL` (mkSLIDE 1 (d-s-1) `snocOL` ENTER)
377 = ASSERT(enTag == True)
378 let (push, arg_words) = pushAtom True d p (AnnVar f)
380 `appOL` mkSLIDE (narg_words+arg_words) (d - s - narg_words)
384 = if d == 0 then nilOL else unitOL (SLIDE n d)
386 should_args_be_tagged (_, AnnVar v)
387 = case isDataConId_maybe v of
388 Just dcon -> False; Nothing -> True
389 should_args_be_tagged (_, AnnApp f a)
390 = should_args_be_tagged f
391 should_args_be_tagged (_, other)
392 = panic "should_args_be_tagged: tail call to non-con, non-var"
395 -- Make code to unpack a constructor onto the stack, adding
396 -- tags for the unboxed bits. Takes the PrimReps of the constructor's
397 -- arguments, and a travelling offset along both the constructor
398 -- (off_h) and the stack (off_s).
399 mkUnpackCode :: Int -> Int -> [PrimRep] -> BCInstrList
400 mkUnpackCode off_h off_s [] = nilOL
401 mkUnpackCode off_h off_s (r:rs)
403 = let (rs_ptr, rs_nptr) = span isFollowableRep (r:rs)
404 ptrs_szw = sum (map untaggedSizeW rs_ptr)
405 in ASSERT(ptrs_szw == length rs_ptr)
409 `consOL` mkUnpackCode (off_h + ptrs_szw) (off_s + ptrs_szw) rs_nptr
414 DoubleRep -> approved
416 approved = UPK_TAG usizeW off_h off_s `consOL` theRest
417 theRest = mkUnpackCode (off_h + usizeW) (off_s + tsizeW) rs
418 usizeW = untaggedSizeW r
419 tsizeW = taggedSizeW r
421 -- Push an atom onto the stack, returning suitable code & number of
422 -- stack words used. Pushes it either tagged or untagged, since
423 -- pushAtom is used to set up the stack prior to copying into the
424 -- heap for both APs (requiring tags) and constructors (which don't).
426 -- NB this means NO GC between pushing atoms for a constructor and
427 -- copying them into the heap. It probably also means that
428 -- tail calls MUST be of the form atom{atom ... atom} since if the
429 -- expression head was allowed to be arbitrary, there could be GC
430 -- in between pushing the arg atoms and completing the head.
431 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
432 -- isn't a problem; but only if arbitrary graph construction for the
433 -- head doesn't leave this BCO, since GC might happen at the start of
434 -- each BCO (we consult doYouWantToGC there).
436 -- Blargh. JRS 001206
438 -- NB (further) that the env p must map each variable to the highest-
439 -- numbered stack slot for it. For example, if the stack has depth 4
440 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
441 -- the tag in stack[5], the stack will have depth 6, and p must map v to
442 -- 5 and not to 4. Stack locations are numbered from zero, so a depth
443 -- 6 stack has valid words 0 .. 5.
445 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
446 pushAtom tagged d p (AnnVar v)
447 = let str = "\npushAtom " ++ showSDocDebug (ppr v) ++ ", depth = " ++ show d
449 showSDocDebug (nest 4 (vcat (map ppr (fmToList p))))
451 showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
452 ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
453 str' = if str == str then str else str
456 = case lookupBCEnv_maybe p v of
457 Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), sz_t)
458 Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), sz_t)
461 sz_t = taggedIdSizeW v
462 sz_u = untaggedIdSizeW v
463 nwords = if tagged then sz_t else sz_u
468 pushAtom True d p (AnnLit lit)
469 = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
470 in (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
472 pushAtom False d p (AnnLit lit)
474 MachInt i -> code IntRep
475 MachFloat r -> code FloatRep
476 MachDouble r -> code DoubleRep
479 = let size_host_words = untaggedSizeW rep
480 size_in_word32s = (size_host_words * wORD_SIZE) `div` 4
481 in (unitOL (PUSH_UBX lit size_in_word32s), size_host_words)
483 pushAtom tagged d p (AnnApp f (_, AnnType _))
484 = pushAtom tagged d p (snd f)
486 pushAtom tagged d p other
487 = pprPanic "ByteCodeGen.pushAtom"
488 (pprCoreExpr (deAnnotate (undefined, other)))
491 -- Given a bunch of alts code and their discrs, do the donkey work
492 -- of making a multiway branch using a switch tree.
493 -- What a load of hassle!
494 mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
495 -- a hint; generates better code
496 -- Nothing is always safe
497 -> [(Discr, BCInstrList)]
499 mkMultiBranch maybe_ncons raw_ways
500 = let d_way = filter (isNoDiscr.fst) raw_ways
501 notd_ways = naturalMergeSortLe
502 (\w1 w2 -> leAlt (fst w1) (fst w2))
503 (filter (not.isNoDiscr.fst) raw_ways)
505 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
506 mkTree [] range_lo range_hi = returnBc the_default
508 mkTree [val] range_lo range_hi
509 | range_lo `eqAlt` range_hi
512 = getLabelBc `thenBc` \ label_neq ->
513 returnBc (mkTestEQ (fst val) label_neq
515 `appOL` unitOL (LABEL label_neq)
516 `appOL` the_default))
518 mkTree vals range_lo range_hi
519 = let n = length vals `div` 2
520 vals_lo = take n vals
521 vals_hi = drop n vals
522 v_mid = fst (head vals_hi)
524 getLabelBc `thenBc` \ label_geq ->
525 mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
526 mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
527 returnBc (mkTestLT v_mid label_geq
529 `appOL` unitOL (LABEL label_geq)
533 = case d_way of [] -> unitOL CASEFAIL
536 -- None of these will be needed if there are no non-default alts
537 (mkTestLT, mkTestEQ, init_lo, init_hi)
539 = panic "mkMultiBranch: awesome foursome"
541 = case fst (head notd_ways) of {
542 DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
543 \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
546 DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
547 \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
550 DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
551 \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
554 DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
555 \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
560 (algMinBound, algMaxBound)
561 = case maybe_ncons of
562 Just n -> (fIRST_TAG, fIRST_TAG + n - 1)
563 Nothing -> (minBound, maxBound)
565 (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
566 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
567 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
568 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
569 NoDiscr `eqAlt` NoDiscr = True
572 (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
573 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
574 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
575 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
576 NoDiscr `leAlt` NoDiscr = True
579 isNoDiscr NoDiscr = True
582 dec (DiscrI i) = DiscrI (i-1)
583 dec (DiscrP i) = DiscrP (i-1)
584 dec other = other -- not really right, but if you
585 -- do cases on floating values, you'll get what you deserve
587 -- same snotty comment applies to the following
595 mkTree notd_ways init_lo init_hi
599 %************************************************************************
601 \subsection{Supporting junk for the compilation schemes}
603 %************************************************************************
607 -- Describes case alts
615 instance Outputable Discr where
616 ppr (DiscrI i) = int i
617 ppr (DiscrF f) = text (show f)
618 ppr (DiscrD d) = text (show d)
619 ppr (DiscrP i) = int i
620 ppr NoDiscr = text "DEF"
623 -- Find things in the BCEnv (the what's-on-the-stack-env)
624 -- See comment preceding pushAtom for precise meaning of env contents
625 lookupBCEnv :: BCEnv -> Id -> Int
627 = case lookupFM env nm of
628 Nothing -> pprPanic "lookupBCEnv"
629 (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
632 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
633 lookupBCEnv_maybe = lookupFM
636 -- When I push one of these on the stack, how much does Sp move by?
637 taggedSizeW :: PrimRep -> Int
639 | isFollowableRep pr = 1
640 | otherwise = 1{-the tag-} + getPrimRepSize pr
643 -- The plain size of something, without tag.
644 untaggedSizeW :: PrimRep -> Int
646 | isFollowableRep pr = 1
647 | otherwise = getPrimRepSize pr
650 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
651 taggedIdSizeW = taggedSizeW . typePrimRep . idType
652 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
656 %************************************************************************
658 \subsection{The bytecode generator's monad}
660 %************************************************************************
664 = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
665 nextlabel :: Int } -- for generating local labels
667 type BcM result = BcM_State -> (result, BcM_State)
669 mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State
670 mkBcM_State = BcM_State
672 runBc :: BcM_State -> BcM () -> BcM_State
673 runBc init_st m = case m init_st of { (r,st) -> st }
675 thenBc :: BcM a -> (a -> BcM b) -> BcM b
677 = case expr st of { (result, st') -> cont result st' }
679 thenBc_ :: BcM a -> BcM b -> BcM b
681 = case expr st of { (result, st') -> cont st' }
683 returnBc :: a -> BcM a
684 returnBc result st = (result, st)
686 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
687 mapBc f [] = returnBc []
689 = f x `thenBc` \ r ->
690 mapBc f xs `thenBc` \ rs ->
693 emitBc :: ProtoBCO Name -> BcM ()
695 = ((), st{bcos = bco : bcos st})
697 getLabelBc :: BcM Int
699 = (nextlabel st, st{nextlabel = 1 + nextlabel st})
703 %************************************************************************
705 \subsection{The bytecode assembler}
707 %************************************************************************
709 The object format for bytecodes is: 16 bits for the opcode, and 16 for
710 each field -- so the code can be considered a sequence of 16-bit ints.
711 Each field denotes either a stack offset or number of items on the
712 stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
713 index into the literal table (eg PUSH_I/D/L), or a bytecode address in
717 -- An (almost) assembled BCO.
718 data BCO a = BCO [Word16] -- instructions
719 [Word32] -- literal pool
720 [a] -- Names or HValues
722 -- Top level assembler fn.
723 assembleBCO :: ProtoBCO Name -> IO AsmState
724 assembleBCO (ProtoBCO nm instrs origin)
726 -- pass 1: collect up the offsets of the local labels
727 label_env = mkLabelEnv emptyFM 0 instrs
729 mkLabelEnv env i_offset [] = env
730 mkLabelEnv env i_offset (i:is)
732 = case i of LABEL n -> addToFM env n i_offset ; _ -> env
733 in mkLabelEnv new_env (i_offset + instrSizeB i) is
736 = case lookupFM label_env lab of
737 Just bco_offset -> bco_offset
738 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
744 do insns <- newXIOUArray init_n_insns :: IO (XIOUArray Word16)
745 lits <- newXIOUArray init_n_lits :: IO (XIOUArray Word32)
746 ptrs <- newXIOArray init_n_ptrs -- :: IO (XIOArray Name)
748 -- pass 2: generate the instruction, ptr and nonptr bits
749 let init_asm_state = (insns,lits,ptrs)
750 final_asm_state <- mkBits findLabel init_asm_state instrs
752 return final_asm_state
755 -- instrs nonptrs ptrs
756 type AsmState = (XIOUArray Word16, XIOUArray Word32, XIOArray Name)
759 -- This is where all the action is (pass 2 of the assembler)
760 mkBits :: (Int -> Int) -- label finder
762 -> [BCInstr] -- instructions (in)
765 mkBits findLabel st proto_insns
766 = foldM doInstr st proto_insns
768 doInstr :: AsmState -> BCInstr -> IO AsmState
771 ARGCHECK n -> instr2 st i_ARGCHECK n
772 PUSH_L o1 -> instr2 st i_PUSH_L o1
773 PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2
774 PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
775 PUSH_G nm -> do (p, st2) <- ptr st nm
776 instr2 st2 i_PUSH_G p
777 PUSH_AS nm pk -> do (p, st2) <- ptr st nm
778 (np, st3) <- ret_itbl st2 pk
779 instr3 st3 i_PUSH_AS p np
780 PUSH_UBX lit nw32s -> do (np, st2) <- literal st lit
781 instr3 st2 i_PUSH_UBX np nw32s
782 PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
783 SLIDE n by -> instr3 st i_SLIDE n by
784 ALLOC n -> instr2 st i_ALLOC n
785 MKAP off sz -> instr3 st i_MKAP off sz
786 UNPACK n -> instr2 st i_UNPACK n
787 UPK_TAG n m k -> instr4 st i_UPK_TAG n m k
788 PACK dcon sz -> do (np,st2) <- itbl st dcon
789 instr3 st2 i_PACK np sz
790 LABEL lab -> return st
791 TESTLT_I i l -> do (np, st2) <- int st i
792 instr3 st2 i_TESTLT_I np (findLabel l)
793 TESTEQ_I i l -> do (np, st2) <- int st i
794 instr3 st2 i_TESTEQ_I np (findLabel l)
795 TESTLT_F f l -> do (np, st2) <- float st f
796 instr3 st2 i_TESTLT_F np (findLabel l)
797 TESTEQ_F f l -> do (np, st2) <- float st f
798 instr3 st2 i_TESTEQ_F np (findLabel l)
799 TESTLT_D d l -> do (np, st2) <- double st d
800 instr3 st2 i_TESTLT_D np (findLabel l)
801 TESTEQ_D d l -> do (np, st2) <- double st d
802 instr3 st2 i_TESTEQ_D np (findLabel l)
803 TESTLT_P i l -> do (np, st2) <- int st i
804 instr3 st2 i_TESTLT_P np (findLabel l)
805 TESTEQ_P i l -> do (np, st2) <- int st i
806 instr3 st2 i_TESTEQ_P np (findLabel l)
807 CASEFAIL -> instr1 st i_CASEFAIL
808 ENTER -> instr1 st i_ENTER
809 RETURN -> instr1 st i_RETURN
814 instr1 (st_i0,st_l0,st_p0) i1
815 = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
816 return (st_i1,st_l0,st_p0)
818 instr2 (st_i0,st_l0,st_p0) i1 i2
819 = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
820 st_i2 <- addToXIOUArray st_i1 (i2s i2)
821 return (st_i2,st_l0,st_p0)
823 instr3 (st_i0,st_l0,st_p0) i1 i2 i3
824 = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
825 st_i2 <- addToXIOUArray st_i1 (i2s i2)
826 st_i3 <- addToXIOUArray st_i2 (i2s i3)
827 return (st_i3,st_l0,st_p0)
829 instr4 (st_i0,st_l0,st_p0) i1 i2 i3 i4
830 = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
831 st_i2 <- addToXIOUArray st_i1 (i2s i2)
832 st_i3 <- addToXIOUArray st_i2 (i2s i3)
833 st_i4 <- addToXIOUArray st_i3 (i2s i4)
834 return (st_i4,st_l0,st_p0)
836 float (st_i0,st_l0,st_p0) f
837 = do let w32s = mkLitF f
838 st_l1 <- addListToXIOUArray st_l0 w32s
839 return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
841 double (st_i0,st_l0,st_p0) d
842 = do let w32s = mkLitD d
843 st_l1 <- addListToXIOUArray st_l0 w32s
844 return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
846 int (st_i0,st_l0,st_p0) i
847 = do let w32s = mkLitI i
848 st_l1 <- addListToXIOUArray st_l0 w32s
849 return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
851 addr (st_i0,st_l0,st_p0) a
852 = do let w32s = mkLitA a
853 st_l1 <- addListToXIOUArray st_l0 w32s
854 return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
856 ptr (st_i0,st_l0,st_p0) p
857 = do st_p1 <- addToXIOArray st_p0 p
858 return (usedXIO st_p0, (st_i0,st_l0,st_p1))
860 literal st (MachInt j) = int st (fromIntegral j)
861 literal st (MachFloat r) = float st (fromRational r)
862 literal st (MachDouble r) = double st (fromRational r)
864 ret_itbl st pk = panic "ret_itbl" -- return (65535, st)
865 itbl st dcon = panic "itbl" -- return (65536, st)
868 -- The size in bytes of an instruction.
869 instrSizeB :: BCInstr -> Int
896 -- Sizes of Int, Float and Double literals, in units of 32-bitses
897 intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int
898 intLitSz32s = wORD_SIZE `div` 4
899 floatLitSz32s = 1 -- Assume IEEE floats
901 addrLitSz32s = intLitSz32s
903 -- Make lists of 32-bit words for literals, so that when the
904 -- words are placed in memory at increasing addresses, the
905 -- bit pattern is correct for the host's word size and endianness.
906 mkLitI :: Int -> [Word32]
907 mkLitF :: Float -> [Word32]
908 mkLitD :: Double -> [Word32]
909 mkLitA :: Addr -> [Word32]
913 arr <- newFloatArray ((0::Int),0)
914 writeFloatArray arr 0 f
915 f_arr <- castSTUArray arr
916 w0 <- readWord32Array f_arr 0
922 arr <- newDoubleArray ((0::Int),0)
923 writeDoubleArray arr 0 d
924 d_arr <- castSTUArray arr
925 w0 <- readWord32Array d_arr 0
926 w1 <- readWord32Array d_arr 1
933 arr <- newIntArray ((0::Int),0)
934 writeIntArray arr 0 i
935 i_arr <- castSTUArray arr
936 w0 <- readWord32Array i_arr 0
941 arr <- newIntArray ((0::Int),0)
942 writeIntArray arr 0 i
943 i_arr <- castSTUArray arr
944 w0 <- readWord32Array i_arr 0
945 w1 <- readWord32Array i_arr 1
952 arr <- newAddrArray ((0::Int),0)
953 writeAddrArray arr 0 a
954 a_arr <- castSTUArray arr
955 w0 <- readWord32Array a_arr 0
960 arr <- newAddrArray ((0::Int),0)
961 writeAddrArray arr 0 a
962 a_arr <- castSTUArray arr
963 w0 <- readWord32Array a_arr 0
964 w1 <- readWord32Array a_arr 1
970 -- Zero-based expandable arrays
972 = XIOUArray { usedXIOU :: Int, stuffXIOU :: (IOUArray Int ele) }
974 = XIOArray { usedXIO :: Int , stuffXIO :: (IOArray Int ele) }
977 = do arr <- newArray (0, size-1)
978 return (XIOUArray 0 arr)
980 addListToXIOUArray xarr []
982 addListToXIOUArray xarr (x:xs)
983 = addToXIOUArray xarr x >>= \ xarr' -> addListToXIOUArray xarr' xs
986 addToXIOUArray :: MArray IOUArray a IO
987 => XIOUArray a -> a -> IO (XIOUArray a)
988 addToXIOUArray (XIOUArray n_arr arr) x
990 (lo, hi) -> ASSERT(lo == 0)
992 then do new_arr <- newArray (0, 2*hi-1)
994 addToXIOUArray (XIOUArray n_arr new_arr) x
995 else do writeArray arr n_arr x
996 return (XIOUArray (n_arr+1) arr)
998 copy :: MArray IOUArray a IO
999 => Int -> IOUArray Int a -> IOUArray Int a -> IO ()
1002 | otherwise = do nx <- readArray src n
1009 = do arr <- newArray (0, size-1)
1010 return (XIOArray 0 arr)
1012 addToXIOArray :: XIOArray a -> a -> IO (XIOArray a)
1013 addToXIOArray (XIOArray n_arr arr) x
1014 = case bounds arr of
1015 (lo, hi) -> ASSERT(lo == 0)
1017 then do new_arr <- newArray (0, 2*hi-1)
1019 addToXIOArray (XIOArray n_arr new_arr) x
1020 else do writeArray arr n_arr x
1021 return (XIOArray (n_arr+1) arr)
1023 copy :: Int -> IOArray Int a -> IOArray Int a -> IO ()
1026 | otherwise = do nx <- readArray src n
1031 #include "Bytecodes.h"
1033 i_ARGCHECK = (bci_ARGCHECK :: Int)
1034 i_PUSH_L = (bci_PUSH_L :: Int)
1035 i_PUSH_LL = (bci_PUSH_LL :: Int)
1036 i_PUSH_LLL = (bci_PUSH_LLL :: Int)
1037 i_PUSH_G = (bci_PUSH_G :: Int)
1038 i_PUSH_AS = (bci_PUSH_AS :: Int)
1039 i_PUSH_UBX = (bci_PUSH_UBX :: Int)
1040 i_PUSH_TAG = (bci_PUSH_TAG :: Int)
1041 i_SLIDE = (bci_SLIDE :: Int)
1042 i_ALLOC = (bci_ALLOC :: Int)
1043 i_MKAP = (bci_MKAP :: Int)
1044 i_UNPACK = (bci_UNPACK :: Int)
1045 i_UPK_TAG = (bci_UPK_TAG :: Int)
1046 i_PACK = (bci_PACK :: Int)
1047 i_LABEL = (bci_LABEL :: Int)
1048 i_TESTLT_I = (bci_TESTLT_I :: Int)
1049 i_TESTEQ_I = (bci_TESTEQ_I :: Int)
1050 i_TESTLT_F = (bci_TESTLT_F :: Int)
1051 i_TESTEQ_F = (bci_TESTEQ_F :: Int)
1052 i_TESTLT_D = (bci_TESTLT_D :: Int)
1053 i_TESTEQ_D = (bci_TESTEQ_D :: Int)
1054 i_TESTLT_P = (bci_TESTLT_P :: Int)
1055 i_TESTEQ_P = (bci_TESTEQ_P :: Int)
1056 i_CASEFAIL = (bci_CASEFAIL :: Int)
1057 i_ENTER = (bci_ENTER :: Int)
1058 i_RETURN = (bci_RETURN :: Int)