compiler/codeGen/StgCmmLayout.hs

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