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