ghc/compiler/codeGen/CgHeapery.lhs

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