ghc/compiler/codeGen/CgHeapery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgHeapery.lhs,v 1.36 2002/12/18 16:15:43 simonmar Exp $
   5 %
   6 \section[CgHeapery]{Heap management functions}
   7
   8 \begin{code}
   9 module CgHeapery (
  10         funEntryChecks, altHeapCheck, unbxTupleHeapCheck, thunkChecks,
  11         allocDynClosure, inPlaceAllocDynClosure
  12
  13         -- new functions, basically inserting macro calls into Code -- HWL
  14         ,fetchAndReschedule, yield
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import AbsCSyn
  20 import CLabel
  21 import CgMonad
  22
  23 import CgStackery       ( getFinalStackHW )
  24 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  25 import CgUsages         ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
  26                           initHeapUsage
  27                         )
  28 import ClosureInfo      ( closureSize, closureGoodStuffSize,
  29                           slopSize, allocProfilingMsg, ClosureInfo
  30                         )
  31 import PrimRep          ( PrimRep(..), isFollowableRep )
  32 import CmdLineOpts      ( opt_GranMacros )
  33 import Outputable
  34
  35 #ifdef DEBUG
  36 import PprAbsC          ( pprMagicId ) -- tmp
  37 #endif
  38
  39 import GLAEXTS
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 The new code  for heapChecks. For GrAnSim the code for doing a heap check
  49 and doing a context switch has been separated. Especially, the HEAP_CHK
  50 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
  51 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
  52 beginning of every slow entry code in order to simulate the fetching of
  53 closures. If fetching is necessary (i.e. current closure is not local) then
  54 an automatic context switch is done.
  55
  56 -----------------------------------------------------------------------------
  57 A heap/stack check at a function or thunk entry point.
  58
  59 \begin{code}
  60 funEntryChecks :: Maybe CLabel -> AbstractC -> Code -> Code
  61 funEntryChecks closure_lbl reg_save_code code
  62   = hpStkCheck closure_lbl True reg_save_code code
  63
  64 thunkChecks :: Maybe CLabel -> Code -> Code
  65 thunkChecks closure_lbl code
  66   = hpStkCheck closure_lbl False AbsCNop code
  67
  68 hpStkCheck
  69         :: Maybe CLabel                 -- function closure
  70         -> Bool                         -- is a function? (not a thunk)
  71         -> AbstractC                    -- register saves
  72         -> Code
  73         -> Code
  74
  75 hpStkCheck closure_lbl is_fun reg_save_code code
  76   =  getFinalStackHW                             (\ spHw ->
  77      getRealSp                                   `thenFC` \ sp ->
  78      let stk_words = spHw - sp in
  79      initHeapUsage                               (\ hHw  ->
  80
  81      getTickyCtrLabel `thenFC` \ ticky_ctr ->
  82
  83      absC (checking_code stk_words hHw ticky_ctr) `thenC`
  84
  85      setRealHp hHw `thenC`
  86      code))
  87
  88   where
  89     node_asst
  90         | Just lbl <- closure_lbl = CAssign nodeReg (CLbl lbl PtrRep)
  91         | otherwise = AbsCNop
  92
  93     save_code = mkAbstractCs [node_asst, reg_save_code]
  94
  95     checking_code stk hp ctr
  96         = mkAbstractCs
  97           [ if is_fun
  98                 then do_checks_fun stk hp save_code
  99                 else do_checks_np  stk hp save_code,
 100             if hp == 0
 101                 then AbsCNop
 102                 else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
 103                           [ mkIntCLit hp, CLbl ctr DataPtrRep ]
 104           ]
 105
 106
 107 -- For functions:
 108
 109 do_checks_fun
 110         :: Int          -- stack headroom
 111         -> Int          -- heap  headroom
 112         -> AbstractC    -- assignments to perform on failure
 113         -> AbstractC
 114 do_checks_fun 0 0 _ = AbsCNop
 115 do_checks_fun 0 hp_words assts =
 116     CCheck HP_CHK_FUN [ mkIntCLit hp_words ] assts
 117 do_checks_fun stk_words 0 assts =
 118     CCheck STK_CHK_FUN [ mkIntCLit stk_words ] assts
 119 do_checks_fun stk_words hp_words assts =
 120     CCheck HP_STK_CHK_FUN [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
 121
 122 -- For thunks:
 123
 124 do_checks_np
 125         :: Int          -- stack headroom
 126         -> Int          -- heap  headroom
 127         -> AbstractC    -- assignments to perform on failure
 128         -> AbstractC
 129 do_checks_np 0 0 _ = AbsCNop
 130 do_checks_np 0 hp_words assts =
 131     CCheck HP_CHK_NP [ mkIntCLit hp_words ] assts
 132 do_checks_np stk_words 0 assts =
 133     CCheck STK_CHK_NP [ mkIntCLit stk_words ] assts
 134 do_checks_np stk_words hp_words assts =
 135     CCheck HP_STK_CHK_NP [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
 136 \end{code}
 137
 138 Heap checks in a case alternative are nice and easy, provided this is
 139 a bog-standard algebraic case.  We have in our hand:
 140
 141        * one return address, on the stack,
 142        * one return value, in Node.
 143
 144 the canned code for this heap check failure just pushes Node on the
 145 stack, saying 'EnterGHC' to return.  The scheduler will return by
 146 entering the top value on the stack, which in turn will return through
 147 the return address, getting us back to where we were.  This is
 148 therefore only valid if the return value is *lifted* (just being
 149 boxed isn't good enough).
 150
 151 For primitive returns, we have an unlifted value in some register
 152 (either R1 or FloatReg1 or DblReg1).  This means using specialised
 153 heap-check code for these cases.
 154
 155 For unboxed tuple returns, there are an arbitrary number of possibly
 156 unboxed return values, some of which will be in registers, and the
 157 others will be on the stack.  We always organise the stack-resident
 158 fields into pointers & non-pointers, and pass the number of each to
 159 the heap check code.
 160
 161 \begin{code}
 162 altHeapCheck
 163         :: Bool                 -- do not enter node on return
 164         -> [MagicId]            -- live registers
 165         -> Code                 -- continuation
 166         -> Code
 167
 168
 169 -- normal algebraic and primitive case alternatives:
 170
 171 altHeapCheck no_enter regs code
 172   = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
 173   where
 174     do_heap_chk :: HeapOffset -> Code
 175     do_heap_chk words_required
 176       = getTickyCtrLabel `thenFC` \ ctr ->
 177         absC ( if words_required == 0
 178                  then  AbsCNop
 179                  else  mkAbstractCs
 180                        [ checking_code,
 181                          profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
 182                             [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
 183                        ]
 184         )  `thenC`
 185         setRealHp words_required
 186
 187       where
 188         non_void_regs = filter (/= VoidReg) regs
 189
 190         checking_code =
 191           case non_void_regs of
 192
 193             -- No regs live: probably a Void return
 194             [] ->
 195                CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
 196
 197             [VanillaReg rep 1#]
 198             -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
 199                 | isFollowableRep rep && no_enter ->
 200                   CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
 201
 202             -- R1 is lifted (the common case)
 203                 | isFollowableRep rep ->
 204                   CCheck HP_CHK_NP
 205                         [mkIntCLit words_required]
 206                         AbsCNop
 207
 208             -- R1 is unboxed
 209                 | otherwise ->
 210                   CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
 211
 212             -- FloatReg1
 213             [FloatReg 1#] ->
 214                   CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
 215
 216             -- DblReg1
 217             [DoubleReg 1#] ->
 218                   CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
 219
 220             -- LngReg1
 221             [LongReg _ 1#] ->
 222                   CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
 223
 224 #ifdef DEBUG
 225             _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
 226 #endif
 227
 228 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
 229 -- constructs to generate code for!):
 230
 231 unbxTupleHeapCheck
 232         :: [MagicId]            -- live registers
 233         -> Int                  -- no. of stack slots containing ptrs
 234         -> Int                  -- no. of stack slots containing nonptrs
 235         -> AbstractC            -- code to insert in the failure path
 236         -> Code
 237         -> Code
 238
 239 unbxTupleHeapCheck regs ptrs nptrs fail_code code
 240   -- we can't manage more than 255 pointers/non-pointers in a generic
 241   -- heap check.
 242   | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
 243   | otherwise = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
 244   where
 245     do_heap_chk words_required
 246       = getTickyCtrLabel `thenFC` \ ctr ->
 247         absC ( if words_required == 0
 248                   then  AbsCNop
 249                   else  mkAbstractCs
 250                         [ checking_code,
 251                           profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
 252                             [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
 253                         ]
 254         )  `thenC`
 255         setRealHp words_required
 256
 257       where
 258         checking_code =
 259                 let liveness = mkRegLiveness regs ptrs nptrs
 260                 in
 261                 CCheck HP_CHK_UNBX_TUPLE
 262                      [mkIntCLit words_required,
 263                       mkIntCLit (I# (word2Int# liveness))]
 264                      fail_code
 265
 266 -- build up a bitmap of the live pointer registers
 267
 268 #if __GLASGOW_HASKELL__ >= 503
 269 shiftL = uncheckedShiftL#
 270 #else
 271 shiftL = shiftL#
 272 #endif
 273
 274 mkRegLiveness :: [MagicId] -> Int -> Int -> Word#
 275 mkRegLiveness [] (I# ptrs) (I# nptrs) =
 276   (int2Word# nptrs `shiftL` 16#) `or#` (int2Word# ptrs `shiftL` 24#)
 277 mkRegLiveness (VanillaReg rep i : regs) ptrs nptrs | isFollowableRep rep
 278   =  ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs ptrs nptrs
 279 mkRegLiveness (_ : regs)  ptrs nptrs =  mkRegLiveness regs ptrs nptrs
 280
 281 -- The two functions below are only used in a GranSim setup
 282 -- Emit macro for simulating a fetch and then reschedule
 283
 284 fetchAndReschedule ::   [MagicId]               -- Live registers
 285                         -> Bool                 -- Node reqd?
 286                         -> Code
 287
 288 fetchAndReschedule regs node_reqd  =
 289       if (node `elem` regs || node_reqd)
 290         then fetch_code `thenC` reschedule_code
 291         else absC AbsCNop
 292       where
 293         liveness_mask = mkRegLiveness regs 0 0
 294         reschedule_code = absC  (CMacroStmt GRAN_RESCHEDULE [
 295                                  mkIntCLit (I# (word2Int# liveness_mask)),
 296                                  mkIntCLit (if node_reqd then 1 else 0)])
 297
 298          --HWL: generate GRAN_FETCH macro for GrAnSim
 299          --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
 300         fetch_code = absC (CMacroStmt GRAN_FETCH [])
 301 \end{code}
 302
 303 The @GRAN_YIELD@ macro is taken from JSM's  code for Concurrent Haskell. It
 304 allows to context-switch at  places where @node@ is  not alive (it uses the
 305 @Continue@ rather  than the @EnterNodeCode@  function in the  RTS). We emit
 306 this kind of macro at the beginning of the following kinds of basic bocks:
 307 \begin{itemize}
 308  \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
 309        we use @fetchAndReschedule@ at a slow entry code.
 310  \item Fast entry code (see @CgClosure.lhs@).
 311  \item Alternatives in case expressions (@CLabelledCode@ structures), provided
 312        that they are not inlined (see @CgCases.lhs@). These alternatives will
 313        be turned into separate functions.
 314 \end{itemize}
 315
 316 \begin{code}
 317 yield ::   [MagicId]               -- Live registers
 318              -> Bool                 -- Node reqd?
 319              -> Code
 320
 321 yield regs node_reqd =
 322    if opt_GranMacros && node_reqd
 323      then yield_code
 324      else absC AbsCNop
 325    where
 326      liveness_mask = mkRegLiveness regs 0 0
 327      yield_code =
 328        absC (CMacroStmt GRAN_YIELD
 329                           [mkIntCLit (I# (word2Int# liveness_mask))])
 330 \end{code}
 331
 332 %************************************************************************
 333 %*                                                                      *
 334 \subsection[initClosure]{Initialise a dynamic closure}
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
 339 to account for this.
 340
 341 \begin{code}
 342 allocDynClosure
 343         :: ClosureInfo
 344         -> CAddrMode            -- Cost Centre to stick in the object
 345         -> CAddrMode            -- Cost Centre to blame for this alloc
 346                                 -- (usually the same; sometimes "OVERHEAD")
 347
 348         -> [(CAddrMode, VirtualHeapOffset)]     -- Offsets from start of the object
 349                                                 -- ie Info ptr has offset zero.
 350         -> FCode VirtualHeapOffset              -- Returns virt offset of object
 351
 352 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
 353   = getVirtAndRealHp                            `thenFC` \ (virtHp, realHp) ->
 354
 355         -- FIND THE OFFSET OF THE INFO-PTR WORD
 356         -- virtHp points to last allocated word, ie 1 *before* the
 357         -- info-ptr word of new object.
 358     let  info_offset = virtHp + 1
 359
 360         -- do_move IS THE ASSIGNMENT FUNCTION
 361          do_move (amode, offset_from_start)
 362            = CAssign (CVal (hpRel realHp
 363                                   (info_offset + offset_from_start))
 364                            (getAmodeRep amode))
 365                      amode
 366     in
 367         -- SAY WHAT WE ARE ABOUT TO DO
 368     profCtrC (allocProfilingMsg closure_info)
 369                            [mkIntCLit (closureGoodStuffSize closure_info),
 370                             mkIntCLit slop_size]        `thenC`
 371
 372         -- GENERATE THE CODE
 373     absC ( mkAbstractCs (
 374            [ CInitHdr closure_info
 375                 (CAddr (hpRel realHp info_offset))
 376                 use_cc closure_size ]
 377            ++ (map do_move amodes_with_offsets)))       `thenC`
 378
 379         -- BUMP THE VIRTUAL HEAP POINTER
 380     setVirtHp (virtHp + closure_size)                   `thenC`
 381
 382         -- RETURN PTR TO START OF OBJECT
 383     returnFC info_offset
 384   where
 385     closure_size = closureSize closure_info
 386     slop_size    = slopSize closure_info
 387 \end{code}
 388
 389 Occasionally we can update a closure in place instead of allocating
 390 new space for it.  This is the function that does the business, assuming:
 391
 392         - node points to the closure to be overwritten
 393
 394         - the new closure doesn't contain any pointers if we're
 395           using a generational collector.
 396
 397 \begin{code}
 398 inPlaceAllocDynClosure
 399         :: ClosureInfo
 400         -> CAddrMode            -- Pointer to beginning of closure
 401         -> CAddrMode            -- Cost Centre to stick in the object
 402
 403         -> [(CAddrMode, VirtualHeapOffset)]     -- Offsets from start of the object
 404                                                 -- ie Info ptr has offset zero.
 405         -> Code
 406
 407 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
 408   = let -- do_move IS THE ASSIGNMENT FUNCTION
 409          do_move (amode, offset_from_start)
 410            = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
 411                         (getAmodeRep amode))
 412                      amode
 413     in
 414         -- GENERATE THE CODE
 415     absC ( mkAbstractCs (
 416            [ CInitHdr closure_info head use_cc 0{-no alloc-} ]
 417            ++ (map do_move amodes_with_offsets)))
 418 \end{code}