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