ghc/compiler/codeGen/CgHeapery.lhs

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