63fc8408453f38da5af3cd31ead586d2bf3d12a3
[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 module StgCmmLayout (
10 mkArgDescr,
11 emitCall, emitReturn,
12
13 emitClosureProcAndInfoTable,
14 emitClosureAndInfoTable,
15
16 slowCall, directCall,
17
18 mkVirtHeapOffsets, getHpRelOffset, hpRel,
19
20 stdInfoTableSizeB,
21 entryCode, closureInfoPtr,
22 getConstrTag,
23 cmmGetClosureType,
24 infoTable, infoTableClosureType,
25 infoTablePtrs, infoTableNonPtrs,
26 funInfoTable, makeRelativeRefTo
27 ) where
28
29
30 #include "HsVersions.h"
31
32 import StgCmmClosure
33 import StgCmmEnv
34 import StgCmmTicky
35 import StgCmmUtils
36 import StgCmmMonad
37
38 import MkGraph
39 import SMRep
40 import CmmDecl
41 import CmmExpr
42 import CmmUtils
43 import CLabel
44 import StgSyn
45 import DataCon
46 import Id
47 import Name
48 import TyCon ( PrimRep(..) )
49 import Unique
50 import BasicTypes ( Arity )
51 import StaticFlags
52
53 import Bitmap
54 import Data.Bits
55
56 import Constants
57 import Util
58 import Data.List
59 import Outputable
60 import FastString ( mkFastString, FastString, fsLit )
61
62 ------------------------------------------------------------------------
63 -- Call and return sequences
64 ------------------------------------------------------------------------
65
66 emitReturn :: [CmmExpr] -> FCode ()
67 -- Return multiple values to the sequel
68 --
69 -- If the sequel is Return
70 -- return (x,y)
71 -- If the sequel is AssignTo [p,q]
72 -- p=x; q=y;
73 emitReturn results
74 = do { sequel <- getSequel;
75 ; updfr_off <- getUpdFrameOff
76 ; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel)
77 ; case sequel of
78 Return _ ->
79 do { adjustHpBackwards
80 ; emit (mkReturnSimple results updfr_off) }
81 AssignTo regs adjust ->
82 do { if adjust then adjustHpBackwards else return ()
83 ; emit (mkMultiAssign regs results) }
84 }
85
86 emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ()
87 -- (cgCall fun args) makes a call to the entry-code of 'fun',
88 -- passing 'args', and returning the results to the current sequel
89 emitCall convs@(callConv, _) fun args
90 = do { adjustHpBackwards
91 ; sequel <- getSequel
92 ; updfr_off <- getUpdFrameOff
93 ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
94 ; case sequel of
95 Return _ -> emit (mkForeignJump callConv fun args updfr_off)
96 AssignTo res_regs _ -> emit (mkCall fun convs res_regs args updfr_off)
97 }
98
99 adjustHpBackwards :: FCode ()
100 -- This function adjusts and heap pointers just before a tail call or
101 -- return. At a call or return, the virtual heap pointer may be less
102 -- than the real Hp, because the latter was advanced to deal with
103 -- the worst-case branch of the code, and we may be in a better-case
104 -- branch. In that case, move the real Hp *back* and retract some
105 -- ticky allocation count.
106 --
107 -- It *does not* deal with high-water-mark adjustment.
108 -- That's done by functions which allocate heap.
109 adjustHpBackwards
110 = do { hp_usg <- getHpUsage
111 ; let rHp = realHp hp_usg
112 vHp = virtHp hp_usg
113 adjust_words = vHp -rHp
114 ; new_hp <- getHpRelOffset vHp
115
116 ; emit (if adjust_words == 0
117 then mkNop
118 else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp
119
120 ; tickyAllocHeap adjust_words -- ...ditto
121
122 ; setRealHp vHp
123 }
124
125
126 -------------------------------------------------------------------------
127 -- Making calls: directCall and slowCall
128 -------------------------------------------------------------------------
129
130 directCall :: CLabel -> Arity -> [StgArg] -> FCode ()
131 -- (directCall f n args)
132 -- calls f(arg1, ..., argn), and applies the result to the remaining args
133 -- The function f has arity n, and there are guaranteed at least n args
134 -- Both arity and args include void args
135 directCall lbl arity stg_args
136 = do { cmm_args <- getNonVoidArgAmodes stg_args
137 ; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) }
138
139 slowCall :: CmmExpr -> [StgArg] -> FCode ()
140 -- (slowCall fun args) applies fun to args, returning the results to Sequel
141 slowCall fun stg_args
142 = do { cmm_args <- getNonVoidArgAmodes stg_args
143 ; slow_call fun cmm_args (argsLReps stg_args) }
144
145 --------------
146 direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode ()
147 -- NB1: (length args) may be less than (length reps), because
148 -- the args exclude the void ones
149 -- NB2: 'arity' refers to the *reps*
150 direct_call caller lbl arity args reps
151 | debugIsOn && arity > length reps -- Too few args
152 = -- Caller should ensure that there enough args!
153 pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps)
154 <+> ppr args <+> ppr reps )
155
156 | null rest_reps -- Precisely the right number of arguments
157 = emitCall (NativeDirectCall, NativeReturn) target args
158
159 | otherwise -- Over-saturated call
160 = ASSERT( arity == length initial_reps )
161 do { pap_id <- newTemp gcWord
162 ; withSequel (AssignTo [pap_id] True)
163 (emitCall (NativeDirectCall, NativeReturn) target fast_args)
164 ; slow_call (CmmReg (CmmLocal pap_id))
165 rest_args rest_reps }
166 where
167 target = CmmLit (CmmLabel lbl)
168 (initial_reps, rest_reps) = splitAt arity reps
169 arg_arity = count isNonV initial_reps
170 (fast_args, rest_args) = splitAt arg_arity args
171
172 --------------
173 slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode ()
174 slow_call fun args reps
175 = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
176 emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
177 " with pat " ++ showSDoc (ftext rts_fun))
178 emit (mkAssign nodeReg fun <*> call)
179 where
180 (rts_fun, arity) = slowCallPattern reps
181
182 -- These cases were found to cover about 99% of all slow calls:
183 slowCallPattern :: [LRep] -> (FastString, Arity)
184 -- Returns the generic apply function and arity
185 slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
186 slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5)
187 slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4)
188 slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4)
189 slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3)
190 slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3)
191 slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2)
192 slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2)
193 slowCallPattern (P: _) = (fsLit "stg_ap_p", 1)
194 slowCallPattern (V: _) = (fsLit "stg_ap_v", 1)
195 slowCallPattern (N: _) = (fsLit "stg_ap_n", 1)
196 slowCallPattern (F: _) = (fsLit "stg_ap_f", 1)
197 slowCallPattern (D: _) = (fsLit "stg_ap_d", 1)
198 slowCallPattern (L: _) = (fsLit "stg_ap_l", 1)
199 slowCallPattern [] = (fsLit "stg_ap_0", 0)
200
201
202 -------------------------------------------------------------------------
203 -- Classifying arguments: LRep
204 -------------------------------------------------------------------------
205
206 -- LRep is not exported (even abstractly)
207 -- It's a local helper type for classification
208
209 data LRep = P -- GC Ptr
210 | N -- One-word non-ptr
211 | L -- Two-word non-ptr (long)
212 | V -- Void
213 | F -- Float
214 | D -- Double
215 instance Outputable LRep where
216 ppr P = text "P"
217 ppr N = text "N"
218 ppr L = text "L"
219 ppr V = text "V"
220 ppr F = text "F"
221 ppr D = text "D"
222
223 toLRep :: PrimRep -> LRep
224 toLRep VoidRep = V
225 toLRep PtrRep = P
226 toLRep IntRep = N
227 toLRep WordRep = N
228 toLRep AddrRep = N
229 toLRep Int64Rep = L
230 toLRep Word64Rep = L
231 toLRep FloatRep = F
232 toLRep DoubleRep = D
233
234 isNonV :: LRep -> Bool
235 isNonV V = False
236 isNonV _ = True
237
238 argsLReps :: [StgArg] -> [LRep]
239 argsLReps = map (toLRep . argPrimRep)
240
241 lRepSizeW :: LRep -> WordOff -- Size in words
242 lRepSizeW N = 1
243 lRepSizeW P = 1
244 lRepSizeW F = 1
245 lRepSizeW L = wORD64_SIZE `quot` wORD_SIZE
246 lRepSizeW D = dOUBLE_SIZE `quot` wORD_SIZE
247 lRepSizeW V = 0
248
249 -------------------------------------------------------------------------
250 ---- Laying out objects on the heap and stack
251 -------------------------------------------------------------------------
252
253 -- The heap always grows upwards, so hpRel is easy
254 hpRel :: VirtualHpOffset -- virtual offset of Hp
255 -> VirtualHpOffset -- virtual offset of The Thing
256 -> WordOff -- integer word offset
257 hpRel hp off = off - hp
258
259 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
260 getHpRelOffset virtual_offset
261 = do { hp_usg <- getHpUsage
262 ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
263
264 mkVirtHeapOffsets
265 :: Bool -- True <=> is a thunk
266 -> [(PrimRep,a)] -- Things to make offsets for
267 -> (WordOff, -- _Total_ number of words allocated
268 WordOff, -- Number of words allocated for *pointers*
269 [(NonVoid a, VirtualHpOffset)])
270
271 -- Things with their offsets from start of object in order of
272 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
273 -- First in list gets lowest offset, which is initial offset + 1.
274 --
275 -- Void arguments are removed, so output list may be shorter than
276 -- input list
277 --
278 -- mkVirtHeapOffsets always returns boxed things with smaller offsets
279 -- than the unboxed things
280
281 mkVirtHeapOffsets is_thunk things
282 = let non_void_things = filterOut (isVoidRep . fst) things
283 (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things
284 (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
285 (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
286 in
287 (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
288 where
289 hdr_size | is_thunk = thunkHdrSize
290 | otherwise = fixedHdrSize
291
292 computeOffset wds_so_far (rep, thing)
293 = (wds_so_far + lRepSizeW (toLRep rep),
294 (NonVoid thing, hdr_size + wds_so_far))
295
296
297 -------------------------------------------------------------------------
298 --
299 -- Making argument descriptors
300 --
301 -- An argument descriptor describes the layout of args on the stack,
302 -- both for * GC (stack-layout) purposes, and
303 -- * saving/restoring registers when a heap-check fails
304 --
305 -- Void arguments aren't important, therefore (contrast constructSlowCall)
306 --
307 -------------------------------------------------------------------------
308
309 -- bring in ARG_P, ARG_N, etc.
310 #include "../includes/rts/storage/FunTypes.h"
311
312 -------------------------
313 -- argDescrType :: ArgDescr -> StgHalfWord
314 -- -- The "argument type" RTS field type
315 -- argDescrType (ArgSpec n) = n
316 -- argDescrType (ArgGen liveness)
317 -- | isBigLiveness liveness = ARG_GEN_BIG
318 -- | otherwise = ARG_GEN
319
320
321 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
322 mkArgDescr nm args
323 = case stdPattern arg_reps of
324 Just spec_id -> return (ArgSpec spec_id)
325 Nothing -> do { liveness <- mkLiveness nm size bitmap
326 ; return (ArgGen liveness) }
327 where
328 arg_reps = filter isNonV (map (toLRep . idPrimRep) args)
329 -- Getting rid of voids eases matching of standard patterns
330
331 bitmap = mkBitmap arg_bits
332 arg_bits = argBits arg_reps
333 size = length arg_bits
334
335 argBits :: [LRep] -> [Bool] -- True for non-ptr, False for ptr
336 argBits [] = []
337 argBits (P : args) = False : argBits args
338 argBits (arg : args) = take (lRepSizeW arg) (repeat True) ++ argBits args
339
340 ----------------------
341 stdPattern :: [LRep] -> Maybe StgHalfWord
342 stdPattern reps
343 = case reps of
344 [] -> Just ARG_NONE -- just void args, probably
345 [N] -> Just ARG_N
346 [P] -> Just ARG_P
347 [F] -> Just ARG_F
348 [D] -> Just ARG_D
349 [L] -> Just ARG_L
350
351 [N,N] -> Just ARG_NN
352 [N,P] -> Just ARG_NP
353 [P,N] -> Just ARG_PN
354 [P,P] -> Just ARG_PP
355
356 [N,N,N] -> Just ARG_NNN
357 [N,N,P] -> Just ARG_NNP
358 [N,P,N] -> Just ARG_NPN
359 [N,P,P] -> Just ARG_NPP
360 [P,N,N] -> Just ARG_PNN
361 [P,N,P] -> Just ARG_PNP
362 [P,P,N] -> Just ARG_PPN
363 [P,P,P] -> Just ARG_PPP
364
365 [P,P,P,P] -> Just ARG_PPPP
366 [P,P,P,P,P] -> Just ARG_PPPPP
367 [P,P,P,P,P,P] -> Just ARG_PPPPPP
368
369 _ -> Nothing
370
371 -------------------------------------------------------------------------
372 --
373 -- Liveness info
374 --
375 -------------------------------------------------------------------------
376
377 -- TODO: This along with 'mkArgDescr' should be unified
378 -- with 'CmmInfo.mkLiveness'. However that would require
379 -- potentially invasive changes to the 'ClosureInfo' type.
380 -- For now, 'CmmInfo.mkLiveness' handles only continuations and
381 -- this one handles liveness everything else. Another distinction
382 -- between these two is that 'CmmInfo.mkLiveness' information
383 -- about the stack layout, and this one is information about
384 -- the heap layout of PAPs.
385 mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
386 mkLiveness name size bits
387 | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
388 = do { let lbl = mkBitmapLabel (getUnique name)
389 ; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
390 : map mkWordCLit bits)
391 ; return (BigLiveness lbl) }
392
393 | otherwise -- Bitmap fits in one word
394 = let
395 small_bits = case bits of
396 [] -> 0
397 [b] -> b
398 _ -> panic "livenessToAddrMode"
399 in
400 return (smallLiveness size small_bits)
401
402 smallLiveness :: Int -> StgWord -> Liveness
403 smallLiveness size small_bits = SmallLiveness bits
404 where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
405
406 -------------------
407 -- isBigLiveness :: Liveness -> Bool
408 -- isBigLiveness (BigLiveness _) = True
409 -- isBigLiveness (SmallLiveness _) = False
410
411 -------------------
412 -- mkLivenessCLit :: Liveness -> CmmLit
413 -- mkLivenessCLit (BigLiveness lbl) = CmmLabel lbl
414 -- mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits
415
416
417 -------------------------------------------------------------------------
418 --
419 -- Bitmap describing register liveness
420 -- across GC when doing a "generic" heap check
421 -- (a RET_DYN stack frame).
422 --
423 -- NB. Must agree with these macros (currently in StgMacros.h):
424 -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
425 -------------------------------------------------------------------------
426
427 {- Not used in new code gen
428 mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
429 mkRegLiveness regs ptrs nptrs
430 = (fromIntegral nptrs `shiftL` 16) .|.
431 (fromIntegral ptrs `shiftL` 24) .|.
432 all_non_ptrs `xor` reg_bits regs
433 where
434 all_non_ptrs = 0xff
435
436 reg_bits [] = 0
437 reg_bits ((id, VanillaReg i) : regs) | isGcPtrRep (idPrimRep id)
438 = (1 `shiftL` (i - 1)) .|. reg_bits regs
439 reg_bits (_ : regs)
440 = reg_bits regs
441 -}
442
443 -------------------------------------------------------------------------
444 --
445 -- Generating the info table and code for a closure
446 --
447 -------------------------------------------------------------------------
448
449 -- Here we make an info table of type 'CmmInfo'. The concrete
450 -- representation as a list of 'CmmAddr' is handled later
451 -- in the pipeline by 'cmmToRawCmm'.
452 -- When loading the free variables, a function closure pointer may be tagged,
453 -- so we must take it into account.
454
455 emitClosureProcAndInfoTable :: Bool -- top-level?
456 -> Id -- name of the closure
457 -> ClosureInfo -- lots of info abt the closure
458 -> [NonVoid Id] -- incoming arguments
459 -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
460 -> FCode ()
461 emitClosureProcAndInfoTable top_lvl bndr cl_info args body
462 = do { let lf_info = closureLFInfo cl_info
463 -- Bind the binder itself, but only if it's not a top-level
464 -- binding. We need non-top let-bindings to refer to the
465 -- top-level binding, which this binding would incorrectly shadow.
466 ; node <- if top_lvl then return $ idToReg (NonVoid bndr)
467 else bindToReg (NonVoid bndr) lf_info
468 ; let node_points = nodeMustPointToIt lf_info
469 ; arg_regs <- bindArgsToRegs args
470 ; let args' = if node_points then (node : arg_regs) else arg_regs
471 conv = if nodeMustPointToIt lf_info then NativeNodeCall
472 else NativeDirectCall
473 (offset, _) = mkCallEntry conv args'
474 ; emitClosureAndInfoTable cl_info conv args' $ body (offset, node, arg_regs)
475 }
476
477 -- Data constructors need closures, but not with all the argument handling
478 -- needed for functions. The shared part goes here.
479 emitClosureAndInfoTable ::
480 ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode ()
481 emitClosureAndInfoTable cl_info conv args body
482 = do { info <- mkCmmInfo cl_info
483 ; blks <- getCode body
484 ; emitProcWithConvention conv info (entryLabelFromCI cl_info) args blks
485 }
486
487 -- Convert from 'ClosureInfo' to 'CmmInfoTable'.
488 -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.)
489 mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable
490 mkCmmInfo cl_info
491 = do { info <- closureTypeInfo cl_info k_with_con_name return
492 ; prof <- if opt_SccProfilingOn then
493 do fd_lit <- mkStringCLit (closureTypeDescr cl_info)
494 ad_lit <- mkStringCLit (closureValDescr cl_info)
495 return $ ProfilingInfo fd_lit ad_lit
496 else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
497 ; return (CmmInfoTable (infoTableLabelFromCI cl_info) (isStaticClosure cl_info) prof cl_type info) }
498 where
499 k_with_con_name con_info con info_lbl =
500 do cstr <- mkByteStringCLit $ dataConIdentity con
501 return $ con_info $ makeRelativeRefTo info_lbl cstr
502 cl_type = smRepClosureTypeInt (closureSMRep cl_info)
503
504 -----------------------------------------------------------------------------
505 --
506 -- Info table offsets
507 --
508 -----------------------------------------------------------------------------
509
510 stdInfoTableSizeW :: WordOff
511 -- The size of a standard info table varies with profiling/ticky etc,
512 -- so we can't get it from Constants
513 -- It must vary in sync with mkStdInfoTable
514 stdInfoTableSizeW
515 = size_fixed + size_prof
516 where
517 size_fixed = 2 -- layout, type
518 size_prof | opt_SccProfilingOn = 2
519 | otherwise = 0
520
521 stdInfoTableSizeB :: ByteOff
522 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
523
524 stdSrtBitmapOffset :: ByteOff
525 -- Byte offset of the SRT bitmap half-word which is
526 -- in the *higher-addressed* part of the type_lit
527 stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
528
529 stdClosureTypeOffset :: ByteOff
530 -- Byte offset of the closure type half-word
531 stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
532
533 stdPtrsOffset, stdNonPtrsOffset :: ByteOff
534 stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE
535 stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
536
537 -------------------------------------------------------------------------
538 --
539 -- Accessing fields of an info table
540 --
541 -------------------------------------------------------------------------
542
543 closureInfoPtr :: CmmExpr -> CmmExpr
544 -- Takes a closure pointer and returns the info table pointer
545 closureInfoPtr e = CmmLoad e bWord
546
547 entryCode :: CmmExpr -> CmmExpr
548 -- Takes an info pointer (the first word of a closure)
549 -- and returns its entry code
550 entryCode e | tablesNextToCode = e
551 | otherwise = CmmLoad e bWord
552
553 getConstrTag :: CmmExpr -> CmmExpr
554 -- Takes a closure pointer, and return the *zero-indexed*
555 -- constructor tag obtained from the info table
556 -- This lives in the SRT field of the info table
557 -- (constructors don't need SRTs).
558 getConstrTag closure_ptr
559 = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
560 where
561 info_table = infoTable (closureInfoPtr closure_ptr)
562
563 cmmGetClosureType :: CmmExpr -> CmmExpr
564 -- Takes a closure pointer, and return the closure type
565 -- obtained from the info table
566 cmmGetClosureType closure_ptr
567 = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
568 where
569 info_table = infoTable (closureInfoPtr closure_ptr)
570
571 infoTable :: CmmExpr -> CmmExpr
572 -- Takes an info pointer (the first word of a closure)
573 -- and returns a pointer to the first word of the standard-form
574 -- info table, excluding the entry-code word (if present)
575 infoTable info_ptr
576 | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
577 | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer
578
579 infoTableConstrTag :: CmmExpr -> CmmExpr
580 -- Takes an info table pointer (from infoTable) and returns the constr tag
581 -- field of the info table (same as the srt_bitmap field)
582 infoTableConstrTag = infoTableSrtBitmap
583
584 infoTableSrtBitmap :: CmmExpr -> CmmExpr
585 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
586 -- field of the info table
587 infoTableSrtBitmap info_tbl
588 = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
589
590 infoTableClosureType :: CmmExpr -> CmmExpr
591 -- Takes an info table pointer (from infoTable) and returns the closure type
592 -- field of the info table.
593 infoTableClosureType info_tbl
594 = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
595
596 infoTablePtrs :: CmmExpr -> CmmExpr
597 infoTablePtrs info_tbl
598 = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
599
600 infoTableNonPtrs :: CmmExpr -> CmmExpr
601 infoTableNonPtrs info_tbl
602 = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
603
604 funInfoTable :: CmmExpr -> CmmExpr
605 -- Takes the info pointer of a function,
606 -- and returns a pointer to the first word of the StgFunInfoExtra struct
607 -- in the info table.
608 funInfoTable info_ptr
609 | tablesNextToCode
610 = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
611 | otherwise
612 = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
613 -- Past the entry code pointer
614
615 -------------------------------------------------------------------------
616 --
617 -- Static reference tables
618 --
619 -------------------------------------------------------------------------
620
621 -- srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
622 -- srtLabelAndLength NoC_SRT _
623 -- = (zeroCLit, 0)
624 -- srtLabelAndLength (C_SRT lbl off bitmap) info_lbl
625 -- = (makeRelativeRefTo info_lbl $ cmmLabelOffW lbl off, bitmap)
626
627 -------------------------------------------------------------------------
628 --
629 -- Position independent code
630 --
631 -------------------------------------------------------------------------
632 -- In order to support position independent code, we mustn't put absolute
633 -- references into read-only space. Info tables in the tablesNextToCode
634 -- case must be in .text, which is read-only, so we doctor the CmmLits
635 -- to use relative offsets instead.
636
637 -- Note that this is done even when the -fPIC flag is not specified,
638 -- as we want to keep binary compatibility between PIC and non-PIC.
639
640 makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
641
642 makeRelativeRefTo info_lbl (CmmLabel lbl)
643 | tablesNextToCode
644 = CmmLabelDiffOff lbl info_lbl 0
645 makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
646 | tablesNextToCode
647 = CmmLabelDiffOff lbl info_lbl off
648 makeRelativeRefTo _ lit = lit