compiler/codeGen/CgInfoTbls.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Building info tables.
   4 --
   5 -- (c) The University of Glasgow 2004
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CgInfoTbls (
  10         emitClosureCodeAndInfoTable,
  11         emitInfoTableAndCode,
  12         dataConTagZ,
  13         getSRTInfo,
  14         emitDirectReturnTarget, emitAlgReturnTarget,
  15         emitDirectReturnInstr, emitVectoredReturnInstr,
  16         mkRetInfoTable,
  17         mkStdInfoTable,
  18         stdInfoTableSizeB,
  19         mkFunGenInfoExtraBits,
  20         entryCode, closureInfoPtr,
  21         getConstrTag,
  22         infoTable, infoTableClosureType,
  23         infoTablePtrs, infoTableNonPtrs,
  24         funInfoTable,
  25         retVec
  26   ) where
  27
  28
  29 #include "HsVersions.h"
  30
  31 import ClosureInfo      ( ClosureInfo, closureTypeDescr, closureName,
  32                           infoTableLabelFromCI, Liveness,
  33                           closureValDescr, closureSRT, closureSMRep,
  34                           closurePtrsSize, closureNonHdrSize, closureFunInfo,
  35                           C_SRT(..), needsSRT, isConstrClosure_maybe,
  36                           ArgDescr(..) )
  37 import SMRep            ( StgHalfWord, hALF_WORD_SIZE_IN_BITS, hALF_WORD_SIZE,
  38                           WordOff, ByteOff,
  39                           smRepClosureTypeInt, tablesNextToCode,
  40                           rET_BIG, rET_SMALL, rET_VEC_BIG, rET_VEC_SMALL )
  41 import CgBindery        ( getLiveStackSlots )
  42 import CgCallConv       ( isBigLiveness, mkLivenessCLit, buildContLiveness,
  43                           argDescrType, getSequelAmode,
  44                           CtrlReturnConvention(..) )
  45 import CgUtils          ( mkStringCLit, packHalfWordsCLit, mkWordCLit,
  46                           cmmOffsetB, cmmOffsetExprW, cmmLabelOffW, cmmOffsetW,
  47                           emitDataLits, emitRODataLits, emitSwitch, cmmNegate,
  48                           newTemp )
  49 import CgMonad
  50
  51 import CmmUtils         ( mkIntCLit, zeroCLit )
  52 import Cmm              ( CmmStmt(..), CmmExpr(..), CmmLit(..), LocalReg,
  53                           CmmBasicBlock, nodeReg )
  54 import MachOp
  55 import CLabel
  56 import StgSyn           ( SRT(..) )
  57 import Name             ( Name )
  58 import DataCon          ( DataCon, dataConTag, fIRST_TAG )
  59 import Unique           ( Uniquable(..) )
  60 import DynFlags         ( DynFlags(..), HscTarget(..) )
  61 import StaticFlags      ( opt_SccProfilingOn )
  62 import ListSetOps       ( assocDefault )
  63 import Maybes           ( isJust )
  64 import Constants        ( wORD_SIZE, sIZEOF_StgFunInfoExtraRev )
  65 import Outputable
  66
  67
  68 -------------------------------------------------------------------------
  69 --
  70 --      Generating the info table and code for a closure
  71 --
  72 -------------------------------------------------------------------------
  73
  74 -- Here we make a concrete info table, represented as a list of CmmAddr
  75 -- (it can't be simply a list of Word, because the SRT field is
  76 -- represented by a label+offset expression).
  77
  78 -- With tablesNextToCode, the layout is
  79 --      <reversed variable part>
  80 --      <normal forward StgInfoTable, but without
  81 --              an entry point at the front>
  82 --      <code>
  83 --
  84 -- Without tablesNextToCode, the layout of an info table is
  85 --      <entry label>
  86 --      <normal forward rest of StgInfoTable>
  87 --      <forward variable part>
  88 --
  89 --      See includes/InfoTables.h
  90
  91 emitClosureCodeAndInfoTable :: ClosureInfo -> [LocalReg] -> CgStmts -> Code
  92 emitClosureCodeAndInfoTable cl_info args body
  93  = do   { ty_descr_lit <-
  94                 if opt_SccProfilingOn
  95                    then mkStringCLit (closureTypeDescr cl_info)
  96                    else return (mkIntCLit 0)
  97         ; cl_descr_lit <-
  98                 if opt_SccProfilingOn
  99                    then mkStringCLit cl_descr_string
 100                    else return (mkIntCLit 0)
 101         ; let std_info = mkStdInfoTable ty_descr_lit cl_descr_lit
 102                                         cl_type srt_len layout_lit
 103
 104         ; blks <- cgStmtsToBlocks body
 105         ; emitInfoTableAndCode info_lbl std_info extra_bits args blks }
 106   where
 107     info_lbl  = infoTableLabelFromCI cl_info
 108
 109     cl_descr_string = closureValDescr cl_info
 110     cl_type = smRepClosureTypeInt (closureSMRep cl_info)
 111
 112     srt = closureSRT cl_info
 113     needs_srt = needsSRT srt
 114
 115     mb_con = isConstrClosure_maybe  cl_info
 116     is_con = isJust mb_con
 117
 118     (srt_label,srt_len)
 119         = case mb_con of
 120             Just con -> -- Constructors don't have an SRT
 121                         -- We keep the *zero-indexed* tag in the srt_len
 122                         -- field of the info table.
 123                         (mkIntCLit 0, fromIntegral (dataConTagZ con))
 124
 125             Nothing  -> -- Not a constructor
 126                         srtLabelAndLength srt info_lbl
 127
 128     ptrs       = closurePtrsSize cl_info
 129     nptrs      = size - ptrs
 130     size       = closureNonHdrSize cl_info
 131     layout_lit = packHalfWordsCLit ptrs nptrs
 132
 133     extra_bits
 134         | is_fun    = fun_extra_bits
 135         | is_con    = []
 136         | needs_srt = [srt_label]
 137         | otherwise = []
 138
 139     maybe_fun_stuff = closureFunInfo cl_info
 140     is_fun = isJust maybe_fun_stuff
 141     (Just (arity, arg_descr)) = maybe_fun_stuff
 142
 143     fun_extra_bits
 144         | ArgGen liveness <- arg_descr
 145         = [ fun_amode,
 146             srt_label,
 147             makeRelativeRefTo info_lbl $ mkLivenessCLit liveness,
 148             slow_entry ]
 149         | needs_srt = [fun_amode, srt_label]
 150         | otherwise = [fun_amode]
 151
 152     slow_entry = makeRelativeRefTo info_lbl (CmmLabel slow_entry_label)
 153     slow_entry_label = mkSlowEntryLabel (closureName cl_info)
 154
 155     fun_amode = packHalfWordsCLit fun_type arity
 156     fun_type  = argDescrType arg_descr
 157
 158 -- We keep the *zero-indexed* tag in the srt_len field of the info
 159 -- table of a data constructor.
 160 dataConTagZ :: DataCon -> ConTagZ
 161 dataConTagZ con = dataConTag con - fIRST_TAG
 162
 163 -- A low-level way to generate the variable part of a fun-style info table.
 164 -- (must match fun_extra_bits above).  Used by the C-- parser.
 165 mkFunGenInfoExtraBits :: Int -> Int -> CmmLit -> CmmLit -> CmmLit -> [CmmLit]
 166 mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry
 167   = [ packHalfWordsCLit fun_type arity,
 168       srt_label,
 169       liveness,
 170       slow_entry ]
 171
 172 -------------------------------------------------------------------------
 173 --
 174 --      Generating the info table and code for a return point
 175 --
 176 -------------------------------------------------------------------------
 177
 178 --      Here's the layout of a return-point info table
 179 --
 180 -- Tables next to code:
 181 --
 182 --                      <reversed vector table>
 183 --                      <srt slot>
 184 --                      <standard info table>
 185 --      ret-addr -->    <entry code (if any)>
 186 --
 187 -- Not tables-next-to-code:
 188 --
 189 --      ret-addr -->    <ptr to entry code>
 190 --                      <standard info table>
 191 --                      <srt slot>
 192 --                      <forward vector table>
 193 --
 194 --  * The vector table is only present for vectored returns
 195 --
 196 --  * The SRT slot is only there if either
 197 --      (a) there is SRT info to record, OR
 198 --      (b) if the return is vectored
 199 --   The latter (b) is necessary so that the vector is in a
 200 --   predictable place
 201
 202 vectorSlot :: CmmExpr -> CmmExpr -> CmmExpr
 203 -- Get the vector slot from the info pointer
 204 vectorSlot info_amode zero_indexed_tag
 205   | tablesNextToCode
 206   = cmmOffsetExprW (cmmOffsetW info_amode (- (stdInfoTableSizeW + 2)))
 207                    (cmmNegate zero_indexed_tag)
 208         -- The "2" is one for the SRT slot, and one more
 209         -- to get to the first word of the vector
 210
 211   | otherwise
 212   = cmmOffsetExprW (cmmOffsetW info_amode (stdInfoTableSizeW + 2))
 213                    zero_indexed_tag
 214         -- The "2" is one for the entry-code slot and one for the SRT slot
 215
 216 retVec :: CmmExpr -> CmmExpr -> CmmExpr
 217 -- Get a return vector from the info pointer
 218 retVec info_amode zero_indexed_tag
 219   = let slot = vectorSlot info_amode zero_indexed_tag
 220 #ifdef x86_64_TARGET_ARCH
 221         tableEntry = CmmMachOp (MO_S_Conv I32 I64) [CmmLoad slot I32]
 222         -- offsets are 32-bits on x86-64, due to the inability of
 223         -- the tools to handle 64-bit PC-relative relocations.  See also
 224         -- PprMach.pprDataItem, and InfoTables.h:OFFSET_FIELD().
 225 #else
 226         tableEntry = CmmLoad slot wordRep
 227 #endif
 228     in if tablesNextToCode
 229            then CmmMachOp (MO_Add wordRep) [tableEntry, info_amode]
 230            else tableEntry
 231
 232 emitReturnTarget
 233    :: Name
 234    -> CgStmts                   -- The direct-return code (if any)
 235                                 --      (empty for vectored returns)
 236    -> [CmmLit]                  -- Vector of return points
 237                                 --      (empty for non-vectored returns)
 238    -> SRT
 239    -> FCode CLabel
 240 emitReturnTarget name stmts vector srt
 241   = do  { live_slots <- getLiveStackSlots
 242         ; liveness   <- buildContLiveness name live_slots
 243         ; srt_info   <- getSRTInfo name srt
 244
 245         ; let
 246               cl_type = case (null vector, isBigLiveness liveness) of
 247                          (True,  True)  -> rET_BIG
 248                          (True,  False) -> rET_SMALL
 249                          (False, True)  -> rET_VEC_BIG
 250                          (False, False) -> rET_VEC_SMALL
 251
 252               (std_info, extra_bits) =
 253                    mkRetInfoTable info_lbl liveness srt_info cl_type vector
 254
 255         ; blks <- cgStmtsToBlocks stmts
 256         ; emitInfoTableAndCode info_lbl std_info extra_bits args blks
 257         ; return info_lbl }
 258   where
 259     args      = {- trace "emitReturnTarget: missing args" -} []
 260     uniq      = getUnique name
 261     info_lbl  = mkReturnInfoLabel uniq
 262
 263
 264 mkRetInfoTable
 265   :: CLabel             -- info label
 266   -> Liveness           -- liveness
 267   -> C_SRT              -- SRT Info
 268   -> Int                -- type (eg. rET_SMALL)
 269   -> [CmmLit]           -- vector
 270   -> ([CmmLit],[CmmLit])
 271 mkRetInfoTable info_lbl liveness srt_info cl_type vector
 272   =  (std_info, extra_bits)
 273   where
 274         (srt_label, srt_len) = srtLabelAndLength srt_info info_lbl
 275
 276         srt_slot | need_srt  = [srt_label]
 277                  | otherwise = []
 278
 279         need_srt = needsSRT srt_info || not (null vector)
 280                 -- If there's a vector table then we must allocate
 281                 -- an SRT slot, so that the vector table is at a
 282                 -- known offset from the info pointer
 283
 284         liveness_lit = makeRelativeRefTo info_lbl $ mkLivenessCLit liveness
 285         std_info = mkStdInfoTable zeroCLit zeroCLit cl_type srt_len liveness_lit
 286         extra_bits = srt_slot ++ map (makeRelativeRefTo info_lbl) vector
 287
 288
 289 emitDirectReturnTarget
 290    :: Name
 291    -> CgStmts           -- The direct-return code
 292    -> SRT
 293    -> FCode CLabel
 294 emitDirectReturnTarget name code srt
 295   = emitReturnTarget name code [] srt
 296
 297 emitAlgReturnTarget
 298         :: Name                         -- Just for its unique
 299         -> [(ConTagZ, CgStmts)]         -- Tagged branches
 300         -> Maybe CgStmts                -- Default branch (if any)
 301         -> SRT                          -- Continuation's SRT
 302         -> CtrlReturnConvention
 303         -> FCode (CLabel, SemiTaggingStuff)
 304
 305 emitAlgReturnTarget name branches mb_deflt srt ret_conv
 306   = case ret_conv of
 307       UnvectoredReturn fam_sz -> do
 308         { blks <- getCgStmts $
 309                     emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
 310                 -- NB: tag_expr is zero-based
 311         ; lbl <- emitDirectReturnTarget name blks srt
 312         ; return (lbl, Nothing) }
 313                 -- Nothing: the internal branches in the switch don't have
 314                 -- global labels, so we can't use them at the 'call site'
 315
 316       VectoredReturn fam_sz -> do
 317         { let tagged_lbls = zip (map fst branches) $
 318                             map (CmmLabel . mkAltLabel uniq . fst) branches
 319               deflt_lbl | isJust mb_deflt = CmmLabel $ mkDefaultLabel uniq
 320                         | otherwise       = mkIntCLit 0
 321         ; let vector = [ assocDefault deflt_lbl tagged_lbls i
 322                        | i <- [0..fam_sz-1]]
 323         ; lbl <- emitReturnTarget name noCgStmts vector srt
 324         ; mapFCs emit_alt branches
 325         ; emit_deflt mb_deflt
 326         ; return (lbl, Just (tagged_lbls, deflt_lbl)) }
 327   where
 328     uniq = getUnique name
 329     tag_expr = getConstrTag (CmmReg nodeReg)
 330
 331     emit_alt :: (Int, CgStmts) -> FCode (Int, CmmLit)
 332         -- Emit the code for the alternative as a top-level
 333         -- code block returning a label for it
 334     emit_alt (tag, stmts) = do   { let lbl = mkAltLabel uniq tag
 335                                  ; blks <- cgStmtsToBlocks stmts
 336                                  ; emitProc [] lbl [] blks
 337                                  ; return (tag, CmmLabel lbl) }
 338
 339     emit_deflt (Just stmts) = do { let lbl = mkDefaultLabel uniq
 340                                  ; blks <- cgStmtsToBlocks stmts
 341                                  ; emitProc [] lbl [] blks
 342                                  ; return (CmmLabel lbl) }
 343     emit_deflt Nothing = return (mkIntCLit 0)
 344                 -- Nothing case: the simplifier might have eliminated a case
 345                 --               so we may have e.g. case xs of
 346                 --                                       [] -> e
 347                 -- In that situation the default should never be taken,
 348                 -- so we just use a NULL pointer
 349
 350 --------------------------------
 351 emitDirectReturnInstr :: Code
 352 emitDirectReturnInstr
 353   = do  { info_amode <- getSequelAmode
 354         ; stmtC (CmmJump (entryCode info_amode) []) }
 355
 356 emitVectoredReturnInstr :: CmmExpr      -- _Zero-indexed_ constructor tag
 357                         -> Code
 358 emitVectoredReturnInstr zero_indexed_tag
 359   = do  { info_amode <- getSequelAmode
 360                 -- HACK! assign info_amode to a temp, because retVec
 361                 -- uses it twice and the NCG doesn't have any CSE yet.
 362                 -- Only do this for the NCG, because gcc is too stupid
 363                 -- to optimise away the extra tmp (grrr).
 364         ; dflags <- getDynFlags
 365         ; x <- if hscTarget dflags == HscAsm
 366                    then do z <- newTemp wordRep
 367                            stmtC (CmmAssign z info_amode)
 368                            return (CmmReg z)
 369                    else
 370                         return info_amode
 371         ; let target = retVec x zero_indexed_tag
 372         ; stmtC (CmmJump target []) }
 373
 374
 375 -------------------------------------------------------------------------
 376 --
 377 --      Generating a standard info table
 378 --
 379 -------------------------------------------------------------------------
 380
 381 -- The standard bits of an info table.  This part of the info table
 382 -- corresponds to the StgInfoTable type defined in InfoTables.h.
 383 --
 384 -- Its shape varies with ticky/profiling/tables next to code etc
 385 -- so we can't use constant offsets from Constants
 386
 387 mkStdInfoTable
 388    :: CmmLit            -- closure type descr (profiling)
 389    -> CmmLit            -- closure descr (profiling)
 390    -> Int               -- closure type
 391    -> StgHalfWord       -- SRT length
 392    -> CmmLit            -- layout field
 393    -> [CmmLit]
 394
 395 mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
 396  =      -- Parallel revertible-black hole field
 397     prof_info
 398         -- Ticky info (none at present)
 399         -- Debug info (none at present)
 400  ++ [layout_lit, type_lit]
 401
 402  where
 403     prof_info
 404         | opt_SccProfilingOn = [type_descr, closure_descr]
 405         | otherwise          = []
 406
 407     type_lit = packHalfWordsCLit cl_type srt_len
 408
 409 stdInfoTableSizeW :: WordOff
 410 -- The size of a standard info table varies with profiling/ticky etc,
 411 -- so we can't get it from Constants
 412 -- It must vary in sync with mkStdInfoTable
 413 stdInfoTableSizeW
 414   = size_fixed + size_prof
 415   where
 416     size_fixed = 2      -- layout, type
 417     size_prof | opt_SccProfilingOn = 2
 418               | otherwise          = 0
 419
 420 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
 421
 422 stdSrtBitmapOffset :: ByteOff
 423 -- Byte offset of the SRT bitmap half-word which is
 424 -- in the *higher-addressed* part of the type_lit
 425 stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
 426
 427 stdClosureTypeOffset :: ByteOff
 428 -- Byte offset of the closure type half-word
 429 stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
 430
 431 stdPtrsOffset, stdNonPtrsOffset :: ByteOff
 432 stdPtrsOffset    = stdInfoTableSizeB - 2*wORD_SIZE
 433 stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
 434
 435 -------------------------------------------------------------------------
 436 --
 437 --      Accessing fields of an info table
 438 --
 439 -------------------------------------------------------------------------
 440
 441 closureInfoPtr :: CmmExpr -> CmmExpr
 442 -- Takes a closure pointer and returns the info table pointer
 443 closureInfoPtr e = CmmLoad e wordRep
 444
 445 entryCode :: CmmExpr -> CmmExpr
 446 -- Takes an info pointer (the first word of a closure)
 447 -- and returns its entry code
 448 entryCode e | tablesNextToCode = e
 449             | otherwise        = CmmLoad e wordRep
 450
 451 getConstrTag :: CmmExpr -> CmmExpr
 452 -- Takes a closure pointer, and return the *zero-indexed*
 453 -- constructor tag obtained from the info table
 454 -- This lives in the SRT field of the info table
 455 -- (constructors don't need SRTs).
 456 getConstrTag closure_ptr
 457   = CmmMachOp (MO_U_Conv halfWordRep wordRep) [infoTableConstrTag info_table]
 458   where
 459     info_table = infoTable (closureInfoPtr closure_ptr)
 460
 461 infoTable :: CmmExpr -> CmmExpr
 462 -- Takes an info pointer (the first word of a closure)
 463 -- and returns a pointer to the first word of the standard-form
 464 -- info table, excluding the entry-code word (if present)
 465 infoTable info_ptr
 466   | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
 467   | otherwise        = cmmOffsetW info_ptr 1    -- Past the entry code pointer
 468
 469 infoTableConstrTag :: CmmExpr -> CmmExpr
 470 -- Takes an info table pointer (from infoTable) and returns the constr tag
 471 -- field of the info table (same as the srt_bitmap field)
 472 infoTableConstrTag = infoTableSrtBitmap
 473
 474 infoTableSrtBitmap :: CmmExpr -> CmmExpr
 475 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
 476 -- field of the info table
 477 infoTableSrtBitmap info_tbl
 478   = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) halfWordRep
 479
 480 infoTableClosureType :: CmmExpr -> CmmExpr
 481 -- Takes an info table pointer (from infoTable) and returns the closure type
 482 -- field of the info table.
 483 infoTableClosureType info_tbl
 484   = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) halfWordRep
 485
 486 infoTablePtrs :: CmmExpr -> CmmExpr
 487 infoTablePtrs info_tbl
 488   = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) halfWordRep
 489
 490 infoTableNonPtrs :: CmmExpr -> CmmExpr
 491 infoTableNonPtrs info_tbl
 492   = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) halfWordRep
 493
 494 funInfoTable :: CmmExpr -> CmmExpr
 495 -- Takes the info pointer of a function,
 496 -- and returns a pointer to the first word of the StgFunInfoExtra struct
 497 -- in the info table.
 498 funInfoTable info_ptr
 499   | tablesNextToCode
 500   = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
 501   | otherwise
 502   = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
 503                                 -- Past the entry code pointer
 504
 505 -------------------------------------------------------------------------
 506 --
 507 --      Emit the code for a closure (or return address)
 508 --      and its associated info table
 509 --
 510 -------------------------------------------------------------------------
 511
 512 -- The complication here concerns whether or not we can
 513 -- put the info table next to the code
 514
 515 emitInfoTableAndCode
 516         :: CLabel               -- Label of info table
 517         -> [CmmLit]             -- ...its invariant part
 518         -> [CmmLit]             -- ...and its variant part
 519         -> [LocalReg]           -- ...args
 520         -> [CmmBasicBlock]      -- ...and body
 521         -> Code
 522
 523 emitInfoTableAndCode info_lbl std_info extra_bits args blocks
 524   | tablesNextToCode    -- Reverse the extra_bits; and emit the top-level proc
 525   = emitProc (reverse extra_bits ++ std_info)
 526              entry_lbl args blocks
 527         -- NB: the info_lbl is discarded
 528
 529   | null blocks -- No actual code; only the info table is significant
 530   =             -- Use a zero place-holder in place of the
 531                 -- entry-label in the info table
 532     emitRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)
 533
 534   | otherwise   -- Separately emit info table (with the function entry
 535   =             -- point as first entry) and the entry code
 536     do  { emitDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)
 537         ; emitProc [] entry_lbl args blocks }
 538
 539   where
 540         entry_lbl = infoLblToEntryLbl info_lbl
 541
 542 -------------------------------------------------------------------------
 543 --
 544 --      Static reference tables
 545 --
 546 -------------------------------------------------------------------------
 547
 548 -- There is just one SRT for each top level binding; all the nested
 549 -- bindings use sub-sections of this SRT.  The label is passed down to
 550 -- the nested bindings via the monad.
 551
 552 getSRTInfo :: Name -> SRT -> FCode C_SRT
 553 getSRTInfo id NoSRT = return NoC_SRT
 554 getSRTInfo id (SRT off len bmp)
 555   | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 556   = do  { srt_lbl <- getSRTLabel
 557         ; let srt_desc_lbl = mkSRTDescLabel id
 558         ; emitRODataLits srt_desc_lbl
 559                    ( cmmLabelOffW srt_lbl off
 560                    : mkWordCLit (fromIntegral len)
 561                    : map mkWordCLit bmp)
 562         ; return (C_SRT srt_desc_lbl 0 srt_escape) }
 563
 564   | otherwise
 565   = do  { srt_lbl <- getSRTLabel
 566         ; return (C_SRT srt_lbl off (fromIntegral (head bmp))) }
 567                 -- The fromIntegral converts to StgHalfWord
 568
 569 srt_escape = (-1) :: StgHalfWord
 570
 571 srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
 572 srtLabelAndLength NoC_SRT _
 573   = (zeroCLit, 0)
 574 srtLabelAndLength (C_SRT lbl off bitmap) info_lbl
 575   = (makeRelativeRefTo info_lbl $ cmmLabelOffW lbl off, bitmap)
 576
 577 -------------------------------------------------------------------------
 578 --
 579 --      Position independent code
 580 --
 581 -------------------------------------------------------------------------
 582 -- In order to support position independent code, we mustn't put absolute
 583 -- references into read-only space. Info tables in the tablesNextToCode
 584 -- case must be in .text, which is read-only, so we doctor the CmmLits
 585 -- to use relative offsets instead.
 586
 587 -- Note that this is done even when the -fPIC flag is not specified,
 588 -- as we want to keep binary compatibility between PIC and non-PIC.
 589
 590 makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
 591
 592 makeRelativeRefTo info_lbl (CmmLabel lbl)
 593   | tablesNextToCode
 594   = CmmLabelDiffOff lbl info_lbl 0
 595 makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
 596   | tablesNextToCode
 597   = CmmLabelDiffOff lbl info_lbl off
 598 makeRelativeRefTo _ lit = lit