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