ghc/compiler/codeGen/CgMonad.lhs

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