ghc/compiler/codeGen/CgMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgMonad.lhs,v 1.39 2003/07/02 13:12:38 simonpj Exp $
   5 %
   6 \section[CgMonad]{The code generation monad}
   7
   8 See the beginning of the top-level @CodeGen@ module, to see how this
   9 monadic stuff fits into the Big Picture.
  10
  11 \begin{code}
  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         EndOfBlockInfo(..),
  24         setEndOfBlockInfo, getEndOfBlockInfo,
  25
  26         setSRTLabel, getSRTLabel, getSRTInfo,
  27         setTickyCtrLabel, getTickyCtrLabel,
  28
  29         StackUsage, Slot(..), HeapUsage,
  30
  31         profCtrC, profCtrAbsC, ldvEnter,
  32
  33         costCentresC, moduleName,
  34
  35         Sequel(..), -- ToDo: unabstract?
  36         sequelToAmode,
  37
  38         -- ideally we wouldn't export these, but some other modules access internal state
  39         getState, setState, getInfoDown,
  40
  41         -- more localised access to monad state
  42         getUsage, setUsage,
  43         getBinds, setBinds, getStaticBinds,
  44
  45         -- out of general friendliness, we also export ...
  46         CgInfoDownwards(..), CgState(..),       -- non-abstract
  47         CompilationInfo(..)
  48     ) where
  49
  50 #include "HsVersions.h"
  51
  52 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
  53 import {-# SOURCE #-} CgUsages  ( getSpRelOffset )
  54
  55 import AbsCSyn
  56 import CLabel
  57 import StgSyn           ( SRT(..) )
  58 import AbsCUtils        ( mkAbsCStmts )
  59 import CmdLineOpts      ( opt_SccProfilingOn, opt_DoTickyProfiling )
  60 import Module           ( Module )
  61 import DataCon          ( ConTag )
  62 import Id               ( Id )
  63 import Name             ( Name )
  64 import VarEnv
  65 import PrimRep          ( PrimRep(..) )
  66 import SMRep            ( StgHalfWord, hALF_WORD )
  67 import FastString
  68 import Outputable
  69
  70 infixr 9 `thenC`        -- Right-associative!
  71 infixr 9 `thenFC`
  72 \end{code}
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection[CgMonad-environment]{Stuff for manipulating environments}
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 This monadery has some information that it only passes {\em
  81 downwards}, as well as some ``state'' which is modified as we go
  82 along.
  83
  84 \begin{code}
  85 data CgInfoDownwards    -- information only passed *downwards* by the monad
  86   = MkCgInfoDown
  87      CompilationInfo    -- COMPLETELY STATIC info about this compilation
  88                         --  (e.g., what flags were passed to the compiler)
  89
  90      CgBindings         -- [Id -> info] : static environment
  91
  92      CLabel             -- label of the current SRT
  93
  94      CLabel             -- current destination for ticky counts
  95
  96      EndOfBlockInfo     -- Info for stuff to do at end of basic block:
  97
  98
  99 data CompilationInfo
 100   = MkCompInfo
 101         Module          -- the module name
 102
 103 data CgState
 104   = MkCgState
 105         AbstractC       -- code accumulated so far
 106         CgBindings      -- [Id -> info] : *local* bindings environment
 107                         -- Bindings for top-level things are given in the info-down part
 108         CgStksAndHeapUsage
 109 \end{code}
 110
 111 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
 112 if the expression is a @case@, what to do at the end of each
 113 alternative.
 114
 115 \begin{code}
 116 data EndOfBlockInfo
 117   = EndOfBlockInfo
 118         VirtualSpOffset   -- Args Sp: trim the stack to this point at a
 119                           -- return; push arguments starting just
 120                           -- above this point on a tail call.
 121
 122                           -- This is therefore the stk ptr as seen
 123                           -- by a case alternative.
 124         Sequel
 125
 126 initEobInfo = EndOfBlockInfo 0 (OnStack 0)
 127 \end{code}
 128
 129 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
 130 that it must survive stack pointer adjustments at the end of the
 131 block.
 132
 133 \begin{code}
 134 data Sequel
 135   = OnStack
 136         VirtualSpOffset   -- Continuation is on the stack, at the
 137                           -- specified location
 138
 139   | UpdateCode
 140
 141   | CaseAlts
 142           CAddrMode   -- Jump to this; if the continuation is for a vectored
 143                       -- case this might be the label of a return
 144                       -- vector Guaranteed to be a non-volatile
 145                       -- addressing mode (I think)
 146           SemiTaggingStuff
 147
 148           Bool        -- True <=> polymorphic, push a SEQ frame too
 149
 150
 151 type SemiTaggingStuff
 152   = Maybe                           -- Maybe[1] we don't have any semi-tagging stuff...
 153      ([(ConTag, JoinDetails)],      -- Alternatives
 154       Maybe (Id, JoinDetails)       -- Default (but Maybe[2] we don't have one)
 155                                     -- The default branch expects a
 156                                     -- it expects a ptr to the thing
 157                                     -- in Node, bound to b
 158      )
 159
 160 type JoinDetails
 161   = (AbstractC, CLabel)         -- Code to load regs from heap object + profiling macros,
 162                                 -- and join point label
 163
 164 -- The abstract C is executed only from a successful semitagging
 165 -- venture, when a case has looked at a variable, found that it's
 166 -- evaluated, and wants to load up the contents and go to the join
 167 -- point.
 168
 169 -- DIRE WARNING.
 170 -- The OnStack case of sequelToAmode delivers an Amode which is only
 171 -- valid just before the final control transfer, because it assumes
 172 -- that Sp is pointing to the top word of the return address.  This
 173 -- seems unclean but there you go.
 174
 175 -- sequelToAmode returns an amode which refers to an info table.  The info
 176 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind.  We're careful
 177 -- not to handle real code pointers, just in case we're compiling for
 178 -- an unregisterised/untailcallish architecture, where info pointers and
 179 -- code pointers aren't the same.
 180
 181 sequelToAmode :: Sequel -> FCode CAddrMode
 182
 183 sequelToAmode (OnStack virt_sp_offset)
 184   = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
 185     returnFC (CVal sp_rel RetRep)
 186
 187 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
 188
 189 sequelToAmode (CaseAlts amode _ False) = returnFC amode
 190 sequelToAmode (CaseAlts amode _ True)  = returnFC (CLbl mkSeqInfoLabel RetRep)
 191
 192 type CgStksAndHeapUsage         -- stacks and heap usage information
 193   = (StackUsage, HeapUsage)
 194
 195 data Slot = Free | NonPointer
 196   deriving
 197 #ifdef DEBUG
 198         (Eq,Show)
 199 #else
 200         Eq
 201 #endif
 202
 203 type StackUsage =
 204         (Int,              -- virtSp:  Virtual offset of topmost allocated slot
 205          Int,              -- frameSp: End of the current stack frame
 206          [(Int,Slot)],     -- free:    List of free slots, in increasing order
 207          Int,              -- realSp:  Virtual offset of real stack pointer
 208          Int)              -- hwSp:    Highest value ever taken by virtSp
 209
 210 -- ToDo (SDM, 7 Jan 2003): I'm not sure that the distinction between
 211 -- Free and NonPointer in the free list is needed any more.  It used
 212 -- to be needed because we constructed bitmaps from the free list, but
 213 -- now we construct bitmaps by finding all the live pointer bindings
 214 -- instead.  Non-pointer stack slots (i.e. saved cost centres) can
 215 -- just be removed from the free list instead of being recorded as a
 216 -- NonPointer.
 217
 218 type HeapUsage =
 219         (HeapOffset,    -- virtHp: Virtual offset of highest-allocated word
 220          HeapOffset)    -- realHp: Virtual offset of real heap ptr
 221 \end{code}
 222
 223 NB: absolutely every one of the above Ints is really
 224 a VirtualOffset of some description (the code generator
 225 works entirely in terms of VirtualOffsets).
 226
 227 Initialisation.
 228
 229 \begin{code}
 230 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
 231
 232 initUsage :: CgStksAndHeapUsage
 233 initUsage  = ((0,0,[],0,0), (0,0))
 234 \end{code}
 235
 236 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
 237 marks found in $e_2$.
 238
 239 \begin{code}
 240 stateIncUsage :: CgState -> CgState -> CgState
 241
 242 stateIncUsage (MkCgState abs_c bs ((v,t,f,r,h1),(vH1,rH1)))
 243               (MkCgState _     _  ((_,_,_,_,h2),(vH2, _)))
 244      = MkCgState abs_c
 245                  bs
 246                  ((v,t,f,r,h1 `max` h2),
 247                   (vH1 `max` vH2, rH1))
 248 \end{code}
 249
 250 %************************************************************************
 251 %*                                                                      *
 252 \subsection[CgMonad-basics]{Basic code-generation monad magic}
 253 %*                                                                      *
 254 %************************************************************************
 255
 256 \begin{code}
 257 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
 258 type Code    = FCode ()
 259
 260 instance Monad FCode where
 261         (>>=) = thenFC
 262         return = returnFC
 263
 264 {-# INLINE thenC #-}
 265 {-# INLINE thenFC #-}
 266 {-# INLINE returnFC #-}
 267 \end{code}
 268 The Abstract~C is not in the environment so as to improve strictness.
 269
 270 \begin{code}
 271 initC :: CompilationInfo -> Code -> AbstractC
 272
 273 initC cg_info (FCode code)
 274   = case (code (MkCgInfoDown
 275                         cg_info
 276                         emptyVarEnv -- (error "initC: statics")
 277                         (error "initC: srt")
 278                         (mkTopTickyCtrLabel)
 279                         initEobInfo)
 280                initialStateC) of
 281       ((),MkCgState abc _ _) -> abc
 282
 283 returnFC :: a -> FCode a
 284 returnFC val = FCode (\info_down state -> (val, state))
 285 \end{code}
 286
 287 \begin{code}
 288 thenC :: Code -> FCode a -> FCode a
 289 thenC (FCode m) (FCode k) =
 290         FCode (\info_down state -> let (_,new_state) = m info_down state in
 291                 k info_down new_state)
 292
 293 listCs :: [Code] -> Code
 294 listCs [] = return ()
 295 listCs (fc:fcs) = do
 296         fc
 297         listCs fcs
 298
 299 mapCs :: (a -> Code) -> [a] -> Code
 300 mapCs = mapM_
 301 \end{code}
 302
 303 \begin{code}
 304 thenFC  :: FCode a -> (a -> FCode c) -> FCode c
 305 thenFC (FCode m) k = FCode (
 306         \info_down state ->
 307                 let
 308                         (m_result, new_state) = m info_down state
 309                         (FCode kcode) = k m_result
 310                 in
 311                         kcode info_down new_state
 312         )
 313
 314 listFCs :: [FCode a] -> FCode [a]
 315 listFCs = sequence
 316
 317 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
 318 mapFCs = mapM
 319 \end{code}
 320
 321 And the knot-tying combinator:
 322 \begin{code}
 323 fixC :: (a -> FCode a) -> FCode a
 324 fixC fcode = FCode (
 325         \info_down state ->
 326                 let
 327                         FCode fc = fcode v
 328                         result@(v,_) = fc info_down state
 329                         --          ^--------^
 330                 in
 331                         result
 332         )
 333 \end{code}
 334
 335 Operators for getting and setting the state and "info_down".
 336 To maximise encapsulation, code should try to only get and set the
 337 state it actually uses.
 338
 339 \begin{code}
 340 getState :: FCode CgState
 341 getState = FCode $ \info_down state -> (state,state)
 342
 343 setState :: CgState -> FCode ()
 344 setState state = FCode $ \info_down _ -> ((),state)
 345
 346 getUsage :: FCode CgStksAndHeapUsage
 347 getUsage = do
 348         MkCgState absC binds usage <- getState
 349         return usage
 350
 351 setUsage :: CgStksAndHeapUsage -> FCode ()
 352 setUsage newusage = do
 353         MkCgState absC binds usage <- getState
 354         setState $ MkCgState absC binds newusage
 355
 356 getBinds :: FCode CgBindings
 357 getBinds = do
 358         MkCgState absC binds usage <- getState
 359         return binds
 360
 361 setBinds :: CgBindings -> FCode ()
 362 setBinds newbinds = do
 363         MkCgState absC binds usage <- getState
 364         setState $ MkCgState absC newbinds usage
 365
 366 getStaticBinds :: FCode CgBindings
 367 getStaticBinds = do
 368         (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
 369         return static_binds
 370
 371 withState :: FCode a -> CgState -> FCode (a,CgState)
 372 withState (FCode fcode) newstate = FCode $ \info_down state ->
 373         let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
 374
 375 getInfoDown :: FCode CgInfoDownwards
 376 getInfoDown = FCode $ \info_down state -> (info_down,state)
 377
 378 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
 379 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
 380
 381 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
 382 doFCode (FCode fcode) info_down state = fcode info_down state
 383 \end{code}
 384
 385
 386 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
 387 fresh environment, except that:
 388         - compilation info and statics are passed in unchanged.
 389 The current environment is passed on completely unaltered, except that
 390 abstract C from the fork is incorporated.
 391
 392 @forkAbsC@ takes a code and compiles it in the current environment,
 393 returning the abstract C thus constructed.  The current environment
 394 is passed on completely unchanged.  It is pretty similar to @getAbsC@,
 395 except that the latter does affect the environment. ToDo: combine?
 396
 397 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
 398 from the current bindings, but which is otherwise freshly initialised.
 399 The Abstract~C returned is attached to the current state, but the
 400 bindings and usage information is otherwise unchanged.
 401
 402 \begin{code}
 403 forkClosureBody :: Code -> Code
 404
 405 forkClosureBody (FCode code) = do
 406         (MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
 407         (MkCgState absC_in binds un_usage) <- getState
 408         let     body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
 409         let     ((),fork_state)             = code body_info_down initialStateC
 410         let     MkCgState absC_fork _ _ = fork_state
 411         setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
 412
 413 forkStatics :: FCode a -> FCode a
 414
 415 forkStatics (FCode fcode) = FCode (
 416         \(MkCgInfoDown cg_info _ srt ticky _)
 417         (MkCgState absC_in statics un_usage)
 418   ->
 419         let
 420                 (result, state) = fcode rhs_info_down initialStateC
 421                 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
 422                                 -- above or it becomes too strict!
 423                 rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
 424         in
 425                 (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
 426         )
 427
 428 forkAbsC :: Code -> FCode AbstractC
 429 forkAbsC (FCode code) =
 430         do
 431                 info_down <- getInfoDown
 432                 (MkCgState absC1 bs usage) <- getState
 433                 let ((),MkCgState absC2 _ ((_, _, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
 434                 let ((v, t, f, r, h1), heap_usage) = usage
 435                 let new_usage = ((v, t, f, r, h1 `max` h2), heap_usage)
 436                 setState $ MkCgState absC1 bs new_usage
 437                 return absC2
 438 \end{code}
 439
 440 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
 441 an fcode for the default case $d$, and compiles each in the current
 442 environment.  The current environment is passed on unmodified, except
 443 that
 444         - the worst stack high-water mark is incorporated
 445         - the virtual Hp is moved on to the worst virtual Hp for the branches
 446
 447 \begin{code}
 448 forkAlts :: [FCode a] -> FCode [a]
 449
 450 forkAlts branch_fcodes
 451   = do  info_down <- getInfoDown
 452         in_state  <- getState
 453         let compile (FCode fc)                  = fc info_down in_state
 454         let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
 455         setState $ foldl stateIncUsage in_state branch_out_states
 456                         -- NB foldl.  in_state is the *left* argument to stateIncUsage
 457         return branch_results
 458 \end{code}
 459
 460 @forkEval@ takes two blocks of code.
 461
 462    -  The first meddles with the environment to set it up as expected by
 463       the alternatives of a @case@ which does an eval (or gc-possible primop).
 464    -  The second block is the code for the alternatives.
 465       (plus info for semi-tagging purposes)
 466
 467 @forkEval@ picks up the virtual stack pointer and returns a suitable
 468 @EndOfBlockInfo@ for the caller to use, together with whatever value
 469 is returned by the second block.
 470
 471 It uses @initEnvForAlternatives@ to initialise the environment, and
 472 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
 473 usage.
 474
 475 \begin{code}
 476 forkEval :: EndOfBlockInfo              -- For the body
 477          -> Code                        -- Code to set environment
 478          -> FCode Sequel                -- Semi-tagging info to store
 479          -> FCode EndOfBlockInfo        -- The new end of block info
 480
 481 forkEval body_eob_info env_code body_code
 482   = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
 483     returnFC (EndOfBlockInfo v sequel)
 484
 485 forkEvalHelp :: EndOfBlockInfo  -- For the body
 486              -> Code            -- Code to set environment
 487              -> FCode a         -- The code to do after the eval
 488              -> FCode (Int,     -- Sp
 489                        a)       -- Result of the FCode
 490
 491 forkEvalHelp body_eob_info env_code body_code =
 492         do
 493                 info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
 494                 state <- getState
 495                 let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
 496                 let (_,MkCgState _ binds ((v,t,f,_,_),_)) =
 497                         doFCode env_code info_down_for_body state
 498                 let state_for_body = MkCgState AbsCNop
 499                              (nukeVolatileBinds binds)
 500                              ((v,t,f,v,v), (0,0))
 501                 let (value_returned, state_at_end_return) =
 502                         doFCode body_code info_down_for_body state_for_body
 503                 setState $ state `stateIncUsageEval` state_at_end_return
 504                 return (v,value_returned)
 505
 506 stateIncUsageEval :: CgState -> CgState -> CgState
 507 stateIncUsageEval (MkCgState absC1 bs ((v,t,f,r,h1),heap_usage))
 508                   (MkCgState absC2 _  ((_,_,_,_,h2),         _))
 509      = MkCgState (absC1 `mkAbsCStmts` absC2)
 510                  -- The AbsC coming back should consist only of nested declarations,
 511                  -- notably of the return vector!
 512                  bs
 513                  ((v,t,f,r,h1 `max` h2), heap_usage)
 514         -- We don't max the heap high-watermark because stateIncUsageEval is
 515         -- used only in forkEval, which in turn is only used for blocks of code
 516         -- which do their own heap-check.
 517 \end{code}
 518
 519 %************************************************************************
 520 %*                                                                      *
 521 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
 522 %*                                                                      *
 523 %************************************************************************
 524
 525 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
 526 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
 527 \begin{code}
 528 nopC :: Code
 529 nopC = return ()
 530
 531 absC :: AbstractC -> Code
 532 absC more_absC = do
 533         state@(MkCgState absC binds usage) <- getState
 534         setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
 535 \end{code}
 536
 537 These two are just like @absC@, except they examine the compilation
 538 info (whether SCC profiling or profiling-ctrs going) and possibly emit
 539 nothing.
 540
 541 \begin{code}
 542 costCentresC :: FastString -> [CAddrMode] -> Code
 543 costCentresC macro args
 544  | opt_SccProfilingOn  = absC (CCallProfCCMacro macro args)
 545  | otherwise           = nopC
 546
 547 profCtrC :: FastString -> [CAddrMode] -> Code
 548 profCtrC macro args
 549  | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args)
 550  | otherwise            = nopC
 551
 552 profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC
 553 profCtrAbsC macro args
 554  | opt_DoTickyProfiling = CCallProfCtrMacro macro args
 555  | otherwise            = AbsCNop
 556
 557 ldvEnter :: Code
 558 ldvEnter = costCentresC FSLIT("LDV_ENTER") [CReg node]
 559
 560 {- Try to avoid adding too many special compilation strategies here.
 561    It's better to modify the header files as necessary for particular
 562    targets, so that we can get away with as few variants of .hc files
 563    as possible.
 564 -}
 565 \end{code}
 566
 567 @getAbsC@ compiles the code in the current environment, and returns
 568 the abstract C thus constructed (leaving the abstract C being carried
 569 around in the state untouched).  @getAbsC@ does not generate any
 570 in-line Abstract~C itself, but the environment it returns is that
 571 obtained from the compilation.
 572
 573 \begin{code}
 574 getAbsC :: Code -> FCode AbstractC
 575 getAbsC code = do
 576         MkCgState absC binds usage <- getState
 577         ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage)
 578         setState $ MkCgState absC binds2 usage2
 579         return absC2
 580 \end{code}
 581
 582 \begin{code}
 583 moduleName :: FCode Module
 584 moduleName = do
 585         (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
 586         return mod_name
 587 \end{code}
 588
 589 \begin{code}
 590 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
 591 setEndOfBlockInfo eob_info code = do
 592         (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
 593         withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
 594
 595 getEndOfBlockInfo :: FCode EndOfBlockInfo
 596 getEndOfBlockInfo = do
 597         (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
 598         return eob_info
 599 \end{code}
 600
 601 There is just one SRT for each top level binding; all the nested
 602 bindings use sub-sections of this SRT.  The label is passed down to
 603 the nested bindings via the monad.
 604
 605 \begin{code}
 606 getSRTInfo :: Name -> SRT -> FCode C_SRT
 607 getSRTInfo id NoSRT = return NoC_SRT
 608 getSRTInfo id (SRT off len bmp)
 609   | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do
 610         srt_lbl <- getSRTLabel
 611         let srt_desc_lbl = mkSRTDescLabel id
 612         absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp)
 613         return (C_SRT srt_desc_lbl 0 srt_escape)
 614   | otherwise = do
 615         srt_lbl <- getSRTLabel
 616         return (C_SRT srt_lbl off (fromIntegral (head bmp)))
 617
 618 srt_escape = (-1) :: StgHalfWord
 619
 620 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
 621 getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
 622                  return srt_lbl
 623
 624 setSRTLabel :: CLabel -> FCode a -> FCode a
 625 setSRTLabel srt_lbl code
 626   = do  MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
 627         withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
 628 \end{code}
 629
 630 \begin{code}
 631 getTickyCtrLabel :: FCode CLabel
 632 getTickyCtrLabel = do
 633         (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
 634         return ticky
 635
 636 setTickyCtrLabel :: CLabel -> Code -> Code
 637 setTickyCtrLabel ticky code = do
 638         (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown
 639         withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
 640 \end{code}