ghc/compiler/codeGen/CgMonad.lhs

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