2 % (c) The University of Glasgow 2000
4 \section[ByteCodeGen]{Generate bytecode from Core}
7 module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
9 byteCodeGen, coreExprToBCOs,
10 linkIModules, linkIExpr
13 #include "HsVersions.h"
16 import Name ( Name, getName, nameModule, mkSysLocalName, toRdrName )
17 import RdrName ( rdrNameOcc, rdrNameModule )
18 import OccName ( occNameString )
19 import Id ( Id, idType, isDataConId_maybe, mkVanillaId )
20 import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
21 nilOL, toOL, concatOL, fromOL )
22 import FiniteMap ( FiniteMap, addListToFM, listToFM, filterFM,
23 addToFM, lookupFM, fmToList, emptyFM, plusFM )
25 import PprCore ( pprCoreExpr, pprCoreAlt )
26 import Literal ( Literal(..), literalPrimRep )
27 import PrimRep ( PrimRep(..) )
28 import CoreFVs ( freeVars )
29 import Type ( typePrimRep )
30 import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
32 import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
33 import Class ( Class, classTyCon )
34 import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, global )
35 import Var ( isTyVar )
36 import VarSet ( VarSet, varSetElems )
37 import PrimRep ( getPrimRepSize, isFollowableRep )
38 import Constants ( wORD_SIZE )
39 import CmdLineOpts ( DynFlags, DynFlag(..) )
40 import ErrUtils ( showPass, dumpIfSet_dyn )
41 import ClosureInfo ( mkVirtHeapOffsets )
42 import Module ( ModuleName, moduleName, moduleNameFS )
43 import Unique ( mkPseudoUnique3 )
44 import Linker ( lookupSymbol )
46 import List ( intersperse )
47 import Monad ( foldM )
49 import MArray ( castSTUArray,
50 newFloatArray, writeFloatArray,
51 newDoubleArray, writeDoubleArray,
52 newIntArray, writeIntArray,
53 newAddrArray, writeAddrArray )
54 import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..),
55 malloc, castPtr, plusPtr )
56 import Addr ( Word, Addr, addrToInt, nullAddr )
57 import Bits ( Bits(..), shiftR )
59 import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array# )
60 import IOExts ( IORef, fixIO )
62 import PrelArr ( Array(..) )
63 import PrelIOBase ( IO(..) )
67 %************************************************************************
69 \subsection{Functions visible from outside this module.}
71 %************************************************************************
75 byteCodeGen :: DynFlags
78 -> IO ([UnlinkedBCO], ItblEnv)
79 byteCodeGen dflags binds local_tycons local_classes
80 = do showPass dflags "ByteCodeGen"
81 let tycs = local_tycons ++ map classTyCon local_classes
82 itblenv <- mkITbls tycs
84 let flatBinds = concatMap getBind binds
85 getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
86 getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
87 final_state = runBc (BcM_State [] 0)
88 (mapBc schemeR flatBinds `thenBc_` returnBc ())
89 (BcM_State proto_bcos final_ctr) = final_state
91 dumpIfSet_dyn dflags Opt_D_dump_BCOs
92 "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
94 bcos <- mapM assembleBCO proto_bcos
96 return (bcos, itblenv)
99 -- Returns: (the root BCO for this expression,
100 -- a list of auxilary BCOs resulting from compiling closures)
101 coreExprToBCOs :: DynFlags
103 -> IO UnlinkedBCOExpr
104 coreExprToBCOs dflags expr
105 = do showPass dflags "ByteCodeGen"
107 -- create a totally bogus name for the top-level BCO; this
108 -- should be harmless, since it's never used for anything
109 let invented_name = mkSysLocalName (mkPseudoUnique3 0) SLIT("Expr-Top-Level")
110 let invented_id = mkVanillaId invented_name (panic "invented_id's type")
112 let (BcM_State all_proto_bcos final_ctr)
113 = runBc (BcM_State [] 0)
114 (schemeR (invented_id, freeVars expr))
115 dumpIfSet_dyn dflags Opt_D_dump_BCOs
116 "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))
119 = case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of
120 [root_bco] -> root_bco
122 = filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos
124 auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos
125 root_bco <- assembleBCO root_proto_bco
127 return (root_bco, auxiliary_bcos)
131 linkIModules :: ItblEnv -- incoming global itbl env; returned updated
132 -> ClosureEnv -- incoming global closure env; returned updated
133 -> [([UnlinkedBCO], ItblEnv)]
134 -> IO ([HValue], ItblEnv, ClosureEnv)
135 linkIModules gie gce mods = do
136 let (bcoss, ies) = unzip mods
138 top_level_binders = map nameOfUnlinkedBCO bcos
139 final_gie = foldr plusFM gie ies
141 (new_bcos, new_gce) <-
142 fixIO (\ ~(new_bcos, new_gce) -> do
143 new_bcos <- linkBCOs final_gie new_gce bcos
144 let new_gce = addListToFM gce (zip top_level_binders new_bcos)
145 return (new_bcos, new_gce))
147 return (new_bcos, final_gie, new_gce)
150 linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
151 -> IO HValue -- IO BCO# really
152 linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
153 = do let aux_ul_binders = map nameOfUnlinkedBCO aux_ul_bcos
156 (\ ~(aux_bcos, new_ce)
157 -> do new_bcos <- linkBCOs ie new_ce aux_ul_bcos
158 let new_ce = addListToFM ce (zip aux_ul_binders new_bcos)
159 return (new_bcos, new_ce)
162 <- linkBCOs ie aux_ce [root_ul_bco]
169 (SizedSeq Word16) -- insns
170 (SizedSeq Word) -- literals
171 (SizedSeq Name) -- ptrs
172 (SizedSeq Name) -- itbl refs
174 nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm
176 -- When translating expressions, we need to distinguish the root
177 -- BCO for the expression
178 type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO])
180 instance Outputable UnlinkedBCO where
181 ppr (UnlinkedBCO nm insns lits ptrs itbls)
182 = sep [text "BCO", ppr nm, text "with",
183 int (sizeSS insns), text "insns",
184 int (sizeSS lits), text "lits",
185 int (sizeSS ptrs), text "ptrs",
186 int (sizeSS itbls), text "itbls"]
189 -- these need a proper home
190 type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
191 type ClosureEnv = FiniteMap Name HValue
192 data HValue = HValue -- dummy type, actually a pointer to some Real Code.
194 -- remove all entries for a given set of modules from the environment
195 filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
196 filterNameMap mods env
197 = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
200 %************************************************************************
202 \subsection{Bytecodes, and Outputery.}
204 %************************************************************************
208 type LocalLabel = Int
211 -- Messing with the stack
213 -- Push locals (existing bits of the stack)
214 | PUSH_L Int{-offset-}
215 | PUSH_LL Int Int{-2 offsets-}
216 | PUSH_LLL Int Int Int{-3 offsets-}
219 -- Push an alt continuation
220 | PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info
221 -- PrimRep so we know which itbl
223 | PUSH_UBX Literal Int
224 -- push this int/float/double, NO TAG, on the stack
225 -- Int is # of words to copy from literal pool
226 | PUSH_TAG Int -- push this tag on the stack
228 | SLIDE Int{-this many-} Int{-down by this much-}
229 -- To do with the heap
230 | ALLOC Int -- make an AP_UPD with this many payload words, zeroed
231 | MKAP Int{-ptr to AP_UPD is this far down stack-} Int{-# words-}
232 | UNPACK Int -- unpack N ptr words from t.o.s Constr
233 | UPK_TAG Int Int Int
234 -- unpack N non-ptr words from offset M in constructor
235 -- K words down the stack
237 -- after assembly, the DataCon is an index into the
239 -- For doing case trees
241 | TESTLT_I Int LocalLabel
242 | TESTEQ_I Int LocalLabel
243 | TESTLT_F Float LocalLabel
244 | TESTEQ_F Float LocalLabel
245 | TESTLT_D Double LocalLabel
246 | TESTEQ_D Double LocalLabel
248 -- The Int value is a constructor number and therefore
249 -- stored in the insn stream rather than as an offset into
251 | TESTLT_P Int LocalLabel
252 | TESTEQ_P Int LocalLabel
255 -- To Infinity And Beyond
258 -- unboxed value on TOS. Use tag to find underlying ret itbl
259 -- and return as per that.
262 instance Outputable BCInstr where
263 ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
264 ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
265 ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
266 ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
267 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
268 ppr (PUSH_AS nm pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk
269 ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
270 ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n
271 ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
272 ppr (ALLOC sz) = text "ALLOC " <+> int sz
273 ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
274 ppr (UNPACK sz) = text "UNPACK " <+> int sz
275 ppr (UPK_TAG n m k) = text "UPK_TAG " <+> int n <> text "words"
276 <+> int m <> text "conoff"
277 <+> int k <> text "stkoff"
278 ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
279 ppr (LABEL lab) = text "__" <> int lab <> colon
280 ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
281 ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
282 ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab
283 ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
284 ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab
285 ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
286 ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab
287 ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
288 ppr CASEFAIL = text "CASEFAIL"
289 ppr ENTER = text "ENTER"
290 ppr (RETURN pk) = text "RETURN " <+> ppr pk
292 instance Outputable a => Outputable (ProtoBCO a) where
293 ppr (ProtoBCO name instrs origin)
294 = (text "ProtoBCO" <+> ppr name <> colon)
295 $$ nest 6 (vcat (map ppr instrs))
297 Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
298 Right rhs -> pprCoreExpr (deAnnotate rhs)
301 %************************************************************************
303 \subsection{Compilation schema for the bytecode generator.}
305 %************************************************************************
309 type BCInstrList = OrdList BCInstr
312 = ProtoBCO a -- name, in some sense
314 -- what the BCO came from
315 (Either [AnnAlt Id VarSet]
318 nameOfProtoBCO (ProtoBCO nm insns origin) = nm
321 type Sequel = Int -- back off to this depth before ENTER
323 -- Maps Ids to the offset from the stack _base_ so we don't have
324 -- to mess with it after each push/pop.
325 type BCEnv = FiniteMap Id Int -- To find vars on the stack
328 -- Create a BCO and do a spot of peephole optimisation on the insns
330 mkProtoBCO nm instrs_ordlist origin
331 = ProtoBCO nm (peep (fromOL instrs_ordlist)) origin
333 peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
334 = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
335 peep (PUSH_L off1 : PUSH_L off2 : rest)
336 = PUSH_LL off1 off2 : peep rest
343 -- Compile code for the right hand side of a let binding.
344 -- Park the resulting BCO in the monad. Also requires the
345 -- variable to which this value was bound, so as to give the
346 -- resulting BCO a name.
347 schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
348 schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs)
350 collect xs (_, AnnLam x e)
351 = collect (if isTyVar x then xs else (x:xs)) e
352 collect xs not_lambda
353 = (reverse xs, not_lambda)
355 schemeR_wrk original_body nm (args, body)
356 = let fvs = filter (not.isTyVar) (varSetElems (fst original_body))
357 all_args = fvs ++ reverse args
358 szsw_args = map taggedIdSizeW all_args
359 szw_args = sum szsw_args
360 p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
361 argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
363 schemeE szw_args 0 p_init body `thenBc` \ body_code ->
364 emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
366 -- Let szsw be the sizes in words of some items pushed onto the stack,
367 -- which has initial depth d'. Return the values which the stack environment
368 -- should map these items to.
369 mkStackOffsets :: Int -> [Int] -> [Int]
370 mkStackOffsets original_depth szsw
371 = map (subtract 1) (tail (scanl (+) original_depth szsw))
373 -- Compile code to apply the given expression to the remaining args
374 -- on the stack, returning a HNF.
375 schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
377 -- Delegate tail-calls to schemeT.
378 schemeE d s p e@(fvs, AnnApp f a)
379 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
380 schemeE d s p e@(fvs, AnnVar v)
381 | isFollowableRep v_rep
382 = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
384 = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN.
385 let (push, szw) = pushAtom True d p (AnnVar v)
386 in returnBc (push -- value onto stack
387 `snocOL` SLIDE szw (d-s) -- clear to sequel
388 `snocOL` RETURN v_rep) -- go
390 v_rep = typePrimRep (idType v)
392 schemeE d s p (fvs, AnnLit literal)
393 = let (push, szw) = pushAtom True d p (AnnLit literal)
394 l_rep = literalPrimRep literal
395 in returnBc (push -- value onto stack
396 `snocOL` SLIDE szw (d-s) -- clear to sequel
397 `snocOL` RETURN l_rep) -- go
399 schemeE d s p (fvs, AnnLet binds b)
400 = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
401 AnnRec xs_n_rhss -> unzip xs_n_rhss
403 fvss = map (filter (not.isTyVar).varSetElems.fst) rhss
404 sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
406 -- This p', d' defn is safe because all the items being pushed
407 -- are ptrs, so all have size 1. d' and p' reflect the stack
408 -- after the closures have been allocated in the heap (but not
409 -- filled in), and pointers to them parked on the stack.
410 p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n 1)))
413 infos = zipE4 fvss sizes xs [n, n-1 .. 1]
414 zipE = zipEqual "schemeE"
415 zipE4 = zipWith4Equal "schemeE" (\a b c d -> (a,b,c,d))
417 -- ToDo: don't build thunks for things with no free variables
418 buildThunk dd ([], size, id, off)
419 = PUSH_G (getName id)
420 `consOL` unitOL (MKAP (off+size-1) size)
421 buildThunk dd ((fv:fvs), size, id, off)
422 = case pushAtom True dd p' (AnnVar fv) of
423 (push_code, pushed_szw)
425 buildThunk (dd+pushed_szw) (fvs, size, id, off)
427 thunkCode = concatOL (map (buildThunk d') infos)
428 allocCode = toOL (map ALLOC sizes)
430 schemeE d' s p' b `thenBc` \ bodyCode ->
431 mapBc schemeR (zip xs rhss) `thenBc_`
432 returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
435 schemeE d s p (fvs, AnnCase scrut bndr alts)
437 -- Top of stack is the return itbl, as usual.
438 -- underneath it is the pointer to the alt_code BCO.
439 -- When an alt is entered, it assumes the returned value is
440 -- on top of the itbl.
443 -- Env and depth in which to compile the alts, not including
444 -- any vars bound by the alts themselves
445 d' = d + ret_frame_sizeW + taggedIdSizeW bndr
446 p' = addToFM p bndr (d' - 1)
448 scrut_primrep = typePrimRep (idType bndr)
450 = case scrut_primrep of
451 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
453 other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
455 -- given an alt, return a discr and code for it.
456 codeAlt alt@(discr, binds_f, rhs)
458 = let binds_r = reverse binds_f
459 binds_r_szsw = map untaggedIdSizeW binds_r
460 binds_szw = sum binds_r_szsw
462 p' (zip binds_r (mkStackOffsets d' binds_r_szsw))
464 unpack_code = mkUnpackCode 0 0 (map (typePrimRep.idType) binds_f)
465 in schemeE d'' s p'' rhs `thenBc` \ rhs_code ->
466 returnBc (my_discr alt, unpack_code `appOL` rhs_code)
468 = ASSERT(null binds_f)
469 schemeE d' s p' rhs `thenBc` \ rhs_code ->
470 returnBc (my_discr alt, rhs_code)
472 my_discr (DEFAULT, binds, rhs) = NoDiscr
473 my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc)
474 my_discr (LitAlt l, binds, rhs)
475 = case l of MachInt i -> DiscrI (fromInteger i)
476 MachFloat r -> DiscrF (fromRational r)
477 MachDouble r -> DiscrD (fromRational r)
480 | not isAlgCase = Nothing
482 = case [dc | (DataAlt dc, _, _) <- alts] of
484 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
487 mapBc codeAlt alts `thenBc` \ alt_stuff ->
488 mkMultiBranch maybe_ncons alt_stuff `thenBc` \ alt_final ->
490 alt_bco_name = getName bndr
491 alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
493 schemeE (d + ret_frame_sizeW)
494 (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
496 emitBc alt_bco `thenBc_`
497 returnBc (PUSH_AS alt_bco_name scrut_primrep `consOL` scrut_code)
500 schemeE d s p (fvs, AnnNote note body)
504 = pprPanic "ByteCodeGen.schemeE: unhandled case"
505 (pprCoreExpr (deAnnotate other))
508 -- Compile code to do a tail call. Doesn't need to be monadic.
509 schemeT :: Bool -- do tagging?
510 -> Int -- Stack depth
511 -> Sequel -- Sequel depth
512 -> Int -- # arg words so far
513 -> BCEnv -- stack env
517 schemeT enTag d s narg_words p (_, AnnApp f a)
519 AnnType _ -> schemeT enTag d s narg_words p f
521 -> let (push, arg_words) = pushAtom enTag d p (snd a)
523 `appOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
525 schemeT enTag d s narg_words p (_, AnnVar f)
526 | Just con <- isDataConId_maybe f
527 = ASSERT(enTag == False)
528 PACK con narg_words `consOL` (mkSLIDE 1 (d-s-1) `snocOL` ENTER)
530 = ASSERT(enTag == True)
531 let (push, arg_words) = pushAtom True d p (AnnVar f)
533 `appOL` mkSLIDE (narg_words+arg_words) (d - s - narg_words)
537 = if d == 0 then nilOL else unitOL (SLIDE n d)
539 should_args_be_tagged (_, AnnVar v)
540 = case isDataConId_maybe v of
541 Just dcon -> False; Nothing -> True
542 should_args_be_tagged (_, AnnApp f a)
543 = should_args_be_tagged f
544 should_args_be_tagged (_, other)
545 = panic "should_args_be_tagged: tail call to non-con, non-var"
548 -- Make code to unpack a constructor onto the stack, adding
549 -- tags for the unboxed bits. Takes the PrimReps of the constructor's
550 -- arguments, and a travelling offset along both the constructor
551 -- (off_h) and the stack (off_s).
552 mkUnpackCode :: Int -> Int -> [PrimRep] -> BCInstrList
553 mkUnpackCode off_h off_s [] = nilOL
554 mkUnpackCode off_h off_s (r:rs)
556 = let (rs_ptr, rs_nptr) = span isFollowableRep (r:rs)
557 ptrs_szw = sum (map untaggedSizeW rs_ptr)
558 in ASSERT(ptrs_szw == length rs_ptr)
562 `consOL` mkUnpackCode (off_h + ptrs_szw) (off_s + ptrs_szw) rs_nptr
567 DoubleRep -> approved
569 approved = UPK_TAG usizeW off_h off_s `consOL` theRest
570 theRest = mkUnpackCode (off_h + usizeW) (off_s + tsizeW) rs
571 usizeW = untaggedSizeW r
572 tsizeW = taggedSizeW r
574 -- Push an atom onto the stack, returning suitable code & number of
575 -- stack words used. Pushes it either tagged or untagged, since
576 -- pushAtom is used to set up the stack prior to copying into the
577 -- heap for both APs (requiring tags) and constructors (which don't).
579 -- NB this means NO GC between pushing atoms for a constructor and
580 -- copying them into the heap. It probably also means that
581 -- tail calls MUST be of the form atom{atom ... atom} since if the
582 -- expression head was allowed to be arbitrary, there could be GC
583 -- in between pushing the arg atoms and completing the head.
584 -- (not sure; perhaps the allocate/doYouWantToGC interface means this
585 -- isn't a problem; but only if arbitrary graph construction for the
586 -- head doesn't leave this BCO, since GC might happen at the start of
587 -- each BCO (we consult doYouWantToGC there).
589 -- Blargh. JRS 001206
591 -- NB (further) that the env p must map each variable to the highest-
592 -- numbered stack slot for it. For example, if the stack has depth 4
593 -- and we tagged-ly push (v :: Int#) on it, the value will be in stack[4],
594 -- the tag in stack[5], the stack will have depth 6, and p must map v to
595 -- 5 and not to 4. Stack locations are numbered from zero, so a depth
596 -- 6 stack has valid words 0 .. 5.
598 pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
599 pushAtom tagged d p (AnnVar v)
600 = let str = "\npushAtom " ++ showSDocDebug (ppr v) ++ ", depth = " ++ show d
602 showSDocDebug (nest 4 (vcat (map ppr (fmToList p))))
604 showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
605 ++ "\nendPushAtom " ++ showSDocDebug (ppr v)
606 str' = if str == str then str else str
609 = case lookupBCEnv_maybe p v of
610 Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), sz_t)
611 Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), sz_t)
614 sz_t = taggedIdSizeW v
615 sz_u = untaggedIdSizeW v
616 nwords = if tagged then sz_t else sz_u
621 pushAtom True d p (AnnLit lit)
622 = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
623 in (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
625 pushAtom False d p (AnnLit lit)
627 MachInt i -> code IntRep
628 MachFloat r -> code FloatRep
629 MachDouble r -> code DoubleRep
632 = let size_host_words = untaggedSizeW rep
633 in (unitOL (PUSH_UBX lit size_host_words), size_host_words)
635 pushAtom tagged d p (AnnApp f (_, AnnType _))
636 = pushAtom tagged d p (snd f)
638 pushAtom tagged d p other
639 = pprPanic "ByteCodeGen.pushAtom"
640 (pprCoreExpr (deAnnotate (undefined, other)))
643 -- Given a bunch of alts code and their discrs, do the donkey work
644 -- of making a multiway branch using a switch tree.
645 -- What a load of hassle!
646 mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
647 -- a hint; generates better code
648 -- Nothing is always safe
649 -> [(Discr, BCInstrList)]
651 mkMultiBranch maybe_ncons raw_ways
652 = let d_way = filter (isNoDiscr.fst) raw_ways
653 notd_ways = naturalMergeSortLe
654 (\w1 w2 -> leAlt (fst w1) (fst w2))
655 (filter (not.isNoDiscr.fst) raw_ways)
657 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
658 mkTree [] range_lo range_hi = returnBc the_default
660 mkTree [val] range_lo range_hi
661 | range_lo `eqAlt` range_hi
664 = getLabelBc `thenBc` \ label_neq ->
665 returnBc (mkTestEQ (fst val) label_neq
667 `appOL` unitOL (LABEL label_neq)
668 `appOL` the_default))
670 mkTree vals range_lo range_hi
671 = let n = length vals `div` 2
672 vals_lo = take n vals
673 vals_hi = drop n vals
674 v_mid = fst (head vals_hi)
676 getLabelBc `thenBc` \ label_geq ->
677 mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
678 mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
679 returnBc (mkTestLT v_mid label_geq
681 `appOL` unitOL (LABEL label_geq)
685 = case d_way of [] -> unitOL CASEFAIL
688 -- None of these will be needed if there are no non-default alts
689 (mkTestLT, mkTestEQ, init_lo, init_hi)
691 = panic "mkMultiBranch: awesome foursome"
693 = case fst (head notd_ways) of {
694 DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
695 \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
698 DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
699 \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
702 DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
703 \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
706 DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
707 \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
712 (algMinBound, algMaxBound)
713 = case maybe_ncons of
714 Just n -> (fIRST_TAG, fIRST_TAG + n - 1)
715 Nothing -> (minBound, maxBound)
717 (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
718 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
719 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
720 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
721 NoDiscr `eqAlt` NoDiscr = True
724 (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
725 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
726 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
727 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
728 NoDiscr `leAlt` NoDiscr = True
731 isNoDiscr NoDiscr = True
734 dec (DiscrI i) = DiscrI (i-1)
735 dec (DiscrP i) = DiscrP (i-1)
736 dec other = other -- not really right, but if you
737 -- do cases on floating values, you'll get what you deserve
739 -- same snotty comment applies to the following
747 mkTree notd_ways init_lo init_hi
751 %************************************************************************
753 \subsection{Supporting junk for the compilation schemes}
755 %************************************************************************
759 -- Describes case alts
767 instance Outputable Discr where
768 ppr (DiscrI i) = int i
769 ppr (DiscrF f) = text (show f)
770 ppr (DiscrD d) = text (show d)
771 ppr (DiscrP i) = int i
772 ppr NoDiscr = text "DEF"
775 -- Find things in the BCEnv (the what's-on-the-stack-env)
776 -- See comment preceding pushAtom for precise meaning of env contents
777 --lookupBCEnv :: BCEnv -> Id -> Int
779 -- = case lookupFM env nm of
780 -- Nothing -> pprPanic "lookupBCEnv"
781 -- (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
784 lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
785 lookupBCEnv_maybe = lookupFM
788 -- When I push one of these on the stack, how much does Sp move by?
789 taggedSizeW :: PrimRep -> Int
791 | isFollowableRep pr = 1
792 | otherwise = 1{-the tag-} + getPrimRepSize pr
795 -- The plain size of something, without tag.
796 untaggedSizeW :: PrimRep -> Int
798 | isFollowableRep pr = 1
799 | otherwise = getPrimRepSize pr
802 taggedIdSizeW, untaggedIdSizeW :: Id -> Int
803 taggedIdSizeW = taggedSizeW . typePrimRep . idType
804 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
808 %************************************************************************
810 \subsection{The bytecode generator's monad}
812 %************************************************************************
816 = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
817 nextlabel :: Int } -- for generating local labels
819 type BcM result = BcM_State -> (result, BcM_State)
821 runBc :: BcM_State -> BcM () -> BcM_State
822 runBc init_st m = case m init_st of { (r,st) -> st }
824 thenBc :: BcM a -> (a -> BcM b) -> BcM b
826 = case expr st of { (result, st') -> cont result st' }
828 thenBc_ :: BcM a -> BcM b -> BcM b
830 = case expr st of { (result, st') -> cont st' }
832 returnBc :: a -> BcM a
833 returnBc result st = (result, st)
835 mapBc :: (a -> BcM b) -> [a] -> BcM [b]
836 mapBc f [] = returnBc []
838 = f x `thenBc` \ r ->
839 mapBc f xs `thenBc` \ rs ->
842 emitBc :: ProtoBCO Name -> BcM ()
844 = ((), st{bcos = bco : bcos st})
846 getLabelBc :: BcM Int
848 = (nextlabel st, st{nextlabel = 1 + nextlabel st})
852 %************************************************************************
854 \subsection{The bytecode assembler}
856 %************************************************************************
858 The object format for bytecodes is: 16 bits for the opcode, and 16 for
859 each field -- so the code can be considered a sequence of 16-bit ints.
860 Each field denotes either a stack offset or number of items on the
861 stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
862 index into the literal table (eg PUSH_I/D/L), or a bytecode address in
866 -- Top level assembler fn.
867 assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
869 assembleBCO (ProtoBCO nm instrs origin)
871 -- pass 1: collect up the offsets of the local labels.
872 -- Remember that the first insn starts at offset 1 since offset 0
873 -- (eventually) will hold the total # of insns.
874 label_env = mkLabelEnv emptyFM 1 instrs
876 mkLabelEnv env i_offset [] = env
877 mkLabelEnv env i_offset (i:is)
879 = case i of LABEL n -> addToFM env n i_offset ; _ -> env
880 in mkLabelEnv new_env (i_offset + instrSizeB i) is
883 = case lookupFM label_env lab of
884 Just bco_offset -> bco_offset
885 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
887 do -- pass 2: generate the instruction, ptr and nonptr bits
888 insns <- return emptySS :: IO (SizedSeq Word16)
889 lits <- return emptySS :: IO (SizedSeq Word)
890 ptrs <- return emptySS :: IO (SizedSeq Name)
891 itbls <- return emptySS :: IO (SizedSeq Name)
892 let init_asm_state = (insns,lits,ptrs,itbls)
893 (final_insns, final_lits, final_ptrs, final_itbls)
894 <- mkBits findLabel init_asm_state instrs
896 return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls)
898 -- instrs nonptrs ptrs itbls
899 type AsmState = (SizedSeq Word16, SizedSeq Word, SizedSeq Name, SizedSeq Name)
901 data SizedSeq a = SizedSeq !Int [a]
902 emptySS = SizedSeq 0 []
903 addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
904 addListToSS (SizedSeq n r_xs) xs
905 = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
906 sizeSS (SizedSeq n r_xs) = n
907 listFromSS (SizedSeq n r_xs) = return (reverse r_xs)
910 -- This is where all the action is (pass 2 of the assembler)
911 mkBits :: (Int -> Int) -- label finder
913 -> [BCInstr] -- instructions (in)
916 mkBits findLabel st proto_insns
917 = foldM doInstr st proto_insns
919 doInstr :: AsmState -> BCInstr -> IO AsmState
922 ARGCHECK n -> instr2 st i_ARGCHECK n
923 PUSH_L o1 -> instr2 st i_PUSH_L o1
924 PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2
925 PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
926 PUSH_G nm -> do (p, st2) <- ptr st nm
927 instr2 st2 i_PUSH_G p
928 PUSH_AS nm pk -> do (p, st2) <- ptr st nm
929 (np, st3) <- ctoi_itbl st2 pk
930 instr3 st3 i_PUSH_AS p np
931 PUSH_UBX lit nws -> do (np, st2) <- literal st lit
932 instr3 st2 i_PUSH_UBX np nws
933 PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
934 SLIDE n by -> instr3 st i_SLIDE n by
935 ALLOC n -> instr2 st i_ALLOC n
936 MKAP off sz -> instr3 st i_MKAP off sz
937 UNPACK n -> instr2 st i_UNPACK n
938 UPK_TAG n m k -> instr4 st i_UPK_TAG n m k
939 PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
940 instr3 st2 i_PACK itbl_no sz
941 LABEL lab -> return st
942 TESTLT_I i l -> do (np, st2) <- int st i
943 instr3 st2 i_TESTLT_I np (findLabel l)
944 TESTEQ_I i l -> do (np, st2) <- int st i
945 instr3 st2 i_TESTEQ_I np (findLabel l)
946 TESTLT_F f l -> do (np, st2) <- float st f
947 instr3 st2 i_TESTLT_F np (findLabel l)
948 TESTEQ_F f l -> do (np, st2) <- float st f
949 instr3 st2 i_TESTEQ_F np (findLabel l)
950 TESTLT_D d l -> do (np, st2) <- double st d
951 instr3 st2 i_TESTLT_D np (findLabel l)
952 TESTEQ_D d l -> do (np, st2) <- double st d
953 instr3 st2 i_TESTEQ_D np (findLabel l)
954 TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l)
955 TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l)
956 CASEFAIL -> instr1 st i_CASEFAIL
957 ENTER -> instr1 st i_ENTER
958 RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
959 instr2 st2 i_RETURN itbl_no
964 instr1 (st_i0,st_l0,st_p0,st_I0) i1
965 = do st_i1 <- addToSS st_i0 (i2s i1)
966 return (st_i1,st_l0,st_p0,st_I0)
968 instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
969 = do st_i1 <- addToSS st_i0 (i2s i1)
970 st_i2 <- addToSS st_i1 (i2s i2)
971 return (st_i2,st_l0,st_p0,st_I0)
973 instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
974 = do st_i1 <- addToSS st_i0 (i2s i1)
975 st_i2 <- addToSS st_i1 (i2s i2)
976 st_i3 <- addToSS st_i2 (i2s i3)
977 return (st_i3,st_l0,st_p0,st_I0)
979 instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
980 = do st_i1 <- addToSS st_i0 (i2s i1)
981 st_i2 <- addToSS st_i1 (i2s i2)
982 st_i3 <- addToSS st_i2 (i2s i3)
983 st_i4 <- addToSS st_i3 (i2s i4)
984 return (st_i4,st_l0,st_p0,st_I0)
986 float (st_i0,st_l0,st_p0,st_I0) f
987 = do let ws = mkLitF f
988 st_l1 <- addListToSS st_l0 ws
989 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
991 double (st_i0,st_l0,st_p0,st_I0) d
992 = do let ws = mkLitD d
993 st_l1 <- addListToSS st_l0 ws
994 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
996 int (st_i0,st_l0,st_p0,st_I0) i
997 = do let ws = mkLitI i
998 st_l1 <- addListToSS st_l0 ws
999 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
1001 addr (st_i0,st_l0,st_p0,st_I0) a
1002 = do let ws = mkLitA a
1003 st_l1 <- addListToSS st_l0 ws
1004 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
1006 ptr (st_i0,st_l0,st_p0,st_I0) p
1007 = do st_p1 <- addToSS st_p0 p
1008 return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
1010 itbl (st_i0,st_l0,st_p0,st_I0) dcon
1011 = do st_I1 <- addToSS st_I0 (getName dcon)
1012 return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
1014 literal st (MachInt j) = int st (fromIntegral j)
1015 literal st (MachFloat r) = float st (fromRational r)
1016 literal st (MachDouble r) = double st (fromRational r)
1019 = addr st ret_itbl_addr
1021 ret_itbl_addr = case pk of
1022 IntRep -> stg_ctoi_ret_R1_info
1023 FloatRep -> stg_ctoi_ret_F1_info
1024 DoubleRep -> stg_ctoi_ret_D1_info
1026 stg_ctoi_ret_F1_info = nullAddr
1027 stg_ctoi_ret_D1_info = nullAddr
1030 = addr st ret_itbl_addr
1032 ret_itbl_addr = case pk of
1033 IntRep -> stg_gc_unbx_r1_info
1034 FloatRep -> stg_gc_f1_info
1035 DoubleRep -> stg_gc_d1_info
1037 foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_info :: Addr
1038 --foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr
1039 --foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr
1041 foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr
1042 foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr
1043 foreign label "stg_gc_d1_info" stg_gc_d1_info :: Addr
1045 -- The size in bytes of an instruction.
1046 instrSizeB :: BCInstr -> Int
1077 -- Make lists of host-sized words for literals, so that when the
1078 -- words are placed in memory at increasing addresses, the
1079 -- bit pattern is correct for the host's word size and endianness.
1080 mkLitI :: Int -> [Word]
1081 mkLitF :: Float -> [Word]
1082 mkLitD :: Double -> [Word]
1083 mkLitA :: Addr -> [Word]
1087 arr <- newFloatArray ((0::Int),0)
1088 writeFloatArray arr 0 f
1089 f_arr <- castSTUArray arr
1090 w0 <- readWordArray f_arr 0
1097 arr <- newDoubleArray ((0::Int),0)
1098 writeDoubleArray arr 0 d
1099 d_arr <- castSTUArray arr
1100 w0 <- readWordArray d_arr 0
1101 w1 <- readWordArray d_arr 1
1106 arr <- newDoubleArray ((0::Int),0)
1107 writeDoubleArray arr 0 d
1108 d_arr <- castSTUArray arr
1109 w0 <- readWordArray d_arr 0
1115 arr <- newIntArray ((0::Int),0)
1116 writeIntArray arr 0 i
1117 i_arr <- castSTUArray arr
1118 w0 <- readWordArray i_arr 0
1124 arr <- newAddrArray ((0::Int),0)
1125 writeAddrArray arr 0 a
1126 a_arr <- castSTUArray arr
1127 w0 <- readWordArray a_arr 0
1133 %************************************************************************
1135 \subsection{Linking interpretables into something we can run}
1137 %************************************************************************
1142 data BCO# = BCO# ByteArray# -- instrs :: array Word16#
1143 ByteArray# -- literals :: array Word32#
1144 PtrArray# -- ptrs :: Array HValue
1145 ByteArray# -- itbls :: Array Addr#
1148 GLOBAL_VAR(v_cafTable, [], [HValue])
1150 --addCAF :: HValue -> IO ()
1151 --addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs)
1153 --bcosToHValue :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr -> IO HValue
1154 --bcosToHValue ie ce (root_bco, other_bcos)
1155 -- = do linked_expr <- linkIExpr ie ce (root_bco, other_bcos)
1156 -- return linked_expr
1159 linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
1160 -> IO [HValue] -- IO [BCO#] really
1161 linkBCOs ie ce binds = mapM (linkBCO ie ce) binds
1163 linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
1164 = do insns <- listFromSS insnsSS
1165 literals <- listFromSS literalsSS
1166 ptrs <- listFromSS ptrsSS
1167 itbls <- listFromSS itblsSS
1169 let linked_ptrs = map (lookupCE ce) ptrs
1170 linked_itbls <- mapM (lookupIE ie) itbls
1172 let n_insns = sizeSS insnsSS
1173 n_literals = sizeSS literalsSS
1174 n_ptrs = sizeSS ptrsSS
1175 n_itbls = sizeSS itblsSS
1177 let ptrs_arr = array (0, n_ptrs-1) (indexify linked_ptrs)
1179 ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
1181 itbls_arr = array (0, n_itbls-1) (indexify linked_itbls)
1183 itbls_barr = case itbls_arr of UArray lo hi barr -> barr
1185 insns_arr | n_insns > 65535
1186 = panic "linkBCO: >= 64k insns in BCO"
1188 = array (0, n_insns)
1189 (indexify (fromIntegral n_insns:insns))
1190 :: UArray Int Word16
1191 insns_barr = case insns_arr of UArray lo hi barr -> barr
1193 literals_arr = array (0, n_literals-1) (indexify literals)
1195 literals_barr = case literals_arr of UArray lo hi barr -> barr
1197 indexify :: [a] -> [(Int, a)]
1198 indexify xs = zip [0..] xs
1200 BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr
1202 return (unsafeCoerce# bco#)
1207 newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO
1209 = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
1212 lookupCE :: ClosureEnv -> Name -> HValue
1214 = case lookupFM ce nm of
1215 Just aa -> unsafeCoerce# aa
1216 Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
1218 lookupIE :: ItblEnv -> Name -> IO Addr
1220 = case lookupFM ie con_nm of
1221 Just (Ptr a) -> return a
1223 -> do -- try looking up in the object files.
1224 m <- lookupSymbol (nameToCLabel con_nm "con_info")
1226 Just addr -> return addr
1227 Nothing -> pprPanic "ByteCodeGen.lookupIE" (ppr con_nm)
1229 -- HACK!!! ToDo: cleaner
1230 nameToCLabel :: Name -> String{-suffix-} -> String
1231 nameToCLabel n suffix
1232 = _UNPK_(moduleNameFS (rdrNameModule rn))
1233 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
1234 where rn = toRdrName n
1239 case lookupFM ie con of
1240 Just (Ptr addr) -> return addr
1242 -- try looking up in the object files.
1243 m <- lookupSymbol (nameToCLabel con "con_info")
1245 Just addr -> return addr
1246 Nothing -> pprPanic "linkIExpr" (ppr con)
1248 -- nullary constructors don't have normal _con_info tables.
1249 lookupNullaryCon ie con =
1250 case lookupFM ie con of
1251 Just (Ptr addr) -> return (ConApp addr)
1253 -- try looking up in the object files.
1254 m <- lookupSymbol (nameToCLabel con "closure")
1256 Just (A# addr) -> return (Native (unsafeCoerce# addr))
1257 Nothing -> pprPanic "lookupNullaryCon" (ppr con)
1260 lookupNative ce var =
1261 unsafeInterleaveIO (do
1262 case lookupFM ce var of
1263 Just e -> return (Native e)
1265 -- try looking up in the object files.
1266 let lbl = (nameToCLabel var "closure")
1267 m <- lookupSymbol lbl
1270 -> do addCAF (unsafeCoerce# addr)
1271 return (Native (unsafeCoerce# addr))
1272 Nothing -> pprPanic "linkIExpr" (ppr var)
1275 -- some VarI/VarP refer to top-level interpreted functions; we change
1276 -- them into Natives here.
1278 unsafeInterleaveIO (
1279 case lookupFM ce (getName v) of
1280 Nothing -> return (f v)
1281 Just e -> return (Native e)
1286 %************************************************************************
1288 \subsection{Manufacturing of info tables for DataCons}
1290 %************************************************************************
1294 #if __GLASGOW_HASKELL__ <= 408
1297 type ItblPtr = Ptr StgInfoTable
1300 -- Make info tables for the data decls in this module
1301 mkITbls :: [TyCon] -> IO ItblEnv
1302 mkITbls [] = return emptyFM
1303 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1304 itbls2 <- mkITbls tcs
1305 return (itbls `plusFM` itbls2)
1307 mkITbl :: TyCon -> IO ItblEnv
1309 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1311 | not (isDataTyCon tc)
1313 | n == length dcs -- paranoia; this is an assertion.
1314 = make_constr_itbls dcs
1316 dcs = tyConDataCons tc
1317 n = tyConFamilySize tc
1320 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1322 -- Assumes constructors are numbered from zero, not one
1323 make_constr_itbls :: [DataCon] -> IO ItblEnv
1324 make_constr_itbls cons
1326 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1327 return (listToFM is)
1329 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1330 return (listToFM is)
1332 mk_vecret_itbl (dcon, conNo)
1333 = mk_itbl dcon conNo (vecret_entry conNo)
1334 mk_dirret_itbl (dcon, conNo)
1335 = mk_itbl dcon conNo stg_interp_constr_entry
1337 mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
1338 mk_itbl dcon conNo entry_addr
1339 = let (tot_wds, ptr_wds, _)
1340 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1342 nptrs = tot_wds - ptr_wds
1343 itbl = StgInfoTable {
1344 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1345 tipe = fromIntegral cONSTR,
1346 srtlen = fromIntegral conNo,
1347 code0 = fromIntegral code0, code1 = fromIntegral code1,
1348 code2 = fromIntegral code2, code3 = fromIntegral code3,
1349 code4 = fromIntegral code4, code5 = fromIntegral code5,
1350 code6 = fromIntegral code6, code7 = fromIntegral code7
1352 -- Make a piece of code to jump to "entry_label".
1353 -- This is the only arch-dependent bit.
1354 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1355 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1357 -- B8 ZZ YY XX WW FF E0
1358 (code0,code1,code2,code3,code4,code5,code6,code7)
1359 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1360 byte 2 entry_addr_w, byte 3 entry_addr_w,
1364 entry_addr_w :: Word32
1365 entry_addr_w = fromIntegral (addrToInt entry_addr)
1368 --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1369 --putStrLn ("# ptrs of itbl is " ++ show ptrs)
1370 --putStrLn ("# nptrs of itbl is " ++ show nptrs)
1372 return (getName dcon, addr `plusPtr` 8)
1375 byte :: Int -> Word32 -> Word32
1376 byte 0 w = w .&. 0xFF
1377 byte 1 w = (w `shiftR` 8) .&. 0xFF
1378 byte 2 w = (w `shiftR` 16) .&. 0xFF
1379 byte 3 w = (w `shiftR` 24) .&. 0xFF
1382 vecret_entry 0 = stg_interp_constr1_entry
1383 vecret_entry 1 = stg_interp_constr2_entry
1384 vecret_entry 2 = stg_interp_constr3_entry
1385 vecret_entry 3 = stg_interp_constr4_entry
1386 vecret_entry 4 = stg_interp_constr5_entry
1387 vecret_entry 5 = stg_interp_constr6_entry
1388 vecret_entry 6 = stg_interp_constr7_entry
1389 vecret_entry 7 = stg_interp_constr8_entry
1391 -- entry point for direct returns for created constr itbls
1392 foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr
1393 -- and the 8 vectored ones
1394 foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr
1395 foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr
1396 foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr
1397 foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr
1398 foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr
1399 foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr
1400 foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr
1401 foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr
1407 -- Ultra-minimalist version specially for constructors
1408 data StgInfoTable = StgInfoTable {
1413 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1417 instance Storable StgInfoTable where
1420 = (sum . map (\f -> f itbl))
1421 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1422 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1423 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1426 = (sum . map (\f -> f itbl))
1427 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1428 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1429 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1432 = do a1 <- store (ptrs itbl) (castPtr a0)
1433 a2 <- store (nptrs itbl) a1
1434 a3 <- store (tipe itbl) a2
1435 a4 <- store (srtlen itbl) a3
1436 a5 <- store (code0 itbl) a4
1437 a6 <- store (code1 itbl) a5
1438 a7 <- store (code2 itbl) a6
1439 a8 <- store (code3 itbl) a7
1440 a9 <- store (code4 itbl) a8
1441 aA <- store (code5 itbl) a9
1442 aB <- store (code6 itbl) aA
1443 aC <- store (code7 itbl) aB
1447 = do (a1,ptrs) <- load (castPtr a0)
1448 (a2,nptrs) <- load a1
1449 (a3,tipe) <- load a2
1450 (a4,srtlen) <- load a3
1451 (a5,code0) <- load a4
1452 (a6,code1) <- load a5
1453 (a7,code2) <- load a6
1454 (a8,code3) <- load a7
1455 (a9,code4) <- load a8
1456 (aA,code5) <- load a9
1457 (aB,code6) <- load aA
1458 (aC,code7) <- load aB
1459 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1460 srtlen = srtlen, tipe = tipe,
1461 code0 = code0, code1 = code1, code2 = code2,
1462 code3 = code3, code4 = code4, code5 = code5,
1463 code6 = code6, code7 = code7 }
1465 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1466 fieldSz sel x = sizeOf (sel x)
1468 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1469 fieldAl sel x = alignment (sel x)
1471 store :: Storable a => a -> Ptr a -> IO (Ptr b)
1472 store x addr = do poke addr x
1473 return (castPtr (addr `plusPtr` sizeOf x))
1475 load :: Storable a => Ptr a -> IO (Ptr b, a)
1476 load addr = do x <- peek addr
1477 return (castPtr (addr `plusPtr` sizeOf x), x)
1481 %************************************************************************
1483 \subsection{Connect to actual values for bytecode opcodes}
1485 %************************************************************************
1489 #include "Bytecodes.h"
1491 i_ARGCHECK = (bci_ARGCHECK :: Int)
1492 i_PUSH_L = (bci_PUSH_L :: Int)
1493 i_PUSH_LL = (bci_PUSH_LL :: Int)
1494 i_PUSH_LLL = (bci_PUSH_LLL :: Int)
1495 i_PUSH_G = (bci_PUSH_G :: Int)
1496 i_PUSH_AS = (bci_PUSH_AS :: Int)
1497 i_PUSH_UBX = (bci_PUSH_UBX :: Int)
1498 i_PUSH_TAG = (bci_PUSH_TAG :: Int)
1499 i_SLIDE = (bci_SLIDE :: Int)
1500 i_ALLOC = (bci_ALLOC :: Int)
1501 i_MKAP = (bci_MKAP :: Int)
1502 i_UNPACK = (bci_UNPACK :: Int)
1503 i_UPK_TAG = (bci_UPK_TAG :: Int)
1504 i_PACK = (bci_PACK :: Int)
1505 i_TESTLT_I = (bci_TESTLT_I :: Int)
1506 i_TESTEQ_I = (bci_TESTEQ_I :: Int)
1507 i_TESTLT_F = (bci_TESTLT_F :: Int)
1508 i_TESTEQ_F = (bci_TESTEQ_F :: Int)
1509 i_TESTLT_D = (bci_TESTLT_D :: Int)
1510 i_TESTEQ_D = (bci_TESTEQ_D :: Int)
1511 i_TESTLT_P = (bci_TESTLT_P :: Int)
1512 i_TESTEQ_P = (bci_TESTEQ_P :: Int)
1513 i_CASEFAIL = (bci_CASEFAIL :: Int)
1514 i_ENTER = (bci_ENTER :: Int)
1515 i_RETURN = (bci_RETURN :: Int)