compiler/codeGen/CgHeapery.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[CgHeapery]{Heap management functions}
   6
   7 \begin{code}
   8 module CgHeapery (
   9         initHeapUsage, getVirtHp, setVirtHp, setRealHp,
  10         getHpRelOffset, hpRel,
  11
  12         funEntryChecks, thunkEntryChecks,
  13         altHeapCheck, unbxTupleHeapCheck,
  14         hpChkGen, hpChkNodePointsAssignSp0,
  15         stkChkGen, stkChkNodePoints,
  16
  17         layOutDynConstr, layOutStaticConstr,
  18         mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
  19
  20         allocDynClosure, emitSetDynHdr
  21     ) where
  22
  23 #include "HsVersions.h"
  24
  25 import StgSyn
  26 import CLabel
  27 import CgUtils
  28 import CgMonad
  29 import CgProf
  30 import CgTicky
  31 import CgParallel
  32 import CgStackery
  33 import CgCallConv
  34 import ClosureInfo
  35 import SMRep
  36
  37 import Cmm
  38 import MachOp
  39 import CmmUtils
  40 import Id
  41 import DataCon
  42 import TyCon
  43 import CostCentre
  44 import Util
  45 import Constants
  46 import PackageConfig
  47 import Outputable
  48 \end{code}
  49
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 The heap always grows upwards, so hpRel is easy
  58
  59 \begin{code}
  60 hpRel :: VirtualHpOffset        -- virtual offset of Hp
  61       -> VirtualHpOffset        -- virtual offset of The Thing
  62       -> WordOff                        -- integer word offset
  63 hpRel hp off = off - hp
  64 \end{code}
  65
  66 @initHeapUsage@ applies a function to the amount of heap that it uses.
  67 It initialises the heap usage to zeros, and passes on an unchanged
  68 heap usage.
  69
  70 It is usually a prelude to performing a GC check, so everything must
  71 be in a tidy and consistent state.
  72
  73 rje: Note the slightly suble fixed point behaviour needed here
  74
  75 \begin{code}
  76 initHeapUsage :: (VirtualHpOffset -> Code) -> Code
  77 initHeapUsage fcode
  78   = do  { orig_hp_usage <- getHpUsage
  79         ; setHpUsage initHpUsage
  80         ; fixC (\heap_usage2 -> do
  81                 { fcode (heapHWM heap_usage2)
  82                 ; getHpUsage })
  83         ; setHpUsage orig_hp_usage }
  84
  85 setVirtHp :: VirtualHpOffset -> Code
  86 setVirtHp new_virtHp
  87   = do  { hp_usage <- getHpUsage
  88         ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
  89
  90 getVirtHp :: FCode VirtualHpOffset
  91 getVirtHp
  92   = do  { hp_usage <- getHpUsage
  93         ; return (virtHp hp_usage) }
  94
  95 setRealHp ::  VirtualHpOffset -> Code
  96 setRealHp new_realHp
  97   = do  { hp_usage <- getHpUsage
  98         ; setHpUsage (hp_usage {realHp = new_realHp}) }
  99
 100 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
 101 getHpRelOffset virtual_offset
 102   = do  { hp_usg <- getHpUsage
 103         ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
 104 \end{code}
 105
 106
 107 %************************************************************************
 108 %*                                                                      *
 109                 Layout of heap objects
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 \begin{code}
 114 layOutDynConstr, layOutStaticConstr
 115         :: PackageId
 116         -> DataCon
 117         -> [(CgRep,a)]
 118         -> (ClosureInfo,
 119             [(a,VirtualHpOffset)])
 120
 121 layOutDynConstr    = layOutConstr False
 122 layOutStaticConstr = layOutConstr True
 123
 124 layOutConstr  is_static this_pkg data_con args
 125    = (mkConInfo this_pkg is_static data_con tot_wds ptr_wds,
 126       things_w_offsets)
 127   where
 128     (tot_wds,            --  #ptr_wds + #nonptr_wds
 129      ptr_wds,            --  #ptr_wds
 130      things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
 131 \end{code}
 132
 133 @mkVirtHeapOffsets@ always returns boxed things with smaller offsets
 134 than the unboxed things, and furthermore, the offsets in the result
 135 list
 136
 137 \begin{code}
 138 mkVirtHeapOffsets
 139           :: Bool               -- True <=> is a thunk
 140           -> [(CgRep,a)]        -- Things to make offsets for
 141           -> (WordOff,          -- _Total_ number of words allocated
 142               WordOff,          -- Number of words allocated for *pointers*
 143               [(a, VirtualHpOffset)])
 144                                 -- Things with their offsets from start of
 145                                 --  object in order of increasing offset
 146
 147 -- First in list gets lowest offset, which is initial offset + 1.
 148
 149 mkVirtHeapOffsets is_thunk things
 150   = let non_void_things               = filterOut (isVoidArg . fst) things
 151         (ptrs, non_ptrs)              = separateByPtrFollowness non_void_things
 152         (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
 153         (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
 154     in
 155     (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
 156   where
 157     hdr_size    | is_thunk   = thunkHdrSize
 158                 | otherwise  = fixedHdrSize
 159
 160     computeOffset wds_so_far (rep, thing)
 161       = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far))
 162 \end{code}
 163
 164
 165 %************************************************************************
 166 %*                                                                      *
 167                 Lay out a static closure
 168 %*                                                                      *
 169 %************************************************************************
 170
 171 Make a static closure, adding on any extra padding needed for CAFs,
 172 and adding a static link field if necessary.
 173
 174 \begin{code}
 175 mkStaticClosureFields
 176         :: ClosureInfo
 177         -> CostCentreStack
 178         -> Bool                 -- Has CAF refs
 179         -> [CmmLit]             -- Payload
 180         -> [CmmLit]             -- The full closure
 181 mkStaticClosureFields cl_info ccs caf_refs payload
 182   = mkStaticClosure info_lbl ccs payload padding_wds
 183         static_link_field saved_info_field
 184   where
 185     info_lbl = infoTableLabelFromCI cl_info
 186
 187     -- CAFs must have consistent layout, regardless of whether they
 188     -- are actually updatable or not.  The layout of a CAF is:
 189     --
 190     --        3 saved_info
 191     --        2 static_link
 192     --        1 indirectee
 193     --        0 info ptr
 194     --
 195     -- the static_link and saved_info fields must always be in the same
 196     -- place.  So we use closureNeedsUpdSpace rather than
 197     -- closureUpdReqd here:
 198
 199     is_caf = closureNeedsUpdSpace cl_info
 200
 201     padding_wds
 202         | not is_caf = []
 203         | otherwise  = ASSERT(null payload) [mkIntCLit 0]
 204
 205     static_link_field
 206         | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
 207         | otherwise                                = []
 208
 209     saved_info_field
 210         | is_caf     = [mkIntCLit 0]
 211         | otherwise  = []
 212
 213         -- for a static constructor which has NoCafRefs, we set the
 214         -- static link field to a non-zero value so the garbage
 215         -- collector will ignore it.
 216     static_link_value
 217         | caf_refs      = mkIntCLit 0
 218         | otherwise     = mkIntCLit 1
 219
 220
 221 mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
 222   -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
 223 mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
 224   =  [CmmLabel info_lbl]
 225   ++ variable_header_words
 226   ++ payload
 227   ++ padding_wds
 228   ++ static_link_field
 229   ++ saved_info_field
 230   where
 231     variable_header_words
 232         =  staticGranHdr
 233         ++ staticParHdr
 234         ++ staticProfHdr ccs
 235         ++ staticTickyHdr
 236 \end{code}
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
 241 %*                                                                      *
 242 %************************************************************************
 243
 244 The new code  for heapChecks. For GrAnSim the code for doing a heap check
 245 and doing a context switch has been separated. Especially, the HEAP_CHK
 246 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
 247 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
 248 beginning of every slow entry code in order to simulate the fetching of
 249 closures. If fetching is necessary (i.e. current closure is not local) then
 250 an automatic context switch is done.
 251
 252 --------------------------------------------------------------
 253 A heap/stack check at a function or thunk entry point.
 254
 255 \begin{code}
 256 funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
 257 funEntryChecks cl_info reg_save_code code
 258   = hpStkCheck cl_info True reg_save_code code
 259
 260 thunkEntryChecks :: ClosureInfo -> Code -> Code
 261 thunkEntryChecks cl_info code
 262   = hpStkCheck cl_info False noStmts code
 263
 264 hpStkCheck :: ClosureInfo       -- Function closure
 265            -> Bool              -- Is a function? (not a thunk)
 266            -> CmmStmts          -- Register saves
 267            -> Code
 268            -> Code
 269
 270 hpStkCheck cl_info is_fun reg_save_code code
 271   =  getFinalStackHW    $ \ spHw -> do
 272         { sp <- getRealSp
 273         ; let stk_words = spHw - sp
 274         ; initHeapUsage $ \ hpHw  -> do
 275             {   -- Emit heap checks, but be sure to do it lazily so
 276                 -- that the conditionals on hpHw don't cause a black hole
 277               codeOnly $ do
 278                 { do_checks stk_words hpHw full_save_code rts_label
 279                 ; tickyAllocHeap hpHw }
 280             ; setRealHp hpHw
 281             ; code }
 282         }
 283   where
 284     node_asst
 285         | nodeMustPointToIt (closureLFInfo cl_info)
 286         = noStmts
 287         | otherwise
 288         = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
 289     closure_lbl = closureLabelFromCI cl_info
 290
 291     full_save_code = node_asst `plusStmts` reg_save_code
 292
 293     rts_label | is_fun    = CmmReg (CmmGlobal GCFun)
 294                                 -- Function entry point
 295               | otherwise = CmmReg (CmmGlobal GCEnter1)
 296                                 -- Thunk or case return
 297         -- In the thunk/case-return case, R1 points to a closure
 298         -- which should be (re)-entered after GC
 299 \end{code}
 300
 301 Heap checks in a case alternative are nice and easy, provided this is
 302 a bog-standard algebraic case.  We have in our hand:
 303
 304        * one return address, on the stack,
 305        * one return value, in Node.
 306
 307 the canned code for this heap check failure just pushes Node on the
 308 stack, saying 'EnterGHC' to return.  The scheduler will return by
 309 entering the top value on the stack, which in turn will return through
 310 the return address, getting us back to where we were.  This is
 311 therefore only valid if the return value is *lifted* (just being
 312 boxed isn't good enough).
 313
 314 For primitive returns, we have an unlifted value in some register
 315 (either R1 or FloatReg1 or DblReg1).  This means using specialised
 316 heap-check code for these cases.
 317
 318 \begin{code}
 319 altHeapCheck
 320     :: AltType  -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
 321                 --      (Unboxed tuples are dealt with by ubxTupleHeapCheck)
 322     -> Code     -- Continuation
 323     -> Code
 324 altHeapCheck alt_type code
 325   = initHeapUsage $ \ hpHw -> do
 326         { codeOnly $ do
 327              { do_checks 0 {- no stack chk -} hpHw
 328                          noStmts {- nothign to save -}
 329                          (rts_label alt_type)
 330              ; tickyAllocHeap hpHw }
 331         ; setRealHp hpHw
 332         ; code }
 333   where
 334     rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")))
 335         -- Do *not* enter R1 after a heap check in
 336         -- a polymorphic case.  It might be a function
 337         -- and the entry code for a function (currently)
 338         -- applies it
 339         --
 340         -- However R1 is guaranteed to be a pointer
 341
 342     rts_label (AlgAlt tc) = stg_gc_enter1
 343         -- Enter R1 after the heap check; it's a pointer
 344
 345     rts_label (PrimAlt tc)
 346       = CmmLit $ CmmLabel $
 347         case primRepToCgRep (tyConPrimRep tc) of
 348           VoidArg   -> mkRtsCodeLabel SLIT( "stg_gc_noregs")
 349           FloatArg  -> mkRtsCodeLabel SLIT( "stg_gc_f1")
 350           DoubleArg -> mkRtsCodeLabel SLIT( "stg_gc_d1")
 351           LongArg   -> mkRtsCodeLabel SLIT( "stg_gc_l1")
 352                                 -- R1 is boxed but unlifted:
 353           PtrArg    -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")
 354                                 -- R1 is unboxed:
 355           NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1")
 356
 357     rts_label (UbxTupAlt _) = panic "altHeapCheck"
 358 \end{code}
 359
 360
 361 Unboxed tuple alternatives and let-no-escapes (the two most annoying
 362 constructs to generate code for!)  For unboxed tuple returns, there
 363 are an arbitrary number of possibly unboxed return values, some of
 364 which will be in registers, and the others will be on the stack.  We
 365 always organise the stack-resident fields into pointers &
 366 non-pointers, and pass the number of each to the heap check code.
 367
 368 \begin{code}
 369 unbxTupleHeapCheck
 370         :: [(Id, GlobalReg)]    -- Live registers
 371         -> WordOff      -- no. of stack slots containing ptrs
 372         -> WordOff      -- no. of stack slots containing nonptrs
 373         -> CmmStmts     -- code to insert in the failure path
 374         -> Code
 375         -> Code
 376
 377 unbxTupleHeapCheck regs ptrs nptrs fail_code code
 378   -- We can't manage more than 255 pointers/non-pointers
 379   -- in a generic heap check.
 380   | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
 381   | otherwise
 382   = initHeapUsage $ \ hpHw -> do
 383         { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
 384                                     full_fail_code rts_label
 385                         ; tickyAllocHeap hpHw }
 386         ; setRealHp hpHw
 387         ; code }
 388   where
 389     full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
 390     assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9))      -- Ho ho ho!
 391                                 (CmmLit (mkWordCLit liveness))
 392     liveness        = mkRegLiveness regs ptrs nptrs
 393     rts_label       = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_ut")))
 394
 395 \end{code}
 396
 397
 398 %************************************************************************
 399 %*                                                                      *
 400                 Heap/Stack Checks.
 401 %*                                                                      *
 402 %************************************************************************
 403
 404 When failing a check, we save a return address on the stack and
 405 jump to a pre-compiled code fragment that saves the live registers
 406 and returns to the scheduler.
 407
 408 The return address in most cases will be the beginning of the basic
 409 block in which the check resides, since we need to perform the check
 410 again on re-entry because someone else might have stolen the resource
 411 in the meantime.
 412
 413 \begin{code}
 414 do_checks :: WordOff    -- Stack headroom
 415           -> WordOff    -- Heap  headroom
 416           -> CmmStmts   -- Assignments to perform on failure
 417           -> CmmExpr    -- Rts address to jump to on failure
 418           -> Code
 419 do_checks 0 0 _ _   = nopC
 420 do_checks stk hp reg_save_code rts_lbl
 421   = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE)))
 422                (CmmLit (mkIntCLit (hp*wORD_SIZE)))
 423          (stk /= 0) (hp /= 0) reg_save_code rts_lbl
 424
 425 -- The offsets are now in *bytes*
 426 do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
 427   = do  { doGranAllocate hp_expr
 428
 429         -- Emit a block for the heap-check-failure code
 430         ; blk_id <- forkLabelledCode $ do
 431                         { whenC hp_nonzero $
 432                                 stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
 433                         ; emitStmts reg_save_code
 434                         ; stmtC (CmmJump rts_lbl []) }
 435
 436         -- Check for stack overflow *FIRST*; otherwise
 437         -- we might bumping Hp and then failing stack oflo
 438         ; whenC stk_nonzero
 439                 (stmtC (CmmCondBranch stk_oflo blk_id))
 440
 441         ; whenC hp_nonzero
 442                 (stmtsC [CmmAssign hpReg
 443                                 (cmmOffsetExprB (CmmReg hpReg) hp_expr),
 444                         CmmCondBranch hp_oflo blk_id])
 445                 -- Bump heap pointer, and test for heap exhaustion
 446                 -- Note that we don't move the heap pointer unless the
 447                 -- stack check succeeds.  Otherwise we might end up
 448                 -- with slop at the end of the current block, which can
 449                 -- confuse the LDV profiler.
 450     }
 451   where
 452         -- Stk overflow if (Sp - stk_bytes < SpLim)
 453     stk_oflo = CmmMachOp mo_wordULt
 454                   [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr],
 455                    CmmReg (CmmGlobal SpLim)]
 456
 457         -- Hp overflow if (Hpp > HpLim)
 458         -- (Hp has been incremented by now)
 459         -- HpLim points to the LAST WORD of valid allocation space.
 460     hp_oflo = CmmMachOp mo_wordUGt
 461                   [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
 462 \end{code}
 463
 464 %************************************************************************
 465 %*                                                                      *
 466      Generic Heap/Stack Checks - used in the RTS
 467 %*                                                                      *
 468 %************************************************************************
 469
 470 \begin{code}
 471 hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 472 hpChkGen bytes liveness reentry
 473   = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
 474   where
 475     assigns = mkStmts [
 476                 CmmAssign (CmmGlobal (VanillaReg 9))  liveness,
 477                 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
 478                 ]
 479
 480 -- a heap check where R1 points to the closure to enter on return, and
 481 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
 482 hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
 483 hpChkNodePointsAssignSp0 bytes sp0
 484   = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
 485   where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
 486
 487 stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 488 stkChkGen bytes liveness reentry
 489   = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
 490   where
 491     assigns = mkStmts [
 492                 CmmAssign (CmmGlobal (VanillaReg 9))  liveness,
 493                 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
 494                 ]
 495
 496 stkChkNodePoints :: CmmExpr -> Code
 497 stkChkNodePoints bytes
 498   = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
 499
 500 stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_gen")))
 501 stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
 502 \end{code}
 503
 504 %************************************************************************
 505 %*                                                                      *
 506 \subsection[initClosure]{Initialise a dynamic closure}
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
 511 to account for this.
 512
 513 \begin{code}
 514 allocDynClosure
 515         :: ClosureInfo
 516         -> CmmExpr              -- Cost Centre to stick in the object
 517         -> CmmExpr              -- Cost Centre to blame for this alloc
 518                                 -- (usually the same; sometimes "OVERHEAD")
 519
 520         -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object
 521                                         -- ie Info ptr has offset zero.
 522         -> FCode VirtualHpOffset        -- Returns virt offset of object
 523
 524 allocDynClosure cl_info use_cc blame_cc amodes_with_offsets
 525   = do  { virt_hp <- getVirtHp
 526
 527         -- FIND THE OFFSET OF THE INFO-PTR WORD
 528         ; let   info_offset = virt_hp + 1
 529                 -- info_offset is the VirtualHpOffset of the first
 530                 -- word of the new object
 531                 -- Remember, virtHp points to last allocated word,
 532                 -- ie 1 *before* the info-ptr word of new object.
 533
 534                 info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
 535                 hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..]
 536
 537         -- SAY WHAT WE ARE ABOUT TO DO
 538         ; profDynAlloc cl_info use_cc
 539                 -- ToDo: This is almost certainly wrong
 540                 -- We're ignoring blame_cc. But until we've
 541                 -- fixed the boxing hack in chooseDynCostCentres etc,
 542                 -- we're worried about making things worse by "fixing"
 543                 -- this part to use blame_cc!
 544
 545         ; tickyDynAlloc cl_info
 546
 547         -- ALLOCATE THE OBJECT
 548         ; base <- getHpRelOffset info_offset
 549         ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
 550
 551         -- BUMP THE VIRTUAL HEAP POINTER
 552         ; setVirtHp (virt_hp + closureSize cl_info)
 553
 554         -- RETURN PTR TO START OF OBJECT
 555         ; returnFC info_offset }
 556
 557
 558 initDynHdr :: CmmExpr
 559            -> CmmExpr           -- Cost centre to put in object
 560            -> [CmmExpr]
 561 initDynHdr info_ptr cc
 562   =  [info_ptr]
 563         -- ToDo: Gransim stuff
 564         -- ToDo: Parallel stuff
 565   ++ dynProfHdr cc
 566         -- No ticky header
 567
 568 hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
 569 -- Store the item (expr,off) in base[off]
 570 hpStore base es
 571   = stmtsC [ CmmStore (cmmOffsetW base off) val
 572            | (val, off) <- es ]
 573
 574 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 575 emitSetDynHdr base info_ptr ccs
 576   = hpStore base (zip (initDynHdr info_ptr ccs) [0..])
 577 \end{code}