ghc/compiler/codeGen/CgHeapery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgHeapery.lhs,v 1.18 1999/06/24 13:04:19 simonmar Exp $
   5 %
   6 \section[CgHeapery]{Heap management functions}
   7
   8 \begin{code}
   9 module CgHeapery (
  10         fastEntryChecks, altHeapCheck, thunkChecks,
  11         allocDynClosure, inPlaceAllocDynClosure
  12
  13         -- new functions, basically inserting macro calls into Code -- HWL
  14         ,fetchAndReschedule, yield
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import AbsCSyn
  20 import CLabel
  21 import CgMonad
  22
  23 import CgStackery       ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
  24 import SMRep            ( fixedHdrSize )
  25 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  26 import CgUsages         ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
  27                           initHeapUsage
  28                         )
  29 import ClosureInfo      ( closureSize, closureGoodStuffSize,
  30                           slopSize, allocProfilingMsg, ClosureInfo,
  31                           closureSMRep
  32                         )
  33 import PrimRep          ( PrimRep(..), isFollowableRep )
  34 import Unique           ( Unique )
  35 import CmdLineOpts      ( opt_SccProfilingOn )
  36 import GlaExts
  37 import Outputable
  38
  39 #ifdef DEBUG
  40 import PprAbsC          ( pprMagicId ) -- tmp
  41 #endif
  42 \end{code}
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 The new code  for heapChecks. For GrAnSim the code for doing a heap check
  51 and doing a context switch has been separated. Especially, the HEAP_CHK
  52 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
  53 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
  54 beginning of every slow entry code in order to simulate the fetching of
  55 closures. If fetching is necessary (i.e. current closure is not local) then
  56 an automatic context switch is done.
  57
  58 -----------------------------------------------------------------------------
  59 A heap/stack check at a fast entry point.
  60
  61 \begin{code}
  62
  63 fastEntryChecks
  64         :: [MagicId]                    -- Live registers
  65         -> [(VirtualSpOffset,Int)]      -- stack slots to tag
  66         -> CLabel                       -- return point
  67         -> Bool                         -- node points to closure
  68         -> Code
  69         -> Code
  70
  71 fastEntryChecks regs tags ret node_points code
  72   =  mkTagAssts tags                             `thenFC` \tag_assts ->
  73      getFinalStackHW                             (\ spHw ->
  74      getRealSp                                   `thenFC` \ sp ->
  75      let stk_words = spHw - sp in
  76      initHeapUsage                               (\ hp_words  ->
  77
  78      ( if all_pointers then -- heap checks are quite easy
  79           absC (checking_code stk_words hp_words tag_assts
  80                     free_reg (length regs))
  81
  82        else -- they are complicated
  83
  84           -- save all registers on the stack and adjust the stack pointer.
  85           -- ToDo: find the initial all-pointer segment and don't save them.
  86
  87           mkTaggedStkAmodes sp addrmode_regs
  88                   `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
  89
  90           -- only let the extra stack assignments affect the stack
  91           -- high water mark if we were doing a stack check anyway;
  92           -- otherwise we end up generating unnecessary stack checks.
  93           -- Careful about knot-tying loops!
  94           let real_stk_words =  if new_sp - sp > stk_words && stk_words /= 0
  95                                         then new_sp - sp
  96                                         else stk_words
  97           in
  98
  99           let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
 100
 101           absC (checking_code real_stk_words hp_words
 102                     (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
 103                                    adjust_sp])
 104                     (CReg node) 0)
 105
 106       ) `thenC`
 107
 108       setRealHp hp_words `thenC`
 109       code))
 110
 111   where
 112
 113     checking_code stk hp assts ret regs
 114         | node_points = do_checks_np stk hp assts (regs+1) -- ret not required
 115         | otherwise   = do_checks    stk hp assts ret regs
 116
 117     -- When node points to the closure for the function:
 118
 119     do_checks_np
 120         :: Int                          -- stack headroom
 121         -> Int                          -- heap  headroom
 122         -> AbstractC                    -- assignments to perform on failure
 123         -> Int                          -- number of pointer registers live
 124         -> AbstractC
 125     do_checks_np 0 0 _ _ = AbsCNop
 126     do_checks_np 0 hp_words tag_assts ptrs =
 127             CCheck HP_CHK_NP [
 128                   mkIntCLit hp_words,
 129                   mkIntCLit ptrs
 130                  ]
 131                  tag_assts
 132     do_checks_np stk_words 0 tag_assts ptrs =
 133             CCheck STK_CHK_NP [
 134                   mkIntCLit stk_words,
 135                   mkIntCLit ptrs
 136                  ]
 137                  tag_assts
 138     do_checks_np stk_words hp_words tag_assts ptrs =
 139             CCheck HP_STK_CHK_NP [
 140                   mkIntCLit stk_words,
 141                   mkIntCLit hp_words,
 142                   mkIntCLit ptrs
 143                  ]
 144                  tag_assts
 145
 146     -- When node doesn't point to the closure (we need an explicit retn addr)
 147
 148     do_checks
 149         :: Int                          -- stack headroom
 150         -> Int                          -- heap  headroom
 151         -> AbstractC                    -- assignments to perform on failure
 152         -> CAddrMode                    -- a register to hold the retn addr.
 153         -> Int                          -- number of pointer registers live
 154         -> AbstractC
 155
 156     do_checks 0 0 _ _ _ = AbsCNop
 157     do_checks 0 hp_words tag_assts ret_reg ptrs =
 158             CCheck HP_CHK [
 159                   mkIntCLit hp_words,
 160                   CLbl ret CodePtrRep,
 161                   ret_reg,
 162                   mkIntCLit ptrs
 163                  ]
 164                  tag_assts
 165     do_checks stk_words 0 tag_assts ret_reg ptrs =
 166             CCheck STK_CHK [
 167                   mkIntCLit stk_words,
 168                   CLbl ret CodePtrRep,
 169                   ret_reg,
 170                   mkIntCLit ptrs
 171                  ]
 172                  tag_assts
 173     do_checks stk_words hp_words tag_assts ret_reg ptrs =
 174             CCheck HP_STK_CHK [
 175                   mkIntCLit stk_words,
 176                   mkIntCLit hp_words,
 177                   CLbl ret CodePtrRep,
 178                   ret_reg,
 179                   mkIntCLit ptrs
 180                  ]
 181                  tag_assts
 182
 183     free_reg  = case length regs + 1 of
 184                        IBOX(x) -> CReg (VanillaReg PtrRep x)
 185
 186     all_pointers = all pointer regs
 187     pointer (VanillaReg rep _) = isFollowableRep rep
 188     pointer _ = False
 189
 190     addrmode_regs = map CReg regs
 191
 192 -- Checking code for thunks is just a special case of fast entry points:
 193
 194 thunkChecks :: CLabel -> Bool -> Code -> Code
 195 thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
 196 \end{code}
 197
 198 Heap checks in a case alternative are nice and easy, provided this is
 199 a bog-standard algebraic case.  We have in our hand:
 200
 201        * one return address, on the stack,
 202        * one return value, in Node.
 203
 204 the canned code for this heap check failure just pushes Node on the
 205 stack, saying 'EnterGHC' to return.  The scheduler will return by
 206 entering the top value on the stack, which in turn will return through
 207 the return address, getting us back to where we were.  This is
 208 therefore only valid if the return value is *lifted* (just being
 209 boxed isn't good enough).  Only a PtrRep will do.
 210
 211 For primitive returns, we have an unlifted value in some register
 212 (either R1 or FloatReg1 or DblReg1).  This means using specialised
 213 heap-check code for these cases.
 214
 215 For unboxed tuple returns, there are an arbitrary number of possibly
 216 unboxed return values, some of which will be in registers, and the
 217 others will be on the stack, with gaps left for tagging the unboxed
 218 objects.  If a heap check is required, we need to fill in these tags.
 219
 220 The code below will cover all cases for the x86 architecture (where R1
 221 is the only VanillaReg ever used).  For other architectures, we'll
 222 have to do something about saving and restoring the other registers.
 223
 224 \begin{code}
 225 altHeapCheck
 226         :: Bool                         -- is an algebraic alternative
 227         -> [MagicId]                    -- live registers
 228         -> [(VirtualSpOffset,Int)]      -- stack slots to tag
 229         -> AbstractC
 230         -> Maybe Unique                 -- uniq of ret address (possibly)
 231         -> Code
 232         -> Code
 233
 234 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
 235 -- constructs to generate code for!):
 236
 237 altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
 238   = mkTagAssts tags `thenFC` \tag_assts1 ->
 239     let tag_assts = mkAbstractCs [fail_code, tag_assts1]
 240     in
 241     initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
 242   where
 243     do_heap_chk words_required tag_assts
 244       = absC (if words_required == 0
 245                 then  AbsCNop
 246                 else  checking_code tag_assts)  `thenC`
 247         setRealHp words_required
 248
 249       where
 250         non_void_regs = filter (/= VoidReg) regs
 251
 252         checking_code tag_assts =
 253           case non_void_regs of
 254
 255 {- no: there might be stuff on top of the retn. addr. on the stack.
 256             [{-no regs-}] ->
 257                 CCheck HP_CHK_NOREGS
 258                     [mkIntCLit words_required]
 259                     tag_assts
 260 -}
 261             -- this will cover all cases for x86
 262             [VanillaReg rep ILIT(1)]
 263
 264                | isFollowableRep rep ->
 265                   CCheck HP_CHK_UT_ALT
 266                       [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
 267                         CReg (VanillaReg RetRep ILIT(2)),
 268                         CLbl (mkReturnInfoLabel ret_addr) RetRep]
 269                       tag_assts
 270
 271                | otherwise ->
 272                   CCheck HP_CHK_UT_ALT
 273                       [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
 274                         CReg (VanillaReg RetRep ILIT(2)),
 275                         CLbl (mkReturnInfoLabel ret_addr) RetRep]
 276                       tag_assts
 277
 278             several_regs ->
 279                 let liveness = mkRegLiveness several_regs
 280                 in
 281                 CCheck HP_CHK_GEN
 282                      [mkIntCLit words_required,
 283                       mkIntCLit (IBOX(word2Int# liveness)),
 284                         -- HP_CHK_GEN needs a direct return address,
 285                         -- not an info table (might be different if
 286                         -- we're not assembly-mangling/tail-jumping etc.)
 287                       CLbl (mkReturnPtLabel ret_addr) RetRep]
 288                      tag_assts
 289
 290 -- normal algebraic and primitive case alternatives:
 291
 292 altHeapCheck is_fun regs [] AbsCNop Nothing code
 293   = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
 294   where
 295     do_heap_chk :: HeapOffset -> Code
 296     do_heap_chk words_required
 297       = absC (if words_required == 0
 298                 then  AbsCNop
 299                 else  checking_code)  `thenC`
 300         setRealHp words_required
 301
 302       where
 303         non_void_regs = filter (/= VoidReg) regs
 304
 305         checking_code =
 306           case non_void_regs of
 307
 308             -- No regs live: probably a Void return
 309             [] ->
 310                CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
 311
 312             -- The SEQ case (polymophic/function typed case branch)
 313             -- We need this case because the closure in Node won't return
 314             -- directly when we enter it (it could be a function), so the
 315             -- heap check code needs to push a seq frame on top of the stack.
 316             [VanillaReg rep ILIT(1)]
 317                 |  rep == PtrRep
 318                 && is_fun ->
 319                   CCheck HP_CHK_SEQ_NP
 320                         [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
 321                         AbsCNop
 322
 323             -- R1 is lifted (the common case)
 324             [VanillaReg rep ILIT(1)]
 325                 | rep == PtrRep ->
 326                   CCheck HP_CHK_NP
 327                         [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
 328                         AbsCNop
 329
 330             -- R1 is boxed, but unlifted
 331                 | isFollowableRep rep ->
 332                   CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
 333
 334             -- R1 is unboxed
 335                 | otherwise ->
 336                   CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
 337
 338             -- FloatReg1
 339             [FloatReg ILIT(1)] ->
 340                   CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
 341
 342             -- DblReg1
 343             [DoubleReg ILIT(1)] ->
 344                   CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
 345
 346             -- LngReg1
 347             [LongReg _ ILIT(1)] ->
 348                   CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
 349
 350 #ifdef DEBUG
 351             _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
 352 #endif
 353
 354 -- build up a bitmap of the live pointer registers
 355
 356 mkRegLiveness :: [MagicId] -> Word#
 357 mkRegLiveness []  =  int2Word# 0#
 358 mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
 359   =  ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
 360 mkRegLiveness (_ : regs)  =  mkRegLiveness regs
 361
 362 -- Emit macro for simulating a fetch and then reschedule
 363
 364 fetchAndReschedule ::   [MagicId]               -- Live registers
 365                         -> Bool                 -- Node reqd?
 366                         -> Code
 367
 368 fetchAndReschedule regs node_reqd  =
 369       if (node `elem` regs || node_reqd)
 370         then fetch_code `thenC` reschedule_code
 371         else absC AbsCNop
 372       where
 373         all_regs = if node_reqd then node:regs else regs
 374         liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
 375
 376         reschedule_code = absC  (CMacroStmt GRAN_RESCHEDULE [
 377                                  mkIntCLit liveness_mask,
 378                                  mkIntCLit (if node_reqd then 1 else 0)])
 379
 380          --HWL: generate GRAN_FETCH macro for GrAnSim
 381          --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
 382         fetch_code = absC (CMacroStmt GRAN_FETCH [])
 383 \end{code}
 384
 385 The @GRAN_YIELD@ macro is taken from JSM's  code for Concurrent Haskell. It
 386 allows to context-switch at  places where @node@ is  not alive (it uses the
 387 @Continue@ rather  than the @EnterNodeCode@  function in the  RTS). We emit
 388 this kind of macro at the beginning of the following kinds of basic bocks:
 389 \begin{itemize}
 390  \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
 391        we use @fetchAndReschedule@ at a slow entry code.
 392  \item Fast entry code (see @CgClosure.lhs@).
 393  \item Alternatives in case expressions (@CLabelledCode@ structures), provided
 394        that they are not inlined (see @CgCases.lhs@). These alternatives will
 395        be turned into separate functions.
 396 \end{itemize}
 397
 398 \begin{code}
 399 yield ::   [MagicId]               -- Live registers
 400              -> Bool                 -- Node reqd?
 401              -> Code
 402
 403 yield regs node_reqd =
 404       -- NB: node is not alive; that's why we use DO_YIELD rather than
 405       --     GRAN_RESCHEDULE
 406       yield_code
 407       where
 408         all_regs = if node_reqd then node:regs else regs
 409         liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
 410
 411         yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
 412 \end{code}
 413
 414 %************************************************************************
 415 %*                                                                      *
 416 \subsection[initClosure]{Initialise a dynamic closure}
 417 %*                                                                      *
 418 %************************************************************************
 419
 420 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
 421 to account for this.
 422
 423 \begin{code}
 424 allocDynClosure
 425         :: ClosureInfo
 426         -> CAddrMode            -- Cost Centre to stick in the object
 427         -> CAddrMode            -- Cost Centre to blame for this alloc
 428                                 -- (usually the same; sometimes "OVERHEAD")
 429
 430         -> [(CAddrMode, VirtualHeapOffset)]     -- Offsets from start of the object
 431                                                 -- ie Info ptr has offset zero.
 432         -> FCode VirtualHeapOffset              -- Returns virt offset of object
 433
 434 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
 435   = getVirtAndRealHp                            `thenFC` \ (virtHp, realHp) ->
 436
 437         -- FIND THE OFFSET OF THE INFO-PTR WORD
 438         -- virtHp points to last allocated word, ie 1 *before* the
 439         -- info-ptr word of new object.
 440     let  info_offset = virtHp + 1
 441
 442         -- do_move IS THE ASSIGNMENT FUNCTION
 443          do_move (amode, offset_from_start)
 444            = CAssign (CVal (hpRel realHp
 445                                   (info_offset + offset_from_start))
 446                            (getAmodeRep amode))
 447                      amode
 448     in
 449         -- SAY WHAT WE ARE ABOUT TO DO
 450     profCtrC (allocProfilingMsg closure_info)
 451                            [mkIntCLit (closureGoodStuffSize closure_info),
 452                             mkIntCLit slop_size]        `thenC`
 453
 454         -- GENERATE THE CODE
 455     absC ( mkAbstractCs (
 456            [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
 457            ++ (map do_move amodes_with_offsets)))       `thenC`
 458
 459         -- GENERATE CC PROFILING MESSAGES
 460     costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
 461                                                         `thenC`
 462
 463         -- BUMP THE VIRTUAL HEAP POINTER
 464     setVirtHp (virtHp + closure_size)                   `thenC`
 465
 466         -- RETURN PTR TO START OF OBJECT
 467     returnFC info_offset
 468   where
 469     closure_size = closureSize closure_info
 470     slop_size    = slopSize closure_info
 471 \end{code}
 472
 473 Occasionally we can update a closure in place instead of allocating
 474 new space for it.  This is the function that does the business, assuming:
 475
 476         - node points to the closure to be overwritten
 477
 478         - the new closure doesn't contain any pointers if we're
 479           using a generational collector.
 480
 481 \begin{code}
 482 inPlaceAllocDynClosure
 483         :: ClosureInfo
 484         -> CAddrMode            -- Pointer to beginning of closure
 485         -> CAddrMode            -- Cost Centre to stick in the object
 486
 487         -> [(CAddrMode, VirtualHeapOffset)]     -- Offsets from start of the object
 488                                                 -- ie Info ptr has offset zero.
 489         -> Code
 490
 491 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
 492   = let -- do_move IS THE ASSIGNMENT FUNCTION
 493          do_move (amode, offset_from_start)
 494            = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
 495                         (getAmodeRep amode))
 496                      amode
 497     in
 498         -- GENERATE THE CODE
 499     absC ( mkAbstractCs (
 500            [ CInitHdr closure_info head use_cc ]
 501            ++ (map do_move amodes_with_offsets)))
 502
 503 -- Avoid hanging on to anything in the CC field when we're not profiling.
 504
 505 cInitHdr closure_info amode cc
 506   | opt_SccProfilingOn = CInitHdr closure_info (CAddr amode) cc
 507   | otherwise          = CInitHdr closure_info (CAddr amode) (panic "absent cc")
 508
 509 \end{code}