ghc/compiler/codeGen/CgHeapery.lhs

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