ghc/compiler/codeGen/CgHeapery.lhs

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