ghc/compiler/codeGen/CgHeapery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgHeapery.lhs,v 1.35 2002/12/11 15:36:26 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, with gaps left for tagging the unboxed
 158 objects.  If a heap check is required, we need to fill in these tags.
 159
 160 The code below will cover all cases for the x86 architecture (where R1
 161 is the only VanillaReg ever used).  For other architectures, we'll
 162 have to do something about saving and restoring the other registers.
 163
 164 \begin{code}
 165 altHeapCheck
 166         :: Bool                 -- do not enter node on return
 167         -> [MagicId]            -- live registers
 168         -> Code                 -- continuation
 169         -> Code
 170
 171
 172 -- normal algebraic and primitive case alternatives:
 173
 174 altHeapCheck no_enter regs code
 175   = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
 176   where
 177     do_heap_chk :: HeapOffset -> Code
 178     do_heap_chk words_required
 179       = getTickyCtrLabel `thenFC` \ ctr ->
 180         absC ( if words_required == 0
 181                  then  AbsCNop
 182                  else  mkAbstractCs
 183                        [ checking_code,
 184                          profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
 185                             [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
 186                        ]
 187         )  `thenC`
 188         setRealHp words_required
 189
 190       where
 191         non_void_regs = filter (/= VoidReg) regs
 192
 193         checking_code =
 194           case non_void_regs of
 195
 196             -- No regs live: probably a Void return
 197             [] ->
 198                CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
 199
 200             [VanillaReg rep 1#]
 201             -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
 202                 | isFollowableRep rep && no_enter ->
 203                   CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
 204
 205             -- R1 is lifted (the common case)
 206                 | isFollowableRep rep ->
 207                   CCheck HP_CHK_NP
 208                         [mkIntCLit words_required]
 209                         AbsCNop
 210
 211             -- R1 is unboxed
 212                 | otherwise ->
 213                   CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
 214
 215             -- FloatReg1
 216             [FloatReg 1#] ->
 217                   CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
 218
 219             -- DblReg1
 220             [DoubleReg 1#] ->
 221                   CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
 222
 223             -- LngReg1
 224             [LongReg _ 1#] ->
 225                   CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
 226
 227 #ifdef DEBUG
 228             _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
 229 #endif
 230
 231 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
 232 -- constructs to generate code for!):
 233
 234 unbxTupleHeapCheck
 235         :: [MagicId]            -- live registers
 236         -> Int                  -- no. of stack slots containing ptrs
 237         -> Int                  -- no. of stack slots containing nonptrs
 238         -> AbstractC            -- code to insert in the failure path
 239         -> Code
 240         -> Code
 241
 242 unbxTupleHeapCheck regs ptrs nptrs fail_code code
 243   -- we can't manage more than 255 pointers/non-pointers in a generic
 244   -- heap check.
 245   | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
 246   | otherwise = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
 247   where
 248     do_heap_chk words_required
 249       = getTickyCtrLabel `thenFC` \ ctr ->
 250         absC ( if words_required == 0
 251                   then  AbsCNop
 252                   else  mkAbstractCs
 253                         [ checking_code,
 254                           profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
 255                             [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
 256                         ]
 257         )  `thenC`
 258         setRealHp words_required
 259
 260       where
 261         checking_code =
 262                 let liveness = mkRegLiveness regs ptrs nptrs
 263                 in
 264                 CCheck HP_CHK_UNBX_TUPLE
 265                      [mkIntCLit words_required,
 266                       mkIntCLit (I# (word2Int# liveness))]
 267                      fail_code
 268
 269 -- build up a bitmap of the live pointer registers
 270
 271 #if __GLASGOW_HASKELL__ >= 503
 272 shiftL = uncheckedShiftL#
 273 #else
 274 shiftL = shiftL#
 275 #endif
 276
 277 mkRegLiveness :: [MagicId] -> Int -> Int -> Word#
 278 mkRegLiveness [] (I# ptrs) (I# nptrs) =
 279   (int2Word# nptrs `shiftL` 16#) `or#` (int2Word# ptrs `shiftL` 24#)
 280 mkRegLiveness (VanillaReg rep i : regs) ptrs nptrs | isFollowableRep rep
 281   =  ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs ptrs nptrs
 282 mkRegLiveness (_ : regs)  ptrs nptrs =  mkRegLiveness regs ptrs nptrs
 283
 284 -- The two functions below are only used in a GranSim setup
 285 -- Emit macro for simulating a fetch and then reschedule
 286
 287 fetchAndReschedule ::   [MagicId]               -- Live registers
 288                         -> Bool                 -- Node reqd?
 289                         -> Code
 290
 291 fetchAndReschedule regs node_reqd  =
 292       if (node `elem` regs || node_reqd)
 293         then fetch_code `thenC` reschedule_code
 294         else absC AbsCNop
 295       where
 296         liveness_mask = mkRegLiveness regs 0 0
 297         reschedule_code = absC  (CMacroStmt GRAN_RESCHEDULE [
 298                                  mkIntCLit (I# (word2Int# liveness_mask)),
 299                                  mkIntCLit (if node_reqd then 1 else 0)])
 300
 301          --HWL: generate GRAN_FETCH macro for GrAnSim
 302          --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
 303         fetch_code = absC (CMacroStmt GRAN_FETCH [])
 304 \end{code}
 305
 306 The @GRAN_YIELD@ macro is taken from JSM's  code for Concurrent Haskell. It
 307 allows to context-switch at  places where @node@ is  not alive (it uses the
 308 @Continue@ rather  than the @EnterNodeCode@  function in the  RTS). We emit
 309 this kind of macro at the beginning of the following kinds of basic bocks:
 310 \begin{itemize}
 311  \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
 312        we use @fetchAndReschedule@ at a slow entry code.
 313  \item Fast entry code (see @CgClosure.lhs@).
 314  \item Alternatives in case expressions (@CLabelledCode@ structures), provided
 315        that they are not inlined (see @CgCases.lhs@). These alternatives will
 316        be turned into separate functions.
 317 \end{itemize}
 318
 319 \begin{code}
 320 yield ::   [MagicId]               -- Live registers
 321              -> Bool                 -- Node reqd?
 322              -> Code
 323
 324 yield regs node_reqd =
 325    if opt_GranMacros && node_reqd
 326      then yield_code
 327      else absC AbsCNop
 328    where
 329      liveness_mask = mkRegLiveness regs 0 0
 330      yield_code =
 331        absC (CMacroStmt GRAN_YIELD
 332                           [mkIntCLit (I# (word2Int# liveness_mask))])
 333 \end{code}
 334
 335 %************************************************************************
 336 %*                                                                      *
 337 \subsection[initClosure]{Initialise a dynamic closure}
 338 %*                                                                      *
 339 %************************************************************************
 340
 341 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
 342 to account for this.
 343
 344 \begin{code}
 345 allocDynClosure
 346         :: ClosureInfo
 347         -> CAddrMode            -- Cost Centre to stick in the object
 348         -> CAddrMode            -- Cost Centre to blame for this alloc
 349                                 -- (usually the same; sometimes "OVERHEAD")
 350
 351         -> [(CAddrMode, VirtualHeapOffset)]     -- Offsets from start of the object
 352                                                 -- ie Info ptr has offset zero.
 353         -> FCode VirtualHeapOffset              -- Returns virt offset of object
 354
 355 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
 356   = getVirtAndRealHp                            `thenFC` \ (virtHp, realHp) ->
 357
 358         -- FIND THE OFFSET OF THE INFO-PTR WORD
 359         -- virtHp points to last allocated word, ie 1 *before* the
 360         -- info-ptr word of new object.
 361     let  info_offset = virtHp + 1
 362
 363         -- do_move IS THE ASSIGNMENT FUNCTION
 364          do_move (amode, offset_from_start)
 365            = CAssign (CVal (hpRel realHp
 366                                   (info_offset + offset_from_start))
 367                            (getAmodeRep amode))
 368                      amode
 369     in
 370         -- SAY WHAT WE ARE ABOUT TO DO
 371     profCtrC (allocProfilingMsg closure_info)
 372                            [mkIntCLit (closureGoodStuffSize closure_info),
 373                             mkIntCLit slop_size]        `thenC`
 374
 375         -- GENERATE THE CODE
 376     absC ( mkAbstractCs (
 377            [ CInitHdr closure_info
 378                 (CAddr (hpRel realHp info_offset))
 379                 use_cc closure_size ]
 380            ++ (map do_move amodes_with_offsets)))       `thenC`
 381
 382         -- BUMP THE VIRTUAL HEAP POINTER
 383     setVirtHp (virtHp + closure_size)                   `thenC`
 384
 385         -- RETURN PTR TO START OF OBJECT
 386     returnFC info_offset
 387   where
 388     closure_size = closureSize closure_info
 389     slop_size    = slopSize closure_info
 390 \end{code}
 391
 392 Occasionally we can update a closure in place instead of allocating
 393 new space for it.  This is the function that does the business, assuming:
 394
 395         - node points to the closure to be overwritten
 396
 397         - the new closure doesn't contain any pointers if we're
 398           using a generational collector.
 399
 400 \begin{code}
 401 inPlaceAllocDynClosure
 402         :: ClosureInfo
 403         -> CAddrMode            -- Pointer to beginning of closure
 404         -> CAddrMode            -- Cost Centre to stick in the object
 405
 406         -> [(CAddrMode, VirtualHeapOffset)]     -- Offsets from start of the object
 407                                                 -- ie Info ptr has offset zero.
 408         -> Code
 409
 410 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
 411   = let -- do_move IS THE ASSIGNMENT FUNCTION
 412          do_move (amode, offset_from_start)
 413            = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
 414                         (getAmodeRep amode))
 415                      amode
 416     in
 417         -- GENERATE THE CODE
 418     absC ( mkAbstractCs (
 419            [ CInitHdr closure_info head use_cc 0{-no alloc-} ]
 420            ++ (map do_move amodes_with_offsets)))
 421 \end{code}