ghc/compiler/codeGen/CgHeapery.lhs

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