ghc/compiler/codeGen/CgMonad.lhs

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