Merge branch 'master' of http://darcs.haskell.org/ghc
[ghc.git] / compiler / codeGen / StgCmmLayout.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Building info tables.
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module StgCmmLayout (
17 mkArgDescr,
18 emitCall, emitReturn, adjustHpBackwards,
19
20 emitClosureProcAndInfoTable,
21 emitClosureAndInfoTable,
22
23 slowCall, directCall,
24
25 mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel,
26
27 stdInfoTableSizeB,
28 entryCode, closureInfoPtr,
29 getConstrTag,
30 cmmGetClosureType,
31 infoTable, infoTableClosureType,
32 infoTablePtrs, infoTableNonPtrs,
33 funInfoTable
34 ) where
35
36
37 #include "HsVersions.h"
38
39 import StgCmmClosure
40 import StgCmmEnv
41 import StgCmmTicky
42 import StgCmmMonad
43 import StgCmmUtils
44 import StgCmmProf
45
46 import MkGraph
47 import SMRep
48 import Cmm
49 import CmmUtils
50 import CLabel
51 import StgSyn
52 import Id
53 import Name
54 import TyCon ( PrimRep(..) )
55 import BasicTypes ( RepArity )
56 import DynFlags
57 import Module
58
59 import Constants
60 import Util
61 import Data.List
62 import Outputable
63 import FastString
64
65 ------------------------------------------------------------------------
66 -- Call and return sequences
67 ------------------------------------------------------------------------
68
69 -- | Return multiple values to the sequel
70 --
71 -- If the sequel is @Return@
72 --
73 -- > return (x,y)
74 --
75 -- If the sequel is @AssignTo [p,q]@
76 --
77 -- > p=x; q=y;
78 --
79 emitReturn :: [CmmExpr] -> FCode ReturnKind
80 emitReturn results
81 = do { dflags <- getDynFlags
82 ; sequel <- getSequel
83 ; updfr_off <- getUpdFrameOff
84 ; case sequel of
85 Return _ ->
86 do { adjustHpBackwards
87 ; emit (mkReturnSimple dflags results updfr_off) }
88 AssignTo regs adjust ->
89 do { if adjust then adjustHpBackwards else return ()
90 ; emitMultiAssign regs results }
91 ; return AssignedDirectly
92 }
93
94
95 -- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,
96 -- using the call/return convention @conv@, passing @args@, and
97 -- returning the results to the current sequel.
98 --
99 emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind
100 emitCall convs fun args
101 = emitCallWithExtraStack convs fun args noExtraStack
102
103
104 -- | @emitCallWithExtraStack conv fun args stack@ makes a call to the
105 -- entry-code of @fun@, using the call/return convention @conv@,
106 -- passing @args@, pushing some extra stack frames described by
107 -- @stack@, and returning the results to the current sequel.
108 --
109 emitCallWithExtraStack
110 :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
111 -> (ByteOff, [(CmmExpr,ByteOff)]) -> FCode ReturnKind
112 emitCallWithExtraStack (callConv, retConv) fun args extra_stack
113 = do { dflags <- getDynFlags
114 ; adjustHpBackwards
115 ; sequel <- getSequel
116 ; updfr_off <- getUpdFrameOff
117 ; case sequel of
118 Return _ -> do
119 emit $ mkForeignJumpExtra dflags callConv fun args updfr_off extra_stack
120 return AssignedDirectly
121 AssignTo res_regs _ -> do
122 k <- newLabelC
123 let area = Young k
124 (off, copyin) = copyInOflow dflags retConv area res_regs
125 copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
126 extra_stack
127 emit (copyout <*> mkLabel k <*> copyin)
128 return (ReturnedTo k off)
129 }
130
131
132 adjustHpBackwards :: FCode ()
133 -- This function adjusts and heap pointers just before a tail call or
134 -- return. At a call or return, the virtual heap pointer may be less
135 -- than the real Hp, because the latter was advanced to deal with
136 -- the worst-case branch of the code, and we may be in a better-case
137 -- branch. In that case, move the real Hp *back* and retract some
138 -- ticky allocation count.
139 --
140 -- It *does not* deal with high-water-mark adjustment.
141 -- That's done by functions which allocate heap.
142 adjustHpBackwards
143 = do { hp_usg <- getHpUsage
144 ; let rHp = realHp hp_usg
145 vHp = virtHp hp_usg
146 adjust_words = vHp -rHp
147 ; new_hp <- getHpRelOffset vHp
148
149 ; emit (if adjust_words == 0
150 then mkNop
151 else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp
152
153 ; tickyAllocHeap adjust_words -- ...ditto
154
155 ; setRealHp vHp
156 }
157
158
159 -------------------------------------------------------------------------
160 -- Making calls: directCall and slowCall
161 -------------------------------------------------------------------------
162
163 -- General plan is:
164 -- - we'll make *one* fast call, either to the function itself
165 -- (directCall) or to stg_ap_<pat>_fast (slowCall)
166 -- Any left-over arguments will be pushed on the stack,
167 --
168 -- e.g. Sp[old+8] = arg1
169 -- Sp[old+16] = arg2
170 -- Sp[old+32] = stg_ap_pp_info
171 -- R2 = arg3
172 -- R3 = arg4
173 -- call f() return to Nothing updfr_off: 32
174
175
176 directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
177 -- (directCall f n args)
178 -- calls f(arg1, ..., argn), and applies the result to the remaining args
179 -- The function f has arity n, and there are guaranteed at least n args
180 -- Both arity and args include void args
181 directCall conv lbl arity stg_args
182 = do { argreps <- getArgRepsAmodes stg_args
183 ; direct_call "directCall" conv lbl arity argreps }
184
185
186 slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
187 -- (slowCall fun args) applies fun to args, returning the results to Sequel
188 slowCall fun stg_args
189 = do { dflags <- getDynFlags
190 ; argsreps <- getArgRepsAmodes stg_args
191 ; let (rts_fun, arity) = slowCallPattern (map fst argsreps)
192 ; r <- direct_call "slow_call" NativeNodeCall
193 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
194 ; emitComment $ mkFastString ("slow_call for " ++
195 showSDoc dflags (ppr fun) ++
196 " with pat " ++ unpackFS rts_fun)
197 ; return r
198 }
199
200
201 --------------
202 direct_call :: String
203 -> Convention -- e.g. NativeNodeCall or NativeDirectCall
204 -> CLabel -> RepArity
205 -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
206 direct_call caller call_conv lbl arity args
207 | debugIsOn && real_arity > length args -- Too few args
208 = do -- Caller should ensure that there enough args!
209 pprPanic "direct_call" $
210 text caller <+> ppr arity <+>
211 ppr lbl <+> ppr (length args) <+>
212 ppr (map snd args) <+> ppr (map fst args)
213
214 | null rest_args -- Precisely the right number of arguments
215 = emitCall (call_conv, NativeReturn) target (nonVArgs args)
216
217 | otherwise -- Note [over-saturated calls]
218 = do dflags <- getDynFlags
219 emitCallWithExtraStack (call_conv, NativeReturn)
220 target
221 (nonVArgs fast_args)
222 (mkStkOffsets dflags (stack_args dflags))
223 where
224 target = CmmLit (CmmLabel lbl)
225 (fast_args, rest_args) = splitAt real_arity args
226 stack_args dflags = slowArgs dflags rest_args
227 real_arity = case call_conv of
228 NativeNodeCall -> arity+1
229 _ -> arity
230
231
232 -- When constructing calls, it is easier to keep the ArgReps and the
233 -- CmmExprs zipped together. However, a void argument has no
234 -- representation, so we need to use Maybe CmmExpr (the alternative of
235 -- using zeroCLit or even undefined would work, but would be ugly).
236 --
237 getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
238 getArgRepsAmodes = mapM getArgRepAmode
239 where getArgRepAmode arg
240 | V <- rep = return (V, Nothing)
241 | otherwise = do expr <- getArgAmode (NonVoid arg)
242 return (rep, Just expr)
243 where rep = toArgRep (argPrimRep arg)
244
245 nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
246 nonVArgs [] = []
247 nonVArgs ((_,Nothing) : args) = nonVArgs args
248 nonVArgs ((_,Just arg) : args) = arg : nonVArgs args
249
250 {-
251 Note [over-saturated calls]
252
253 The natural thing to do for an over-saturated call would be to call
254 the function with the correct number of arguments, and then apply the
255 remaining arguments to the value returned, e.g.
256
257 f a b c d (where f has arity 2)
258 -->
259 r = call f(a,b)
260 call r(c,d)
261
262 but this entails
263 - saving c and d on the stack
264 - making a continuation info table
265 - at the continuation, loading c and d off the stack into regs
266 - finally, call r
267
268 Note that since there are a fixed number of different r's
269 (e.g. stg_ap_pp_fast), we can also pre-compile continuations
270 that correspond to each of them, rather than generating a fresh
271 one for each over-saturated call.
272
273 Not only does this generate much less code, it is faster too. We will
274 generate something like:
275
276 Sp[old+16] = c
277 Sp[old+24] = d
278 Sp[old+32] = stg_ap_pp_info
279 call f(a,b) -- usual calling convention
280
281 For the purposes of the CmmCall node, we count this extra stack as
282 just more arguments that we are passing on the stack (cml_args).
283 -}
284
285 -- | 'slowArgs' takes a list of function arguments and prepares them for
286 -- pushing on the stack for "extra" arguments to a function which requires
287 -- fewer arguments than we currently have.
288 slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
289 slowArgs _ [] = []
290 slowArgs dflags args -- careful: reps contains voids (V), but args does not
291 | dopt Opt_SccProfilingOn dflags
292 = save_cccs ++ this_pat ++ slowArgs dflags rest_args
293 | otherwise = this_pat ++ slowArgs dflags rest_args
294 where
295 (arg_pat, n) = slowCallPattern (map fst args)
296 (call_args, rest_args) = splitAt n args
297
298 stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
299 this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args
300 save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)]
301 save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs")
302
303
304
305 -- These cases were found to cover about 99% of all slow calls:
306 slowCallPattern :: [ArgRep] -> (FastString, RepArity)
307 -- Returns the generic apply function and arity
308 slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
309 slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5)
310 slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4)
311 slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4)
312 slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3)
313 slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3)
314 slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2)
315 slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2)
316 slowCallPattern (P: _) = (fsLit "stg_ap_p", 1)
317 slowCallPattern (V: _) = (fsLit "stg_ap_v", 1)
318 slowCallPattern (N: _) = (fsLit "stg_ap_n", 1)
319 slowCallPattern (F: _) = (fsLit "stg_ap_f", 1)
320 slowCallPattern (D: _) = (fsLit "stg_ap_d", 1)
321 slowCallPattern (L: _) = (fsLit "stg_ap_l", 1)
322 slowCallPattern [] = (fsLit "stg_ap_0", 0)
323
324
325 -------------------------------------------------------------------------
326 -- Fix the byte-offsets of a bunch of things to push on the stack
327
328 -- This is used for pushing slow-call continuations.
329 -- See Note [over-saturated calls].
330
331 mkStkOffsets
332 :: DynFlags
333 -> [(ArgRep, Maybe CmmExpr)] -- things to make offsets for
334 -> ( ByteOff -- OUTPUTS: Topmost allocated word
335 , [(CmmExpr, ByteOff)] ) -- things with offsets (voids filtered out)
336 mkStkOffsets dflags things
337 = loop 0 [] (reverse things)
338 where
339 loop offset offs [] = (offset,offs)
340 loop offset offs ((_,Nothing):things) = loop offset offs things
341 -- ignore Void arguments
342 loop offset offs ((rep,Just thing):things)
343 = loop thing_off ((thing, thing_off):offs) things
344 where
345 thing_off = offset + argRepSizeW dflags rep * wORD_SIZE dflags
346 -- offset of thing is offset+size, because we're
347 -- growing the stack *downwards* as the offsets increase.
348
349
350 -------------------------------------------------------------------------
351 -- Classifying arguments: ArgRep
352 -------------------------------------------------------------------------
353
354 -- ArgRep is not exported (even abstractly)
355 -- It's a local helper type for classification
356
357 data ArgRep = P -- GC Ptr
358 | N -- One-word non-ptr
359 | L -- Two-word non-ptr (long)
360 | V -- Void
361 | F -- Float
362 | D -- Double
363 instance Outputable ArgRep where
364 ppr P = text "P"
365 ppr N = text "N"
366 ppr L = text "L"
367 ppr V = text "V"
368 ppr F = text "F"
369 ppr D = text "D"
370
371 toArgRep :: PrimRep -> ArgRep
372 toArgRep VoidRep = V
373 toArgRep PtrRep = P
374 toArgRep IntRep = N
375 toArgRep WordRep = N
376 toArgRep AddrRep = N
377 toArgRep Int64Rep = L
378 toArgRep Word64Rep = L
379 toArgRep FloatRep = F
380 toArgRep DoubleRep = D
381
382 isNonV :: ArgRep -> Bool
383 isNonV V = False
384 isNonV _ = True
385
386 argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words
387 argRepSizeW _ N = 1
388 argRepSizeW _ P = 1
389 argRepSizeW _ F = 1
390 argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags
391 argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags
392 argRepSizeW _ V = 0
393
394 idArgRep :: Id -> ArgRep
395 idArgRep = toArgRep . idPrimRep
396
397 -------------------------------------------------------------------------
398 ---- Laying out objects on the heap and stack
399 -------------------------------------------------------------------------
400
401 -- The heap always grows upwards, so hpRel is easy
402 hpRel :: VirtualHpOffset -- virtual offset of Hp
403 -> VirtualHpOffset -- virtual offset of The Thing
404 -> WordOff -- integer word offset
405 hpRel hp off = off - hp
406
407 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
408 getHpRelOffset virtual_offset
409 = do dflags <- getDynFlags
410 hp_usg <- getHpUsage
411 return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))
412
413 mkVirtHeapOffsets
414 :: DynFlags
415 -> Bool -- True <=> is a thunk
416 -> [(PrimRep,a)] -- Things to make offsets for
417 -> (WordOff, -- _Total_ number of words allocated
418 WordOff, -- Number of words allocated for *pointers*
419 [(NonVoid a, VirtualHpOffset)])
420
421 -- Things with their offsets from start of object in order of
422 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
423 -- First in list gets lowest offset, which is initial offset + 1.
424 --
425 -- Void arguments are removed, so output list may be shorter than
426 -- input list
427 --
428 -- mkVirtHeapOffsets always returns boxed things with smaller offsets
429 -- than the unboxed things
430
431 mkVirtHeapOffsets dflags is_thunk things
432 = let non_void_things = filterOut (isVoidRep . fst) things
433 (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things
434 (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
435 (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
436 in
437 (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
438 where
439 hdr_size | is_thunk = thunkHdrSize dflags
440 | otherwise = fixedHdrSize dflags
441
442 computeOffset wds_so_far (rep, thing)
443 = (wds_so_far + argRepSizeW dflags (toArgRep rep),
444 (NonVoid thing, hdr_size + wds_so_far))
445
446 mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)])
447 -- Just like mkVirtHeapOffsets, but for constructors
448 mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
449
450
451 -------------------------------------------------------------------------
452 --
453 -- Making argument descriptors
454 --
455 -- An argument descriptor describes the layout of args on the stack,
456 -- both for * GC (stack-layout) purposes, and
457 -- * saving/restoring registers when a heap-check fails
458 --
459 -- Void arguments aren't important, therefore (contrast constructSlowCall)
460 --
461 -------------------------------------------------------------------------
462
463 -- bring in ARG_P, ARG_N, etc.
464 #include "../includes/rts/storage/FunTypes.h"
465
466 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
467 mkArgDescr _nm args
468 = do dflags <- getDynFlags
469 let arg_bits = argBits dflags arg_reps
470 arg_reps = filter isNonV (map idArgRep args)
471 -- Getting rid of voids eases matching of standard patterns
472 case stdPattern arg_reps of
473 Just spec_id -> return (ArgSpec spec_id)
474 Nothing -> return (ArgGen arg_bits)
475
476 argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr
477 argBits _ [] = []
478 argBits dflags (P : args) = False : argBits dflags args
479 argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
480 ++ argBits dflags args
481
482 ----------------------
483 stdPattern :: [ArgRep] -> Maybe StgHalfWord
484 stdPattern reps
485 = case reps of
486 [] -> Just ARG_NONE -- just void args, probably
487 [N] -> Just ARG_N
488 [P] -> Just ARG_P
489 [F] -> Just ARG_F
490 [D] -> Just ARG_D
491 [L] -> Just ARG_L
492
493 [N,N] -> Just ARG_NN
494 [N,P] -> Just ARG_NP
495 [P,N] -> Just ARG_PN
496 [P,P] -> Just ARG_PP
497
498 [N,N,N] -> Just ARG_NNN
499 [N,N,P] -> Just ARG_NNP
500 [N,P,N] -> Just ARG_NPN
501 [N,P,P] -> Just ARG_NPP
502 [P,N,N] -> Just ARG_PNN
503 [P,N,P] -> Just ARG_PNP
504 [P,P,N] -> Just ARG_PPN
505 [P,P,P] -> Just ARG_PPP
506
507 [P,P,P,P] -> Just ARG_PPPP
508 [P,P,P,P,P] -> Just ARG_PPPPP
509 [P,P,P,P,P,P] -> Just ARG_PPPPPP
510
511 _ -> Nothing
512
513 -------------------------------------------------------------------------
514 --
515 -- Generating the info table and code for a closure
516 --
517 -------------------------------------------------------------------------
518
519 -- Here we make an info table of type 'CmmInfo'. The concrete
520 -- representation as a list of 'CmmAddr' is handled later
521 -- in the pipeline by 'cmmToRawCmm'.
522 -- When loading the free variables, a function closure pointer may be tagged,
523 -- so we must take it into account.
524
525 emitClosureProcAndInfoTable :: Bool -- top-level?
526 -> Id -- name of the closure
527 -> LambdaFormInfo
528 -> CmmInfoTable
529 -> [NonVoid Id] -- incoming arguments
530 -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
531 -> FCode ()
532 emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
533 = do { dflags <- getDynFlags
534 -- Bind the binder itself, but only if it's not a top-level
535 -- binding. We need non-top let-bindings to refer to the
536 -- top-level binding, which this binding would incorrectly shadow.
537 ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)
538 else bindToReg (NonVoid bndr) lf_info
539 ; let node_points = nodeMustPointToIt dflags lf_info
540 ; arg_regs <- bindArgsToRegs args
541 ; let args' = if node_points then (node : arg_regs) else arg_regs
542 conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall
543 else NativeDirectCall
544 (offset, _) = mkCallEntry dflags conv args'
545 ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
546 }
547
548 -- Data constructors need closures, but not with all the argument handling
549 -- needed for functions. The shared part goes here.
550 emitClosureAndInfoTable ::
551 CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
552 emitClosureAndInfoTable info_tbl conv args body
553 = do { blks <- getCode body
554 ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
555 ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
556 }
557
558 -----------------------------------------------------------------------------
559 --
560 -- Info table offsets
561 --
562 -----------------------------------------------------------------------------
563
564 stdInfoTableSizeW :: DynFlags -> WordOff
565 -- The size of a standard info table varies with profiling/ticky etc,
566 -- so we can't get it from Constants
567 -- It must vary in sync with mkStdInfoTable
568 stdInfoTableSizeW dflags
569 = size_fixed + size_prof
570 where
571 size_fixed = 2 -- layout, type
572 size_prof | dopt Opt_SccProfilingOn dflags = 2
573 | otherwise = 0
574
575 stdInfoTableSizeB :: DynFlags -> ByteOff
576 stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
577
578 stdSrtBitmapOffset :: DynFlags -> ByteOff
579 -- Byte offset of the SRT bitmap half-word which is
580 -- in the *higher-addressed* part of the type_lit
581 stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE
582
583 stdClosureTypeOffset :: DynFlags -> ByteOff
584 -- Byte offset of the closure type half-word
585 stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
586
587 stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
588 stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
589 stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE
590
591 -------------------------------------------------------------------------
592 --
593 -- Accessing fields of an info table
594 --
595 -------------------------------------------------------------------------
596
597 closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
598 -- Takes a closure pointer and returns the info table pointer
599 closureInfoPtr dflags e = CmmLoad e (bWord dflags)
600
601 entryCode :: DynFlags -> CmmExpr -> CmmExpr
602 -- Takes an info pointer (the first word of a closure)
603 -- and returns its entry code
604 entryCode dflags e
605 | tablesNextToCode dflags = e
606 | otherwise = CmmLoad e (bWord dflags)
607
608 getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
609 -- Takes a closure pointer, and return the *zero-indexed*
610 -- constructor tag obtained from the info table
611 -- This lives in the SRT field of the info table
612 -- (constructors don't need SRTs).
613 getConstrTag dflags closure_ptr
614 = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
615 where
616 info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
617
618 cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
619 -- Takes a closure pointer, and return the closure type
620 -- obtained from the info table
621 cmmGetClosureType dflags closure_ptr
622 = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
623 where
624 info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
625
626 infoTable :: DynFlags -> CmmExpr -> CmmExpr
627 -- Takes an info pointer (the first word of a closure)
628 -- and returns a pointer to the first word of the standard-form
629 -- info table, excluding the entry-code word (if present)
630 infoTable dflags info_ptr
631 | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
632 | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
633
634 infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
635 -- Takes an info table pointer (from infoTable) and returns the constr tag
636 -- field of the info table (same as the srt_bitmap field)
637 infoTableConstrTag = infoTableSrtBitmap
638
639 infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
640 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
641 -- field of the info table
642 infoTableSrtBitmap dflags info_tbl
643 = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
644
645 infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
646 -- Takes an info table pointer (from infoTable) and returns the closure type
647 -- field of the info table.
648 infoTableClosureType dflags info_tbl
649 = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
650
651 infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
652 infoTablePtrs dflags info_tbl
653 = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
654
655 infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
656 infoTableNonPtrs dflags info_tbl
657 = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
658
659 funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
660 -- Takes the info pointer of a function,
661 -- and returns a pointer to the first word of the StgFunInfoExtra struct
662 -- in the info table.
663 funInfoTable dflags info_ptr
664 | tablesNextToCode dflags
665 = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
666 | otherwise
667 = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
668 -- Past the entry code pointer
669