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