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