ghc/compiler/codeGen/CgHeapery.lhs

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