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 module CgMonad (
  11         Code,   -- type
  12         FCode,  -- type
  13
  14         initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
  15         returnFC, fixC, absC, nopC, getAbsC,
  16
  17         forkClosureBody, forkStatics, forkAlts, forkEval,
  18         forkEvalHelp, forkAbsC,
  19         SemiTaggingStuff,
  20
  21         addBindC, addBindsC, modifyBindC, lookupBindC,
  22
  23         EndOfBlockInfo(..),
  24         setEndOfBlockInfo, getEndOfBlockInfo,
  25
  26         AStackUsage, BStackUsage, HeapUsage,
  27         StubFlag,
  28         isStubbed,
  29
  30         nukeDeadBindings, getUnstubbedAStackSlots,
  31
  32 --      addFreeASlots,  -- no need to export it
  33         addFreeBSlots,  -- ToDo: Belong elsewhere
  34
  35         noBlackHolingFlag,
  36         profCtrC,
  37
  38         costCentresC, costCentresFlag, moduleName,
  39
  40         Sequel(..), -- ToDo: unabstract?
  41         sequelToAmode,
  42
  43         -- out of general friendliness, we also export ...
  44         CgInfoDownwards(..), CgState(..),       -- non-abstract
  45         CompilationInfo(..)
  46     ) where
  47
  48 #include "HsVersions.h"
  49
  50 import  List    ( nub )
  51
  52 import {-# SOURCE #-} CgBindery ( CgIdInfo(..), CgBindings, maybeAStkLoc, maybeBStkLoc, nukeVolatileBinds )
  53 import {-# SOURCE #-} CgUsages
  54
  55 import AbsCSyn
  56 import AbsCUtils        ( mkAbsCStmts )
  57 import CmdLineOpts      ( opt_SccProfilingOn, opt_DoTickyProfiling,
  58                           opt_OmitBlackHoling
  59                         )
  60 import HeapOffs         ( maxOff,
  61                           VirtualSpAOffset, VirtualSpBOffset,
  62                           HeapOffset
  63                         )
  64 import CLabel           ( CLabel )
  65 import Id               ( idType,
  66                           nullIdEnv, mkIdEnv, addOneToIdEnv,
  67                           modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv,
  68                           ConTag, GenId{-instance Outputable-},
  69                           Id
  70                         )
  71 import Literal          ( Literal )
  72 import Maybes           ( maybeToBool )
  73 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  74 import StgSyn           ( StgLiveVars )
  75 import Type             ( typePrimRep )
  76 import UniqSet          ( elementOfUniqSet )
  77 import Util             ( sortLt )
  78 import Outputable
  79
  80 infixr 9 `thenC`        -- Right-associative!
  81 infixr 9 `thenFC`
  82 \end{code}
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsection[CgMonad-environment]{Stuff for manipulating environments}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 This monadery has some information that it only passes {\em
  91 downwards}, as well as some ``state'' which is modified as we go
  92 along.
  93
  94 \begin{code}
  95 data CgInfoDownwards    -- information only passed *downwards* by the monad
  96   = MkCgInfoDown
  97      CompilationInfo    -- COMPLETELY STATIC info about this compilation
  98                         --  (e.g., what flags were passed to the compiler)
  99
 100      CgBindings         -- [Id -> info] : static environment
 101
 102      EndOfBlockInfo     -- Info for stuff to do at end of basic block:
 103
 104
 105 data CompilationInfo
 106   = MkCompInfo
 107         FAST_STRING     -- the module name
 108
 109 data CgState
 110   = MkCgState
 111         AbstractC       -- code accumulated so far
 112         CgBindings      -- [Id -> info] : *local* bindings environment
 113                         -- Bindings for top-level things are given in the info-down part
 114         CgStksAndHeapUsage
 115 \end{code}
 116
 117 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
 118 if the expression is a @case@, what to do at the end of each
 119 alternative.
 120
 121 \begin{code}
 122 data EndOfBlockInfo
 123   = EndOfBlockInfo
 124         VirtualSpAOffset  -- Args SpA: trim the A stack to this point at a
 125                           -- return; push arguments starting just
 126                           -- above this point on a tail call.
 127
 128                           -- This is therefore the A-stk ptr as seen
 129                           -- by a case alternative.
 130
 131                           -- Args SpA is used when we want to stub any
 132                           -- currently-unstubbed dead A-stack (ptr)
 133                           -- slots; we want to know what SpA in the
 134                           -- continuation is so that we don't stub any
 135                           -- slots which are off the top of the
 136                           -- continuation's stack!
 137
 138         VirtualSpBOffset  -- Args SpB: Very similar to Args SpA.
 139                           -- Two main differences:
 140                           --  1. If Sequel isn't OnStack, then Args SpB points
 141                           --     just below the slot in which the return address
 142                           --     should be put.  In effect, the Sequel
 143                           --     is a pending argument.  If it is
 144                           --     OnStack, Args SpB
 145                           --     points to the top word of the return
 146                           --     address.
 147                           --
 148                           --  2. It ain't used for stubbing because there are
 149                           --     no ptrs on B stk.
 150         Sequel
 151
 152 initEobInfo = EndOfBlockInfo 0 0 InRetReg
 153 \end{code}
 154
 155 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
 156 that it must survive stack pointer adjustments at the end of the
 157 block.
 158
 159 \begin{code}
 160 data Sequel
 161   = InRetReg              -- The continuation is in RetReg
 162
 163   | OnStack VirtualSpBOffset
 164                           -- Continuation is on the stack, at the
 165                           -- specified location
 166
 167   | UpdateCode CAddrMode  -- May be standard update code, or might be
 168                           -- the data-type-specific one.
 169
 170   | CaseAlts
 171           CAddrMode   -- Jump to this; if the continuation is for a vectored
 172                       -- case this might be the label of a return
 173                       -- vector Guaranteed to be a non-volatile
 174                       -- addressing mode (I think)
 175           SemiTaggingStuff
 176
 177 type SemiTaggingStuff
 178   = Maybe                           -- Maybe[1] we don't have any semi-tagging stuff...
 179      ([(ConTag, JoinDetails)],      -- Alternatives
 180       Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
 181                                     -- Maybe[3] the default is a
 182                                     -- bind-default (Just b); that is,
 183                                     -- it expects a ptr to the thing
 184                                     -- in Node, bound to b
 185      )
 186
 187 type JoinDetails
 188   = (AbstractC, CLabel)         -- Code to load regs from heap object + profiling macros,
 189                                 -- and join point label
 190
 191 -- The abstract C is executed only from a successful semitagging
 192 -- venture, when a case has looked at a variable, found that it's
 193 -- evaluated, and wants to load up the contents and go to the join
 194 -- point.
 195
 196 -- DIRE WARNING.
 197 -- The OnStack case of sequelToAmode delivers an Amode which is only
 198 -- valid just before the final control transfer, because it assumes
 199 -- that SpB is pointing to the top word of the return address.  This
 200 -- seems unclean but there you go.
 201
 202 sequelToAmode :: Sequel -> FCode CAddrMode
 203
 204 sequelToAmode (OnStack virt_spb_offset)
 205   = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
 206     returnFC (CVal spb_rel RetRep)
 207
 208 sequelToAmode InRetReg           = returnFC (CReg RetReg)
 209 --Andy/Simon's patch:
 210 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
 211 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
 212 sequelToAmode (CaseAlts amode _) = returnFC amode
 213 \end{code}
 214
 215 See the NOTES about the details of stack/heap usage tracking.
 216
 217 \begin{code}
 218 type CgStksAndHeapUsage         -- stacks and heap usage information
 219   = (AStackUsage,               -- A-stack usage
 220      BStackUsage,               -- B-stack usage
 221      HeapUsage)
 222
 223 type AStackUsage =
 224         (Int,                   -- virtSpA: Virtual offset of topmost allocated slot
 225          [(Int,StubFlag)],      -- freeA:   List of free slots, in increasing order
 226          Int,                   -- realSpA: Virtual offset of real stack pointer
 227          Int)                   -- hwSpA:   Highest value ever taken by virtSp
 228
 229 data StubFlag = Stubbed | NotStubbed
 230
 231 isStubbed Stubbed    = True  -- so the type can be abstract
 232 isStubbed NotStubbed = False
 233
 234 type BStackUsage =
 235         (Int,           -- virtSpB: Virtual offset of topmost allocated slot
 236          [Int],         -- freeB:   List of free slots, in increasing order
 237          Int,           -- realSpB: Virtual offset of real stack pointer
 238          Int)           -- hwSpB:   Highest value ever taken by virtSp
 239
 240 type HeapUsage =
 241         (HeapOffset,    -- virtHp: Virtual offset of highest-numbered allocated word
 242          HeapOffset)    -- realHp: Virtual offset of real heap ptr
 243 \end{code}
 244 NB: absolutely every one of the above Ints is really
 245 a VirtualOffset of some description (the code generator
 246 works entirely in terms of VirtualOffsets; see NOTES).
 247
 248 Initialisation.
 249
 250 \begin{code}
 251 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
 252
 253 initUsage :: CgStksAndHeapUsage
 254 initUsage  = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
 255 initVirtHp = panic "Uninitialised virtual Hp"
 256 initRealHp = panic "Uninitialised real Hp"
 257 \end{code}
 258
 259 @envInitForAlternatives@ initialises the environment for a case alternative,
 260 assuming that the alternative is entered after an evaluation.
 261 This involves:
 262 \begin{itemize}
 263 \item
 264 zapping any volatile bindings, which aren't valid.
 265 \item
 266 zapping the heap usage.  It should be restored by a heap check.
 267 \item
 268 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
 269 this doesn't represent any {\em code}; it is a prediction of where the
 270 real stack pointer will be when we come back from the case analysis.
 271 \item
 272 BUT LEAVING the rest of the stack-usage info because it is all valid.
 273 In particular, we leave the tail stack pointers unchanged, becuase the
 274 alternative has to de-allocate the original @case@ expression's stack.
 275 \end{itemize}
 276
 277 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
 278 marks found in $e_2$.
 279
 280 \begin{code}
 281 stateIncUsage :: CgState -> CgState -> CgState
 282
 283 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
 284               (MkCgState _     _  (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
 285      = MkCgState abs_c
 286                  bs
 287                  ((vA,fA,rA,hA1 `max` hA2),
 288                   (vB,fB,rB,hB1 `max` hB2),
 289                   (vH1 `maxOff` vH2, rH1))
 290 \end{code}
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection[CgMonad-basics]{Basic code-generation monad magic}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 \begin{code}
 299 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
 300 type Code    = CgInfoDownwards -> CgState -> CgState
 301
 302 {-# INLINE thenC #-}
 303 {-# INLINE thenFC #-}
 304 {-# INLINE returnFC #-}
 305 \end{code}
 306 The Abstract~C is not in the environment so as to improve strictness.
 307
 308 \begin{code}
 309 initC :: CompilationInfo -> Code -> AbstractC
 310
 311 initC cg_info code
 312   = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
 313                initialStateC) of
 314       MkCgState abc _ _ -> abc
 315
 316 returnFC :: a -> FCode a
 317
 318 returnFC val info_down state = (val, state)
 319 \end{code}
 320
 321 \begin{code}
 322 thenC :: Code
 323       -> (CgInfoDownwards -> CgState -> a)
 324       -> CgInfoDownwards -> CgState -> a
 325
 326 -- thenC has both of the following types:
 327 -- thenC :: Code -> Code    -> Code
 328 -- thenC :: Code -> FCode a -> FCode a
 329
 330 thenC m k info_down state
 331   = k info_down new_state
 332   where
 333     new_state  = m info_down state
 334
 335 listCs :: [Code] -> Code
 336
 337 listCs []     info_down state = state
 338 listCs (c:cs) info_down state = stateN
 339   where
 340     state1 = c         info_down state
 341     stateN = listCs cs info_down state1
 342
 343 mapCs :: (a -> Code) -> [a] -> Code
 344
 345 mapCs f []     info_down state = state
 346 mapCs f (c:cs) info_down state = stateN
 347   where
 348     state1 = (f c)      info_down state
 349     stateN = mapCs f cs info_down state1
 350 \end{code}
 351
 352 \begin{code}
 353 thenFC  :: FCode a
 354         -> (a -> CgInfoDownwards -> CgState -> c)
 355         -> CgInfoDownwards -> CgState -> c
 356
 357 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
 358 -- thenFC :: FCode a -> (a -> Code)    -> Code
 359
 360 thenFC m k info_down state
 361   = k m_result info_down new_state
 362   where
 363     (m_result, new_state) = m info_down state
 364
 365 listFCs :: [FCode a] -> FCode [a]
 366
 367 listFCs []       info_down state = ([],             state)
 368 listFCs (fc:fcs) info_down state = (thing : things, stateN)
 369   where
 370     (thing,  state1) = fc          info_down state
 371     (things, stateN) = listFCs fcs info_down state1
 372
 373 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
 374
 375 mapFCs f []       info_down state = ([],             state)
 376 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
 377   where
 378     (thing,  state1) = (f fc)       info_down state
 379     (things, stateN) = mapFCs f fcs info_down state1
 380 \end{code}
 381
 382 And the knot-tying combinator:
 383 \begin{code}
 384 fixC :: (a -> FCode a) -> FCode a
 385 fixC fcode info_down state = result
 386   where
 387     result@(v, _) = fcode v info_down state
 388     --      ^-------------^
 389 \end{code}
 390
 391 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
 392 fresh environment, except that:
 393         - compilation info and statics are passed in unchanged.
 394 The current environment is passed on completely unaltered, except that
 395 abstract C from the fork is incorporated.
 396
 397 @forkAbsC@ takes a code and compiles it in the current environment,
 398 returning the abstract C thus constructed.  The current environment
 399 is passed on completely unchanged.  It is pretty similar to @getAbsC@,
 400 except that the latter does affect the environment. ToDo: combine?
 401
 402 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
 403 from the current bindings, but which is otherwise freshly initialised.
 404 The Abstract~C returned is attached to the current state, but the
 405 bindings and usage information is otherwise unchanged.
 406
 407 \begin{code}
 408 forkClosureBody :: Code -> Code
 409
 410 forkClosureBody code
 411         (MkCgInfoDown cg_info statics _)
 412         (MkCgState absC_in binds un_usage)
 413   = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
 414   where
 415     fork_state              = code body_info_down initialStateC
 416     MkCgState absC_fork _ _ = fork_state
 417     body_info_down = MkCgInfoDown cg_info statics initEobInfo
 418
 419 forkStatics :: FCode a -> FCode a
 420
 421 forkStatics fcode (MkCgInfoDown cg_info _ _)
 422                   (MkCgState absC_in statics un_usage)
 423   = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
 424   where
 425   (result, state) = fcode rhs_info_down initialStateC
 426   MkCgState absC_fork _ _ = state       -- Don't merge these this line with the one
 427                                         -- above or it becomes too strict!
 428   rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
 429
 430 forkAbsC :: Code -> FCode AbstractC
 431 forkAbsC code info_down (MkCgState absC1 bs usage)
 432   = (absC2, new_state)
 433   where
 434     MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
 435         code info_down (MkCgState AbsCNop bs usage)
 436     ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
 437
 438     new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
 439     new_state = MkCgState absC1 bs new_usage
 440 \end{code}
 441
 442 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
 443 an fcode for the default case $d$, and compiles each in the current
 444 environment.  The current environment is passed on unmodified, except
 445 that
 446         - the worst stack high-water mark is incorporated
 447         - the virtual Hp is moved on to the worst virtual Hp for the branches
 448
 449 The "extra branches" arise from handling the default case:
 450
 451         case f x of
 452           C1 a b -> e1
 453           z     -> e2
 454
 455 Here we in effect expand to
 456
 457         case f x of
 458           C1 a b -> e1
 459           C2 c -> let z = C2 c in JUMP(default)
 460           C3 d e f -> let z = C2 d e f in JUMP(default)
 461
 462           default: e2
 463
 464 The stuff for C2 and C3 are the extra branches.  They are
 465 handled differently by forkAlts, because their
 466 heap usage is joined onto that for the default case.
 467
 468 \begin{code}
 469 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
 470
 471 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
 472  = ((extra_branch_results ++ branch_results , deflt_result), out_state)
 473   where
 474     compile fc = fc info_down in_state
 475
 476     (branch_results,       branch_out_states)       = unzip (map compile branch_fcodes)
 477     (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
 478
 479         -- The "in_state" for the default branch is got by worst-casing the
 480         -- heap usages etc from the "extra_branches"
 481     default_in_state                = foldl stateIncUsage in_state extra_branch_out_states
 482     (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
 483
 484     out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
 485                 -- NB foldl.  in_state is the *left* argument to stateIncUsage
 486 \end{code}
 487
 488 @forkEval@ takes two blocks of code.
 489 \begin{itemize}
 490 \item The first meddles with the environment to set it up as expected by
 491         the alternatives of a @case@ which does an eval (or gc-possible primop).
 492 \item The second block is the code for the alternatives.
 493         (plus info for semi-tagging purposes)
 494 \end{itemize}
 495 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
 496 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
 497 the caller to use, together with whatever value is returned by the second block.
 498
 499 It uses @initEnvForAlternatives@ to initialise the environment, and
 500 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
 501 usage.
 502
 503 \begin{code}
 504 forkEval :: EndOfBlockInfo              -- For the body
 505          -> Code                        -- Code to set environment
 506          -> FCode Sequel                -- Semi-tagging info to store
 507          -> FCode EndOfBlockInfo        -- The new end of block info
 508
 509 forkEval body_eob_info env_code body_code
 510   = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
 511     returnFC (EndOfBlockInfo vA vB sequel)
 512
 513 forkEvalHelp :: EndOfBlockInfo  -- For the body
 514              -> Code            -- Code to set environment
 515              -> FCode a         -- The code to do after the eval
 516              -> FCode (Int,     -- SpA
 517                        Int,     -- SpB
 518                        a)       -- Result of the FCode
 519
 520 forkEvalHelp body_eob_info env_code body_code
 521          info_down@(MkCgInfoDown cg_info statics _) state
 522   = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
 523   where
 524     info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
 525
 526     (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
 527         -- These vA and fA things are now set up as the body code expects them
 528
 529     state_at_end_return :: CgState
 530
 531     (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
 532
 533     state_for_body :: CgState
 534
 535     state_for_body = MkCgState AbsCNop
 536                              (nukeVolatileBinds binds)
 537                              ((vA,stubbed_fA,vA,vA),    -- Set real and hwms
 538                               (vB,fB,vB,vB),            -- to virtual ones
 539                               (initVirtHp, initRealHp))
 540
 541     stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
 542         -- In the branch, all free locations will have been stubbed
 543
 544
 545 stateIncUsageEval :: CgState -> CgState -> CgState
 546 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
 547                   (MkCgState absC2 _  (( _, _, _,hA2),( _, _, _,hB2),        _))
 548      = MkCgState (absC1 `AbsCStmts` absC2)
 549                  -- The AbsC coming back should consist only of nested declarations,
 550                  -- notably of the return vector!
 551                  bs
 552                  ((vA,fA,rA,hA1 `max` hA2),
 553                   (vB,fB,rB,hB1 `max` hB2),
 554                   heap_usage)
 555         -- We don't max the heap high-watermark because stateIncUsageEval is
 556         -- used only in forkEval, which in turn is only used for blocks of code
 557         -- which do their own heap-check.
 558 \end{code}
 559
 560 %************************************************************************
 561 %*                                                                      *
 562 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
 563 %*                                                                      *
 564 %************************************************************************
 565
 566 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
 567 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
 568 \begin{code}
 569 nopC :: Code
 570 nopC info_down state = state
 571
 572 absC :: AbstractC -> Code
 573 absC more_absC info_down state@(MkCgState absC binds usage)
 574   = MkCgState (mkAbsCStmts absC more_absC) binds usage
 575 \end{code}
 576
 577 These two are just like @absC@, except they examine the compilation
 578 info (whether SCC profiling or profiling-ctrs going) and possibly emit
 579 nothing.
 580
 581 \begin{code}
 582 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
 583
 584 costCentresC macro args _ state@(MkCgState absC binds usage)
 585   = if opt_SccProfilingOn
 586     then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
 587     else state
 588
 589 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
 590
 591 profCtrC macro args _ state@(MkCgState absC binds usage)
 592   = if not opt_DoTickyProfiling
 593     then state
 594     else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
 595
 596 {- Try to avoid adding too many special compilation strategies here.
 597    It's better to modify the header files as necessary for particular
 598    targets, so that we can get away with as few variants of .hc files
 599    as possible.  'ForConcurrent' is somewhat special anyway, as it
 600    changes entry conventions pretty significantly.
 601 -}
 602 \end{code}
 603
 604 @getAbsC@ compiles the code in the current environment, and returns
 605 the abstract C thus constructed (leaving the abstract C being carried
 606 around in the state untouched).  @getAbsC@ does not generate any
 607 in-line Abstract~C itself, but the environment it returns is that
 608 obtained from the compilation.
 609
 610 \begin{code}
 611 getAbsC :: Code -> FCode AbstractC
 612
 613 getAbsC code info_down (MkCgState absC binds usage)
 614   = (absC2, MkCgState absC binds2 usage2)
 615   where
 616     (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
 617 \end{code}
 618
 619 \begin{code}
 620 noBlackHolingFlag, costCentresFlag :: FCode Bool
 621
 622 noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
 623 costCentresFlag   _ state = (opt_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. (nice ASSERT, eh?)
 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 mangle_fn binds 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                         (vcat [
 695                             hsep [ptext SLIT("for:"), ppr name],
 696                             ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
 697                             ptext SLIT("static binds for:"),
 698                             vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
 699                             ptext SLIT("local binds for:"),
 700                             vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
 701                          ])
 702 \end{code}
 703
 704 %************************************************************************
 705 %*                                                                      *
 706 \subsection[CgMonad-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 . typePrimRep . 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}