ghc/compiler/codeGen/CgHeapery.lhs

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