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, nOfThem )
26 import Var ( isTyVar )
27 import VarSet ( VarSet, varSetElems )
28 import PrimRep ( getPrimRepSize, isFollowableRep )
29 import Constants ( wORD_SIZE )
31 import Foreign ( Addr, Word16, Word32, nullAddr )
33 import MutableArray ( readWord32Array,
34 newFloatArray, writeFloatArray,
35 newDoubleArray, writeDoubleArray,
36 newIntArray, writeIntArray,
37 newAddrArray, writeAddrArray )
43 byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
45 = let flatBinds = concatMap getBind binds
46 getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
47 getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
48 final_state = runBc (BcM_State [] 0)
49 (mapBc schemeR flatBinds `thenBc_` returnBc ())
52 BcM_State bcos final_ctr -> bcos
56 %************************************************************************
58 \subsection{Bytecodes, and Outputery.}
60 %************************************************************************
67 -- Messing with the stack
69 | PUSH_L Int{-offset-}
77 | SLIDE Int{-this many-} Int{-down by this much-}
78 -- To do with the heap
80 | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-}
83 -- For doing case trees
85 | TESTLT_I Int LocalLabel
86 | TESTEQ_I Int LocalLabel
87 | TESTLT_F Float LocalLabel
88 | TESTEQ_F Float LocalLabel
89 | TESTLT_D Double LocalLabel
90 | TESTEQ_D Double LocalLabel
91 | TESTLT_P Int LocalLabel
92 | TESTEQ_P Int LocalLabel
94 -- To Infinity And Beyond
97 instance Outputable BCInstr where
98 ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
99 ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
100 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
101 ppr (PUSHT_I i) = text "PUSHT_I " <+> int i
102 ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
103 ppr (ALLOC sz) = text "ALLOC " <+> int sz
104 ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
105 ppr (UNPACK sz) = text "UNPACK " <+> int sz
106 ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
107 ppr ENTER = text "ENTER"
109 pprAltCode discrs_n_codes
110 = vcat (map f discrs_n_codes)
111 where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
113 instance Outputable a => Outputable (ProtoBCO a) where
114 ppr (ProtoBCO name instrs origin)
115 = (text "ProtoBCO" <+> ppr name <> colon)
116 $$ nest 6 (vcat (map ppr (fromOL instrs)))
118 Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
119 Right rhs -> pprCoreExpr (deAnnotate rhs)
122 %************************************************************************
124 \subsection{Compilation schema for the bytecode generator.}
126 %************************************************************************
130 type BCInstrList = OrdList BCInstr
133 = ProtoBCO a -- name, in some sense
134 BCInstrList -- instrs
135 -- what the BCO came from
136 (Either [AnnAlt Id VarSet]
140 type Sequel = Int -- back off to this depth before ENTER
142 -- Maps Ids to the offset from the stack _base_ so we don't have
143 -- to mess with it after each push/pop.
144 type BCEnv = FiniteMap Id Int -- To find vars on the stack
148 -- Compile code for the right hand side of a let binding.
149 -- Park the resulting BCO in the monad. Also requires the
150 -- variable to which this value was bound, so as to give the
151 -- resulting BCO a name.
152 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
153 schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs)
155 collect xs (_, AnnLam x e)
156 = collect (if isTyVar x then xs else (x:xs)) e
157 collect xs not_lambda
158 = (reverse xs, not_lambda)
160 schemeR_wrk original_body nm (args, body)
161 = let fvs = filter (not.isTyVar) (varSetElems (fst original_body))
162 all_args = fvs ++ reverse args
163 szsw_args = map taggedIdSizeW all_args
164 szw_args = sum szsw_args
165 p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
166 argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
168 schemeE szw_args 0 p_init body `thenBc` \ body_code ->
169 emitBc (ProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
171 -- Let szsw be the sizes in words of some items pushed onto the stack,
172 -- which has initial depth d'. Return the values which the stack environment
173 -- should map these items to.
174 mkStackOffsets :: Int -> [Int] -> [Int]
175 mkStackOffsets original_depth szsw
176 = map (subtract 1) (tail (scanl (+) original_depth szsw))
178 -- Compile code to apply the given expression to the remaining args
179 -- on the stack, returning a HNF.
180 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
182 -- Delegate tail-calls to schemeT.
183 schemeE d s p e@(fvs, AnnApp f a)
184 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
185 schemeE d s p e@(fvs, AnnVar v)
186 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
188 schemeE d s p (fvs, AnnLet binds b)
189 = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
190 AnnRec xs_n_rhss -> unzip xs_n_rhss
192 fvss = map (filter (not.isTyVar).varSetElems.fst) rhss
193 sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
195 -- This p', d' defn is safe because all the items being pushed
196 -- are ptrs, so all have size 1. d' and p' reflect the stack
197 -- after the closures have been allocated in the heap (but not
198 -- filled in), and pointers to them parked on the stack.
199 p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
202 infos = zipE4 fvss sizes xs [n, n-1 .. 1]
203 zipE = zipEqual "schemeE"
204 zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
206 -- ToDo: don't build thunks for things with no free variables
207 buildThunk dd ([], size, id, off)
208 = PUSH_G (getName id)
209 `consOL` unitOL (MKAP (off+size-1) size)
210 buildThunk dd ((fv:fvs), size, id, off)
211 = case pushAtom True dd p' (AnnVar fv) of
212 (push_code, pushed_szw)
214 buildThunk (dd+pushed_szw) (fvs, size, id, off)
216 thunkCode = concatOL (map (buildThunk d') infos)
217 allocCode = toOL (map ALLOC sizes)
219 schemeE d' s p' b `thenBc` \ bodyCode ->
220 mapBc schemeR (zip xs rhss) `thenBc_`
221 returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
224 schemeE d s p (fvs, AnnCase scrut bndr alts)
226 -- Top of stack is the return itbl, as usual.
227 -- underneath it is the pointer to the alt_code BCO.
228 -- When an alt is entered, it assumes the returned value is
229 -- on top of the itbl.
232 -- Env and depth in which to compile the alts, not including
233 -- any vars bound by the alts themselves
234 d' = d + ret_frame_sizeW + taggedIdSizeW bndr
235 p' = addToFM p bndr (d' - 1)
238 = case typePrimRep (idType bndr) of
239 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
241 other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
243 -- given an alt, return a discr and code for it.
244 codeAlt alt@(discr, binds, rhs)
246 = let binds_szsw = map untaggedIdSizeW binds
247 binds_szw = sum binds_szsw
248 p'' = addListToFM p' (zip binds (mkStackOffsets d' binds_szsw))
250 in schemeE d'' s p'' rhs `thenBc` \ rhs_code ->
251 returnBc (my_discr alt, UNPACK binds_szw `consOL` rhs_code)
254 schemeE d' s p' rhs `thenBc` \ rhs_code ->
255 returnBc (my_discr alt, rhs_code)
257 my_discr (DEFAULT, binds, rhs) = NoDiscr
258 my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
259 my_discr (LitAlt l, binds, rhs)
260 = case l of MachInt i -> DiscrI (fromInteger i)
261 MachFloat r -> DiscrF (fromRational r)
262 MachDouble r -> DiscrD (fromRational r)
265 mapBc codeAlt alts `thenBc` \ alt_stuff ->
266 mkMultiBranch alt_stuff `thenBc` \ alt_final ->
268 alt_bco_name = getName bndr
269 alt_bco = ProtoBCO alt_bco_name alt_final (Left alts)
271 schemeE (d + ret_frame_sizeW)
272 (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
274 emitBc alt_bco `thenBc_`
275 returnBc (PUSH_G alt_bco_name `consOL` scrut_code)
278 -- Compile code to do a tail call. Doesn't need to be monadic.
279 schemeT :: Bool -- do tagging?
280 -> Int -- Stack depth
281 -> Sequel -- Sequel depth
282 -> Int -- # arg words so far
283 -> BCEnv -- stack env
284 -> AnnExpr Id VarSet -> BCInstrList
286 schemeT enTag d s narg_words p (_, AnnApp f a)
287 = let (push, arg_words) = pushAtom enTag d p (snd a)
290 `appOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
292 schemeT enTag d s narg_words p (_, AnnVar f)
293 | Just con <- isDataConId_maybe f
294 = ASSERT(enTag == False)
295 PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
297 = ASSERT(enTag == True)
298 let (push, arg_words) = pushAtom True d p (AnnVar f)
301 `snocOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
304 should_args_be_tagged (_, AnnVar v)
305 = case isDataConId_maybe v of
306 Just dcon -> False; Nothing -> True
307 should_args_be_tagged (_, AnnApp f a)
308 = should_args_be_tagged f
309 should_args_be_tagged (_, other)
310 = panic "should_args_be_tagged: tail call to non-con, non-var"
312 -- Push an atom onto the stack, returning suitable code & number of
313 -- stack words used. Pushes it either tagged or untagged, since
314 -- pushAtom is used to set up the stack prior to copying into the
315 -- heap for both APs (requiring tags) and constructors (which don't).
317 -- NB this means NO GC between pushing atoms for a constructor and
318 -- copying them into the heap. It probably also means that
319 -- tail calls MUST be of the form atom{atom ... atom} since if the
320 -- expression head was allowed to be arbitrary, there could be GC
321 -- in between pushing the arg atoms and completing the head.
322 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
323 -- isn't a problem; but only if arbitrary graph construction for the
324 -- head doesn't leave this BCO, since GC might happen at the start of
325 -- each BCO (we consult doYouWantToGC there).
327 -- Blargh. JRS 001206
329 -- NB (further) that the env p must map each variable to the highest-
330 -- numbered stack slot for it. For example, if the stack has depth 4
331 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
332 -- the tag in stack[5], the stack will have depth 6, and p must map v to
335 pushAtom tagged d p (AnnVar v)
336 = let str = "\npushAtom " ++ showSDocDebug (ppr v) ++ ", depth = " ++ show d
338 showSDocDebug (nest 4 (vcat (map ppr (fmToList p))))
340 showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
341 ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
342 str' = if str == str then str else str
345 = case lookupBCEnv_maybe p v of
346 Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), sz_t)
347 Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), sz_t)
350 sz_t = taggedIdSizeW v
351 sz_u = untaggedIdSizeW v
352 nwords = if tagged then sz_t else sz_u
357 pushAtom True d p (AnnLit lit)
359 MachInt i -> (unitOL (PUSHT_I (fromInteger i)), taggedSizeW IntRep)
360 MachFloat r -> (unitOL (PUSHT_F (fromRational r)), taggedSizeW FloatRep)
361 MachDouble r -> (unitOL (PUSHT_D (fromRational r)), taggedSizeW DoubleRep)
363 pushAtom False d p (AnnLit lit)
365 MachInt i -> (unitOL (PUSHU_I (fromInteger i)), untaggedSizeW IntRep)
366 MachFloat r -> (unitOL (PUSHU_F (fromRational r)), untaggedSizeW FloatRep)
367 MachDouble r -> (unitOL (PUSHU_D (fromRational r)), untaggedSizeW DoubleRep)
370 -- Given a bunch of alts code and their discrs, do the donkey work
371 -- of making a multiway branch using a switch tree.
372 -- What a load of hassle!
373 mkMultiBranch :: [(Discr, BCInstrList)] -> BcM BCInstrList
374 mkMultiBranch raw_ways
375 = let d_way = filter (isNoDiscr.fst) raw_ways
376 notd_ways = naturalMergeSortLe
377 (\w1 w2 -> leAlt (fst w1) (fst w2))
378 (filter (not.isNoDiscr.fst) raw_ways)
380 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
381 mkTree [] range_lo range_hi = returnBc the_default
383 mkTree [val] range_lo range_hi
384 | range_lo `eqAlt` range_hi
387 = getLabelBc `thenBc` \ label_neq ->
388 returnBc (mkTestEQ (fst val) label_neq
390 `appOL` unitOL (LABEL label_neq)
391 `appOL` the_default))
393 mkTree vals range_lo range_hi
394 = let n = length vals `div` 2
395 vals_lo = take n vals
396 vals_hi = drop n vals
397 v_mid = fst (head vals_hi)
399 getLabelBc `thenBc` \ label_geq ->
400 mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
401 mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
402 returnBc (mkTestLT v_mid label_geq
404 `appOL` unitOL (LABEL label_geq)
408 = case d_way of [] -> unitOL CASEFAIL
411 -- None of these will be needed if there are no non-default alts
412 (mkTestLT, mkTestEQ, init_lo, init_hi)
414 = panic "mkMultiBranch: awesome foursome"
416 = case fst (head notd_ways) of {
417 DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
418 \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
421 DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
422 \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
425 DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
426 \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
429 DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
430 \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
435 (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
436 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
437 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
438 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
439 NoDiscr `eqAlt` NoDiscr = True
442 (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
443 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
444 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
445 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
446 NoDiscr `leAlt` NoDiscr = True
449 isNoDiscr NoDiscr = True
452 dec (DiscrI i) = DiscrI (i-1)
453 dec (DiscrP i) = DiscrP (i-1)
454 dec other = other -- not really right, but if you
455 -- do cases on floating values, you'll get what you deserve
457 -- same snotty comment applies to the following
465 mkTree notd_ways init_lo init_hi
469 %************************************************************************
471 \subsection{Supporting junk for the compilation schemes}
473 %************************************************************************
477 -- Describes case alts
485 instance Outputable Discr where
486 ppr (DiscrI i) = int i
487 ppr (DiscrF f) = text (show f)
488 ppr (DiscrD d) = text (show d)
489 ppr (DiscrP i) = int i
490 ppr NoDiscr = text "DEF"
493 -- Find things in the BCEnv (the what's-on-the-stack-env)
494 -- See comment preceding pushAtom for precise meaning of env contents
495 lookupBCEnv :: BCEnv -> Id -> Int
497 = case lookupFM env nm of
498 Nothing -> pprPanic "lookupBCEnv"
499 (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
502 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
503 lookupBCEnv_maybe = lookupFM
506 -- When I push one of these on the stack, how much does Sp move by?
507 taggedSizeW :: PrimRep -> Int
509 | isFollowableRep pr = 1
510 | otherwise = 1{-the tag-} + getPrimRepSize pr
513 -- The plain size of something, without tag.
514 untaggedSizeW :: PrimRep -> Int
516 | isFollowableRep pr = 1
517 | otherwise = getPrimRepSize pr
520 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
521 taggedIdSizeW = taggedSizeW . typePrimRep . idType
522 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
526 %************************************************************************
528 \subsection{The bytecode generator's monad}
530 %************************************************************************
534 = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
535 nextlabel :: Int } -- for generating local labels
537 type BcM result = BcM_State -> (result, BcM_State)
539 mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State
540 mkBcM_State = BcM_State
542 runBc :: BcM_State -> BcM () -> BcM_State
543 runBc init_st m = case m init_st of { (r,st) -> st }
545 thenBc :: BcM a -> (a -> BcM b) -> BcM b
547 = case expr st of { (result, st') -> cont result st' }
549 thenBc_ :: BcM a -> BcM b -> BcM b
551 = case expr st of { (result, st') -> cont st' }
553 returnBc :: a -> BcM a
554 returnBc result st = (result, st)
556 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
557 mapBc f [] = returnBc []
559 = f x `thenBc` \ r ->
560 mapBc f xs `thenBc` \ rs ->
563 emitBc :: ProtoBCO Name -> BcM ()
565 = ((), st{bcos = bco : bcos st})
567 getLabelBc :: BcM Int
569 = (nextlabel st, st{nextlabel = 1 + nextlabel st})
573 %************************************************************************
575 \subsection{The bytecode assembler}
577 %************************************************************************
579 The object format for bytecodes is: 16 bits for the opcode, and 16 for
580 each field -- so the code can be considered a sequence of 16-bit ints.
581 Each field denotes either a stack offset or number of items on the
582 stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
583 index into the literal table (eg PUSH_I/D/L), or a bytecode address in
587 -- An (almost) assembled BCO.
588 data BCO a = BCO [Word16] -- instructions
589 [Word32] -- literal pool
590 [a] -- Names or HValues
592 -- Top level assembler fn.
593 assembleBCO :: ProtoBCO Name -> BCO Name
594 assembleBCO (ProtoBCO nm instrs_ordlist origin)
596 -- pass 1: collect up the offsets of the local labels
597 instrs = fromOL instrs_ordlist
598 label_env = mkLabelEnv emptyFM 0 instrs
600 mkLabelEnv env i_offset [] = env
601 mkLabelEnv env i_offset (i:is)
603 = case i of LABEL n -> addToFM env n i_offset ; _ -> env
604 in mkLabelEnv new_env (i_offset + instrSizeB i) is
607 = case lookupFM label_env lab of
608 Just bco_offset -> bco_offset
609 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
611 -- pass 2: generate the instruction, ptr and nonptr bits
612 (insnW16s, litW32s, ptrs) = mkBits findLabel [] 0 [] 0 [] 0 instrs
614 BCO insnW16s litW32s ptrs
617 -- This is where all the action is (pass 2 of the assembler)
618 mkBits :: (Int -> Int) -- label finder
619 -> [Word16] -> Int -- reverse acc instr bits
620 -> [Word32] -> Int -- reverse acc literal bits
621 -> [Name] -> Int -- reverse acc ptrs
622 -> [BCInstr] -- insns!
623 -> ([Word16], [Word32], [Name])
625 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs []
626 = (reverse r_is, reverse r_lits, reverse r_ptrs)
627 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs (instr:instrs)
629 ARGCHECK n -> boring2 i_ARGCHECK n
630 PUSH_L off -> boring2 i_PUSH_L off
631 PUSH_G nm -> exciting2_P i_PUSH_G n_ptrs nm
632 PUSHT_I i -> exciting2_I i_PUSHT_I n_lits i
633 PUSHT_F f -> exciting2_F i_PUSHT_F n_lits f
634 PUSHT_D d -> exciting2_D i_PUSHT_D n_lits d
635 PUSHU_I i -> exciting2_I i_PUSHU_I n_lits i
636 PUSHU_F f -> exciting2_F i_PUSHU_F n_lits f
637 PUSHU_D d -> exciting2_D i_PUSHU_D n_lits d
638 SLIDE n by -> boring3 i_SLIDE n by
639 ALLOC n -> boring2 i_ALLOC n
640 MKAP off sz -> boring3 i_MKAP off sz
641 UNPACK n -> boring2 i_UNPACK n
642 PACK dcon sz -> exciting3_A i_PACK sz n_lits nullAddr {-findItbl dcon-}
644 TESTLT_I i l -> exciting3_I i_TESTLT_I n_lits (findLabel l) i
645 TESTEQ_I i l -> exciting3_I i_TESTEQ_I n_lits (findLabel l) i
646 TESTLT_F f l -> exciting3_F i_TESTLT_F n_lits (findLabel l) f
647 TESTEQ_F f l -> exciting3_F i_TESTEQ_F n_lits (findLabel l) f
648 TESTLT_D d l -> exciting3_D i_TESTLT_D n_lits (findLabel l) d
649 TESTEQ_D d l -> exciting3_D i_TESTEQ_D n_lits (findLabel l) d
650 TESTLT_P i l -> exciting3_I i_TESTLT_P n_lits (findLabel l) i
651 TESTEQ_P i l -> exciting3_I i_TESTEQ_P n_lits (findLabel l) i
652 CASEFAIL -> boring1 i_CASEFAIL
653 ENTER -> boring1 i_ENTER
655 r_mkILit = reverse . mkILit
656 r_mkFLit = reverse . mkFLit
657 r_mkDLit = reverse . mkDLit
658 r_mkALit = reverse . mkALit
664 = mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs instrs
666 = mkBits findLabel (mkw i1 : r_is) (n_is+1)
667 r_lits n_lits r_ptrs n_ptrs instrs
669 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
670 r_lits n_lits r_ptrs n_ptrs instrs
672 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
673 r_lits n_lits r_ptrs n_ptrs instrs
676 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) r_lits n_lits
677 (p:r_ptrs) (n_ptrs+1) instrs
678 exciting3_P i1 i2 i3 p
679 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) r_lits n_lits
680 (p:r_ptrs) (n_ptrs+1) instrs
683 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
684 (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
686 exciting3_I i1 i2 i3 i
687 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
688 (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
692 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
693 (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
695 exciting3_F i1 i2 i3 f
696 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
697 (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
701 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
702 (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
704 exciting3_D i1 i2 i3 d
705 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
706 (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
709 exciting3_A i1 i2 i3 d
710 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
711 (r_mkALit d ++ r_lits) (n_lits + addrLitSz32s)
715 -- The size in bytes of an instruction.
716 instrSizeB :: BCInstr -> Int
746 -- Sizes of Int, Float and Double literals, in units of 32-bitses
747 intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int
748 intLitSz32s = wORD_SIZE `div` 4
749 floatLitSz32s = 1 -- Assume IEEE floats
751 addrLitSz32s = intLitSz32s
753 -- Make lists of 32-bit words for literals, so that when the
754 -- words are placed in memory at increasing addresses, the
755 -- bit pattern is correct for the host's word size and endianness.
756 mkILit :: Int -> [Word32]
757 mkFLit :: Float -> [Word32]
758 mkDLit :: Double -> [Word32]
759 mkALit :: Addr -> [Word32]
763 arr <- newFloatArray ((0::Int),0)
764 writeFloatArray arr 0 f
765 w0 <- readWord32Array arr 0
771 arr <- newDoubleArray ((0::Int),0)
772 writeDoubleArray arr 0 d
773 w0 <- readWord32Array arr 0
774 w1 <- readWord32Array arr 1
781 arr <- newIntArray ((0::Int),0)
782 writeIntArray arr 0 i
783 w0 <- readWord32Array arr 0
788 arr <- newIntArray ((0::Int),0)
789 writeIntArray arr 0 i
790 w0 <- readWord32Array arr 0
791 w1 <- readWord32Array arr 1
798 arr <- newAddrArray ((0::Int),0)
799 writeAddrArray arr 0 a
800 w0 <- readWord32Array arr 0
805 arr <- newAddrArray ((0::Int),0)
806 writeAddrArray arr 0 a
807 w0 <- readWord32Array arr 0
808 w1 <- readWord32Array arr 1
814 #include "../rts/Bytecodes.h"
816 i_ARGCHECK = (bci_ARGCHECK :: Int)
817 i_PUSH_L = (bci_PUSH_L :: Int)
818 i_PUSH_G = (bci_PUSH_G :: Int)
819 i_PUSHT_I = (bci_PUSHT_I :: Int)
820 i_PUSHT_F = (bci_PUSHT_F :: Int)
821 i_PUSHT_D = (bci_PUSHT_D :: Int)
822 i_PUSHU_I = (bci_PUSHU_I :: Int)
823 i_PUSHU_F = (bci_PUSHU_F :: Int)
824 i_PUSHU_D = (bci_PUSHU_D :: Int)
825 i_SLIDE = (bci_SLIDE :: Int)
826 i_ALLOC = (bci_ALLOC :: Int)
827 i_MKAP = (bci_MKAP :: Int)
828 i_UNPACK = (bci_UNPACK :: Int)
829 i_PACK = (bci_PACK :: Int)
830 i_LABEL = (bci_LABEL :: Int)
831 i_TESTLT_I = (bci_TESTLT_I :: Int)
832 i_TESTEQ_I = (bci_TESTEQ_I :: Int)
833 i_TESTLT_F = (bci_TESTLT_F :: Int)
834 i_TESTEQ_F = (bci_TESTEQ_F :: Int)
835 i_TESTLT_D = (bci_TESTLT_D :: Int)
836 i_TESTEQ_D = (bci_TESTEQ_D :: Int)
837 i_TESTLT_P = (bci_TESTLT_P :: Int)
838 i_TESTEQ_P = (bci_TESTEQ_P :: Int)
839 i_CASEFAIL = (bci_CASEFAIL :: Int)
840 i_ENTER = (bci_ENTER :: Int)