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