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