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 Literal ( Literal(..) )
20 import PrimRep ( PrimRep(..) )
21 import CoreFVs ( freeVars )
22 import Type ( typePrimRep )
23 import DataCon ( DataCon, dataConTag, fIRST_TAG )
24 import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe )
25 import VarSet ( VarSet, varSetElems )
26 import PrimRep ( getPrimRepSize, isFollowableRep )
27 import Constants ( wORD_SIZE )
29 import Foreign ( Addr, Word16, Word32, nullAddr )
31 import MutableArray ( readWord32Array,
32 newFloatArray, writeFloatArray,
33 newDoubleArray, writeDoubleArray,
34 newIntArray, writeIntArray,
35 newAddrArray, writeAddrArray )
41 byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
43 = let flatBinds = concatMap getBind binds
44 getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
45 getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
46 final_state = runBc (BcM_State [] 0)
47 (mapBc schemeR flatBinds `thenBc_` returnBc ())
50 BcM_State bcos final_ctr -> bcos
54 %************************************************************************
56 \subsection{Bytecodes, and Outputery.}
58 %************************************************************************
65 -- Messing with the stack
67 | PUSH_L Int{-size-} Int{-offset-}
75 | SLIDE Int{-this many-} Int{-down by this much-}
76 -- To do with the heap
78 | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-}
81 -- For doing case trees
83 | TESTLT_I Int LocalLabel
84 | TESTEQ_I Int LocalLabel
85 | TESTLT_F Float LocalLabel
86 | TESTEQ_F Float LocalLabel
87 | TESTLT_D Double LocalLabel
88 | TESTEQ_D Double LocalLabel
89 | TESTLT_P Int LocalLabel
90 | TESTEQ_P Int LocalLabel
92 -- To Infinity And Beyond
95 instance Outputable BCInstr where
96 ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
97 ppr (PUSH_L sz offset) = text "PUSH_L " <+> int sz <+> int offset
98 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
99 ppr (PUSHT_I i) = text "PUSHT_I " <+> int i
100 ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
101 ppr (ALLOC sz) = text "ALLOC " <+> int sz
102 ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
103 ppr (UNPACK sz) = text "UNPACK " <+> int sz
104 ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
105 ppr ENTER = text "ENTER"
107 pprAltCode discrs_n_codes
108 = vcat (map f discrs_n_codes)
109 where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
111 instance Outputable a => Outputable (ProtoBCO a) where
112 ppr (ProtoBCO name instrs)
113 = (text "ProtoBCO" <+> ppr name <> colon)
114 $$ nest 6 (vcat (map ppr (fromOL instrs)))
118 %************************************************************************
120 \subsection{Compilation schema for the bytecode generator.}
122 %************************************************************************
126 type BCInstrList = OrdList BCInstr
128 data ProtoBCO a = ProtoBCO a BCInstrList
130 type Sequel = Int -- back off to this depth before ENTER
132 -- Maps Ids to the offset from the stack _base_ so we don't have
133 -- to mess with it after each push/pop.
134 type BCEnv = FiniteMap Id Int -- To find vars on the stack
138 -- Compile code for the right hand side of a let binding.
139 -- Park the resulting BCO in the monad. Also requires the
140 -- variable to which this value was bound, so as to give the
141 -- resulting BCO a name.
142 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
143 schemeR (nm, rhs) = schemeR_wrk nm (collect [] rhs)
145 collect xs (_, AnnLam x e) = collect (x:xs) e
146 collect xs not_lambda = (reverse xs, not_lambda)
148 schemeR_wrk nm (args, body)
150 all_args = varSetElems fvs ++ args
151 szsw_args = map taggedIdSizeW all_args
152 szw_args = sum szsw_args
153 p_init = listToFM (zip all_args (scanl (+) 0 szsw_args))
154 argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
156 schemeE szw_args 0 p_init body `thenBc` \ body_code ->
157 emitBc (ProtoBCO (getName nm) (appOL argcheck body_code))
160 -- Compile code to apply the given expression to the remaining args
161 -- on the stack, returning a HNF.
162 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
164 -- Delegate tail-calls to schemeT.
165 schemeE d s p e@(fvs, AnnApp f a)
166 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
167 schemeE d s p e@(fvs, AnnVar v)
168 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
170 schemeE d s p (fvs, AnnLet binds b)
171 = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
172 AnnRec xs_n_rhss -> unzip xs_n_rhss
174 mapBc schemeR (zip xs rhss) `thenBc_`
176 fvss = map (varSetElems.fst) rhss
177 sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
178 p' = addListToFM p (zipE xs [d .. d+n-1])
180 infos = zipE4 fvss sizes xs [n, n-1 .. 1]
181 zipE = zipEqual "schemeE"
182 zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
184 -- ToDo: don't build thunks for things with no free variables
185 buildThunk (fvs, size, id, off)
186 = case unzip (map (pushAtom True d' p . AnnVar) (reverse fvs)) of
187 (push_codes, pushed_szsw)
188 -> ASSERT(sum pushed_szsw == size - 1)
189 (toOL push_codes `snocOL` PUSH_G (getName id)
190 `appOL` unitOL (MKAP off size))
192 thunkCode = concatOL (map buildThunk infos)
193 allocCode = toOL (map ALLOC sizes)
195 schemeE d' s p' b `thenBc` \ bodyCode ->
196 mapBc schemeR (zip xs rhss) `thenBc` \_ ->
197 returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
200 schemeE d s p (fvs, AnnCase scrut bndr alts)
202 -- Top of stack is the return itbl, as usual.
203 -- underneath it is the pointer to the alt_code BCO.
204 -- When an alt is entered, it assumes the returned value is
205 -- on top of the itbl.
208 -- Env and depth in which to compile the alts, not including
209 -- any vars bound by the alts themselves
210 d' = d + ret_frame_sizeW + taggedIdSizeW bndr
211 p' = addToFM p bndr d'
214 = case typePrimRep (idType bndr) of
215 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
217 other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
219 -- given an alt, return a discr and code for it.
220 codeAlt alt@(discr, binds, rhs)
222 = let binds_szsw = map untaggedIdSizeW binds
223 binds_szw = sum binds_szsw
224 p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw))
226 in schemeE d'' s p'' rhs `thenBc` \ rhs_code ->
227 returnBc (my_discr alt, UNPACK binds_szw `consOL` rhs_code)
230 schemeE d' s p' rhs `thenBc` \ rhs_code ->
231 returnBc (my_discr alt, rhs_code)
233 my_discr (DEFAULT, binds, rhs) = NoDiscr
234 my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
235 my_discr (LitAlt l, binds, rhs)
236 = case l of MachInt i -> DiscrI (fromInteger i)
237 MachFloat r -> DiscrF (fromRational r)
238 MachDouble r -> DiscrD (fromRational r)
241 mapBc codeAlt alts `thenBc` \ alt_stuff ->
242 mkMultiBranch alt_stuff `thenBc` \ alt_final ->
244 alt_bco_name = getName bndr
245 alt_bco = ProtoBCO alt_bco_name alt_final
247 schemeE (d + ret_frame_sizeW)
248 (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
250 emitBc alt_bco `thenBc_`
251 returnBc (PUSH_G alt_bco_name `consOL` scrut_code)
254 -- Compile code to do a tail call. Doesn't need to be monadic.
255 schemeT :: Bool -- do tagging?
256 -> Int -- Stack depth
257 -> Sequel -- Sequel depth
258 -> Int -- # arg words so far
259 -> BCEnv -- stack env
260 -> AnnExpr Id VarSet -> BCInstrList
262 schemeT enTag d s narg_words p (_, AnnApp f a)
263 = let (push, arg_words) = pushAtom enTag d p (snd a)
265 `consOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
267 schemeT enTag d s narg_words p (_, AnnVar f)
268 | Just con <- isDataConId_maybe f
269 = ASSERT(enTag == False)
270 PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
272 = ASSERT(enTag == True)
273 let (push, arg_words) = pushAtom True d p (AnnVar f)
275 `consOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
276 `consOL` unitOL ENTER
278 should_args_be_tagged (_, AnnVar v)
279 = case isDataConId_maybe v of
280 Just dcon -> False; Nothing -> True
281 should_args_be_tagged (_, AnnApp f a)
282 = should_args_be_tagged f
283 should_args_be_tagged (_, other)
284 = panic "should_args_be_tagged: tail call to non-con, non-var"
286 -- Push an atom onto the stack, returning suitable code & number of
287 -- stack words used. Pushes it either tagged or untagged, since
288 -- pushAtom is used to set up the stack prior to copying into the
289 -- heap for both APs (requiring tags) and constructors (which don't).
291 -- NB this means NO GC between pushing atoms for a constructor and
292 -- copying them into the heap. It probably also means that
293 -- tail calls MUST be of the form atom{atom ... atom} since if the
294 -- expression head was allowed to be arbitrary, there could be GC
295 -- in between pushing the arg atoms and completing the head.
296 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
297 -- isn't a problem; but only if arbitrary graph construction for the
298 -- head doesn't leave this BCO, since GC might happen at the start of
299 -- each BCO (we consult doYouWantToGC there).
301 -- Blargh. JRS 001206
303 pushAtom True{-tagged-} d p (AnnVar v)
304 = case lookupBCEnv_maybe p v of
305 Just offset -> (PUSH_L sz offset, sz)
306 Nothing -> ASSERT(sz == 1) (PUSH_G nm, sz)
311 pushAtom False{-not tagged-} d p (AnnVar v)
312 = case lookupBCEnv_maybe p v of
313 Just offset -> (PUSH_L sz (offset+1), sz-1)
314 Nothing -> ASSERT(sz == 1) (PUSH_G nm, sz)
317 sz = untaggedIdSizeW v
319 pushAtom True d p (AnnLit lit)
321 MachInt i -> (PUSHT_I (fromInteger i), taggedSizeW IntRep)
322 MachFloat r -> (PUSHT_F (fromRational r), taggedSizeW FloatRep)
323 MachDouble r -> (PUSHT_D (fromRational r), taggedSizeW DoubleRep)
325 pushAtom False d p (AnnLit lit)
327 MachInt i -> (PUSHU_I (fromInteger i), untaggedSizeW IntRep)
328 MachFloat r -> (PUSHU_F (fromRational r), untaggedSizeW FloatRep)
329 MachDouble r -> (PUSHU_D (fromRational r), untaggedSizeW DoubleRep)
332 -- Given a bunch of alts code and their discrs, do the donkey work
333 -- of making a multiway branch using a switch tree.
334 -- What a load of hassle!
335 mkMultiBranch :: [(Discr, BCInstrList)] -> BcM BCInstrList
336 mkMultiBranch raw_ways
337 = let d_way = filter (isNoDiscr.fst) raw_ways
338 notd_ways = naturalMergeSortLe
339 (\w1 w2 -> leAlt (fst w1) (fst w2))
340 (filter (not.isNoDiscr.fst) raw_ways)
342 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
343 mkTree [] range_lo range_hi = returnBc the_default
345 mkTree [val] range_lo range_hi
346 | range_lo `eqAlt` range_hi
349 = getLabelBc `thenBc` \ label_neq ->
350 returnBc (mkTestEQ (fst val) label_neq
352 `appOL` unitOL (LABEL label_neq)
353 `appOL` the_default))
355 mkTree vals range_lo range_hi
356 = let n = length vals `div` 2
357 vals_lo = take n vals
358 vals_hi = drop n vals
359 v_mid = fst (head vals_hi)
361 getLabelBc `thenBc` \ label_geq ->
362 mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
363 mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
364 returnBc (mkTestLT v_mid label_geq
366 `appOL` unitOL (LABEL label_geq)
370 = case d_way of [] -> unitOL CASEFAIL
373 -- None of these will be needed if there are no non-default alts
374 (mkTestLT, mkTestEQ, init_lo, init_hi)
376 = panic "mkMultiBranch: awesome foursome"
378 = case fst (head notd_ways) of {
379 DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
380 \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
383 DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
384 \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
387 DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
388 \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
391 DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
392 \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
397 (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
398 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
399 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
400 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
401 NoDiscr `eqAlt` NoDiscr = True
404 (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
405 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
406 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
407 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
408 NoDiscr `leAlt` NoDiscr = True
411 isNoDiscr NoDiscr = True
414 dec (DiscrI i) = DiscrI (i-1)
415 dec (DiscrP i) = DiscrP (i-1)
416 dec other = other -- not really right, but if you
417 -- do cases on floating values, you'll get what you deserve
419 -- same snotty comment applies to the following
427 mkTree notd_ways init_lo init_hi
431 %************************************************************************
433 \subsection{Supporting junk for the compilation schemes}
435 %************************************************************************
439 -- Describes case alts
447 instance Outputable Discr where
448 ppr (DiscrI i) = int i
449 ppr (DiscrF f) = text (show f)
450 ppr (DiscrD d) = text (show d)
451 ppr (DiscrP i) = int i
452 ppr NoDiscr = text "DEF"
455 -- Find things in the BCEnv (the what's-on-the-stack-env)
456 lookupBCEnv :: BCEnv -> Id -> Int
458 = case lookupFM env nm of
459 Nothing -> pprPanic "lookupBCEnv"
460 (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
463 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
464 lookupBCEnv_maybe = lookupFM
467 -- When I push one of these on the stack, how much does Sp move by?
468 taggedSizeW :: PrimRep -> Int
470 | isFollowableRep pr = 1
471 | otherwise = 1{-the tag-} + getPrimRepSize pr
474 -- The plain size of something, without tag.
475 untaggedSizeW :: PrimRep -> Int
477 | isFollowableRep pr = 1
478 | otherwise = getPrimRepSize pr
481 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
482 taggedIdSizeW = taggedSizeW . typePrimRep . idType
483 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
487 %************************************************************************
489 \subsection{The bytecode generator's monad}
491 %************************************************************************
495 = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
496 nextlabel :: Int } -- for generating local labels
498 type BcM result = BcM_State -> (result, BcM_State)
500 mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State
501 mkBcM_State = BcM_State
503 runBc :: BcM_State -> BcM () -> BcM_State
504 runBc init_st m = case m init_st of { (r,st) -> st }
506 thenBc :: BcM a -> (a -> BcM b) -> BcM b
508 = case expr st of { (result, st') -> cont result st' }
510 thenBc_ :: BcM a -> BcM b -> BcM b
512 = case expr st of { (result, st') -> cont st' }
514 returnBc :: a -> BcM a
515 returnBc result st = (result, st)
517 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
518 mapBc f [] = returnBc []
520 = f x `thenBc` \ r ->
521 mapBc f xs `thenBc` \ rs ->
524 emitBc :: ProtoBCO Name -> BcM ()
526 = ((), st{bcos = bco : bcos st})
528 getLabelBc :: BcM Int
530 = (nextlabel st, st{nextlabel = 1 + nextlabel st})
534 %************************************************************************
536 \subsection{The bytecode assembler}
538 %************************************************************************
540 The object format for bytecodes is: 16 bits for the opcode, and 16 for
541 each field -- so the code can be considered a sequence of 16-bit ints.
542 Each field denotes either a stack offset or number of items on the
543 stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
544 index into the literal table (eg PUSH_I/D/L), or a bytecode address in
548 -- An (almost) assembled BCO.
549 data BCO a = BCO [Word16] -- instructions
550 [Word32] -- literal pool
551 [a] -- Names or HValues
553 -- Top level assembler fn.
554 assembleBCO :: ProtoBCO Name -> BCO Name
555 assembleBCO (ProtoBCO nm instrs_ordlist)
557 -- pass 1: collect up the offsets of the local labels
558 instrs = fromOL instrs_ordlist
559 label_env = mkLabelEnv emptyFM 0 instrs
561 mkLabelEnv env i_offset [] = env
562 mkLabelEnv env i_offset (i:is)
564 = case i of LABEL n -> addToFM env n i_offset ; _ -> env
565 in mkLabelEnv new_env (i_offset + instrSizeB i) is
568 = case lookupFM label_env lab of
569 Just bco_offset -> bco_offset
570 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
572 -- pass 2: generate the instruction, ptr and nonptr bits
573 (insnW16s, litW32s, ptrs) = mkBits findLabel [] 0 [] 0 [] 0 instrs
575 BCO insnW16s litW32s ptrs
578 -- This is where all the action is (pass 2 of the assembler)
579 mkBits :: (Int -> Int) -- label finder
580 -> [Word16] -> Int -- reverse acc instr bits
581 -> [Word32] -> Int -- reverse acc literal bits
582 -> [Name] -> Int -- reverse acc ptrs
583 -> [BCInstr] -- insns!
584 -> ([Word16], [Word32], [Name])
586 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs []
587 = (reverse r_is, reverse r_lits, reverse r_ptrs)
588 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs (instr:instrs)
590 ARGCHECK n -> boring2 i_ARGCHECK n
591 PUSH_L sz off -> boring3 i_PUSH_L sz off
592 PUSH_G nm -> exciting2_P i_PUSH_G n_ptrs nm
593 PUSHT_I i -> exciting2_I i_PUSHT_I n_lits i
594 PUSHT_F f -> exciting2_F i_PUSHT_F n_lits f
595 PUSHT_D d -> exciting2_D i_PUSHT_D n_lits d
596 PUSHU_I i -> exciting2_I i_PUSHU_I n_lits i
597 PUSHU_F f -> exciting2_F i_PUSHU_F n_lits f
598 PUSHU_D d -> exciting2_D i_PUSHU_D n_lits d
599 SLIDE n by -> boring3 i_SLIDE n by
600 ALLOC n -> boring2 i_ALLOC n
601 MKAP off sz -> boring3 i_MKAP off sz
602 UNPACK n -> boring2 i_UNPACK n
603 PACK dcon sz -> exciting3_A i_PACK sz n_lits nullAddr {-findItbl dcon-}
605 TESTLT_I i l -> exciting3_I i_TESTLT_I n_lits (findLabel l) i
606 TESTEQ_I i l -> exciting3_I i_TESTEQ_I n_lits (findLabel l) i
607 TESTLT_F f l -> exciting3_F i_TESTLT_F n_lits (findLabel l) f
608 TESTEQ_F f l -> exciting3_F i_TESTEQ_F n_lits (findLabel l) f
609 TESTLT_D d l -> exciting3_D i_TESTLT_D n_lits (findLabel l) d
610 TESTEQ_D d l -> exciting3_D i_TESTEQ_D n_lits (findLabel l) d
611 TESTLT_P i l -> exciting3_I i_TESTLT_P n_lits (findLabel l) i
612 TESTEQ_P i l -> exciting3_I i_TESTEQ_P n_lits (findLabel l) i
613 CASEFAIL -> boring1 i_CASEFAIL
614 ENTER -> boring1 i_ENTER
616 r_mkILit = reverse . mkILit
617 r_mkFLit = reverse . mkFLit
618 r_mkDLit = reverse . mkDLit
619 r_mkALit = reverse . mkALit
625 = mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs instrs
627 = mkBits findLabel (mkw i1 : r_is) (n_is+1)
628 r_lits n_lits r_ptrs n_ptrs instrs
630 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
631 r_lits n_lits r_ptrs n_ptrs instrs
633 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
634 r_lits n_lits r_ptrs n_ptrs instrs
637 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) r_lits n_lits
638 (p:r_ptrs) (n_ptrs+1) instrs
639 exciting3_P i1 i2 i3 p
640 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) r_lits n_lits
641 (p:r_ptrs) (n_ptrs+1) instrs
644 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
645 (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
647 exciting3_I i1 i2 i3 i
648 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
649 (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
653 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
654 (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
656 exciting3_F i1 i2 i3 f
657 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
658 (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
662 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
663 (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
665 exciting3_D i1 i2 i3 d
666 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
667 (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
670 exciting3_A i1 i2 i3 d
671 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
672 (r_mkALit d ++ r_lits) (n_lits + addrLitSz32s)
676 -- The size in bytes of an instruction.
677 instrSizeB :: BCInstr -> Int
707 -- Sizes of Int, Float and Double literals, in units of 32-bitses
708 intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int
709 intLitSz32s = wORD_SIZE `div` 4
710 floatLitSz32s = 1 -- Assume IEEE floats
712 addrLitSz32s = intLitSz32s
714 -- Make lists of 32-bit words for literals, so that when the
715 -- words are placed in memory at increasing addresses, the
716 -- bit pattern is correct for the host's word size and endianness.
717 mkILit :: Int -> [Word32]
718 mkFLit :: Float -> [Word32]
719 mkDLit :: Double -> [Word32]
720 mkALit :: Addr -> [Word32]
724 arr <- newFloatArray ((0::Int),0)
725 writeFloatArray arr 0 f
726 w0 <- readWord32Array arr 0
732 arr <- newDoubleArray ((0::Int),0)
733 writeDoubleArray arr 0 d
734 w0 <- readWord32Array arr 0
735 w1 <- readWord32Array arr 1
742 arr <- newIntArray ((0::Int),0)
743 writeIntArray arr 0 i
744 w0 <- readWord32Array arr 0
749 arr <- newIntArray ((0::Int),0)
750 writeIntArray arr 0 i
751 w0 <- readWord32Array arr 0
752 w1 <- readWord32Array arr 1
759 arr <- newAddrArray ((0::Int),0)
760 writeAddrArray arr 0 a
761 w0 <- readWord32Array arr 0
766 arr <- newAddrArray ((0::Int),0)
767 writeAddrArray arr 0 a
768 w0 <- readWord32Array arr 0
769 w1 <- readWord32Array arr 1
775 #include "../rts/Bytecodes.h"
777 i_ARGCHECK = (bci_ARGCHECK :: Int)
778 i_PUSH_L = (bci_PUSH_L :: Int)
779 i_PUSH_G = (bci_PUSH_G :: Int)
780 i_PUSHT_I = (bci_PUSHT_I :: Int)
781 i_PUSHT_F = (bci_PUSHT_F :: Int)
782 i_PUSHT_D = (bci_PUSHT_D :: Int)
783 i_PUSHU_I = (bci_PUSHU_I :: Int)
784 i_PUSHU_F = (bci_PUSHU_F :: Int)
785 i_PUSHU_D = (bci_PUSHU_D :: Int)
786 i_SLIDE = (bci_SLIDE :: Int)
787 i_ALLOC = (bci_ALLOC :: Int)
788 i_MKAP = (bci_MKAP :: Int)
789 i_UNPACK = (bci_UNPACK :: Int)
790 i_PACK = (bci_PACK :: Int)
791 i_LABEL = (bci_LABEL :: Int)
792 i_TESTLT_I = (bci_TESTLT_I :: Int)
793 i_TESTEQ_I = (bci_TESTEQ_I :: Int)
794 i_TESTLT_F = (bci_TESTLT_F :: Int)
795 i_TESTEQ_F = (bci_TESTEQ_F :: Int)
796 i_TESTLT_D = (bci_TESTLT_D :: Int)
797 i_TESTEQ_D = (bci_TESTEQ_D :: Int)
798 i_TESTLT_P = (bci_TESTLT_P :: Int)
799 i_TESTEQ_P = (bci_TESTEQ_P :: Int)
800 i_CASEFAIL = (bci_CASEFAIL :: Int)
801 i_ENTER = (bci_ENTER :: Int)