ghc/compiler/codeGen/CgHeapery.lhs

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