ghc/compiler/codeGen/CgHeapery.lhs

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