compiler/codeGen/StgCmmLayout.hs

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