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