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