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 :: 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                -> C_SRT
 341                -> FCode ()
 342                -> FCode ()
 343
 344 entryHeapCheck fun arity args srt code
 345   = do updfr_sz <- getUpdFrameOff
 346        heapCheck True (gc_call updfr_sz) code   -- The 'fun' keeps relevant CAFs alive
 347   where
 348     fun_expr = CmmReg (CmmLocal fun)
 349     -- JD: ugh... we should only do the following for dynamic closures
 350     args' = fun_expr : map (CmmReg . CmmLocal) args
 351     gc_call updfr_sz
 352         | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) args' updfr_sz
 353         | otherwise  = case gc_lbl (fun : args) of
 354                          Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
 355                                               args' updfr_sz
 356                          Nothing  -> mkCall generic_gc GC [] [] updfr_sz
 357
 358     gc_lbl :: [LocalReg] -> Maybe LitString
 359 {-
 360     gc_lbl [reg]
 361         | isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
 362         | isFloatType ty  = case width of
 363                               W32 -> Just (sLit "stg_gc_f1") -- "stg_gc_fun_f1"
 364                               W64 -> Just (sLit "stg_gc_d1") -- "stg_gc_fun_d1"
 365                               _other -> Nothing
 366         | otherwise       = case width of
 367                               W32 -> Just (sLit "stg_gc_unbx_r1") -- "stg_gc_fun_unbx_r1"
 368                               W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
 369                               _other -> Nothing -- Narrow cases
 370         where
 371           ty = localRegType reg
 372           width = typeWidth ty
 373 -}
 374
 375     gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
 376
 377     gc_lbl_ptrs :: [Bool] -> Maybe LitString
 378     -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
 379     --gc_lbl_ptrs [True,True]      = Just (sLit "stg_gc_fun_2p")
 380     --gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p")
 381     gc_lbl_ptrs _ = Nothing
 382
 383
 384 altHeapCheck :: [LocalReg] -> C_SRT -> FCode a -> FCode a
 385 altHeapCheck regs srt code
 386   = do updfr_sz <- getUpdFrameOff
 387        heapCheck False (gc_call updfr_sz) code
 388   where
 389     gc_call updfr_sz
 390         | null regs = mkCall generic_gc GC [] [] updfr_sz
 391
 392         | Just gc_lbl <- rts_label regs -- Canned call
 393         = mkCall    (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) GC
 394                     regs (map (CmmReg . CmmLocal) regs) updfr_sz
 395         | otherwise             -- No canned call, and non-empty live vars
 396         = mkCall generic_gc GC [] [] updfr_sz
 397
 398 {-
 399     rts_label [reg]
 400         | isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1")
 401         | isFloatType ty  = case width of
 402                               W32 -> Just (sLit "stg_gc_f1")
 403                               W64 -> Just (sLit "stg_gc_d1")
 404                               _other -> Nothing
 405         | otherwise       = case width of
 406                               W32 -> Just (sLit "stg_gc_unbx_r1")
 407                               W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
 408                               _other -> Nothing -- Narrow cases
 409         where
 410           ty = localRegType reg
 411           width = typeWidth ty
 412 -}
 413
 414     rts_label _ = Nothing
 415
 416
 417 generic_gc :: CmmExpr   -- The generic GC procedure; no params, no resuls
 418 generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs")))
 419 -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
 420 -- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
 421
 422 -------------------------------
 423 heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a
 424 heapCheck checkStack do_gc code
 425   = getHeapUsage $ \ hpHw ->
 426     do  { emit $ do_checks checkStack hpHw do_gc
 427                 -- Emit heap checks, but be sure to do it lazily so
 428                 -- that the conditionals on hpHw don't cause a black hole
 429         ; tickyAllocHeap hpHw
 430         ; doGranAllocate hpHw
 431         ; setRealHp hpHw
 432         ; code }
 433
 434 do_checks :: Bool       -- Should we check the stack?
 435           -> WordOff    -- Heap headroom
 436           -> CmmAGraph  -- What to do on failure
 437           -> CmmAGraph
 438 do_checks checkStack alloc do_gc
 439   = withFreshLabel "gc" $ \ loop_id ->
 440     withFreshLabel "gc" $ \ gc_id   ->
 441       mkLabel loop_id emptyStackInfo
 442       <*> (let hpCheck = if alloc == 0 then mkNop
 443                          else mkAssign hpReg bump_hp <*>
 444                               mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
 445            in if checkStack then
 446                 mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
 447               else hpCheck)
 448       <*> mkComment (mkFastString "outOfLine should follow:")
 449       <*> outOfLine (mkLabel gc_id emptyStackInfo
 450                      <*> mkComment (mkFastString "outOfLine here")
 451                      <*> do_gc
 452                      <*> mkBranch loop_id)
 453                 -- Test for stack pointer exhaustion, then
 454                 -- bump heap pointer, and test for heap exhaustion
 455                 -- Note that we don't move the heap pointer unless the
 456                 -- stack check succeeds.  Otherwise we might end up
 457                 -- with slop at the end of the current block, which can
 458                 -- confuse the LDV profiler.
 459   where
 460     alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE))    -- Bytes
 461     bump_hp   = cmmOffsetExprB (CmmReg hpReg) alloc_lit
 462
 463         -- Sp overflow if (Sp - CmmHighStack < SpLim)
 464     sp_oflo = CmmMachOp mo_wordULt
 465                   [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg)))
 466                              [CmmReg spReg, CmmLit CmmHighStackMark],
 467                    CmmReg spLimReg]
 468         -- Hp overflow if (Hp > HpLim)
 469         -- (Hp has been incremented by now)
 470         -- HpLim points to the LAST WORD of valid allocation space.
 471     hp_oflo = CmmMachOp mo_wordUGt
 472                   [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
 473
 474     save_alloc = mkAssign (CmmGlobal HpAlloc) alloc_lit
 475
 476 {-
 477
 478 {- Unboxed tuple alternatives and let-no-escapes (the two most annoying
 479 constructs to generate code for!)  For unboxed tuple returns, there
 480 are an arbitrary number of possibly unboxed return values, some of
 481 which will be in registers, and the others will be on the stack.  We
 482 always organise the stack-resident fields into pointers &
 483 non-pointers, and pass the number of each to the heap check code. -}
 484
 485 unbxTupleHeapCheck
 486         :: [(Id, GlobalReg)]    -- Live registers
 487         -> WordOff      -- no. of stack slots containing ptrs
 488         -> WordOff      -- no. of stack slots containing nonptrs
 489         -> CmmAGraph    -- code to insert in the failure path
 490         -> FCode ()
 491         -> FCode ()
 492
 493 unbxTupleHeapCheck regs ptrs nptrs fail_code code
 494   -- We can't manage more than 255 pointers/non-pointers
 495   -- in a generic heap check.
 496   | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
 497   | otherwise
 498   = initHeapUsage $ \ hpHw -> do
 499         { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
 500                                     full_fail_code rts_label
 501                         ; tickyAllocHeap hpHw }
 502         ; setRealHp hpHw
 503         ; code }
 504   where
 505     full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
 506     assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9))      -- Ho ho ho!
 507                                 (CmmLit (mkWordCLit liveness))
 508     liveness        = mkRegLiveness regs ptrs nptrs
 509     rts_label       = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
 510
 511
 512 {- Old Gransim comment -- I have no idea whether it still makes sense (SLPJ Sep07)
 513 For GrAnSim the code for doing a heap check and doing a context switch
 514 has been separated. Especially, the HEAP_CHK macro only performs a
 515 heap check. THREAD_CONTEXT_SWITCH should be used for doing a context
 516 switch. GRAN_FETCH_AND_RESCHEDULE must be put at the beginning of
 517 every slow entry code in order to simulate the fetching of
 518 closures. If fetching is necessary (i.e. current closure is not local)
 519 then an automatic context switch is done. -}
 520
 521
 522 When failing a check, we save a return address on the stack and
 523 jump to a pre-compiled code fragment that saves the live registers
 524 and returns to the scheduler.
 525
 526 The return address in most cases will be the beginning of the basic
 527 block in which the check resides, since we need to perform the check
 528 again on re-entry because someone else might have stolen the resource
 529 in the meantime.
 530
 531 %************************************************************************
 532 %*                                                                      *
 533      Generic Heap/Stack Checks - used in the RTS
 534 %*                                                                      *
 535 %************************************************************************
 536
 537 \begin{code}
 538 hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 539 hpChkGen bytes liveness reentry
 540   = do_checks' bytes True assigns stg_gc_gen
 541   where
 542     assigns = mkStmts [
 543                 CmmAssign (CmmGlobal (VanillaReg 9))  liveness,
 544                 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
 545                 ]
 546
 547 -- a heap check where R1 points to the closure to enter on return, and
 548 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
 549 hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> FCode ()
 550 hpChkNodePointsAssignSp0 bytes sp0
 551   = do_checks' bytes True assign stg_gc_enter1
 552   where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
 553
 554 stg_gc_gen    = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_gen")))
 555 \end{code}
 556
 557 -}