Produce new-style Cmm from the Cmm parser
[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 -> [CmmExpr] -> 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 (nonVArgs (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 -- Classifying arguments: ArgRep
330 -------------------------------------------------------------------------
331
332 -- ArgRep is not exported (even abstractly)
333 -- It's a local helper type for classification
334
335 data ArgRep = P -- GC Ptr
336 | N -- One-word non-ptr
337 | L -- Two-word non-ptr (long)
338 | V -- Void
339 | F -- Float
340 | D -- Double
341 instance Outputable ArgRep where
342 ppr P = text "P"
343 ppr N = text "N"
344 ppr L = text "L"
345 ppr V = text "V"
346 ppr F = text "F"
347 ppr D = text "D"
348
349 toArgRep :: PrimRep -> ArgRep
350 toArgRep VoidRep = V
351 toArgRep PtrRep = P
352 toArgRep IntRep = N
353 toArgRep WordRep = N
354 toArgRep AddrRep = N
355 toArgRep Int64Rep = L
356 toArgRep Word64Rep = L
357 toArgRep FloatRep = F
358 toArgRep DoubleRep = D
359
360 isNonV :: ArgRep -> Bool
361 isNonV V = False
362 isNonV _ = True
363
364 argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words
365 argRepSizeW _ N = 1
366 argRepSizeW _ P = 1
367 argRepSizeW _ F = 1
368 argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags
369 argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags
370 argRepSizeW _ V = 0
371
372 idArgRep :: Id -> ArgRep
373 idArgRep = toArgRep . idPrimRep
374
375 -------------------------------------------------------------------------
376 ---- Laying out objects on the heap and stack
377 -------------------------------------------------------------------------
378
379 -- The heap always grows upwards, so hpRel is easy
380 hpRel :: VirtualHpOffset -- virtual offset of Hp
381 -> VirtualHpOffset -- virtual offset of The Thing
382 -> WordOff -- integer word offset
383 hpRel hp off = off - hp
384
385 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
386 getHpRelOffset virtual_offset
387 = do dflags <- getDynFlags
388 hp_usg <- getHpUsage
389 return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))
390
391 mkVirtHeapOffsets
392 :: DynFlags
393 -> Bool -- True <=> is a thunk
394 -> [(PrimRep,a)] -- Things to make offsets for
395 -> (WordOff, -- _Total_ number of words allocated
396 WordOff, -- Number of words allocated for *pointers*
397 [(NonVoid a, VirtualHpOffset)])
398
399 -- Things with their offsets from start of object in order of
400 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
401 -- First in list gets lowest offset, which is initial offset + 1.
402 --
403 -- Void arguments are removed, so output list may be shorter than
404 -- input list
405 --
406 -- mkVirtHeapOffsets always returns boxed things with smaller offsets
407 -- than the unboxed things
408
409 mkVirtHeapOffsets dflags is_thunk things
410 = let non_void_things = filterOut (isVoidRep . fst) things
411 (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things
412 (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
413 (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
414 in
415 (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
416 where
417 hdr_size | is_thunk = thunkHdrSize dflags
418 | otherwise = fixedHdrSize dflags
419
420 computeOffset wds_so_far (rep, thing)
421 = (wds_so_far + argRepSizeW dflags (toArgRep rep),
422 (NonVoid thing, hdr_size + wds_so_far))
423
424 mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)])
425 -- Just like mkVirtHeapOffsets, but for constructors
426 mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
427
428
429 -------------------------------------------------------------------------
430 --
431 -- Making argument descriptors
432 --
433 -- An argument descriptor describes the layout of args on the stack,
434 -- both for * GC (stack-layout) purposes, and
435 -- * saving/restoring registers when a heap-check fails
436 --
437 -- Void arguments aren't important, therefore (contrast constructSlowCall)
438 --
439 -------------------------------------------------------------------------
440
441 -- bring in ARG_P, ARG_N, etc.
442 #include "../includes/rts/storage/FunTypes.h"
443
444 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
445 mkArgDescr _nm args
446 = do dflags <- getDynFlags
447 let arg_bits = argBits dflags arg_reps
448 arg_reps = filter isNonV (map idArgRep args)
449 -- Getting rid of voids eases matching of standard patterns
450 case stdPattern arg_reps of
451 Just spec_id -> return (ArgSpec spec_id)
452 Nothing -> return (ArgGen arg_bits)
453
454 argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr
455 argBits _ [] = []
456 argBits dflags (P : args) = False : argBits dflags args
457 argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
458 ++ argBits dflags args
459
460 ----------------------
461 stdPattern :: [ArgRep] -> Maybe Int
462 stdPattern reps
463 = case reps of
464 [] -> Just ARG_NONE -- just void args, probably
465 [N] -> Just ARG_N
466 [P] -> Just ARG_P
467 [F] -> Just ARG_F
468 [D] -> Just ARG_D
469 [L] -> Just ARG_L
470
471 [N,N] -> Just ARG_NN
472 [N,P] -> Just ARG_NP
473 [P,N] -> Just ARG_PN
474 [P,P] -> Just ARG_PP
475
476 [N,N,N] -> Just ARG_NNN
477 [N,N,P] -> Just ARG_NNP
478 [N,P,N] -> Just ARG_NPN
479 [N,P,P] -> Just ARG_NPP
480 [P,N,N] -> Just ARG_PNN
481 [P,N,P] -> Just ARG_PNP
482 [P,P,N] -> Just ARG_PPN
483 [P,P,P] -> Just ARG_PPP
484
485 [P,P,P,P] -> Just ARG_PPPP
486 [P,P,P,P,P] -> Just ARG_PPPPP
487 [P,P,P,P,P,P] -> Just ARG_PPPPPP
488
489 _ -> Nothing
490
491 -------------------------------------------------------------------------
492 --
493 -- Generating the info table and code for a closure
494 --
495 -------------------------------------------------------------------------
496
497 -- Here we make an info table of type 'CmmInfo'. The concrete
498 -- representation as a list of 'CmmAddr' is handled later
499 -- in the pipeline by 'cmmToRawCmm'.
500 -- When loading the free variables, a function closure pointer may be tagged,
501 -- so we must take it into account.
502
503 emitClosureProcAndInfoTable :: Bool -- top-level?
504 -> Id -- name of the closure
505 -> LambdaFormInfo
506 -> CmmInfoTable
507 -> [NonVoid Id] -- incoming arguments
508 -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
509 -> FCode ()
510 emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
511 = do { dflags <- getDynFlags
512 -- Bind the binder itself, but only if it's not a top-level
513 -- binding. We need non-top let-bindings to refer to the
514 -- top-level binding, which this binding would incorrectly shadow.
515 ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)
516 else bindToReg (NonVoid bndr) lf_info
517 ; let node_points = nodeMustPointToIt dflags lf_info
518 ; arg_regs <- bindArgsToRegs args
519 ; let args' = if node_points then (node : arg_regs) else arg_regs
520 conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall
521 else NativeDirectCall
522 (offset, _) = mkCallEntry dflags conv args' []
523 ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
524 }
525
526 -- Data constructors need closures, but not with all the argument handling
527 -- needed for functions. The shared part goes here.
528 emitClosureAndInfoTable ::
529 CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
530 emitClosureAndInfoTable info_tbl conv args body
531 = do { blks <- getCode body
532 ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
533 ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
534 }
535
536 -----------------------------------------------------------------------------
537 --
538 -- Info table offsets
539 --
540 -----------------------------------------------------------------------------
541
542 stdInfoTableSizeW :: DynFlags -> WordOff
543 -- The size of a standard info table varies with profiling/ticky etc,
544 -- so we can't get it from Constants
545 -- It must vary in sync with mkStdInfoTable
546 stdInfoTableSizeW dflags
547 = size_fixed + size_prof
548 where
549 size_fixed = 2 -- layout, type
550 size_prof | dopt Opt_SccProfilingOn dflags = 2
551 | otherwise = 0
552
553 stdInfoTableSizeB :: DynFlags -> ByteOff
554 stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
555
556 stdSrtBitmapOffset :: DynFlags -> ByteOff
557 -- Byte offset of the SRT bitmap half-word which is
558 -- in the *higher-addressed* part of the type_lit
559 stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
560
561 stdClosureTypeOffset :: DynFlags -> ByteOff
562 -- Byte offset of the closure type half-word
563 stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
564
565 stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
566 stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
567 stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
568
569 -------------------------------------------------------------------------
570 --
571 -- Accessing fields of an info table
572 --
573 -------------------------------------------------------------------------
574
575 closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
576 -- Takes a closure pointer and returns the info table pointer
577 closureInfoPtr dflags e = CmmLoad e (bWord dflags)
578
579 entryCode :: DynFlags -> CmmExpr -> CmmExpr
580 -- Takes an info pointer (the first word of a closure)
581 -- and returns its entry code
582 entryCode dflags e
583 | tablesNextToCode dflags = e
584 | otherwise = CmmLoad e (bWord dflags)
585
586 getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
587 -- Takes a closure pointer, and return the *zero-indexed*
588 -- constructor tag obtained from the info table
589 -- This lives in the SRT field of the info table
590 -- (constructors don't need SRTs).
591 getConstrTag dflags closure_ptr
592 = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
593 where
594 info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
595
596 cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
597 -- Takes a closure pointer, and return the closure type
598 -- obtained from the info table
599 cmmGetClosureType dflags closure_ptr
600 = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
601 where
602 info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
603
604 infoTable :: DynFlags -> CmmExpr -> CmmExpr
605 -- Takes an info pointer (the first word of a closure)
606 -- and returns a pointer to the first word of the standard-form
607 -- info table, excluding the entry-code word (if present)
608 infoTable dflags info_ptr
609 | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
610 | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
611
612 infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
613 -- Takes an info table pointer (from infoTable) and returns the constr tag
614 -- field of the info table (same as the srt_bitmap field)
615 infoTableConstrTag = infoTableSrtBitmap
616
617 infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
618 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
619 -- field of the info table
620 infoTableSrtBitmap dflags info_tbl
621 = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
622
623 infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
624 -- Takes an info table pointer (from infoTable) and returns the closure type
625 -- field of the info table.
626 infoTableClosureType dflags info_tbl
627 = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
628
629 infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
630 infoTablePtrs dflags info_tbl
631 = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
632
633 infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
634 infoTableNonPtrs dflags info_tbl
635 = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
636
637 funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
638 -- Takes the info pointer of a function,
639 -- and returns a pointer to the first word of the StgFunInfoExtra struct
640 -- in the info table.
641 funInfoTable dflags info_ptr
642 | tablesNextToCode dflags
643 = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
644 | otherwise
645 = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
646 -- Past the entry code pointer
647