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