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