ghc/compiler/codeGen/CgHeapery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[CgHeapery]{Heap management functions}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CgHeapery (
  10         heapCheck,
  11         allocHeap, allocDynClosure
  12
  13         -- new functions, basically inserting macro calls into Code -- HWL
  14         , heapCheckOnly, fetchAndReschedule, yield
  15     ) where
  16
  17 IMP_Ubiq(){-uitous-}
  18
  19 import AbsCSyn
  20 import CgMonad
  21
  22 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  23 import CgRetConv        ( mkLiveRegsMask )
  24 import CgUsages         ( getVirtAndRealHp, setVirtHp, setRealHp,
  25                           initHeapUsage
  26                         )
  27 import ClosureInfo      ( closureSize, closureHdrSize, closureGoodStuffSize,
  28                           slopSize, allocProfilingMsg, closureKind
  29                         )
  30 import HeapOffs         ( isZeroOff, addOff, intOff,
  31                           VirtualHeapOffset(..)
  32                         )
  33 import PrimRep          ( PrimRep(..) )
  34 \end{code}
  35
  36 %************************************************************************
  37 %*                                                                      *
  38 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
  39 %*                                                                      *
  40 %************************************************************************
  41
  42 The new code  for heapChecks. For GrAnSim the code for doing a heap check
  43 and doing a context switch has been separated. Especially, the HEAP_CHK
  44 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
  45 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
  46 beginning of every slow entry code in order to simulate the fetching of
  47 closures. If fetching is necessary (i.e. current closure is not local) then
  48 an automatic context switch is done.
  49
  50 \begin{code}
  51 heapCheck :: [MagicId]          -- Live registers
  52           -> Bool               -- Node reqd after GC?
  53           -> Code
  54           -> Code
  55
  56 heapCheck = heapCheck' False
  57
  58 heapCheckOnly :: [MagicId]          -- Live registers
  59                  -> Bool               -- Node reqd after GC?
  60                  -> Code
  61                  -> Code
  62
  63 heapCheckOnly = heapCheck' False
  64
  65 -- May be emit context switch and emit heap check macro
  66
  67 heapCheck' ::   Bool                    -- context switch here?
  68                 -> [MagicId]            -- Live registers
  69                 -> Bool                 -- Node reqd after GC?
  70                 -> Code
  71                 -> Code
  72
  73 heapCheck' do_context_switch regs node_reqd code
  74   = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
  75   where
  76
  77     do_heap_chk :: HeapOffset -> Code
  78     do_heap_chk words_required
  79       =
  80         -- HWL:: absC (CComment "Forced heap check --- HWL")  `thenC`
  81         --absC  (if do_context_switch
  82         --         then context_switch_code
  83         --         else AbsCNop)                                 `thenC`
  84
  85         absC (if do_context_switch && not (isZeroOff words_required)
  86                 then context_switch_code
  87                 else AbsCNop)                                   `thenC`
  88         absC (if isZeroOff(words_required)
  89                 then  AbsCNop
  90                 else  checking_code)  `thenC`
  91
  92         -- HWL was here:
  93         --  For GrAnSim we want heap checks even if no heap is allocated in
  94         --  the basic block to make context switches possible.
  95         --  So, the if construct has been replaced by its else branch.
  96
  97             -- The test is *inside* the absC, to avoid black holes!
  98
  99         -- Now we have set up the real heap pointer and checked there is
 100         -- enough space. It remains only to reflect this in the environment
 101
 102         setRealHp words_required
 103
 104             -- The "word_required" here is a fudge.
 105             -- *** IT DEPENDS ON THE DIRECTION ***, and on
 106             -- whether the Hp is moved the whole way all
 107             -- at once or not.
 108       where
 109         all_regs = if node_reqd then node:regs else regs
 110         liveness_mask = mkLiveRegsMask all_regs
 111
 112         maybe_context_switch = if do_context_switch
 113                                 then context_switch_code
 114                                 else AbsCNop
 115
 116         context_switch_code = CMacroStmt THREAD_CONTEXT_SWITCH [
 117                               mkIntCLit liveness_mask,
 118                               mkIntCLit (if node_reqd then 1 else 0)]
 119
 120         -- Good old heap check (excluding context switch)
 121         checking_code = CMacroStmt HEAP_CHK [
 122                         mkIntCLit liveness_mask,
 123                         COffset words_required,
 124                         mkIntCLit (if node_reqd then 1 else 0)]
 125
 126 -- Emit macro for simulating a fetch and then reschedule
 127
 128 fetchAndReschedule ::   [MagicId]               -- Live registers
 129                         -> Bool                 -- Node reqd?
 130                         -> Code
 131
 132 fetchAndReschedule regs node_reqd  =
 133       if (node `elem` regs || node_reqd)
 134         then fetch_code `thenC` reschedule_code
 135         else absC AbsCNop
 136       where
 137         all_regs = if node_reqd then node:regs else regs
 138         liveness_mask = mkLiveRegsMask all_regs
 139
 140         reschedule_code = absC  (CMacroStmt GRAN_RESCHEDULE [
 141                                  mkIntCLit liveness_mask,
 142                                  mkIntCLit (if node_reqd then 1 else 0)])
 143
 144          --HWL: generate GRAN_FETCH macro for GrAnSim
 145          --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
 146         fetch_code = absC (CMacroStmt GRAN_FETCH [])
 147 \end{code}
 148
 149 The @GRAN_YIELD@ macro is taken from JSM's  code for Concurrent Haskell. It
 150 allows to context-switch at  places where @node@ is  not alive (it uses the
 151 @Continue@ rather  than the @EnterNodeCode@  function in the  RTS). We emit
 152 this kind of macro at the beginning of the following kinds of basic bocks:
 153 \begin{itemize}
 154  \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
 155        we use @fetchAndReschedule@ at a slow entry code.
 156  \item Fast entry code (see @CgClosure.lhs@).
 157  \item Alternatives in case expressions (@CLabelledCode@ structures), provided
 158        that they are not inlined (see @CgCases.lhs@). These alternatives will
 159        be turned into separate functions.
 160 \end{itemize}
 161
 162 \begin{code}
 163 yield ::   [MagicId]               -- Live registers
 164              -> Bool                 -- Node reqd?
 165              -> Code
 166
 167 yield regs node_reqd =
 168       -- NB: node is not alive; that's why we use DO_YIELD rather than
 169       --     GRAN_RESCHEDULE
 170       yield_code
 171       where
 172         all_regs = if node_reqd then node:regs else regs
 173         liveness_mask = mkLiveRegsMask all_regs
 174
 175         yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
 176 \end{code}
 177
 178 %************************************************************************
 179 %*                                                                      *
 180 \subsection[initClosure]{Initialise a dynamic closure}
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
 185 to account for this.
 186
 187 \begin{code}
 188 allocDynClosure
 189         :: ClosureInfo
 190         -> CAddrMode            -- Cost Centre to stick in the object
 191         -> CAddrMode            -- Cost Centre to blame for this alloc
 192                                 -- (usually the same; sometimes "OVERHEAD")
 193
 194         -> [(CAddrMode, VirtualHeapOffset)]     -- Offsets from start of the object
 195                                                 -- ie Info ptr has offset zero.
 196         -> FCode VirtualHeapOffset              -- Returns virt offset of object
 197
 198 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
 199   = getVirtAndRealHp                            `thenFC` \ (virtHp, realHp) ->
 200
 201         -- FIND THE OFFSET OF THE INFO-PTR WORD
 202         -- virtHp points to last allocated word, ie 1 *before* the
 203         -- info-ptr word of new object.
 204     let  info_offset = addOff virtHp (intOff 1)
 205
 206         -- do_move IS THE ASSIGNMENT FUNCTION
 207          do_move (amode, offset_from_start)
 208            = CAssign (CVal (HpRel realHp
 209                                   (info_offset `addOff` offset_from_start))
 210                            (getAmodeRep amode))
 211                      amode
 212     in
 213         -- SAY WHAT WE ARE ABOUT TO DO
 214     profCtrC (allocProfilingMsg closure_info)
 215                            [COffset   (closureHdrSize closure_info),
 216                             mkIntCLit (closureGoodStuffSize closure_info),
 217                             mkIntCLit slop_size,
 218                             COffset   closure_size]     `thenC`
 219
 220         -- GENERATE THE CODE
 221     absC ( mkAbstractCs (
 222            [ CInitHdr closure_info (HpRel realHp info_offset) use_cc False ]
 223            ++ (map do_move amodes_with_offsets)))       `thenC`
 224
 225         -- GENERATE CC PROFILING MESSAGES
 226     costCentresC SLIT("CC_ALLOC") [blame_cc,
 227                              COffset closure_size,
 228                              CLitLit (_PK_ (closureKind closure_info)) IntRep]
 229                                                         `thenC`
 230
 231         -- BUMP THE VIRTUAL HEAP POINTER
 232     setVirtHp (virtHp `addOff` closure_size)            `thenC`
 233
 234         -- RETURN PTR TO START OF OBJECT
 235     returnFC info_offset
 236   where
 237     closure_size = closureSize closure_info
 238     slop_size    = slopSize closure_info
 239 \end{code}
 240
 241 %************************************************************************
 242 %*                                                                      *
 243 \subsection{Allocate uninitialized heap space}
 244 %*                                                                      *
 245 %************************************************************************
 246
 247 \begin{code}
 248 allocHeap :: HeapOffset         -- Size of the space required
 249           -> FCode CAddrMode    -- Addr mode for first word of object
 250
 251 allocHeap space
 252   = getVirtAndRealHp                            `thenFC` \ (virtHp, realHp) ->
 253     let block_start = addOff virtHp (intOff 1)
 254     in
 255         -- We charge the allocation to "PRIM" (which is probably right)
 256     profCtrC SLIT("ALLOC_PRIM2") [COffset space]        `thenC`
 257
 258         -- BUMP THE VIRTUAL HEAP POINTER
 259     setVirtHp (virtHp `addOff` space)           `thenC`
 260
 261         -- RETURN PTR TO START OF OBJECT
 262     returnFC (CAddr (HpRel realHp block_start))
 263 \end{code}