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