compiler/codeGen/StgCmmHeap.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Stg to C--: heap management functions
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmHeap (
  10         getVirtHp, setVirtHp, setRealHp,
  11         getHpRelOffset, hpRel,
  12
  13         entryHeapCheck, altHeapCheck,
  14
  15         layOutDynConstr, layOutStaticConstr,
  16         mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
  17
  18         allocDynClosure, emitSetDynHdr
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 import StgSyn
  24 import CLabel
  25 import StgCmmLayout
  26 import StgCmmUtils
  27 import StgCmmMonad
  28 import StgCmmProf
  29 import StgCmmTicky
  30 import StgCmmGran
  31 import StgCmmClosure
  32 import StgCmmEnv
  33
  34 import MkZipCfgCmm
  35
  36 import SMRep
  37 import CmmExpr
  38 import CmmUtils
  39 import DataCon
  40 import TyCon
  41 import CostCentre
  42 import Outputable
  43 import FastString( LitString, mkFastString, sLit )
  44 import Constants
  45 import Data.List
  46
  47
  48 -----------------------------------------------------------
  49 --              Layout of heap objects
  50 -----------------------------------------------------------
  51
  52 layOutDynConstr, layOutStaticConstr
  53         :: DataCon -> [(PrimRep, a)]
  54         -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
  55 -- No Void arguments in result
  56
  57 layOutDynConstr    = layOutConstr False
  58 layOutStaticConstr = layOutConstr True
  59
  60 layOutConstr :: Bool -> DataCon -> [(PrimRep, a)]
  61              -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
  62 layOutConstr is_static data_con args
  63    = (mkConInfo is_static data_con tot_wds ptr_wds,
  64       things_w_offsets)
  65   where
  66     (tot_wds,            --  #ptr_wds + #nonptr_wds
  67      ptr_wds,            --  #ptr_wds
  68      things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
  69
  70
  71 -----------------------------------------------------------
  72 --              Initialise dynamic heap objects
  73 -----------------------------------------------------------
  74
  75 allocDynClosure
  76         :: ClosureInfo
  77         -> CmmExpr              -- Cost Centre to stick in the object
  78         -> CmmExpr              -- Cost Centre to blame for this alloc
  79                                 -- (usually the same; sometimes "OVERHEAD")
  80
  81         -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of the object
  82                                                 -- ie Info ptr has offset zero.
  83                                                 -- No void args in here
  84         -> FCode (LocalReg, CmmAGraph)
  85
  86 -- allocDynClosure allocates the thing in the heap,
  87 -- and modifies the virtual Hp to account for this.
  88 -- The second return value is the graph that sets the value of the
  89 -- returned LocalReg, which should point to the closure after executing
  90 -- the graph.
  91
  92 -- Note [Return a LocalReg]
  93 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  94 -- allocDynClosure returns a LocalReg, not a (Hp+8) CmmExpr.
  95 -- Reason:
  96 --      ...allocate object...
  97 --      obj = Hp + 8
  98 --      y = f(z)
  99 --      ...here obj is still valid,
 100 --         but Hp+8 means something quite different...
 101
 102
 103 allocDynClosure cl_info use_cc _blame_cc args_w_offsets
 104   = do  { virt_hp <- getVirtHp
 105
 106         -- SAY WHAT WE ARE ABOUT TO DO
 107         ; tickyDynAlloc cl_info
 108         ; profDynAlloc cl_info use_cc
 109                 -- ToDo: This is almost certainly wrong
 110                 -- We're ignoring blame_cc. But until we've
 111                 -- fixed the boxing hack in chooseDynCostCentres etc,
 112                 -- we're worried about making things worse by "fixing"
 113                 -- this part to use blame_cc!
 114
 115         -- FIND THE OFFSET OF THE INFO-PTR WORD
 116         ; let   info_offset = virt_hp + 1
 117                 -- info_offset is the VirtualHpOffset of the first
 118                 -- word of the new object
 119                 -- Remember, virtHp points to last allocated word,
 120                 -- ie 1 *before* the info-ptr word of new object.
 121
 122                 info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
 123
 124         -- ALLOCATE THE OBJECT
 125         ; base <- getHpRelOffset info_offset
 126         ; emit (mkComment $ mkFastString "allocDynClosure")
 127         ; emitSetDynHdr base info_ptr  use_cc
 128         ; let (args, offsets) = unzip args_w_offsets
 129         ; cmm_args <- mapM getArgAmode args     -- No void args
 130         ; hpStore base cmm_args offsets
 131
 132         -- BUMP THE VIRTUAL HEAP POINTER
 133         ; setVirtHp (virt_hp + closureSize cl_info)
 134
 135         -- Assign to a temporary and return
 136         -- Note [Return a LocalReg]
 137         ; hp_rel <- getHpRelOffset info_offset
 138         ; getCodeR $ assignTemp hp_rel }
 139
 140 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 141 emitSetDynHdr base info_ptr ccs
 142   = hpStore base header [0..]
 143   where
 144     header :: [CmmExpr]
 145     header = [info_ptr] ++ dynProfHdr ccs
 146         -- ToDo: Gransim stuff
 147         -- ToDo: Parallel stuff
 148         -- No ticky header
 149
 150 hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode ()
 151 -- Store the item (expr,off) in base[off]
 152 hpStore base vals offs
 153   = emit (catAGraphs (zipWith mk_store vals offs))
 154   where
 155     mk_store val off = mkStore (cmmOffsetW base off) val
 156
 157
 158 -----------------------------------------------------------
 159 --              Layout of static closures
 160 -----------------------------------------------------------
 161
 162 -- Make a static closure, adding on any extra padding needed for CAFs,
 163 -- and adding a static link field if necessary.
 164
 165 mkStaticClosureFields
 166         :: ClosureInfo
 167         -> CostCentreStack
 168         -> Bool                 -- Has CAF refs
 169         -> [CmmLit]             -- Payload
 170         -> [CmmLit]             -- The full closure
 171 mkStaticClosureFields cl_info ccs caf_refs payload
 172   = mkStaticClosure info_lbl ccs payload padding_wds
 173         static_link_field saved_info_field
 174   where
 175     info_lbl = infoTableLabelFromCI cl_info
 176
 177     -- CAFs must have consistent layout, regardless of whether they
 178     -- are actually updatable or not.  The layout of a CAF is:
 179     --
 180     --        3 saved_info
 181     --        2 static_link
 182     --        1 indirectee
 183     --        0 info ptr
 184     --
 185     -- the static_link and saved_info fields must always be in the same
 186     -- place.  So we use closureNeedsUpdSpace rather than
 187     -- closureUpdReqd here:
 188
 189     is_caf = closureNeedsUpdSpace cl_info
 190
 191     padding_wds
 192         | not is_caf = []
 193         | otherwise  = ASSERT(null payload) [mkIntCLit 0]
 194
 195     static_link_field
 196         | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
 197         | otherwise                                = []
 198
 199     saved_info_field
 200         | is_caf     = [mkIntCLit 0]
 201         | otherwise  = []
 202
 203         -- for a static constructor which has NoCafRefs, we set the
 204         -- static link field to a non-zero value so the garbage
 205         -- collector will ignore it.
 206     static_link_value
 207         | caf_refs      = mkIntCLit 0
 208         | otherwise     = mkIntCLit 1
 209
 210
 211 mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
 212   -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
 213 mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
 214   =  [CmmLabel info_lbl]
 215   ++ variable_header_words
 216   ++ concatMap padLitToWord payload
 217   ++ padding_wds
 218   ++ static_link_field
 219   ++ saved_info_field
 220   where
 221     variable_header_words
 222         =  staticGranHdr
 223         ++ staticParHdr
 224         ++ staticProfHdr ccs
 225         ++ staticTickyHdr
 226
 227 -- JD: Simon had ellided this padding, but without it the C back end asserts failure.
 228 -- Maybe it's a bad assertion, and this padding is indeed unnecessary?
 229 padLitToWord :: CmmLit -> [CmmLit]
 230 padLitToWord lit = lit : padding pad_length
 231   where width = typeWidth (cmmLitType lit)
 232         pad_length = wORD_SIZE - widthInBytes width :: Int
 233
 234         padding n | n <= 0 = []
 235                   | n `rem` 2 /= 0 = CmmInt 0 W8  : padding (n-1)
 236                   | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)
 237                   | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)
 238                   | otherwise      = CmmInt 0 W64 : padding (n-8)
 239
 240 -----------------------------------------------------------
 241 --              Heap overflow checking
 242 -----------------------------------------------------------
 243
 244 {- Note [Heap checks]
 245    ~~~~~~~~~~~~~~~~~~
 246 Heap checks come in various forms.  We provide the following entry
 247 points to the runtime system, all of which use the native C-- entry
 248 convention.
 249
 250   * gc() performs garbage collection and returns
 251     nothing to its caller
 252
 253   * A series of canned entry points like
 254         r = gc_1p( r )
 255     where r is a pointer.  This performs gc, and
 256     then returns its argument r to its caller.
 257
 258   * A series of canned entry points like
 259         gcfun_2p( f, x, y )
 260     where f is a function closure of arity 2
 261     This performs garbage collection, keeping alive the
 262     three argument ptrs, and then tail-calls f(x,y)
 263
 264 These are used in the following circumstances
 265
 266 * entryHeapCheck: Function entry
 267     (a) With a canned GC entry sequence
 268         f( f_clo, x:ptr, y:ptr ) {
 269              Hp = Hp+8
 270              if Hp > HpLim goto L
 271              ...
 272           L: HpAlloc = 8
 273              jump gcfun_2p( f_clo, x, y ) }
 274      Note the tail call to the garbage collector;
 275      it should do no register shuffling
 276
 277     (b) No canned sequence
 278         f( f_clo, x:ptr, y:ptr, ...etc... ) {
 279           T: Hp = Hp+8
 280              if Hp > HpLim goto L
 281              ...
 282           L: HpAlloc = 8
 283              call gc()  -- Needs an info table
 284              goto T }
 285
 286 * altHeapCheck: Immediately following an eval
 287   Started as
 288         case f x y of r { (p,q) -> rhs }
 289   (a) With a canned sequence for the results of f
 290        (which is the very common case since
 291        all boxed cases return just one pointer
 292            ...
 293            r = f( x, y )
 294         K:      -- K needs an info table
 295            Hp = Hp+8
 296            if Hp > HpLim goto L
 297            ...code for rhs...
 298
 299         L: r = gc_1p( r )
 300            goto K }
 301
 302         Here, the info table needed by the call
 303         to gc_1p should be the *same* as the
 304         one for the call to f; the C-- optimiser
 305         spots this sharing opportunity)
 306
 307    (b) No canned sequence for results of f
 308        Note second info table
 309            ...
 310            (r1,r2,r3) = call f( x, y )
 311         K:
 312            Hp = Hp+8
 313            if Hp > HpLim goto L
 314            ...code for rhs...
 315
 316         L: call gc()    -- Extra info table here
 317            goto K
 318
 319 * generalHeapCheck: Anywhere else
 320   e.g. entry to thunk
 321        case branch *not* following eval,
 322        or let-no-escape
 323   Exactly the same as the previous case:
 324
 325         K:      -- K needs an info table
 326            Hp = Hp+8
 327            if Hp > HpLim goto L
 328            ...
 329
 330         L: call gc()
 331            goto K
 332 -}
 333
 334 --------------------------------------------------------------
 335 -- A heap/stack check at a function or thunk entry point.
 336
 337 entryHeapCheck :: Maybe LocalReg -- Function (closure environment)
 338                -> Int           -- Arity -- not same as length args b/c of voids
 339                -> [LocalReg]    -- Non-void args (empty for thunk)
 340                -> FCode ()
 341                -> FCode ()
 342
 343 entryHeapCheck fun arity args code
 344   = do updfr_sz <- getUpdFrameOff
 345        heapCheck True (gc_call updfr_sz) code   -- The 'fun' keeps relevant CAFs alive
 346   where
 347     args'     = case fun of Just f  -> f : args
 348                             Nothing -> args
 349     arg_exprs = map (CmmReg . CmmLocal) args'
 350     gc_call updfr_sz
 351         | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
 352         | otherwise  = case gc_lbl args' of
 353                          Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
 354                                               arg_exprs updfr_sz
 355                          Nothing  -> mkCall generic_gc (GC, GC) [] [] updfr_sz
 356
 357     gc_lbl :: [LocalReg] -> Maybe LitString
 358 {-
 359     gc_lbl [reg]
 360         | isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
 361         | isFloatType ty  = case width of
 362                               W32 -> Just (sLit "stg_gc_f1") -- "stg_gc_fun_f1"
 363                               W64 -> Just (sLit "stg_gc_d1") -- "stg_gc_fun_d1"
 364                               _other -> Nothing
 365         | otherwise       = case width of
 366                               W32 -> Just (sLit "stg_gc_unbx_r1") -- "stg_gc_fun_unbx_r1"
 367                               W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
 368                               _other -> Nothing -- Narrow cases
 369         where
 370           ty = localRegType reg
 371           width = typeWidth ty
 372 -}
 373
 374     gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
 375
 376     gc_lbl_ptrs :: [Bool] -> Maybe LitString
 377     -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
 378     --gc_lbl_ptrs [True,True]      = Just (sLit "stg_gc_fun_2p")
 379     --gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p")
 380     gc_lbl_ptrs _ = Nothing
 381
 382
 383 altHeapCheck :: [LocalReg] -> FCode a -> FCode a
 384 altHeapCheck regs code
 385   = do updfr_sz <- getUpdFrameOff
 386        heapCheck False (gc_call updfr_sz) code
 387   where
 388     gc_call updfr_sz
 389         | null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz
 390
 391         | Just gc_lbl <- rts_label regs -- Canned call
 392         = mkCall    (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC)
 393                     regs (map (CmmReg . CmmLocal) regs) updfr_sz
 394         | otherwise             -- No canned call, and non-empty live vars
 395         = mkCall generic_gc (GC, GC) [] [] updfr_sz
 396
 397 {-
 398     rts_label [reg]
 399         | isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1")
 400         | isFloatType ty  = case width of
 401                               W32 -> Just (sLit "stg_gc_f1")
 402                               W64 -> Just (sLit "stg_gc_d1")
 403                               _other -> Nothing
 404         | otherwise       = case width of
 405                               W32 -> Just (sLit "stg_gc_unbx_r1")
 406                               W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
 407                               _other -> Nothing -- Narrow cases
 408         where
 409           ty = localRegType reg
 410           width = typeWidth ty
 411 -}
 412
 413     rts_label _ = Nothing
 414
 415
 416 generic_gc :: CmmExpr   -- The generic GC procedure; no params, no resuls
 417 generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs")))
 418 -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
 419 -- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
 420
 421 -------------------------------
 422 heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a
 423 heapCheck checkStack do_gc code
 424   = getHeapUsage $ \ hpHw ->
 425     do  { emit $ do_checks checkStack hpHw do_gc
 426                 -- Emit heap checks, but be sure to do it lazily so
 427                 -- that the conditionals on hpHw don't cause a black hole
 428         ; tickyAllocHeap hpHw
 429         ; doGranAllocate hpHw
 430         ; setRealHp hpHw
 431         ; code }
 432
 433 do_checks :: Bool       -- Should we check the stack?
 434           -> WordOff    -- Heap headroom
 435           -> CmmAGraph  -- What to do on failure
 436           -> CmmAGraph
 437 do_checks checkStack alloc do_gc
 438   = withFreshLabel "gc" $ \ loop_id ->
 439     withFreshLabel "gc" $ \ gc_id   ->
 440       mkLabel loop_id
 441       <*> (let hpCheck = if alloc == 0 then mkNop
 442                          else mkAssign hpReg bump_hp <*>
 443                               mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
 444            in if checkStack then
 445                 mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
 446               else hpCheck)
 447       <*> mkComment (mkFastString "outOfLine should follow:")
 448       <*> outOfLine (mkLabel gc_id
 449                      <*> mkComment (mkFastString "outOfLine here")
 450                      <*> do_gc
 451                      <*> mkBranch loop_id)
 452                 -- Test for stack pointer exhaustion, then
 453                 -- bump heap pointer, and test for heap exhaustion
 454                 -- Note that we don't move the heap pointer unless the
 455                 -- stack check succeeds.  Otherwise we might end up
 456                 -- with slop at the end of the current block, which can
 457                 -- confuse the LDV profiler.
 458   where
 459     alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE))    -- Bytes
 460     bump_hp   = cmmOffsetExprB (CmmReg hpReg) alloc_lit
 461
 462         -- Sp overflow if (Sp - CmmHighStack < SpLim)
 463     sp_oflo = CmmMachOp mo_wordULt
 464                   [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg)))
 465                              [CmmReg spReg, CmmLit CmmHighStackMark],
 466                    CmmReg spLimReg]
 467         -- Hp overflow if (Hp > HpLim)
 468         -- (Hp has been incremented by now)
 469         -- HpLim points to the LAST WORD of valid allocation space.
 470     hp_oflo = CmmMachOp mo_wordUGt
 471                   [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
 472
 473     save_alloc = mkAssign (CmmGlobal HpAlloc) alloc_lit
 474
 475 {-
 476
 477 {- Unboxed tuple alternatives and let-no-escapes (the two most annoying
 478 constructs to generate code for!)  For unboxed tuple returns, there
 479 are an arbitrary number of possibly unboxed return values, some of
 480 which will be in registers, and the others will be on the stack.  We
 481 always organise the stack-resident fields into pointers &
 482 non-pointers, and pass the number of each to the heap check code. -}
 483
 484 unbxTupleHeapCheck
 485         :: [(Id, GlobalReg)]    -- Live registers
 486         -> WordOff      -- no. of stack slots containing ptrs
 487         -> WordOff      -- no. of stack slots containing nonptrs
 488         -> CmmAGraph    -- code to insert in the failure path
 489         -> FCode ()
 490         -> FCode ()
 491
 492 unbxTupleHeapCheck regs ptrs nptrs fail_code code
 493   -- We can't manage more than 255 pointers/non-pointers
 494   -- in a generic heap check.
 495   | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
 496   | otherwise
 497   = initHeapUsage $ \ hpHw -> do
 498         { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
 499                                     full_fail_code rts_label
 500                         ; tickyAllocHeap hpHw }
 501         ; setRealHp hpHw
 502         ; code }
 503   where
 504     full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
 505     assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9))      -- Ho ho ho!
 506                                 (CmmLit (mkWordCLit liveness))
 507     liveness        = mkRegLiveness regs ptrs nptrs
 508     rts_label       = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
 509
 510
 511 {- Old Gransim comment -- I have no idea whether it still makes sense (SLPJ Sep07)
 512 For GrAnSim the code for doing a heap check and doing a context switch
 513 has been separated. Especially, the HEAP_CHK macro only performs a
 514 heap check. THREAD_CONTEXT_SWITCH should be used for doing a context
 515 switch. GRAN_FETCH_AND_RESCHEDULE must be put at the beginning of
 516 every slow entry code in order to simulate the fetching of
 517 closures. If fetching is necessary (i.e. current closure is not local)
 518 then an automatic context switch is done. -}
 519
 520
 521 When failing a check, we save a return address on the stack and
 522 jump to a pre-compiled code fragment that saves the live registers
 523 and returns to the scheduler.
 524
 525 The return address in most cases will be the beginning of the basic
 526 block in which the check resides, since we need to perform the check
 527 again on re-entry because someone else might have stolen the resource
 528 in the meantime.
 529
 530 %************************************************************************
 531 %*                                                                      *
 532      Generic Heap/Stack Checks - used in the RTS
 533 %*                                                                      *
 534 %************************************************************************
 535
 536 \begin{code}
 537 hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 538 hpChkGen bytes liveness reentry
 539   = do_checks' bytes True assigns stg_gc_gen
 540   where
 541     assigns = mkStmts [
 542                 CmmAssign (CmmGlobal (VanillaReg 9))  liveness,
 543                 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
 544                 ]
 545
 546 -- a heap check where R1 points to the closure to enter on return, and
 547 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
 548 hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> FCode ()
 549 hpChkNodePointsAssignSp0 bytes sp0
 550   = do_checks' bytes True assign stg_gc_enter1
 551   where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
 552
 553 stg_gc_gen    = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_gen")))
 554 \end{code}
 555
 556 -}