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 (infoLblToEntryLbl info_lbl) args blks
 485        }
 486   where
 487     info_lbl = infoTableLabelFromCI cl_info
 488
 489 -- Convert from 'ClosureInfo' to 'CmmInfoTable'.
 490 -- Not used for return points.  (The 'smRepClosureTypeInt' call would panic.)
 491 mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable
 492 mkCmmInfo cl_info
 493   = do  { info <- closureTypeInfo cl_info k_with_con_name return
 494         ; prof <- if opt_SccProfilingOn then
 495                     do fd_lit <- mkStringCLit (closureTypeDescr cl_info)
 496                        ad_lit <- mkStringCLit (closureValDescr  cl_info)
 497                        return $ ProfilingInfo fd_lit ad_lit
 498                   else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
 499         ; return (CmmInfoTable (isStaticClosure cl_info) prof cl_type info) }
 500   where
 501     k_with_con_name con_info con info_lbl =
 502       do cstr <- mkByteStringCLit $ dataConIdentity con
 503          return $ con_info $ makeRelativeRefTo info_lbl cstr
 504     cl_type  = smRepClosureTypeInt (closureSMRep cl_info)
 505
 506 -----------------------------------------------------------------------------
 507 --
 508 --      Info table offsets
 509 --
 510 -----------------------------------------------------------------------------
 511
 512 stdInfoTableSizeW :: WordOff
 513 -- The size of a standard info table varies with profiling/ticky etc,
 514 -- so we can't get it from Constants
 515 -- It must vary in sync with mkStdInfoTable
 516 stdInfoTableSizeW
 517   = size_fixed + size_prof
 518   where
 519     size_fixed = 2      -- layout, type
 520     size_prof | opt_SccProfilingOn = 2
 521               | otherwise          = 0
 522
 523 stdInfoTableSizeB  :: ByteOff
 524 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
 525
 526 stdSrtBitmapOffset :: ByteOff
 527 -- Byte offset of the SRT bitmap half-word which is
 528 -- in the *higher-addressed* part of the type_lit
 529 stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
 530
 531 stdClosureTypeOffset :: ByteOff
 532 -- Byte offset of the closure type half-word
 533 stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
 534
 535 stdPtrsOffset, stdNonPtrsOffset :: ByteOff
 536 stdPtrsOffset    = stdInfoTableSizeB - 2*wORD_SIZE
 537 stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
 538
 539 -------------------------------------------------------------------------
 540 --
 541 --      Accessing fields of an info table
 542 --
 543 -------------------------------------------------------------------------
 544
 545 closureInfoPtr :: CmmExpr -> CmmExpr
 546 -- Takes a closure pointer and returns the info table pointer
 547 closureInfoPtr e = CmmLoad e bWord
 548
 549 entryCode :: CmmExpr -> CmmExpr
 550 -- Takes an info pointer (the first word of a closure)
 551 -- and returns its entry code
 552 entryCode e | tablesNextToCode = e
 553             | otherwise        = CmmLoad e bWord
 554
 555 getConstrTag :: CmmExpr -> CmmExpr
 556 -- Takes a closure pointer, and return the *zero-indexed*
 557 -- constructor tag obtained from the info table
 558 -- This lives in the SRT field of the info table
 559 -- (constructors don't need SRTs).
 560 getConstrTag closure_ptr
 561   = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
 562   where
 563     info_table = infoTable (closureInfoPtr closure_ptr)
 564
 565 cmmGetClosureType :: CmmExpr -> CmmExpr
 566 -- Takes a closure pointer, and return the closure type
 567 -- obtained from the info table
 568 cmmGetClosureType closure_ptr
 569   = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
 570   where
 571     info_table = infoTable (closureInfoPtr closure_ptr)
 572
 573 infoTable :: CmmExpr -> CmmExpr
 574 -- Takes an info pointer (the first word of a closure)
 575 -- and returns a pointer to the first word of the standard-form
 576 -- info table, excluding the entry-code word (if present)
 577 infoTable info_ptr
 578   | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
 579   | otherwise        = cmmOffsetW info_ptr 1    -- Past the entry code pointer
 580
 581 infoTableConstrTag :: CmmExpr -> CmmExpr
 582 -- Takes an info table pointer (from infoTable) and returns the constr tag
 583 -- field of the info table (same as the srt_bitmap field)
 584 infoTableConstrTag = infoTableSrtBitmap
 585
 586 infoTableSrtBitmap :: CmmExpr -> CmmExpr
 587 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
 588 -- field of the info table
 589 infoTableSrtBitmap info_tbl
 590   = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
 591
 592 infoTableClosureType :: CmmExpr -> CmmExpr
 593 -- Takes an info table pointer (from infoTable) and returns the closure type
 594 -- field of the info table.
 595 infoTableClosureType info_tbl
 596   = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
 597
 598 infoTablePtrs :: CmmExpr -> CmmExpr
 599 infoTablePtrs info_tbl
 600   = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
 601
 602 infoTableNonPtrs :: CmmExpr -> CmmExpr
 603 infoTableNonPtrs info_tbl
 604   = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
 605
 606 funInfoTable :: CmmExpr -> CmmExpr
 607 -- Takes the info pointer of a function,
 608 -- and returns a pointer to the first word of the StgFunInfoExtra struct
 609 -- in the info table.
 610 funInfoTable info_ptr
 611   | tablesNextToCode
 612   = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
 613   | otherwise
 614   = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
 615                                 -- Past the entry code pointer
 616
 617 -------------------------------------------------------------------------
 618 --
 619 --      Static reference tables
 620 --
 621 -------------------------------------------------------------------------
 622
 623 -- srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
 624 -- srtLabelAndLength NoC_SRT _
 625 --   = (zeroCLit, 0)
 626 -- srtLabelAndLength (C_SRT lbl off bitmap) info_lbl
 627 --   = (makeRelativeRefTo info_lbl $ cmmLabelOffW lbl off, bitmap)
 628
 629 -------------------------------------------------------------------------
 630 --
 631 --      Position independent code
 632 --
 633 -------------------------------------------------------------------------
 634 -- In order to support position independent code, we mustn't put absolute
 635 -- references into read-only space. Info tables in the tablesNextToCode
 636 -- case must be in .text, which is read-only, so we doctor the CmmLits
 637 -- to use relative offsets instead.
 638
 639 -- Note that this is done even when the -fPIC flag is not specified,
 640 -- as we want to keep binary compatibility between PIC and non-PIC.
 641
 642 makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
 643
 644 makeRelativeRefTo info_lbl (CmmLabel lbl)
 645   | tablesNextToCode
 646   = CmmLabelDiffOff lbl info_lbl 0
 647 makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
 648   | tablesNextToCode
 649   = CmmLabelDiffOff lbl info_lbl off
 650 makeRelativeRefTo _ lit = lit