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 )
25 import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe )
26 import VarSet ( VarSet, varSetElems )
27 import PrimRep ( getPrimRepSize, isFollowableRep )
28 import Constants ( wORD_SIZE )
30 import Foreign ( Addr, Word16, Word32, nullAddr )
32 import MutableArray ( readWord32Array,
33 newFloatArray, writeFloatArray,
34 newDoubleArray, writeDoubleArray,
35 newIntArray, writeIntArray,
36 newAddrArray, writeAddrArray )
42 byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
44 = let flatBinds = concatMap getBind binds
45 getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
46 getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
47 final_state = runBc (BcM_State [] 0)
48 (mapBc schemeR flatBinds `thenBc_` returnBc ())
51 BcM_State bcos final_ctr -> bcos
55 %************************************************************************
57 \subsection{Bytecodes, and Outputery.}
59 %************************************************************************
66 -- Messing with the stack
68 | PUSH_L Int{-size-} Int{-offset-}
76 | SLIDE Int{-this many-} Int{-down by this much-}
77 -- To do with the heap
79 | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-}
82 -- For doing case trees
84 | TESTLT_I Int LocalLabel
85 | TESTEQ_I Int LocalLabel
86 | TESTLT_F Float LocalLabel
87 | TESTEQ_F Float LocalLabel
88 | TESTLT_D Double LocalLabel
89 | TESTEQ_D Double LocalLabel
90 | TESTLT_P Int LocalLabel
91 | TESTEQ_P Int LocalLabel
93 -- To Infinity And Beyond
96 instance Outputable BCInstr where
97 ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
98 ppr (PUSH_L sz offset) = text "PUSH_L " <+> int sz <+> int offset
99 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
100 ppr (PUSHT_I i) = text "PUSHT_I " <+> int i
101 ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
102 ppr (ALLOC sz) = text "ALLOC " <+> int sz
103 ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
104 ppr (UNPACK sz) = text "UNPACK " <+> int sz
105 ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
106 ppr ENTER = text "ENTER"
108 pprAltCode discrs_n_codes
109 = vcat (map f discrs_n_codes)
110 where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
112 instance Outputable a => Outputable (ProtoBCO a) where
113 ppr (ProtoBCO name instrs origin)
114 = (text "ProtoBCO" <+> ppr name <> colon)
115 $$ nest 6 (vcat (map ppr (fromOL instrs)))
117 Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
118 Right rhs -> pprCoreExpr (deAnnotate rhs)
121 %************************************************************************
123 \subsection{Compilation schema for the bytecode generator.}
125 %************************************************************************
129 type BCInstrList = OrdList BCInstr
132 = ProtoBCO a -- name, in some sense
133 BCInstrList -- instrs
134 -- what the BCO came from
135 (Either [AnnAlt Id VarSet]
139 type Sequel = Int -- back off to this depth before ENTER
141 -- Maps Ids to the offset from the stack _base_ so we don't have
142 -- to mess with it after each push/pop.
143 type BCEnv = FiniteMap Id Int -- To find vars on the stack
147 -- Compile code for the right hand side of a let binding.
148 -- Park the resulting BCO in the monad. Also requires the
149 -- variable to which this value was bound, so as to give the
150 -- resulting BCO a name.
151 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
152 schemeR (nm, rhs) = schemeR_wrk nm (collect [] rhs)
154 collect xs (_, AnnLam x e) = collect (x:xs) e
155 collect xs not_lambda = (reverse xs, not_lambda)
157 schemeR_wrk nm (args, body)
159 all_args = varSetElems fvs ++ args
160 szsw_args = map taggedIdSizeW all_args
161 szw_args = sum szsw_args
162 p_init = listToFM (zip all_args (scanl (+) 0 szsw_args))
163 argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
165 schemeE szw_args 0 p_init body `thenBc` \ body_code ->
166 emitBc (ProtoBCO (getName nm) (appOL argcheck body_code) (Right body))
169 -- Compile code to apply the given expression to the remaining args
170 -- on the stack, returning a HNF.
171 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
173 -- Delegate tail-calls to schemeT.
174 schemeE d s p e@(fvs, AnnApp f a)
175 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
176 schemeE d s p e@(fvs, AnnVar v)
177 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
179 schemeE d s p (fvs, AnnLet binds b)
180 = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
181 AnnRec xs_n_rhss -> unzip xs_n_rhss
183 mapBc schemeR (zip xs rhss) `thenBc_`
185 fvss = map (varSetElems.fst) rhss
186 sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
187 p' = addListToFM p (zipE xs [d .. d+n-1])
189 infos = zipE4 fvss sizes xs [n, n-1 .. 1]
190 zipE = zipEqual "schemeE"
191 zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
193 -- ToDo: don't build thunks for things with no free variables
194 buildThunk (fvs, size, id, off)
195 = case unzip (map (pushAtom True d' p . AnnVar) (reverse fvs)) of
196 (push_codes, pushed_szsw)
197 -> ASSERT(sum pushed_szsw == size - 1)
198 (toOL push_codes `snocOL` PUSH_G (getName id)
199 `appOL` unitOL (MKAP off size))
201 thunkCode = concatOL (map buildThunk infos)
202 allocCode = toOL (map ALLOC sizes)
204 schemeE d' s p' b `thenBc` \ bodyCode ->
205 mapBc schemeR (zip xs rhss) `thenBc` \_ ->
206 returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
209 schemeE d s p (fvs, AnnCase scrut bndr alts)
211 -- Top of stack is the return itbl, as usual.
212 -- underneath it is the pointer to the alt_code BCO.
213 -- When an alt is entered, it assumes the returned value is
214 -- on top of the itbl.
217 -- Env and depth in which to compile the alts, not including
218 -- any vars bound by the alts themselves
219 d' = d + ret_frame_sizeW + taggedIdSizeW bndr
220 p' = addToFM p bndr d'
223 = case typePrimRep (idType bndr) of
224 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
226 other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
228 -- given an alt, return a discr and code for it.
229 codeAlt alt@(discr, binds, rhs)
231 = let binds_szsw = map untaggedIdSizeW binds
232 binds_szw = sum binds_szsw
233 p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw))
235 in schemeE d'' s p'' rhs `thenBc` \ rhs_code ->
236 returnBc (my_discr alt, UNPACK binds_szw `consOL` rhs_code)
239 schemeE d' s p' rhs `thenBc` \ rhs_code ->
240 returnBc (my_discr alt, rhs_code)
242 my_discr (DEFAULT, binds, rhs) = NoDiscr
243 my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
244 my_discr (LitAlt l, binds, rhs)
245 = case l of MachInt i -> DiscrI (fromInteger i)
246 MachFloat r -> DiscrF (fromRational r)
247 MachDouble r -> DiscrD (fromRational r)
250 mapBc codeAlt alts `thenBc` \ alt_stuff ->
251 mkMultiBranch alt_stuff `thenBc` \ alt_final ->
253 alt_bco_name = getName bndr
254 alt_bco = ProtoBCO alt_bco_name alt_final (Left alts)
256 schemeE (d + ret_frame_sizeW)
257 (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
259 emitBc alt_bco `thenBc_`
260 returnBc (PUSH_G alt_bco_name `consOL` scrut_code)
263 -- Compile code to do a tail call. Doesn't need to be monadic.
264 schemeT :: Bool -- do tagging?
265 -> Int -- Stack depth
266 -> Sequel -- Sequel depth
267 -> Int -- # arg words so far
268 -> BCEnv -- stack env
269 -> AnnExpr Id VarSet -> BCInstrList
271 schemeT enTag d s narg_words p (_, AnnApp f a)
272 = let (push, arg_words) = pushAtom enTag d p (snd a)
274 `consOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
276 schemeT enTag d s narg_words p (_, AnnVar f)
277 | Just con <- isDataConId_maybe f
278 = ASSERT(enTag == False)
279 PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
281 = ASSERT(enTag == True)
282 let (push, arg_words) = pushAtom True d p (AnnVar f)
284 `consOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
285 `consOL` unitOL ENTER
287 should_args_be_tagged (_, AnnVar v)
288 = case isDataConId_maybe v of
289 Just dcon -> False; Nothing -> True
290 should_args_be_tagged (_, AnnApp f a)
291 = should_args_be_tagged f
292 should_args_be_tagged (_, other)
293 = panic "should_args_be_tagged: tail call to non-con, non-var"
295 -- Push an atom onto the stack, returning suitable code & number of
296 -- stack words used. Pushes it either tagged or untagged, since
297 -- pushAtom is used to set up the stack prior to copying into the
298 -- heap for both APs (requiring tags) and constructors (which don't).
300 -- NB this means NO GC between pushing atoms for a constructor and
301 -- copying them into the heap. It probably also means that
302 -- tail calls MUST be of the form atom{atom ... atom} since if the
303 -- expression head was allowed to be arbitrary, there could be GC
304 -- in between pushing the arg atoms and completing the head.
305 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
306 -- isn't a problem; but only if arbitrary graph construction for the
307 -- head doesn't leave this BCO, since GC might happen at the start of
308 -- each BCO (we consult doYouWantToGC there).
310 -- Blargh. JRS 001206
312 pushAtom True{-tagged-} d p (AnnVar v)
313 = case lookupBCEnv_maybe p v of
314 Just offset -> (PUSH_L sz offset, sz)
315 Nothing -> ASSERT(sz == 1) (PUSH_G nm, sz)
320 pushAtom False{-not tagged-} d p (AnnVar v)
321 = case lookupBCEnv_maybe p v of
322 Just offset -> (PUSH_L sz (offset+1), sz-1)
323 Nothing -> ASSERT(sz == 1) (PUSH_G nm, sz)
326 sz = untaggedIdSizeW v
328 pushAtom True d p (AnnLit lit)
330 MachInt i -> (PUSHT_I (fromInteger i), taggedSizeW IntRep)
331 MachFloat r -> (PUSHT_F (fromRational r), taggedSizeW FloatRep)
332 MachDouble r -> (PUSHT_D (fromRational r), taggedSizeW DoubleRep)
334 pushAtom False d p (AnnLit lit)
336 MachInt i -> (PUSHU_I (fromInteger i), untaggedSizeW IntRep)
337 MachFloat r -> (PUSHU_F (fromRational r), untaggedSizeW FloatRep)
338 MachDouble r -> (PUSHU_D (fromRational r), untaggedSizeW DoubleRep)
341 -- Given a bunch of alts code and their discrs, do the donkey work
342 -- of making a multiway branch using a switch tree.
343 -- What a load of hassle!
344 mkMultiBranch :: [(Discr, BCInstrList)] -> BcM BCInstrList
345 mkMultiBranch raw_ways
346 = let d_way = filter (isNoDiscr.fst) raw_ways
347 notd_ways = naturalMergeSortLe
348 (\w1 w2 -> leAlt (fst w1) (fst w2))
349 (filter (not.isNoDiscr.fst) raw_ways)
351 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
352 mkTree [] range_lo range_hi = returnBc the_default
354 mkTree [val] range_lo range_hi
355 | range_lo `eqAlt` range_hi
358 = getLabelBc `thenBc` \ label_neq ->
359 returnBc (mkTestEQ (fst val) label_neq
361 `appOL` unitOL (LABEL label_neq)
362 `appOL` the_default))
364 mkTree vals range_lo range_hi
365 = let n = length vals `div` 2
366 vals_lo = take n vals
367 vals_hi = drop n vals
368 v_mid = fst (head vals_hi)
370 getLabelBc `thenBc` \ label_geq ->
371 mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
372 mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
373 returnBc (mkTestLT v_mid label_geq
375 `appOL` unitOL (LABEL label_geq)
379 = case d_way of [] -> unitOL CASEFAIL
382 -- None of these will be needed if there are no non-default alts
383 (mkTestLT, mkTestEQ, init_lo, init_hi)
385 = panic "mkMultiBranch: awesome foursome"
387 = case fst (head notd_ways) of {
388 DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
389 \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
392 DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
393 \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
396 DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
397 \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
400 DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
401 \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
406 (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
407 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
408 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
409 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
410 NoDiscr `eqAlt` NoDiscr = True
413 (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
414 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
415 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
416 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
417 NoDiscr `leAlt` NoDiscr = True
420 isNoDiscr NoDiscr = True
423 dec (DiscrI i) = DiscrI (i-1)
424 dec (DiscrP i) = DiscrP (i-1)
425 dec other = other -- not really right, but if you
426 -- do cases on floating values, you'll get what you deserve
428 -- same snotty comment applies to the following
436 mkTree notd_ways init_lo init_hi
440 %************************************************************************
442 \subsection{Supporting junk for the compilation schemes}
444 %************************************************************************
448 -- Describes case alts
456 instance Outputable Discr where
457 ppr (DiscrI i) = int i
458 ppr (DiscrF f) = text (show f)
459 ppr (DiscrD d) = text (show d)
460 ppr (DiscrP i) = int i
461 ppr NoDiscr = text "DEF"
464 -- Find things in the BCEnv (the what's-on-the-stack-env)
465 lookupBCEnv :: BCEnv -> Id -> Int
467 = case lookupFM env nm of
468 Nothing -> pprPanic "lookupBCEnv"
469 (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
472 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
473 lookupBCEnv_maybe = lookupFM
476 -- When I push one of these on the stack, how much does Sp move by?
477 taggedSizeW :: PrimRep -> Int
479 | isFollowableRep pr = 1
480 | otherwise = 1{-the tag-} + getPrimRepSize pr
483 -- The plain size of something, without tag.
484 untaggedSizeW :: PrimRep -> Int
486 | isFollowableRep pr = 1
487 | otherwise = getPrimRepSize pr
490 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
491 taggedIdSizeW = taggedSizeW . typePrimRep . idType
492 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
496 %************************************************************************
498 \subsection{The bytecode generator's monad}
500 %************************************************************************
504 = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
505 nextlabel :: Int } -- for generating local labels
507 type BcM result = BcM_State -> (result, BcM_State)
509 mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State
510 mkBcM_State = BcM_State
512 runBc :: BcM_State -> BcM () -> BcM_State
513 runBc init_st m = case m init_st of { (r,st) -> st }
515 thenBc :: BcM a -> (a -> BcM b) -> BcM b
517 = case expr st of { (result, st') -> cont result st' }
519 thenBc_ :: BcM a -> BcM b -> BcM b
521 = case expr st of { (result, st') -> cont st' }
523 returnBc :: a -> BcM a
524 returnBc result st = (result, st)
526 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
527 mapBc f [] = returnBc []
529 = f x `thenBc` \ r ->
530 mapBc f xs `thenBc` \ rs ->
533 emitBc :: ProtoBCO Name -> BcM ()
535 = ((), st{bcos = bco : bcos st})
537 getLabelBc :: BcM Int
539 = (nextlabel st, st{nextlabel = 1 + nextlabel st})
543 %************************************************************************
545 \subsection{The bytecode assembler}
547 %************************************************************************
549 The object format for bytecodes is: 16 bits for the opcode, and 16 for
550 each field -- so the code can be considered a sequence of 16-bit ints.
551 Each field denotes either a stack offset or number of items on the
552 stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
553 index into the literal table (eg PUSH_I/D/L), or a bytecode address in
557 -- An (almost) assembled BCO.
558 data BCO a = BCO [Word16] -- instructions
559 [Word32] -- literal pool
560 [a] -- Names or HValues
562 -- Top level assembler fn.
563 assembleBCO :: ProtoBCO Name -> BCO Name
564 assembleBCO (ProtoBCO nm instrs_ordlist origin)
566 -- pass 1: collect up the offsets of the local labels
567 instrs = fromOL instrs_ordlist
568 label_env = mkLabelEnv emptyFM 0 instrs
570 mkLabelEnv env i_offset [] = env
571 mkLabelEnv env i_offset (i:is)
573 = case i of LABEL n -> addToFM env n i_offset ; _ -> env
574 in mkLabelEnv new_env (i_offset + instrSizeB i) is
577 = case lookupFM label_env lab of
578 Just bco_offset -> bco_offset
579 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
581 -- pass 2: generate the instruction, ptr and nonptr bits
582 (insnW16s, litW32s, ptrs) = mkBits findLabel [] 0 [] 0 [] 0 instrs
584 BCO insnW16s litW32s ptrs
587 -- This is where all the action is (pass 2 of the assembler)
588 mkBits :: (Int -> Int) -- label finder
589 -> [Word16] -> Int -- reverse acc instr bits
590 -> [Word32] -> Int -- reverse acc literal bits
591 -> [Name] -> Int -- reverse acc ptrs
592 -> [BCInstr] -- insns!
593 -> ([Word16], [Word32], [Name])
595 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs []
596 = (reverse r_is, reverse r_lits, reverse r_ptrs)
597 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs (instr:instrs)
599 ARGCHECK n -> boring2 i_ARGCHECK n
600 PUSH_L sz off -> boring3 i_PUSH_L sz off
601 PUSH_G nm -> exciting2_P i_PUSH_G n_ptrs nm
602 PUSHT_I i -> exciting2_I i_PUSHT_I n_lits i
603 PUSHT_F f -> exciting2_F i_PUSHT_F n_lits f
604 PUSHT_D d -> exciting2_D i_PUSHT_D n_lits d
605 PUSHU_I i -> exciting2_I i_PUSHU_I n_lits i
606 PUSHU_F f -> exciting2_F i_PUSHU_F n_lits f
607 PUSHU_D d -> exciting2_D i_PUSHU_D n_lits d
608 SLIDE n by -> boring3 i_SLIDE n by
609 ALLOC n -> boring2 i_ALLOC n
610 MKAP off sz -> boring3 i_MKAP off sz
611 UNPACK n -> boring2 i_UNPACK n
612 PACK dcon sz -> exciting3_A i_PACK sz n_lits nullAddr {-findItbl dcon-}
614 TESTLT_I i l -> exciting3_I i_TESTLT_I n_lits (findLabel l) i
615 TESTEQ_I i l -> exciting3_I i_TESTEQ_I n_lits (findLabel l) i
616 TESTLT_F f l -> exciting3_F i_TESTLT_F n_lits (findLabel l) f
617 TESTEQ_F f l -> exciting3_F i_TESTEQ_F n_lits (findLabel l) f
618 TESTLT_D d l -> exciting3_D i_TESTLT_D n_lits (findLabel l) d
619 TESTEQ_D d l -> exciting3_D i_TESTEQ_D n_lits (findLabel l) d
620 TESTLT_P i l -> exciting3_I i_TESTLT_P n_lits (findLabel l) i
621 TESTEQ_P i l -> exciting3_I i_TESTEQ_P n_lits (findLabel l) i
622 CASEFAIL -> boring1 i_CASEFAIL
623 ENTER -> boring1 i_ENTER
625 r_mkILit = reverse . mkILit
626 r_mkFLit = reverse . mkFLit
627 r_mkDLit = reverse . mkDLit
628 r_mkALit = reverse . mkALit
634 = mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs instrs
636 = mkBits findLabel (mkw i1 : r_is) (n_is+1)
637 r_lits n_lits r_ptrs n_ptrs instrs
639 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
640 r_lits n_lits r_ptrs n_ptrs instrs
642 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
643 r_lits n_lits r_ptrs n_ptrs instrs
646 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) r_lits n_lits
647 (p:r_ptrs) (n_ptrs+1) instrs
648 exciting3_P i1 i2 i3 p
649 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) r_lits n_lits
650 (p:r_ptrs) (n_ptrs+1) instrs
653 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
654 (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
656 exciting3_I i1 i2 i3 i
657 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
658 (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
662 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
663 (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
665 exciting3_F i1 i2 i3 f
666 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
667 (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
671 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
672 (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
674 exciting3_D i1 i2 i3 d
675 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
676 (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
679 exciting3_A i1 i2 i3 d
680 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
681 (r_mkALit d ++ r_lits) (n_lits + addrLitSz32s)
685 -- The size in bytes of an instruction.
686 instrSizeB :: BCInstr -> Int
716 -- Sizes of Int, Float and Double literals, in units of 32-bitses
717 intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int
718 intLitSz32s = wORD_SIZE `div` 4
719 floatLitSz32s = 1 -- Assume IEEE floats
721 addrLitSz32s = intLitSz32s
723 -- Make lists of 32-bit words for literals, so that when the
724 -- words are placed in memory at increasing addresses, the
725 -- bit pattern is correct for the host's word size and endianness.
726 mkILit :: Int -> [Word32]
727 mkFLit :: Float -> [Word32]
728 mkDLit :: Double -> [Word32]
729 mkALit :: Addr -> [Word32]
733 arr <- newFloatArray ((0::Int),0)
734 writeFloatArray arr 0 f
735 w0 <- readWord32Array arr 0
741 arr <- newDoubleArray ((0::Int),0)
742 writeDoubleArray arr 0 d
743 w0 <- readWord32Array arr 0
744 w1 <- readWord32Array arr 1
751 arr <- newIntArray ((0::Int),0)
752 writeIntArray arr 0 i
753 w0 <- readWord32Array arr 0
758 arr <- newIntArray ((0::Int),0)
759 writeIntArray arr 0 i
760 w0 <- readWord32Array arr 0
761 w1 <- readWord32Array arr 1
768 arr <- newAddrArray ((0::Int),0)
769 writeAddrArray arr 0 a
770 w0 <- readWord32Array arr 0
775 arr <- newAddrArray ((0::Int),0)
776 writeAddrArray arr 0 a
777 w0 <- readWord32Array arr 0
778 w1 <- readWord32Array arr 1
784 #include "../rts/Bytecodes.h"
786 i_ARGCHECK = (bci_ARGCHECK :: Int)
787 i_PUSH_L = (bci_PUSH_L :: Int)
788 i_PUSH_G = (bci_PUSH_G :: Int)
789 i_PUSHT_I = (bci_PUSHT_I :: Int)
790 i_PUSHT_F = (bci_PUSHT_F :: Int)
791 i_PUSHT_D = (bci_PUSHT_D :: Int)
792 i_PUSHU_I = (bci_PUSHU_I :: Int)
793 i_PUSHU_F = (bci_PUSHU_F :: Int)
794 i_PUSHU_D = (bci_PUSHU_D :: Int)
795 i_SLIDE = (bci_SLIDE :: Int)
796 i_ALLOC = (bci_ALLOC :: Int)
797 i_MKAP = (bci_MKAP :: Int)
798 i_UNPACK = (bci_UNPACK :: Int)
799 i_PACK = (bci_PACK :: Int)
800 i_LABEL = (bci_LABEL :: Int)
801 i_TESTLT_I = (bci_TESTLT_I :: Int)
802 i_TESTEQ_I = (bci_TESTEQ_I :: Int)
803 i_TESTLT_F = (bci_TESTLT_F :: Int)
804 i_TESTEQ_F = (bci_TESTEQ_F :: Int)
805 i_TESTLT_D = (bci_TESTLT_D :: Int)
806 i_TESTEQ_D = (bci_TESTEQ_D :: Int)
807 i_TESTLT_P = (bci_TESTLT_P :: Int)
808 i_TESTEQ_P = (bci_TESTEQ_P :: Int)
809 i_CASEFAIL = (bci_CASEFAIL :: Int)
810 i_ENTER = (bci_ENTER :: Int)