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  { adjustHpBackwards
  82         ; sequel    <- getSequel;
  83         ; updfr_off <- getUpdFrameOff
  84         ; case sequel of
  85             Return _        -> emit (mkReturnSimple results updfr_off)
  86             AssignTo regs _ -> emit (mkMultiAssign  regs results)
  87     }
  88
  89 emitCall :: Convention -> CmmExpr -> [CmmExpr] -> FCode ()
  90 -- (cgCall fun args) makes a call to the entry-code of 'fun',
  91 -- passing 'args', and returning the results to the current sequel
  92 emitCall conv fun args
  93   = do  { adjustHpBackwards
  94         ; sequel <- getSequel
  95         ; updfr_off <- getUpdFrameOff
  96         ; emit $ mkComment $ mkFastString "emitcall"
  97         ; case sequel of
  98             Return _              -> emit (mkForeignJump conv fun args updfr_off)
  99             AssignTo res_regs srt -> emit (mkCall fun conv res_regs args updfr_off)
 100     }
 101
 102 adjustHpBackwards :: FCode ()
 103 -- This function adjusts and heap pointers just before a tail call or
 104 -- return.  At a call or return, the virtual heap pointer may be less
 105 -- than the real Hp, because the latter was advanced to deal with
 106 -- the worst-case branch of the code, and we may be in a better-case
 107 -- branch.  In that case, move the real Hp *back* and retract some
 108 -- ticky allocation count.
 109 --
 110 -- It *does not* deal with high-water-mark adjustment.
 111 -- That's done by functions which allocate heap.
 112 adjustHpBackwards
 113   = do  { hp_usg <- getHpUsage
 114         ; let rHp = realHp hp_usg
 115               vHp = virtHp hp_usg
 116               adjust_words = vHp -rHp
 117         ; new_hp <- getHpRelOffset vHp
 118
 119         ; emit (if adjust_words == 0
 120                 then mkNop
 121                 else mkAssign hpReg new_hp)     -- Generates nothing when vHp==rHp
 122
 123         ; tickyAllocHeap adjust_words           -- ...ditto
 124
 125         ; setRealHp vHp
 126         }
 127
 128
 129 -------------------------------------------------------------------------
 130 --      Making calls: directCall and slowCall
 131 -------------------------------------------------------------------------
 132
 133 directCall :: CLabel -> Arity -> [StgArg] -> FCode ()
 134 -- (directCall f n args)
 135 -- calls f(arg1, ..., argn), and applies the result to the remaining args
 136 -- The function f has arity n, and there are guaranteed at least n args
 137 -- Both arity and args include void args
 138 directCall lbl arity stg_args
 139   = do  { cmm_args <- getNonVoidArgAmodes stg_args
 140         ; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) }
 141
 142 slowCall :: CmmExpr -> [StgArg] -> FCode ()
 143 -- (slowCall fun args) applies fun to args, returning the results to Sequel
 144 slowCall fun stg_args
 145   = do  { cmm_args <- getNonVoidArgAmodes stg_args
 146         ; slow_call fun cmm_args (argsLReps stg_args) }
 147
 148 --------------
 149 direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode ()
 150 -- NB1: (length args) may be less than (length reps), because
 151 --     the args exclude the void ones
 152 -- NB2: 'arity' refers to the *reps*
 153 direct_call caller lbl arity args reps
 154   | debugIsOn && arity > length reps    -- Too few args
 155   =         -- Caller should ensure that there enough args!
 156     pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps)
 157                             <+> ppr args <+> ppr reps )
 158
 159   | null rest_reps     -- Precisely the right number of arguments
 160   = emitCall Native target args
 161
 162   | otherwise           -- Over-saturated call
 163   = ASSERT( arity == length initial_reps )
 164     do  { pap_id <- newTemp gcWord
 165         ; let srt = pprTrace "Urk! SRT for over-sat call"
 166                              (ppr lbl) NoC_SRT
 167                 -- XXX: what if rest_args contains static refs?
 168         ; withSequel (AssignTo [pap_id] srt)
 169                      (emitCall Native 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/StgFun.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_N
 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         ; arg_regs <-
 475             pprTrace "bindArgsToRegs" (ppr args) $
 476             bindArgsToRegs args
 477         ; emitClosureAndInfoTable cl_info (node : arg_regs) $ 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        ; emitProc info (infoLblToEntryLbl info_lbl) args blks
 487        }
 488   where
 489     info_lbl = infoTableLabelFromCI cl_info
 490
 491 -- Convert from 'ClosureInfo' to 'CmmInfo'.
 492 -- Not used for return points.  (The 'smRepClosureTypeInt' call would panic.)
 493 mkCmmInfo :: ClosureInfo -> FCode CmmInfo
 494 mkCmmInfo cl_info
 495   = do  { info <- closureTypeInfo cl_info k_with_con_name return
 496         ; prof <- if opt_SccProfilingOn then
 497                     do fd_lit <- mkStringCLit (closureTypeDescr cl_info)
 498                        ad_lit <- mkStringCLit (closureValDescr  cl_info)
 499                        return $ ProfilingInfo fd_lit ad_lit
 500                   else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
 501         ; return (CmmInfo gc_target Nothing
 502                    (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) }
 503   where
 504     k_with_con_name con_info con info_lbl =
 505       do cstr <- mkByteStringCLit $ dataConIdentity con
 506          return $ con_info $ makeRelativeRefTo info_lbl cstr
 507     cl_type  = smRepClosureTypeInt (closureSMRep cl_info)
 508
 509     -- The gc_target is to inform the CPS pass when it inserts a stack check.
 510     -- Since that pass isn't used yet we'll punt for now.
 511     -- When the CPS pass is fully integrated, this should
 512     -- be replaced by the label that any heap check jumped to,
 513     -- so that branch can be shared by both the heap (from codeGen)
 514     -- and stack checks (from the CPS pass).
 515     -- JD: Actually, we've decided to go a different route here:
 516     --     the code generator is now responsible for producing the
 517     --     stack limit check explicitly, so this field is now obsolete.
 518     gc_target = Nothing
 519
 520 -----------------------------------------------------------------------------
 521 --
 522 --      Info table offsets
 523 --
 524 -----------------------------------------------------------------------------
 525
 526 stdInfoTableSizeW :: WordOff
 527 -- The size of a standard info table varies with profiling/ticky etc,
 528 -- so we can't get it from Constants
 529 -- It must vary in sync with mkStdInfoTable
 530 stdInfoTableSizeW
 531   = size_fixed + size_prof
 532   where
 533     size_fixed = 2      -- layout, type
 534     size_prof | opt_SccProfilingOn = 2
 535               | otherwise          = 0
 536
 537 stdInfoTableSizeB  :: ByteOff
 538 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
 539
 540 stdSrtBitmapOffset :: ByteOff
 541 -- Byte offset of the SRT bitmap half-word which is
 542 -- in the *higher-addressed* part of the type_lit
 543 stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
 544
 545 stdClosureTypeOffset :: ByteOff
 546 -- Byte offset of the closure type half-word
 547 stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
 548
 549 stdPtrsOffset, stdNonPtrsOffset :: ByteOff
 550 stdPtrsOffset    = stdInfoTableSizeB - 2*wORD_SIZE
 551 stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
 552
 553 -------------------------------------------------------------------------
 554 --
 555 --      Accessing fields of an info table
 556 --
 557 -------------------------------------------------------------------------
 558
 559 closureInfoPtr :: CmmExpr -> CmmExpr
 560 -- Takes a closure pointer and returns the info table pointer
 561 closureInfoPtr e = CmmLoad e bWord
 562
 563 entryCode :: CmmExpr -> CmmExpr
 564 -- Takes an info pointer (the first word of a closure)
 565 -- and returns its entry code
 566 entryCode e | tablesNextToCode = e
 567             | otherwise        = CmmLoad e bWord
 568
 569 getConstrTag :: CmmExpr -> CmmExpr
 570 -- Takes a closure pointer, and return the *zero-indexed*
 571 -- constructor tag obtained from the info table
 572 -- This lives in the SRT field of the info table
 573 -- (constructors don't need SRTs).
 574 getConstrTag closure_ptr
 575   = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
 576   where
 577     info_table = infoTable (closureInfoPtr closure_ptr)
 578
 579 cmmGetClosureType :: CmmExpr -> CmmExpr
 580 -- Takes a closure pointer, and return the closure type
 581 -- obtained from the info table
 582 cmmGetClosureType closure_ptr
 583   = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
 584   where
 585     info_table = infoTable (closureInfoPtr closure_ptr)
 586
 587 infoTable :: CmmExpr -> CmmExpr
 588 -- Takes an info pointer (the first word of a closure)
 589 -- and returns a pointer to the first word of the standard-form
 590 -- info table, excluding the entry-code word (if present)
 591 infoTable info_ptr
 592   | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
 593   | otherwise        = cmmOffsetW info_ptr 1    -- Past the entry code pointer
 594
 595 infoTableConstrTag :: CmmExpr -> CmmExpr
 596 -- Takes an info table pointer (from infoTable) and returns the constr tag
 597 -- field of the info table (same as the srt_bitmap field)
 598 infoTableConstrTag = infoTableSrtBitmap
 599
 600 infoTableSrtBitmap :: CmmExpr -> CmmExpr
 601 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
 602 -- field of the info table
 603 infoTableSrtBitmap info_tbl
 604   = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
 605
 606 infoTableClosureType :: CmmExpr -> CmmExpr
 607 -- Takes an info table pointer (from infoTable) and returns the closure type
 608 -- field of the info table.
 609 infoTableClosureType info_tbl
 610   = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
 611
 612 infoTablePtrs :: CmmExpr -> CmmExpr
 613 infoTablePtrs info_tbl
 614   = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
 615
 616 infoTableNonPtrs :: CmmExpr -> CmmExpr
 617 infoTableNonPtrs info_tbl
 618   = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
 619
 620 funInfoTable :: CmmExpr -> CmmExpr
 621 -- Takes the info pointer of a function,
 622 -- and returns a pointer to the first word of the StgFunInfoExtra struct
 623 -- in the info table.
 624 funInfoTable info_ptr
 625   | tablesNextToCode
 626   = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
 627   | otherwise
 628   = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
 629                                 -- Past the entry code pointer
 630
 631 -------------------------------------------------------------------------
 632 --
 633 --      Static reference tables
 634 --
 635 -------------------------------------------------------------------------
 636
 637 -- srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
 638 -- srtLabelAndLength NoC_SRT _
 639 --   = (zeroCLit, 0)
 640 -- srtLabelAndLength (C_SRT lbl off bitmap) info_lbl
 641 --   = (makeRelativeRefTo info_lbl $ cmmLabelOffW lbl off, bitmap)
 642
 643 -------------------------------------------------------------------------
 644 --
 645 --      Position independent code
 646 --
 647 -------------------------------------------------------------------------
 648 -- In order to support position independent code, we mustn't put absolute
 649 -- references into read-only space. Info tables in the tablesNextToCode
 650 -- case must be in .text, which is read-only, so we doctor the CmmLits
 651 -- to use relative offsets instead.
 652
 653 -- Note that this is done even when the -fPIC flag is not specified,
 654 -- as we want to keep binary compatibility between PIC and non-PIC.
 655
 656 makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
 657
 658 makeRelativeRefTo info_lbl (CmmLabel lbl)
 659   | tablesNextToCode
 660   = CmmLabelDiffOff lbl info_lbl 0
 661 makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
 662   | tablesNextToCode
 663   = CmmLabelDiffOff lbl info_lbl off
 664 makeRelativeRefTo _ lit = lit