ghc/compiler/codeGen/CgMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[CgMonad]{The code generation monad}
   5
   6 See the beginning of the top-level @CodeGen@ module, to see how this
   7 monadic stuff fits into the Big Picture.
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module CgMonad (
  13         Code(..),       -- type
  14         FCode(..),      -- type
  15
  16         initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
  17         returnFC, fixC, absC, nopC, getAbsC,
  18
  19         forkClosureBody, forkStatics, forkAlts, forkEval,
  20         forkEvalHelp, forkAbsC,
  21         SemiTaggingStuff(..),
  22
  23         addBindC, addBindsC, modifyBindC, lookupBindC,
  24
  25         EndOfBlockInfo(..),
  26         setEndOfBlockInfo, getEndOfBlockInfo,
  27
  28         AStackUsage(..), BStackUsage(..), HeapUsage(..),
  29         StubFlag,
  30         isStubbed,
  31
  32         nukeDeadBindings, getUnstubbedAStackSlots,
  33
  34 --      addFreeASlots,  -- no need to export it
  35         addFreeBSlots,  -- ToDo: Belong elsewhere
  36
  37         noBlackHolingFlag,
  38         profCtrC,
  39
  40         costCentresC, costCentresFlag, moduleName,
  41
  42         Sequel(..), -- ToDo: unabstract?
  43         sequelToAmode,
  44
  45         -- out of general friendliness, we also export ...
  46         CgInfoDownwards(..), CgState(..),       -- non-abstract
  47         CompilationInfo(..)
  48     ) where
  49
  50 IMP_Ubiq(){-uitous-}
  51 IMPORT_DELOOPER(CgLoop1)                -- stuff from CgBindery and CgUsages
  52
  53 import AbsCSyn
  54 import AbsCUtils        ( mkAbsCStmts )
  55 import CmdLineOpts      ( opt_SccProfilingOn, opt_DoTickyProfiling,
  56                           opt_OmitBlackHoling
  57                         )
  58 import HeapOffs         ( maxOff,
  59                           VirtualSpAOffset(..), VirtualSpBOffset(..)
  60                         )
  61 import Id               ( idType,
  62                           nullIdEnv, mkIdEnv, addOneToIdEnv,
  63                           modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv(..),
  64                           ConTag(..), GenId{-instance Outputable-}
  65                         )
  66 import Maybes           ( maybeToBool )
  67 import PprStyle         ( PprStyle(..) )
  68 import PprType          ( GenType{-instance Outputable-} )
  69 import Pretty           ( ppAboves, ppCat, ppStr )
  70 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  71 import StgSyn           ( StgLiveVars(..) )
  72 import Type             ( typePrimRep )
  73 import UniqSet          ( elementOfUniqSet )
  74 import Util             ( sortLt, panic, pprPanic )
  75
  76 infixr 9 `thenC`        -- Right-associative!
  77 infixr 9 `thenFC`
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection[CgMonad-environment]{Stuff for manipulating environments}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 This monadery has some information that it only passes {\em
  87 downwards}, as well as some ``state'' which is modified as we go
  88 along.
  89
  90 \begin{code}
  91 data CgInfoDownwards    -- information only passed *downwards* by the monad
  92   = MkCgInfoDown
  93      CompilationInfo    -- COMPLETELY STATIC info about this compilation
  94                         --  (e.g., what flags were passed to the compiler)
  95
  96      CgBindings         -- [Id -> info] : static environment
  97
  98      EndOfBlockInfo     -- Info for stuff to do at end of basic block:
  99
 100
 101 data CompilationInfo
 102   = MkCompInfo
 103         FAST_STRING     -- the module name
 104
 105 data CgState
 106   = MkCgState
 107         AbstractC       -- code accumulated so far
 108         CgBindings      -- [Id -> info] : *local* bindings environment
 109                         -- Bindings for top-level things are given in the info-down part
 110         CgStksAndHeapUsage
 111 \end{code}
 112
 113 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
 114 if the expression is a @case@, what to do at the end of each
 115 alternative.
 116
 117 \begin{code}
 118 data EndOfBlockInfo
 119   = EndOfBlockInfo
 120         VirtualSpAOffset  -- Args SpA: trim the A stack to this point at a
 121                           -- return; push arguments starting just
 122                           -- above this point on a tail call.
 123
 124                           -- This is therefore the A-stk ptr as seen
 125                           -- by a case alternative.
 126
 127                           -- Args SpA is used when we want to stub any
 128                           -- currently-unstubbed dead A-stack (ptr)
 129                           -- slots; we want to know what SpA in the
 130                           -- continuation is so that we don't stub any
 131                           -- slots which are off the top of the
 132                           -- continuation's stack!
 133
 134         VirtualSpBOffset  -- Args SpB: Very similar to Args SpA.
 135                           -- Two main differences:
 136                           --  1. If Sequel isn't OnStack, then Args SpB points
 137                           --     just below the slot in which the return address
 138                           --     should be put.  In effect, the Sequel
 139                           --     is a pending argument.  If it is
 140                           --     OnStack, Args SpB
 141                           --     points to the top word of the return
 142                           --     address.
 143                           --
 144                           --  2. It ain't used for stubbing because there are
 145                           --     no ptrs on B stk.
 146         Sequel
 147
 148 initEobInfo = EndOfBlockInfo 0 0 InRetReg
 149 \end{code}
 150
 151 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
 152 that it must survive stack pointer adjustments at the end of the
 153 block.
 154
 155 \begin{code}
 156 data Sequel
 157   = InRetReg              -- The continuation is in RetReg
 158
 159   | OnStack VirtualSpBOffset
 160                           -- Continuation is on the stack, at the
 161                           -- specified location
 162
 163   | UpdateCode CAddrMode  -- May be standard update code, or might be
 164                           -- the data-type-specific one.
 165
 166   | CaseAlts
 167           CAddrMode   -- Jump to this; if the continuation is for a vectored
 168                       -- case this might be the label of a return
 169                       -- vector Guaranteed to be a non-volatile
 170                       -- addressing mode (I think)
 171           SemiTaggingStuff
 172
 173 type SemiTaggingStuff
 174   = Maybe                           -- Maybe[1] we don't have any semi-tagging stuff...
 175      ([(ConTag, JoinDetails)],      -- Alternatives
 176       Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
 177                                     -- Maybe[3] the default is a
 178                                     -- bind-default (Just b); that is,
 179                                     -- it expects a ptr to the thing
 180                                     -- in Node, bound to b
 181      )
 182
 183 type JoinDetails
 184   = (AbstractC, CLabel)         -- Code to load regs from heap object + profiling macros,
 185                                 -- and join point label
 186
 187 -- The abstract C is executed only from a successful semitagging
 188 -- venture, when a case has looked at a variable, found that it's
 189 -- evaluated, and wants to load up the contents and go to the join
 190 -- point.
 191
 192 -- DIRE WARNING.
 193 -- The OnStack case of sequelToAmode delivers an Amode which is only
 194 -- valid just before the final control transfer, because it assumes
 195 -- that SpB is pointing to the top word of the return address.  This
 196 -- seems unclean but there you go.
 197
 198 sequelToAmode :: Sequel -> FCode CAddrMode
 199
 200 sequelToAmode (OnStack virt_spb_offset)
 201   = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
 202     returnFC (CVal spb_rel RetRep)
 203
 204 sequelToAmode InRetReg           = returnFC (CReg RetReg)
 205 --Andy/Simon's patch:
 206 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
 207 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
 208 sequelToAmode (CaseAlts amode _) = returnFC amode
 209 \end{code}
 210
 211 See the NOTES about the details of stack/heap usage tracking.
 212
 213 \begin{code}
 214 type CgStksAndHeapUsage         -- stacks and heap usage information
 215   = (AStackUsage,               -- A-stack usage
 216      BStackUsage,               -- B-stack usage
 217      HeapUsage)
 218
 219 type AStackUsage =
 220         (Int,                   -- virtSpA: Virtual offset of topmost allocated slot
 221          [(Int,StubFlag)],      -- freeA:   List of free slots, in increasing order
 222          Int,                   -- realSpA: Virtual offset of real stack pointer
 223          Int)                   -- hwSpA:   Highest value ever taken by virtSp
 224
 225 data StubFlag = Stubbed | NotStubbed
 226
 227 isStubbed Stubbed    = True  -- so the type can be abstract
 228 isStubbed NotStubbed = False
 229
 230 type BStackUsage =
 231         (Int,           -- virtSpB: Virtual offset of topmost allocated slot
 232          [Int],         -- freeB:   List of free slots, in increasing order
 233          Int,           -- realSpB: Virtual offset of real stack pointer
 234          Int)           -- hwSpB:   Highest value ever taken by virtSp
 235
 236 type HeapUsage =
 237         (HeapOffset,    -- virtHp: Virtual offset of highest-numbered allocated word
 238          HeapOffset)    -- realHp: Virtual offset of real heap ptr
 239 \end{code}
 240 NB: absolutely every one of the above Ints is really
 241 a VirtualOffset of some description (the code generator
 242 works entirely in terms of VirtualOffsets; see NOTES).
 243
 244 Initialisation.
 245
 246 \begin{code}
 247 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
 248
 249 initUsage :: CgStksAndHeapUsage
 250 initUsage  = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
 251 initVirtHp = panic "Uninitialised virtual Hp"
 252 initRealHp = panic "Uninitialised real Hp"
 253 \end{code}
 254
 255 @envInitForAlternatives@ initialises the environment for a case alternative,
 256 assuming that the alternative is entered after an evaluation.
 257 This involves:
 258 \begin{itemize}
 259 \item
 260 zapping any volatile bindings, which aren't valid.
 261 \item
 262 zapping the heap usage.  It should be restored by a heap check.
 263 \item
 264 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
 265 this doesn't represent any {\em code}; it is a prediction of where the
 266 real stack pointer will be when we come back from the case analysis.
 267 \item
 268 BUT LEAVING the rest of the stack-usage info because it is all valid.
 269 In particular, we leave the tail stack pointers unchanged, becuase the
 270 alternative has to de-allocate the original @case@ expression's stack.
 271 \end{itemize}
 272
 273 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
 274 marks found in $e_2$.
 275
 276 \begin{code}
 277 stateIncUsage :: CgState -> CgState -> CgState
 278
 279 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
 280               (MkCgState _     _  (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
 281      = MkCgState abs_c
 282                  bs
 283                  ((vA,fA,rA,hA1 `max` hA2),
 284                   (vB,fB,rB,hB1 `max` hB2),
 285                   (vH1 `maxOff` vH2, rH1))
 286 \end{code}
 287
 288 %************************************************************************
 289 %*                                                                      *
 290 \subsection[CgMonad-basics]{Basic code-generation monad magic}
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 \begin{code}
 295 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
 296 type Code    = CgInfoDownwards -> CgState -> CgState
 297
 298 {-# INLINE thenC #-}
 299 {-# INLINE thenFC #-}
 300 {-# INLINE returnFC #-}
 301 \end{code}
 302 The Abstract~C is not in the environment so as to improve strictness.
 303
 304 \begin{code}
 305 initC :: CompilationInfo -> Code -> AbstractC
 306
 307 initC cg_info code
 308   = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
 309                initialStateC) of
 310       MkCgState abc _ _ -> abc
 311
 312 returnFC :: a -> FCode a
 313
 314 returnFC val info_down state = (val, state)
 315 \end{code}
 316
 317 \begin{code}
 318 thenC :: Code
 319       -> (CgInfoDownwards -> CgState -> a)
 320       -> CgInfoDownwards -> CgState -> a
 321
 322 -- thenC has both of the following types:
 323 -- thenC :: Code -> Code    -> Code
 324 -- thenC :: Code -> FCode a -> FCode a
 325
 326 (m `thenC` k) info_down state
 327   = k info_down new_state
 328   where
 329     new_state  = m info_down state
 330
 331 listCs :: [Code] -> Code
 332
 333 listCs []     info_down state = state
 334 listCs (c:cs) info_down state = stateN
 335   where
 336     state1 = c         info_down state
 337     stateN = listCs cs info_down state1
 338
 339 mapCs :: (a -> Code) -> [a] -> Code
 340
 341 mapCs f []     info_down state = state
 342 mapCs f (c:cs) info_down state = stateN
 343   where
 344     state1 = (f c)      info_down state
 345     stateN = mapCs f cs info_down state1
 346 \end{code}
 347
 348 \begin{code}
 349 thenFC  :: FCode a
 350         -> (a -> CgInfoDownwards -> CgState -> c)
 351         -> CgInfoDownwards -> CgState -> c
 352
 353 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
 354 -- thenFC :: FCode a -> (a -> Code)    -> Code
 355
 356 (m `thenFC` k) info_down state
 357   = k m_result info_down new_state
 358   where
 359     (m_result, new_state) = m info_down state
 360
 361 listFCs :: [FCode a] -> FCode [a]
 362
 363 listFCs []       info_down state = ([],             state)
 364 listFCs (fc:fcs) info_down state = (thing : things, stateN)
 365   where
 366     (thing,  state1) = fc          info_down state
 367     (things, stateN) = listFCs fcs info_down state1
 368
 369 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
 370
 371 mapFCs f []       info_down state = ([],             state)
 372 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
 373   where
 374     (thing,  state1) = (f fc)       info_down state
 375     (things, stateN) = mapFCs f fcs info_down state1
 376 \end{code}
 377
 378 And the knot-tying combinator:
 379 \begin{code}
 380 fixC :: (a -> FCode a) -> FCode a
 381 fixC fcode info_down state = result
 382   where
 383     result@(v, _) = fcode v info_down state
 384     --      ^-------------^
 385 \end{code}
 386
 387 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
 388 fresh environment, except that:
 389         - compilation info and statics are passed in unchanged.
 390 The current environment is passed on completely unaltered, except that
 391 abstract C from the fork is incorporated.
 392
 393 @forkAbsC@ takes a code and compiles it in the current environment,
 394 returning the abstract C thus constructed.  The current environment
 395 is passed on completely unchanged.  It is pretty similar to @getAbsC@,
 396 except that the latter does affect the environment. ToDo: combine?
 397
 398 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
 399 from the current bindings, but which is otherwise freshly initialised.
 400 The Abstract~C returned is attached to the current state, but the
 401 bindings and usage information is otherwise unchanged.
 402
 403 \begin{code}
 404 forkClosureBody :: Code -> Code
 405
 406 forkClosureBody code
 407         (MkCgInfoDown cg_info statics _)
 408         (MkCgState absC_in binds un_usage)
 409   = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
 410   where
 411     fork_state              = code body_info_down initialStateC
 412     MkCgState absC_fork _ _ = fork_state
 413     body_info_down = MkCgInfoDown cg_info statics initEobInfo
 414
 415 forkStatics :: FCode a -> FCode a
 416
 417 forkStatics fcode (MkCgInfoDown cg_info _ _)
 418                   (MkCgState absC_in statics un_usage)
 419   = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
 420   where
 421   (result, state) = fcode rhs_info_down initialStateC
 422   MkCgState absC_fork _ _ = state       -- Don't merge these this line with the one
 423                                         -- above or it becomes too strict!
 424   rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
 425
 426 forkAbsC :: Code -> FCode AbstractC
 427 forkAbsC code info_down (MkCgState absC1 bs usage)
 428   = (absC2, new_state)
 429   where
 430     MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
 431         code info_down (MkCgState AbsCNop bs usage)
 432     ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
 433
 434     new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
 435     new_state = MkCgState absC1 bs new_usage
 436 \end{code}
 437
 438 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
 439 an fcode for the default case $d$, and compiles each in the current
 440 environment.  The current environment is passed on unmodified, except
 441 that
 442         - the worst stack high-water mark is incorporated
 443         - the virtual Hp is moved on to the worst virtual Hp for the branches
 444
 445 The "extra branches" arise from handling the default case:
 446
 447         case f x of
 448           C1 a b -> e1
 449           z     -> e2
 450
 451 Here we in effect expand to
 452
 453         case f x of
 454           C1 a b -> e1
 455           C2 c -> let z = C2 c in JUMP(default)
 456           C3 d e f -> let z = C2 d e f in JUMP(default)
 457
 458           default: e2
 459
 460 The stuff for C2 and C3 are the extra branches.  They are
 461 handled differently by forkAlts, because their
 462 heap usage is joined onto that for the default case.
 463
 464 \begin{code}
 465 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
 466
 467 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
 468  = ((extra_branch_results ++ branch_results , deflt_result), out_state)
 469   where
 470     compile fc = fc info_down in_state
 471
 472     (branch_results,       branch_out_states)       = unzip (map compile branch_fcodes)
 473     (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
 474
 475         -- The "in_state" for the default branch is got by worst-casing the
 476         -- heap usages etc from the "extra_branches"
 477     default_in_state                = foldl stateIncUsage in_state extra_branch_out_states
 478     (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
 479
 480     out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
 481                 -- NB foldl.  in_state is the *left* argument to stateIncUsage
 482 \end{code}
 483
 484 @forkEval@ takes two blocks of code.
 485 \begin{itemize}
 486 \item The first meddles with the environment to set it up as expected by
 487         the alternatives of a @case@ which does an eval (or gc-possible primop).
 488 \item The second block is the code for the alternatives.
 489         (plus info for semi-tagging purposes)
 490 \end{itemize}
 491 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
 492 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
 493 the caller to use, together with whatever value is returned by the second block.
 494
 495 It uses @initEnvForAlternatives@ to initialise the environment, and
 496 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
 497 usage.
 498
 499 \begin{code}
 500 forkEval :: EndOfBlockInfo              -- For the body
 501          -> Code                        -- Code to set environment
 502          -> FCode Sequel                -- Semi-tagging info to store
 503          -> FCode EndOfBlockInfo        -- The new end of block info
 504
 505 forkEval body_eob_info env_code body_code
 506   = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
 507     returnFC (EndOfBlockInfo vA vB sequel)
 508
 509 forkEvalHelp :: EndOfBlockInfo  -- For the body
 510              -> Code            -- Code to set environment
 511              -> FCode a         -- The code to do after the eval
 512              -> FCode (Int,     -- SpA
 513                        Int,     -- SpB
 514                        a)       -- Result of the FCode
 515
 516 forkEvalHelp body_eob_info env_code body_code
 517          info_down@(MkCgInfoDown cg_info statics _) state
 518   = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
 519   where
 520     info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
 521
 522     (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
 523         -- These vA and fA things are now set up as the body code expects them
 524
 525     state_at_end_return :: CgState
 526
 527     (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
 528
 529     state_for_body :: CgState
 530
 531     state_for_body = MkCgState AbsCNop
 532                              (nukeVolatileBinds binds)
 533                              ((vA,stubbed_fA,vA,vA),    -- Set real and hwms
 534                               (vB,fB,vB,vB),            -- to virtual ones
 535                               (initVirtHp, initRealHp))
 536
 537     stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
 538         -- In the branch, all free locations will have been stubbed
 539
 540
 541 stateIncUsageEval :: CgState -> CgState -> CgState
 542 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
 543                   (MkCgState absC2 _  (( _, _, _,hA2),( _, _, _,hB2),        _))
 544      = MkCgState (absC1 `AbsCStmts` absC2)
 545                  -- The AbsC coming back should consist only of nested declarations,
 546                  -- notably of the return vector!
 547                  bs
 548                  ((vA,fA,rA,hA1 `max` hA2),
 549                   (vB,fB,rB,hB1 `max` hB2),
 550                   heap_usage)
 551         -- We don't max the heap high-watermark because stateIncUsageEval is
 552         -- used only in forkEval, which in turn is only used for blocks of code
 553         -- which do their own heap-check.
 554 \end{code}
 555
 556 %************************************************************************
 557 %*                                                                      *
 558 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
 559 %*                                                                      *
 560 %************************************************************************
 561
 562 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
 563 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
 564 \begin{code}
 565 nopC :: Code
 566 nopC info_down state = state
 567
 568 absC :: AbstractC -> Code
 569 absC more_absC info_down state@(MkCgState absC binds usage)
 570   = MkCgState (mkAbsCStmts absC more_absC) binds usage
 571 \end{code}
 572
 573 These two are just like @absC@, except they examine the compilation
 574 info (whether SCC profiling or profiling-ctrs going) and possibly emit
 575 nothing.
 576
 577 \begin{code}
 578 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
 579
 580 costCentresC macro args _ state@(MkCgState absC binds usage)
 581   = if opt_SccProfilingOn
 582     then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
 583     else state
 584
 585 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
 586
 587 profCtrC macro args _ state@(MkCgState absC binds usage)
 588   = if not opt_DoTickyProfiling
 589     then state
 590     else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
 591
 592 {- Try to avoid adding too many special compilation strategies here.
 593    It's better to modify the header files as necessary for particular
 594    targets, so that we can get away with as few variants of .hc files
 595    as possible.  'ForConcurrent' is somewhat special anyway, as it
 596    changes entry conventions pretty significantly.
 597 -}
 598 \end{code}
 599
 600 @getAbsC@ compiles the code in the current environment, and returns
 601 the abstract C thus constructed (leaving the abstract C being carried
 602 around in the state untouched).  @getAbsC@ does not generate any
 603 in-line Abstract~C itself, but the environment it returns is that
 604 obtained from the compilation.
 605
 606 \begin{code}
 607 getAbsC :: Code -> FCode AbstractC
 608
 609 getAbsC code info_down (MkCgState absC binds usage)
 610   = (absC2, MkCgState absC binds2 usage2)
 611   where
 612     (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
 613 \end{code}
 614
 615 \begin{code}
 616 noBlackHolingFlag, costCentresFlag :: FCode Bool
 617
 618 noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
 619 costCentresFlag   _ state = (opt_SccProfilingOn, state)
 620 \end{code}
 621
 622 \begin{code}
 623
 624 moduleName :: FCode FAST_STRING
 625 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
 626   = (mod_name, state)
 627
 628 \end{code}
 629
 630 \begin{code}
 631 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
 632 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
 633   = code (MkCgInfoDown c_info statics eob_info) state
 634
 635 getEndOfBlockInfo :: FCode EndOfBlockInfo
 636 getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state
 637   = (eob_info, state)
 638 \end{code}
 639
 640 %************************************************************************
 641 %*                                                                      *
 642 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
 643 %*                                                                      *
 644 %************************************************************************
 645
 646 There are three basic routines, for adding (@addBindC@), modifying
 647 (@modifyBindC@) and looking up (@lookupBindC@) bindings.  Each routine
 648 is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
 649 on the end of each function name).
 650
 651 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
 652 The name should not already be bound.
 653 \begin{code}
 654 addBindC :: Id -> CgIdInfo -> Code
 655 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
 656   = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
 657 \end{code}
 658
 659 \begin{code}
 660 addBindsC :: [(Id, CgIdInfo)] -> Code
 661 addBindsC new_bindings info_down (MkCgState absC binds usage)
 662   = MkCgState absC new_binds usage
 663   where
 664     new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
 665                       binds
 666                       new_bindings
 667 \end{code}
 668
 669 \begin{code}
 670 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
 671 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
 672   = MkCgState absC (modifyIdEnv binds mangle_fn name) usage
 673 \end{code}
 674
 675 Lookup is expected to find a binding for the @Id@.
 676 \begin{code}
 677 lookupBindC :: Id -> FCode CgIdInfo
 678 lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
 679                  state@(MkCgState absC local_binds usage)
 680   = (val, state)
 681   where
 682     val = case (lookupIdEnv local_binds name) of
 683             Nothing     -> try_static
 684             Just this   -> this
 685
 686     try_static = case (lookupIdEnv static_binds name) of
 687                    Just this -> this
 688                    Nothing
 689                      -> pprPanic "lookupBindC:no info!\n"
 690                         (ppAboves [
 691                             ppCat [ppStr "for:", ppr PprShowAll name],
 692                             ppStr "(probably: data dependencies broken by an optimisation pass)",
 693                             ppStr "static binds for:",
 694                             ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
 695                             ppStr "local binds for:",
 696                             ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
 697                          ])
 698 \end{code}
 699
 700 %************************************************************************
 701 %*                                                                      *
 702 \subsection[CgStackery-deadslots]{Finding dead stack slots}
 703 %*                                                                      *
 704 %************************************************************************
 705
 706 @nukeDeadBindings@ does the following:
 707 \begin{itemize}
 708 \item   Removes all bindings from the environment other than those
 709         for variables in the argument to @nukeDeadBindings@.
 710 \item   Collects any stack slots so freed, and returns them to the appropriate
 711         stack free list.
 712 \item   Moves the virtual stack pointers to point to the topmost used
 713         stack locations.
 714 \end{itemize}
 715
 716 Find dead slots on the stacks *and* remove bindings for dead variables
 717 from the bindings.
 718
 719 You can have multi-word slots on the B stack; if dead, such a slot
 720 will be reported as {\em several} offsets (one per word).
 721
 722 NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
 723 set, so that no stack-stubbing will take place.
 724
 725 Probably *naughty* to look inside monad...
 726
 727 \begin{code}
 728 nukeDeadBindings :: StgLiveVars  -- All the *live* variables
 729                  -> Code
 730 nukeDeadBindings
 731         live_vars
 732         info_down
 733         state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
 734                                       (vsp_b, free_b, real_b, hw_b),
 735                                       heap_usage))
 736   = MkCgState abs_c (mkIdEnv bs') new_usage
 737   where
 738     new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
 739                  (new_vsp_b, new_free_b, real_b, hw_b),
 740                  heap_usage)
 741
 742     (dead_a_slots, dead_b_slots, bs')
 743       = dead_slots live_vars
 744                    [] [] []
 745                    [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
 746
 747     extra_free_a = (sortLt (<)  dead_a_slots) `zip` (repeat NotStubbed)
 748     extra_free_b = sortLt (<) dead_b_slots
 749
 750     (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
 751     (new_vsp_b, new_free_b) = trim id  vsp_b (addFreeBSlots free_b extra_free_b)
 752
 753 getUnstubbedAStackSlots
 754         :: VirtualSpAOffset             -- Ignore slots bigger than this
 755         -> FCode [VirtualSpAOffset]     -- Return the list of slots found
 756
 757 getUnstubbedAStackSlots tail_spa
 758         info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
 759   = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
 760 \end{code}
 761
 762 Several boring auxiliary functions to do the dirty work.
 763
 764 \begin{code}
 765 dead_slots :: StgLiveVars
 766            -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
 767            -> [(Id,CgIdInfo)]
 768            -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
 769
 770 -- dead_slots carries accumulating parameters for
 771 --      filtered bindings, dead a and b slots
 772 dead_slots live_vars fbs das dbs []
 773   = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
 774
 775 dead_slots live_vars fbs das dbs ((v,i):bs)
 776   | v `elementOfUniqSet` live_vars
 777     = dead_slots live_vars ((v,i):fbs) das dbs bs
 778           -- Live, so don't record it in dead slots
 779           -- Instead keep it in the filtered bindings
 780
 781   | otherwise
 782     = case i of
 783         MkCgIdInfo _ _ stable_loc _
 784          | is_Astk_loc ->
 785            dead_slots live_vars fbs (offsetA : das) dbs bs
 786
 787          | is_Bstk_loc ->
 788            dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
 789          where
 790            maybe_Astk_loc = maybeAStkLoc stable_loc
 791            is_Astk_loc    = maybeToBool maybe_Astk_loc
 792            (Just offsetA) = maybe_Astk_loc
 793
 794            maybe_Bstk_loc = maybeBStkLoc stable_loc
 795            is_Bstk_loc    = maybeToBool maybe_Bstk_loc
 796            (Just offsetB) = maybe_Bstk_loc
 797
 798         _ -> dead_slots live_vars fbs das dbs bs
 799   where
 800     size :: Int
 801     size = (getPrimRepSize . typePrimRep . idType) v
 802
 803 -- addFreeSlots expects *both* args to be in increasing order
 804 addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
 805 addFreeASlots = addFreeSlots fst
 806
 807 addFreeBSlots :: [Int] -> [Int] -> [Int]
 808 addFreeBSlots = addFreeSlots id
 809
 810 addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
 811
 812 addFreeSlots get_offset cs [] = cs
 813 addFreeSlots get_offset [] ns = ns
 814 addFreeSlots get_offset (c:cs) (n:ns)
 815  = if off_c < off_n then
 816         (c : addFreeSlots get_offset cs (n:ns))
 817    else if off_c > off_n then
 818         (n : addFreeSlots get_offset (c:cs) ns)
 819    else
 820         panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
 821  where
 822   off_c = get_offset c
 823   off_n = get_offset n
 824
 825 trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
 826
 827 trim get_offset current_sp free_slots
 828   = try current_sp (reverse free_slots)
 829   where
 830     try csp [] = (csp, [])
 831     try csp (slot:slots)
 832       = if csp < slot_off then
 833             try csp slots               -- Free slot off top of stk; ignore
 834
 835         else if csp == slot_off then
 836             try (csp-1) slots           -- Free slot at top of stk; trim
 837
 838         else
 839             (csp, reverse (slot:slots)) -- Otherwise gap; give up
 840       where
 841         slot_off = get_offset slot
 842 \end{code}