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 Foreign ( Addr, Word16, Word32, nullAddr )
34 import MutableArray ( readWord32Array,
35 newFloatArray, writeFloatArray,
36 newDoubleArray, writeDoubleArray,
37 newIntArray, writeIntArray,
38 newAddrArray, writeAddrArray )
44 byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
46 = let flatBinds = concatMap getBind binds
47 getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
48 getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
49 final_state = runBc (BcM_State [] 0)
50 (mapBc schemeR flatBinds `thenBc_` returnBc ())
53 BcM_State bcos final_ctr -> bcos
57 %************************************************************************
59 \subsection{Bytecodes, and Outputery.}
61 %************************************************************************
68 -- Messing with the stack
70 | PUSH_L Int{-offset-}
71 | PUSH_LL Int Int{-2 offsets-}
72 | PUSH_LLL Int Int Int{-3 offsets-}
74 | PUSH_AS Name --Int -- push alts and BCO_ptr_ret_info
75 -- Int is lit pool offset for itbl
76 | PUSH_LIT Int -- push literal word from offset pool
77 | PUSH_TAG Int -- push this tag on the stack
78 | PUSHU_I Int -- push this int, NO TAG, on the stack
79 | PUSHU_F Float -- ... float ...
80 | PUSHU_D Double -- ... double ...
81 | SLIDE Int{-this many-} Int{-down by this much-}
82 -- To do with the heap
83 | ALLOC Int -- make an AP_UPD with this many payload words, zeroed
84 | MKAP Int{-ptr to AP_UPD is this far down stack-} Int{-# words-}
85 | UNPACK Int -- unpack N ptr words from t.o.s Constr
86 | UNPACK_I Int -- unpack and tag an Int, from t.o.s Constr @ offset
87 | UNPACK_F Int -- unpack and tag a Float, from t.o.s Constr @ offset
88 | UNPACK_D Int -- unpack and tag a Double, from t.o.s Constr @ offset
90 -- For doing case trees
92 | TESTLT_I Int LocalLabel
93 | TESTEQ_I Int LocalLabel
94 | TESTLT_F Float LocalLabel
95 | TESTEQ_F Float LocalLabel
96 | TESTLT_D Double LocalLabel
97 | TESTEQ_D Double LocalLabel
98 | TESTLT_P Int LocalLabel
99 | TESTEQ_P Int LocalLabel
101 -- To Infinity And Beyond
103 | RETURN -- unboxed value on TOS. Use tag to find underlying ret itbl
104 -- and return as per that.
107 instance Outputable BCInstr where
108 ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
109 ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
110 ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
111 ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
112 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
113 ppr (PUSH_AS nm) = text "PUSH_AS " <+> ppr nm
114 ppr (PUSHU_I i) = text "PUSHU_I " <+> int i
115 ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
116 ppr (ALLOC sz) = text "ALLOC " <+> int sz
117 ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
118 ppr (UNPACK sz) = text "UNPACK " <+> int sz
119 ppr (UNPACK_I sz) = text "UNPACK_I" <+> int sz
120 ppr (UNPACK_F sz) = text "UNPACK_F" <+> int sz
121 ppr (UNPACK_D sz) = text "UNPACK_D" <+> int sz
122 ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
123 ppr (LABEL lab) = text "__" <> int lab <> colon
124 ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
125 ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
126 ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab
127 ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
128 ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab
129 ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
130 ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab
131 ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
132 ppr CASEFAIL = text "CASEFAIL"
133 ppr ENTER = text "ENTER"
134 ppr RETURN = text "RETURN"
136 pprAltCode discrs_n_codes
137 = vcat (map f discrs_n_codes)
138 where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
140 instance Outputable a => Outputable (ProtoBCO a) where
141 ppr (ProtoBCO name instrs origin)
142 = (text "ProtoBCO" <+> ppr name <> colon)
143 $$ nest 6 (vcat (map ppr instrs))
145 Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
146 Right rhs -> pprCoreExpr (deAnnotate rhs)
149 %************************************************************************
151 \subsection{Compilation schema for the bytecode generator.}
153 %************************************************************************
157 type BCInstrList = OrdList BCInstr
160 = ProtoBCO a -- name, in some sense
162 -- what the BCO came from
163 (Either [AnnAlt Id VarSet]
167 type Sequel = Int -- back off to this depth before ENTER
169 -- Maps Ids to the offset from the stack _base_ so we don't have
170 -- to mess with it after each push/pop.
171 type BCEnv = FiniteMap Id Int -- To find vars on the stack
174 -- Create a BCO and do a spot of peephole optimisation on the insns
176 mkProtoBCO nm instrs_ordlist origin
177 = ProtoBCO nm (peep (fromOL instrs_ordlist)) origin
179 peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
180 = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
181 peep (PUSH_L off1 : PUSH_L off2 : rest)
182 = PUSH_LL off1 off2 : peep rest
189 -- Compile code for the right hand side of a let binding.
190 -- Park the resulting BCO in the monad. Also requires the
191 -- variable to which this value was bound, so as to give the
192 -- resulting BCO a name.
193 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
194 schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs)
196 collect xs (_, AnnLam x e)
197 = collect (if isTyVar x then xs else (x:xs)) e
198 collect xs not_lambda
199 = (reverse xs, not_lambda)
201 schemeR_wrk original_body nm (args, body)
202 = let fvs = filter (not.isTyVar) (varSetElems (fst original_body))
203 all_args = fvs ++ reverse args
204 szsw_args = map taggedIdSizeW all_args
205 szw_args = sum szsw_args
206 p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
207 argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
209 schemeE szw_args 0 p_init body `thenBc` \ body_code ->
210 emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
212 -- Let szsw be the sizes in words of some items pushed onto the stack,
213 -- which has initial depth d'. Return the values which the stack environment
214 -- should map these items to.
215 mkStackOffsets :: Int -> [Int] -> [Int]
216 mkStackOffsets original_depth szsw
217 = map (subtract 1) (tail (scanl (+) original_depth szsw))
219 -- Compile code to apply the given expression to the remaining args
220 -- on the stack, returning a HNF.
221 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
223 -- Delegate tail-calls to schemeT.
224 schemeE d s p e@(fvs, AnnApp f a)
225 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
226 schemeE d s p e@(fvs, AnnVar v)
227 | isFollowableRep (typePrimRep (idType v))
228 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
230 = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN.
231 let (push, szw) = pushAtom True d p (AnnVar v)
232 in returnBc (push -- value onto stack
233 `snocOL` SLIDE szw (d-s) -- clear to sequel
234 `snocOL` RETURN) -- go
236 schemeE d s p (fvs, AnnLit literal)
237 = let (push, szw) = pushAtom True d p (AnnLit literal)
238 in returnBc (push -- value onto stack
239 `snocOL` SLIDE szw (d-s) -- clear to sequel
240 `snocOL` RETURN) -- go
242 schemeE d s p (fvs, AnnLet binds b)
243 = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
244 AnnRec xs_n_rhss -> unzip xs_n_rhss
246 fvss = map (filter (not.isTyVar).varSetElems.fst) rhss
247 sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
249 -- This p', d' defn is safe because all the items being pushed
250 -- are ptrs, so all have size 1. d' and p' reflect the stack
251 -- after the closures have been allocated in the heap (but not
252 -- filled in), and pointers to them parked on the stack.
253 p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
256 infos = zipE4 fvss sizes xs [n, n-1 .. 1]
257 zipE = zipEqual "schemeE"
258 zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
260 -- ToDo: don't build thunks for things with no free variables
261 buildThunk dd ([], size, id, off)
262 = PUSH_G (getName id)
263 `consOL` unitOL (MKAP (off+size-1) size)
264 buildThunk dd ((fv:fvs), size, id, off)
265 = case pushAtom True dd p' (AnnVar fv) of
266 (push_code, pushed_szw)
268 buildThunk (dd+pushed_szw) (fvs, size, id, off)
270 thunkCode = concatOL (map (buildThunk d') infos)
271 allocCode = toOL (map ALLOC sizes)
273 schemeE d' s p' b `thenBc` \ bodyCode ->
274 mapBc schemeR (zip xs rhss) `thenBc_`
275 returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
278 schemeE d s p (fvs, AnnCase scrut bndr alts)
280 -- Top of stack is the return itbl, as usual.
281 -- underneath it is the pointer to the alt_code BCO.
282 -- When an alt is entered, it assumes the returned value is
283 -- on top of the itbl.
286 -- Env and depth in which to compile the alts, not including
287 -- any vars bound by the alts themselves
288 d' = d + ret_frame_sizeW + taggedIdSizeW bndr
289 p' = addToFM p bndr (d' - 1)
292 = case typePrimRep (idType bndr) of
293 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
295 other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
297 -- given an alt, return a discr and code for it.
298 codeAlt alt@(discr, binds_f, rhs)
300 = let binds_r = reverse binds_f
301 binds_r_szsw = map untaggedIdSizeW binds_r
302 binds_szw = sum binds_r_szsw
304 p' (zip binds_r (mkStackOffsets d' binds_r_szsw))
306 unpack_code = mkUnpackCode 0 (map (typePrimRep.idType) binds_f)
307 in schemeE d'' s p'' rhs `thenBc` \ rhs_code ->
308 returnBc (my_discr alt, unpack_code `appOL` rhs_code)
310 = ASSERT(null binds_f)
311 schemeE d' s p' rhs `thenBc` \ rhs_code ->
312 returnBc (my_discr alt, rhs_code)
314 my_discr (DEFAULT, binds, rhs) = NoDiscr
315 my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc)
316 my_discr (LitAlt l, binds, rhs)
317 = case l of MachInt i -> DiscrI (fromInteger i)
318 MachFloat r -> DiscrF (fromRational r)
319 MachDouble r -> DiscrD (fromRational r)
322 | not isAlgCase = Nothing
324 = case [dc | (DataAlt dc, _, _) <- alts] of
326 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
329 mapBc codeAlt alts `thenBc` \ alt_stuff ->
330 mkMultiBranch maybe_ncons alt_stuff `thenBc` \ alt_final ->
332 alt_bco_name = getName bndr
333 alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
335 schemeE (d + ret_frame_sizeW)
336 (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
338 emitBc alt_bco `thenBc_`
339 returnBc (PUSH_AS alt_bco_name `consOL` scrut_code)
342 schemeE d s p (fvs, AnnNote note body)
346 = pprPanic "ByteCodeGen.schemeE: unhandled case"
347 (pprCoreExpr (deAnnotate other))
350 -- Compile code to do a tail call. Doesn't need to be monadic.
351 schemeT :: Bool -- do tagging?
352 -> Int -- Stack depth
353 -> Sequel -- Sequel depth
354 -> Int -- # arg words so far
355 -> BCEnv -- stack env
356 -> AnnExpr Id VarSet -> BCInstrList
358 schemeT enTag d s narg_words p (_, AnnApp f a)
360 AnnType _ -> schemeT enTag d s narg_words p f
362 -> let (push, arg_words) = pushAtom enTag d p (snd a)
364 `appOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
366 schemeT enTag d s narg_words p (_, AnnVar f)
367 | Just con <- isDataConId_maybe f
368 = ASSERT(enTag == False)
369 PACK con narg_words `consOL` (mkSLIDE 1 (d-s-1) `snocOL` ENTER)
371 = ASSERT(enTag == True)
372 let (push, arg_words) = pushAtom True d p (AnnVar f)
374 `appOL` mkSLIDE (narg_words+arg_words) (d - s - narg_words)
378 = if d == 0 then nilOL else unitOL (SLIDE n d)
380 should_args_be_tagged (_, AnnVar v)
381 = case isDataConId_maybe v of
382 Just dcon -> False; Nothing -> True
383 should_args_be_tagged (_, AnnApp f a)
384 = should_args_be_tagged f
385 should_args_be_tagged (_, other)
386 = panic "should_args_be_tagged: tail call to non-con, non-var"
389 -- Make code to unpack a constructor onto the stack, adding
390 -- tags for the unboxed bits. Takes the PrimReps of the constructor's
391 -- arguments, and a travelling offset along the *constructor*.
392 mkUnpackCode :: Int -> [PrimRep] -> BCInstrList
393 mkUnpackCode off [] = nilOL
394 mkUnpackCode off (r:rs)
396 = let (rs_ptr, rs_nptr) = span isFollowableRep (r:rs)
397 ptrs_szw = sum (map untaggedSizeW rs_ptr)
398 in ASSERT(ptrs_szw == length rs_ptr)
399 UNPACK ptrs_szw `consOL` mkUnpackCode (off+ptrs_szw) rs_nptr
402 IntRep -> UNPACK_I off `consOL` theRest
403 FloatRep -> UNPACK_F off `consOL` theRest
404 DoubleRep -> UNPACK_D off `consOL` theRest
406 theRest = mkUnpackCode (off+untaggedSizeW r) rs
408 -- Push an atom onto the stack, returning suitable code & number of
409 -- stack words used. Pushes it either tagged or untagged, since
410 -- pushAtom is used to set up the stack prior to copying into the
411 -- heap for both APs (requiring tags) and constructors (which don't).
413 -- NB this means NO GC between pushing atoms for a constructor and
414 -- copying them into the heap. It probably also means that
415 -- tail calls MUST be of the form atom{atom ... atom} since if the
416 -- expression head was allowed to be arbitrary, there could be GC
417 -- in between pushing the arg atoms and completing the head.
418 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
419 -- isn't a problem; but only if arbitrary graph construction for the
420 -- head doesn't leave this BCO, since GC might happen at the start of
421 -- each BCO (we consult doYouWantToGC there).
423 -- Blargh. JRS 001206
425 -- NB (further) that the env p must map each variable to the highest-
426 -- numbered stack slot for it. For example, if the stack has depth 4
427 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
428 -- the tag in stack[5], the stack will have depth 6, and p must map v to
429 -- 5 and not to 4. Stack locations are numbered from zero, so a depth
430 -- 6 stack has valid words 0 .. 5.
432 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
433 pushAtom tagged d p (AnnVar v)
434 = let str = "\npushAtom " ++ showSDocDebug (ppr v) ++ ", depth = " ++ show d
436 showSDocDebug (nest 4 (vcat (map ppr (fmToList p))))
438 showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
439 ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
440 str' = if str == str then str else str
443 = case lookupBCEnv_maybe p v of
444 Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), sz_t)
445 Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), sz_t)
448 sz_t = taggedIdSizeW v
449 sz_u = untaggedIdSizeW v
450 nwords = if tagged then sz_t else sz_u
455 pushAtom True d p (AnnLit lit)
456 = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
457 in (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
459 pushAtom False d p (AnnLit lit)
461 MachInt i -> (unitOL (PUSHU_I (fromInteger i)), untaggedSizeW IntRep)
462 MachFloat r -> (unitOL (PUSHU_F (fromRational r)), untaggedSizeW FloatRep)
463 MachDouble r -> (unitOL (PUSHU_D (fromRational r)), untaggedSizeW DoubleRep)
465 pushAtom tagged d p (AnnApp f (_, AnnType _))
466 = pushAtom tagged d p (snd f)
468 pushAtom tagged d p other
469 = pprPanic "ByteCodeGen.pushAtom"
470 (pprCoreExpr (deAnnotate (undefined, other)))
473 -- Given a bunch of alts code and their discrs, do the donkey work
474 -- of making a multiway branch using a switch tree.
475 -- What a load of hassle!
476 mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
477 -- a hint; generates better code
478 -- Nothing is always safe
479 -> [(Discr, BCInstrList)]
481 mkMultiBranch maybe_ncons raw_ways
482 = let d_way = filter (isNoDiscr.fst) raw_ways
483 notd_ways = naturalMergeSortLe
484 (\w1 w2 -> leAlt (fst w1) (fst w2))
485 (filter (not.isNoDiscr.fst) raw_ways)
487 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
488 mkTree [] range_lo range_hi = returnBc the_default
490 mkTree [val] range_lo range_hi
491 | range_lo `eqAlt` range_hi
494 = getLabelBc `thenBc` \ label_neq ->
495 returnBc (mkTestEQ (fst val) label_neq
497 `appOL` unitOL (LABEL label_neq)
498 `appOL` the_default))
500 mkTree vals range_lo range_hi
501 = let n = length vals `div` 2
502 vals_lo = take n vals
503 vals_hi = drop n vals
504 v_mid = fst (head vals_hi)
506 getLabelBc `thenBc` \ label_geq ->
507 mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
508 mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
509 returnBc (mkTestLT v_mid label_geq
511 `appOL` unitOL (LABEL label_geq)
515 = case d_way of [] -> unitOL CASEFAIL
518 -- None of these will be needed if there are no non-default alts
519 (mkTestLT, mkTestEQ, init_lo, init_hi)
521 = panic "mkMultiBranch: awesome foursome"
523 = case fst (head notd_ways) of {
524 DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
525 \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
528 DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
529 \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
532 DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
533 \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
536 DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
537 \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
542 (algMinBound, algMaxBound)
543 = case maybe_ncons of
544 Just n -> (fIRST_TAG, fIRST_TAG + n - 1)
545 Nothing -> (minBound, maxBound)
547 (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
548 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
549 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
550 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
551 NoDiscr `eqAlt` NoDiscr = True
554 (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
555 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
556 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
557 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
558 NoDiscr `leAlt` NoDiscr = True
561 isNoDiscr NoDiscr = True
564 dec (DiscrI i) = DiscrI (i-1)
565 dec (DiscrP i) = DiscrP (i-1)
566 dec other = other -- not really right, but if you
567 -- do cases on floating values, you'll get what you deserve
569 -- same snotty comment applies to the following
577 mkTree notd_ways init_lo init_hi
581 %************************************************************************
583 \subsection{Supporting junk for the compilation schemes}
585 %************************************************************************
589 -- Describes case alts
597 instance Outputable Discr where
598 ppr (DiscrI i) = int i
599 ppr (DiscrF f) = text (show f)
600 ppr (DiscrD d) = text (show d)
601 ppr (DiscrP i) = int i
602 ppr NoDiscr = text "DEF"
605 -- Find things in the BCEnv (the what's-on-the-stack-env)
606 -- See comment preceding pushAtom for precise meaning of env contents
607 lookupBCEnv :: BCEnv -> Id -> Int
609 = case lookupFM env nm of
610 Nothing -> pprPanic "lookupBCEnv"
611 (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
614 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
615 lookupBCEnv_maybe = lookupFM
618 -- When I push one of these on the stack, how much does Sp move by?
619 taggedSizeW :: PrimRep -> Int
621 | isFollowableRep pr = 1
622 | otherwise = 1{-the tag-} + getPrimRepSize pr
625 -- The plain size of something, without tag.
626 untaggedSizeW :: PrimRep -> Int
628 | isFollowableRep pr = 1
629 | otherwise = getPrimRepSize pr
632 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
633 taggedIdSizeW = taggedSizeW . typePrimRep . idType
634 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
638 %************************************************************************
640 \subsection{The bytecode generator's monad}
642 %************************************************************************
646 = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
647 nextlabel :: Int } -- for generating local labels
649 type BcM result = BcM_State -> (result, BcM_State)
651 mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State
652 mkBcM_State = BcM_State
654 runBc :: BcM_State -> BcM () -> BcM_State
655 runBc init_st m = case m init_st of { (r,st) -> st }
657 thenBc :: BcM a -> (a -> BcM b) -> BcM b
659 = case expr st of { (result, st') -> cont result st' }
661 thenBc_ :: BcM a -> BcM b -> BcM b
663 = case expr st of { (result, st') -> cont st' }
665 returnBc :: a -> BcM a
666 returnBc result st = (result, st)
668 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
669 mapBc f [] = returnBc []
671 = f x `thenBc` \ r ->
672 mapBc f xs `thenBc` \ rs ->
675 emitBc :: ProtoBCO Name -> BcM ()
677 = ((), st{bcos = bco : bcos st})
679 getLabelBc :: BcM Int
681 = (nextlabel st, st{nextlabel = 1 + nextlabel st})
685 %************************************************************************
687 \subsection{The bytecode assembler}
689 %************************************************************************
691 The object format for bytecodes is: 16 bits for the opcode, and 16 for
692 each field -- so the code can be considered a sequence of 16-bit ints.
693 Each field denotes either a stack offset or number of items on the
694 stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
695 index into the literal table (eg PUSH_I/D/L), or a bytecode address in
699 -- An (almost) assembled BCO.
700 data BCO a = BCO [Word16] -- instructions
701 [Word32] -- literal pool
702 [a] -- Names or HValues
704 -- Top level assembler fn.
705 assembleBCO :: ProtoBCO Name -> BCO Name
706 assembleBCO (ProtoBCO nm instrs origin)
708 -- pass 1: collect up the offsets of the local labels
709 label_env = mkLabelEnv emptyFM 0 instrs
711 mkLabelEnv env i_offset [] = env
712 mkLabelEnv env i_offset (i:is)
714 = case i of LABEL n -> addToFM env n i_offset ; _ -> env
715 in mkLabelEnv new_env (i_offset + instrSizeB i) is
718 = case lookupFM label_env lab of
719 Just bco_offset -> bco_offset
720 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
722 -- pass 2: generate the instruction, ptr and nonptr bits
723 (insnW16s, litW32s, ptrs) = mkBits findLabel [] 0 [] 0 [] 0 instrs
725 BCO insnW16s litW32s ptrs
728 -- This is where all the action is (pass 2 of the assembler)
729 mkBits :: (Int -> Int) -- label finder
730 -> [Word16] -> Int -- reverse acc instr bits
731 -> [Word32] -> Int -- reverse acc literal bits
732 -> [Name] -> Int -- reverse acc ptrs
733 -> [BCInstr] -- insns!
734 -> ([Word16], [Word32], [Name])
736 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs []
737 = (reverse r_is, reverse r_lits, reverse r_ptrs)
738 mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs (instr:instrs)
740 ARGCHECK n -> boring2 i_ARGCHECK n
741 PUSH_L off -> boring2 i_PUSH_L off
742 PUSH_LL o1 o2 -> boring3 i_PUSH_LL o1 o2
743 PUSH_LLL o1 o2 o3 -> boring4 i_PUSH_LLL o1 o2 o3
744 PUSH_G nm -> exciting2_P i_PUSH_G n_ptrs nm
745 PUSHU_I i -> exciting2_I i_PUSHU_I n_lits i
746 PUSHU_F f -> exciting2_F i_PUSHU_F n_lits f
747 PUSHU_D d -> exciting2_D i_PUSHU_D n_lits d
748 SLIDE n by -> boring3 i_SLIDE n by
749 ALLOC n -> boring2 i_ALLOC n
750 MKAP off sz -> boring3 i_MKAP off sz
751 UNPACK n -> boring2 i_UNPACK n
752 PACK dcon sz -> exciting3_A i_PACK sz n_lits nullAddr {-findItbl dcon-}
754 TESTLT_I i l -> exciting3_I i_TESTLT_I n_lits (findLabel l) i
755 TESTEQ_I i l -> exciting3_I i_TESTEQ_I n_lits (findLabel l) i
756 TESTLT_F f l -> exciting3_F i_TESTLT_F n_lits (findLabel l) f
757 TESTEQ_F f l -> exciting3_F i_TESTEQ_F n_lits (findLabel l) f
758 TESTLT_D d l -> exciting3_D i_TESTLT_D n_lits (findLabel l) d
759 TESTEQ_D d l -> exciting3_D i_TESTEQ_D n_lits (findLabel l) d
760 TESTLT_P i l -> exciting3_I i_TESTLT_P n_lits (findLabel l) i
761 TESTEQ_P i l -> exciting3_I i_TESTEQ_P n_lits (findLabel l) i
762 CASEFAIL -> boring1 i_CASEFAIL
763 ENTER -> boring1 i_ENTER
764 RETURN -> boring1 i_RETURN
766 r_mkILit = reverse . mkILit
767 r_mkFLit = reverse . mkFLit
768 r_mkDLit = reverse . mkDLit
769 r_mkALit = reverse . mkALit
775 = mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs instrs
777 = mkBits findLabel (mkw i1 : r_is) (n_is+1)
778 r_lits n_lits r_ptrs n_ptrs instrs
780 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
781 r_lits n_lits r_ptrs n_ptrs instrs
783 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
784 r_lits n_lits r_ptrs n_ptrs instrs
786 = mkBits findLabel (mkw i4 : mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+4)
787 r_lits n_lits r_ptrs n_ptrs instrs
790 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) r_lits n_lits
791 (p:r_ptrs) (n_ptrs+1) instrs
792 exciting3_P i1 i2 i3 p
793 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) r_lits n_lits
794 (p:r_ptrs) (n_ptrs+1) instrs
797 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
798 (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
800 exciting3_I i1 i2 i3 i
801 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
802 (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
806 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
807 (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
809 exciting3_F i1 i2 i3 f
810 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
811 (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
815 = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
816 (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
818 exciting3_D i1 i2 i3 d
819 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
820 (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
823 exciting3_A i1 i2 i3 d
824 = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
825 (r_mkALit d ++ r_lits) (n_lits + addrLitSz32s)
829 -- The size in bytes of an instruction.
830 instrSizeB :: BCInstr -> Int
860 -- Sizes of Int, Float and Double literals, in units of 32-bitses
861 intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int
862 intLitSz32s = wORD_SIZE `div` 4
863 floatLitSz32s = 1 -- Assume IEEE floats
865 addrLitSz32s = intLitSz32s
867 -- Make lists of 32-bit words for literals, so that when the
868 -- words are placed in memory at increasing addresses, the
869 -- bit pattern is correct for the host's word size and endianness.
870 mkILit :: Int -> [Word32]
871 mkFLit :: Float -> [Word32]
872 mkDLit :: Double -> [Word32]
873 mkALit :: Addr -> [Word32]
877 arr <- newFloatArray ((0::Int),0)
878 writeFloatArray arr 0 f
879 w0 <- readWord32Array arr 0
885 arr <- newDoubleArray ((0::Int),0)
886 writeDoubleArray arr 0 d
887 w0 <- readWord32Array arr 0
888 w1 <- readWord32Array arr 1
895 arr <- newIntArray ((0::Int),0)
896 writeIntArray arr 0 i
897 w0 <- readWord32Array arr 0
902 arr <- newIntArray ((0::Int),0)
903 writeIntArray arr 0 i
904 w0 <- readWord32Array arr 0
905 w1 <- readWord32Array arr 1
912 arr <- newAddrArray ((0::Int),0)
913 writeAddrArray arr 0 a
914 w0 <- readWord32Array arr 0
919 arr <- newAddrArray ((0::Int),0)
920 writeAddrArray arr 0 a
921 w0 <- readWord32Array arr 0
922 w1 <- readWord32Array arr 1
928 #include "Bytecodes.h"
930 i_ARGCHECK = (bci_ARGCHECK :: Int)
931 i_PUSH_L = (bci_PUSH_L :: Int)
932 i_PUSH_LL = (bci_PUSH_LL :: Int)
933 i_PUSH_LLL = (bci_PUSH_LLL :: Int)
934 i_PUSH_G = (bci_PUSH_G :: Int)
935 i_PUSH_AS = (bci_PUSH_AS :: Int)
936 i_PUSHT_I = (bci_PUSHT_I :: Int)
937 i_PUSHT_F = (bci_PUSHT_F :: Int)
938 i_PUSHT_D = (bci_PUSHT_D :: Int)
939 i_PUSHU_I = (bci_PUSHU_I :: Int)
940 i_PUSHU_F = (bci_PUSHU_F :: Int)
941 i_PUSHU_D = (bci_PUSHU_D :: Int)
942 i_SLIDE = (bci_SLIDE :: Int)
943 i_ALLOC = (bci_ALLOC :: Int)
944 i_MKAP = (bci_MKAP :: Int)
945 i_UNPACK = (bci_UNPACK :: Int)
946 i_PACK = (bci_PACK :: Int)
947 i_LABEL = (bci_LABEL :: Int)
948 i_TESTLT_I = (bci_TESTLT_I :: Int)
949 i_TESTEQ_I = (bci_TESTEQ_I :: Int)
950 i_TESTLT_F = (bci_TESTLT_F :: Int)
951 i_TESTEQ_F = (bci_TESTEQ_F :: Int)
952 i_TESTLT_D = (bci_TESTLT_D :: Int)
953 i_TESTEQ_D = (bci_TESTEQ_D :: Int)
954 i_TESTLT_P = (bci_TESTLT_P :: Int)
955 i_TESTEQ_P = (bci_TESTEQ_P :: Int)
956 i_CASEFAIL = (bci_CASEFAIL :: Int)
957 i_ENTER = (bci_ENTER :: Int)
958 i_RETURN = (bci_RETURN :: Int)