[project @ 2003-07-21 15:14:18 by ross]
[ghc-hetmet.git] / ghc / compiler / codeGen / CgMonad.lhs
index fc7e6ab..88083f7 100644 (file)
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgMonad.lhs,v 1.25 2000/09/04 14:07:29 simonmar Exp $
+% $Id: CgMonad.lhs,v 1.39 2003/07/02 13:12:38 simonpj Exp $
 %
 \section[CgMonad]{The code generation monad}
 
@@ -23,18 +23,25 @@ module CgMonad (
        EndOfBlockInfo(..),
        setEndOfBlockInfo, getEndOfBlockInfo,
 
-       setSRTLabel, getSRTLabel,
+       setSRTLabel, getSRTLabel, getSRTInfo,
        setTickyCtrLabel, getTickyCtrLabel,
 
        StackUsage, Slot(..), HeapUsage,
 
-       profCtrC, profCtrAbsC,
+       profCtrC, profCtrAbsC, ldvEnter,
 
        costCentresC, moduleName,
 
        Sequel(..), -- ToDo: unabstract?
        sequelToAmode,
 
+       -- ideally we wouldn't export these, but some other modules access internal state
+       getState, setState, getInfoDown,
+
+       -- more localised access to monad state 
+       getUsage, setUsage,
+       getBinds, setBinds, getStaticBinds,
+
        -- out of general friendliness, we also export ...
        CgInfoDownwards(..), CgState(..),       -- non-abstract
        CompilationInfo(..)
@@ -42,18 +49,22 @@ module CgMonad (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} CgBindery ( CgIdInfo, CgBindings, nukeVolatileBinds )
+import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
 import {-# SOURCE #-} CgUsages  ( getSpRelOffset )
 
 import AbsCSyn
+import CLabel
+import StgSyn          ( SRT(..) )
 import AbsCUtils       ( mkAbsCStmts )
 import CmdLineOpts     ( opt_SccProfilingOn, opt_DoTickyProfiling )
-import CLabel           ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
 import Module          ( Module )
 import DataCon         ( ConTag )
 import Id              ( Id )
+import Name            ( Name )
 import VarEnv
 import PrimRep         ( PrimRep(..) )
+import SMRep           ( StgHalfWord, hALF_WORD )
+import FastString
 import Outputable
 
 infixr 9 `thenC`       -- Right-associative!
@@ -134,16 +145,14 @@ data Sequel
                      -- addressing mode (I think)
          SemiTaggingStuff
 
-  | SeqFrame                   -- like CaseAlts but push a seq frame too.
-         CAddrMode
-         SemiTaggingStuff
+         Bool        -- True <=> polymorphic, push a SEQ frame too
+
 
 type SemiTaggingStuff
   = Maybe                          -- Maybe[1] we don't have any semi-tagging stuff...
      ([(ConTag, JoinDetails)],     -- Alternatives
-      Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
-                                   -- Maybe[3] the default is a
-                                   -- bind-default (Just b); that is,
+      Maybe (Id, JoinDetails)      -- Default (but Maybe[2] we don't have one)
+                                   -- The default branch expects a 
                                    -- it expects a ptr to the thing
                                    -- in Node, bound to b
      )
@@ -176,8 +185,9 @@ sequelToAmode (OnStack virt_sp_offset)
     returnFC (CVal sp_rel RetRep)
 
 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
-sequelToAmode (CaseAlts amode _) = returnFC amode
-sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
+
+sequelToAmode (CaseAlts amode _ False) = returnFC amode
+sequelToAmode (CaseAlts amode _ True)  = returnFC (CLbl mkSeqInfoLabel RetRep)
 
 type CgStksAndHeapUsage                -- stacks and heap usage information
   = (StackUsage, HeapUsage)
@@ -191,10 +201,19 @@ data Slot = Free | NonPointer
 #endif
 
 type StackUsage =
-       (Int,              -- virtSp: Virtual offset of topmost allocated slot
-        [(Int,Slot)],     -- free:   List of free slots, in increasing order
-        Int,              -- realSp: Virtual offset of real stack pointer
-        Int)              -- hwSp:   Highest value ever taken by virtSp
+       (Int,              -- virtSp:  Virtual offset of topmost allocated slot
+        Int,              -- frameSp: End of the current stack frame
+        [(Int,Slot)],     -- free:    List of free slots, in increasing order
+        Int,              -- realSp:  Virtual offset of real stack pointer
+        Int)              -- hwSp:    Highest value ever taken by virtSp
+
+-- ToDo (SDM, 7 Jan 2003): I'm not sure that the distinction between
+-- Free and NonPointer in the free list is needed any more.  It used
+-- to be needed because we constructed bitmaps from the free list, but
+-- now we construct bitmaps by finding all the live pointer bindings
+-- instead.  Non-pointer stack slots (i.e. saved cost centres) can
+-- just be removed from the free list instead of being recorded as a
+-- NonPointer.
 
 type HeapUsage =
        (HeapOffset,    -- virtHp: Virtual offset of highest-allocated word
@@ -211,38 +230,20 @@ Initialisation.
 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
 
 initUsage :: CgStksAndHeapUsage
-initUsage  = ((0,[],0,0), (0,0))
+initUsage  = ((0,0,[],0,0), (0,0))
 \end{code}
 
-"envInitForAlternatives" initialises the environment for a case alternative,
-assuming that the alternative is entered after an evaluation.
-This involves:
-
-   - zapping any volatile bindings, which aren't valid.
-   
-   - zapping the heap usage. It should be restored by a heap check.
-   
-   - setting the virtual AND real stack pointer fields to the given
-   virtual stack offsets.  this doesn't represent any {\em code}; it is a
-   prediction of where the real stack pointer will be when we come back
-   from the case analysis.
-   
-   - BUT LEAVING the rest of the stack-usage info because it is all
-   valid.  In particular, we leave the tail stack pointers unchanged,
-   becuase the alternative has to de-allocate the original @case@
-   expression's stack.  \end{itemize}
-
 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
 marks found in $e_2$.
 
 \begin{code}
 stateIncUsage :: CgState -> CgState -> CgState
 
-stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
-             (MkCgState _     _  ((_,_,_,h2),(vH2, _)))
+stateIncUsage (MkCgState abs_c bs ((v,t,f,r,h1),(vH1,rH1)))
+             (MkCgState _     _  ((_,_,_,_,h2),(vH2, _)))
      = MkCgState abs_c
                 bs
-                ((v,f,r,h1 `max` h2),
+                ((v,t,f,r,h1 `max` h2),
                  (vH1 `max` vH2, rH1))
 \end{code}
 
@@ -253,8 +254,12 @@ stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
 %************************************************************************
 
 \begin{code}
-type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
-type Code    = CgInfoDownwards -> CgState -> CgState
+newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
+type Code    = FCode ()
+
+instance Monad FCode where
+       (>>=) = thenFC
+       return = returnFC
 
 {-# INLINE thenC #-}
 {-# INLINE thenFC #-}
@@ -265,91 +270,119 @@ The Abstract~C is not in the environment so as to improve strictness.
 \begin{code}
 initC :: CompilationInfo -> Code -> AbstractC
 
-initC cg_info code
+initC cg_info (FCode code)
   = case (code (MkCgInfoDown 
                        cg_info 
-                       (error "initC: statics")
+                       emptyVarEnv -- (error "initC: statics")
                        (error "initC: srt")
                        (mkTopTickyCtrLabel)
                        initEobInfo)
               initialStateC) of
-      MkCgState abc _ _ -> abc
+      ((),MkCgState abc _ _) -> abc
 
 returnFC :: a -> FCode a
-
-returnFC val info_down state = (val, state)
+returnFC val = FCode (\info_down state -> (val, state))
 \end{code}
 
 \begin{code}
-thenC :: Code
-      -> (CgInfoDownwards -> CgState -> a)
-      -> CgInfoDownwards -> CgState -> a
-
--- thenC has both of the following types:
--- thenC :: Code -> Code    -> Code
--- thenC :: Code -> FCode a -> FCode a
-
-thenC m k info_down state
-  = k info_down new_state
-  where
-    new_state  = m info_down state
+thenC :: Code -> FCode a -> FCode a
+thenC (FCode m) (FCode k) = 
+       FCode (\info_down state -> let (_,new_state) = m info_down state in 
+               k info_down new_state)
 
 listCs :: [Code] -> Code
-
-listCs []     info_down state = state
-listCs (c:cs) info_down state = stateN
-  where
-    state1 = c        info_down state
-    stateN = listCs cs info_down state1
-
+listCs [] = return ()
+listCs (fc:fcs) = do
+       fc
+       listCs fcs
+       
 mapCs :: (a -> Code) -> [a] -> Code
-
-mapCs f []     info_down state = state
-mapCs f (c:cs) info_down state = stateN
-  where
-    state1 = (f c)      info_down state
-    stateN = mapCs f cs info_down state1
+mapCs = mapM_
 \end{code}
 
 \begin{code}
-thenFC :: FCode a
-       -> (a -> CgInfoDownwards -> CgState -> c)
-       -> CgInfoDownwards -> CgState -> c
-
--- thenFC :: FCode a -> (a -> FCode b) -> FCode b
--- thenFC :: FCode a -> (a -> Code)    -> Code
-
-thenFC m k info_down state
-  = k m_result info_down new_state
-  where
-    (m_result, new_state) = m info_down state
+thenFC :: FCode a -> (a -> FCode c) -> FCode c
+thenFC (FCode m) k = FCode (
+       \info_down state ->
+               let 
+                       (m_result, new_state) = m info_down state
+                       (FCode kcode) = k m_result
+               in 
+                       kcode info_down new_state
+       )
 
 listFCs :: [FCode a] -> FCode [a]
-
-listFCs []      info_down state = ([],             state)
-listFCs (fc:fcs) info_down state = (thing : things, stateN)
-  where
-    (thing,  state1) = fc         info_down state
-    (things, stateN) = listFCs fcs info_down state1
+listFCs = sequence
 
 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
-
-mapFCs f []      info_down state = ([],             state)
-mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
-  where
-    (thing,  state1) = (f fc)      info_down state
-    (things, stateN) = mapFCs f fcs info_down state1
+mapFCs = mapM
 \end{code}
 
 And the knot-tying combinator:
 \begin{code}
 fixC :: (a -> FCode a) -> FCode a
-fixC fcode info_down state = result
-  where
-    result@(v, _) = fcode v info_down state
-    --     ^-------------^
+fixC fcode = FCode (
+       \info_down state -> 
+               let
+                       FCode fc = fcode v
+                       result@(v,_) = fc info_down state
+                       --          ^--------^
+               in
+                       result
+       )
+\end{code}
+
+Operators for getting and setting the state and "info_down".
+To maximise encapsulation, code should try to only get and set the
+state it actually uses.
+
+\begin{code}
+getState :: FCode CgState
+getState = FCode $ \info_down state -> (state,state)
+
+setState :: CgState -> FCode ()
+setState state = FCode $ \info_down _ -> ((),state)
+
+getUsage :: FCode CgStksAndHeapUsage
+getUsage = do
+       MkCgState absC binds usage <- getState
+       return usage
+
+setUsage :: CgStksAndHeapUsage -> FCode ()
+setUsage newusage = do
+       MkCgState absC binds usage <- getState
+       setState $ MkCgState absC binds newusage
+
+getBinds :: FCode CgBindings
+getBinds = do
+       MkCgState absC binds usage <- getState
+       return binds
+       
+setBinds :: CgBindings -> FCode ()
+setBinds newbinds = do
+       MkCgState absC binds usage <- getState
+       setState $ MkCgState absC newbinds usage
+
+getStaticBinds :: FCode CgBindings
+getStaticBinds = do
+       (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
+       return static_binds
+
+withState :: FCode a -> CgState -> FCode (a,CgState)
+withState (FCode fcode) newstate = FCode $ \info_down state -> 
+       let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
+
+getInfoDown :: FCode CgInfoDownwards
+getInfoDown = FCode $ \info_down state -> (info_down,state)
+
+withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state 
+
+doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
+doFCode (FCode fcode) info_down state = fcode info_down state
 \end{code}
 
+
 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
 fresh environment, except that:
        - compilation info and statics are passed in unchanged.
@@ -369,36 +402,39 @@ bindings and usage information is otherwise unchanged.
 \begin{code}
 forkClosureBody :: Code -> Code
 
-forkClosureBody code
-       (MkCgInfoDown cg_info statics srt ticky _)
-       (MkCgState absC_in binds un_usage)
-  = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
-  where
-    fork_state             = code body_info_down initialStateC
-    MkCgState absC_fork _ _ = fork_state
-    body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
-
+forkClosureBody (FCode code) = do
+       (MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
+       (MkCgState absC_in binds un_usage) <- getState
+       let     body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
+       let     ((),fork_state)             = code body_info_down initialStateC
+       let     MkCgState absC_fork _ _ = fork_state
+       setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
+       
 forkStatics :: FCode a -> FCode a
 
-forkStatics fcode (MkCgInfoDown cg_info _ srt ticky _)
-                 (MkCgState absC_in statics un_usage)
-  = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
-  where
-  (result, state) = fcode rhs_info_down initialStateC
-  MkCgState absC_fork _ _ = state      -- Don't merge these this line with the one
-                                       -- above or it becomes too strict!
-  rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
+forkStatics (FCode fcode) = FCode (
+       \(MkCgInfoDown cg_info _ srt ticky _)
+       (MkCgState absC_in statics un_usage)
+  -> 
+       let
+               (result, state) = fcode rhs_info_down initialStateC
+               MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
+                               -- above or it becomes too strict!
+               rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
+       in
+               (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
+       )
 
 forkAbsC :: Code -> FCode AbstractC
-forkAbsC code info_down (MkCgState absC1 bs usage)
-  = (absC2, new_state)
-  where
-    MkCgState absC2 _ ((_, _, _,h2), _) =
-       code info_down (MkCgState AbsCNop bs usage)
-    ((v, f, r, h1), heap_usage) = usage
-
-    new_usage = ((v, f, r, h1 `max` h2), heap_usage)
-    new_state = MkCgState absC1 bs new_usage
+forkAbsC (FCode code) =
+       do
+               info_down <- getInfoDown
+               (MkCgState absC1 bs usage) <- getState
+               let ((),MkCgState absC2 _ ((_, _, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
+               let ((v, t, f, r, h1), heap_usage) = usage
+               let new_usage = ((v, t, f, r, h1 `max` h2), heap_usage)
+               setState $ MkCgState absC1 bs new_usage
+               return absC2
 \end{code}
 
 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
@@ -409,19 +445,16 @@ that
        - the virtual Hp is moved on to the worst virtual Hp for the branches
 
 \begin{code}
-forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
-
-forkAlts branch_fcodes deflt_fcode info_down in_state
- = ((branch_results , deflt_result), out_state)
-  where
-    compile fc = fc info_down in_state
-
-    (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
-
-    (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
-
-    out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
-               -- NB foldl.  in_state is the *left* argument to stateIncUsage
+forkAlts :: [FCode a] -> FCode [a]
+
+forkAlts branch_fcodes
+  = do info_down <- getInfoDown
+       in_state  <- getState
+       let compile (FCode fc)                  = fc info_down in_state
+       let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
+       setState $ foldl stateIncUsage in_state branch_out_states
+                       -- NB foldl.  in_state is the *left* argument to stateIncUsage
+       return branch_results
 \end{code}
 
 @forkEval@ takes two blocks of code.
@@ -455,31 +488,29 @@ forkEvalHelp :: EndOfBlockInfo  -- For the body
             -> FCode (Int,     -- Sp
                       a)       -- Result of the FCode
 
-forkEvalHelp body_eob_info env_code body_code
-        info_down@(MkCgInfoDown cg_info statics srt ticky _) state
-  = ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
-  where
-    info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
-
-    (MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
-       -- These v and f things are now set up as the body code expects them
-
-    (value_returned, state_at_end_return) 
-       = body_code info_down_for_body state_for_body
-
-    state_for_body = MkCgState AbsCNop
+forkEvalHelp body_eob_info env_code body_code =
+       do
+               info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
+               state <- getState
+               let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
+               let (_,MkCgState _ binds ((v,t,f,_,_),_)) = 
+                       doFCode env_code info_down_for_body state
+               let state_for_body = MkCgState AbsCNop
                             (nukeVolatileBinds binds)
-                            ((v,f,v,v), (0,0))
-
-
+                            ((v,t,f,v,v), (0,0))
+               let (value_returned, state_at_end_return) = 
+                       doFCode body_code info_down_for_body state_for_body             
+               setState $ state `stateIncUsageEval` state_at_end_return
+               return (v,value_returned)
+               
 stateIncUsageEval :: CgState -> CgState -> CgState
-stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
-                 (MkCgState absC2 _  ((_,_,_,h2),         _))
+stateIncUsageEval (MkCgState absC1 bs ((v,t,f,r,h1),heap_usage))
+                 (MkCgState absC2 _  ((_,_,_,_,h2),         _))
      = MkCgState (absC1 `mkAbsCStmts` absC2)
                 -- The AbsC coming back should consist only of nested declarations,
                 -- notably of the return vector!
                 bs
-                ((v,f,r,h1 `max` h2), heap_usage)
+                ((v,t,f,r,h1 `max` h2), heap_usage)
        -- We don't max the heap high-watermark because stateIncUsageEval is
        -- used only in forkEval, which in turn is only used for blocks of code
        -- which do their own heap-check.
@@ -495,11 +526,12 @@ stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
 \begin{code}
 nopC :: Code
-nopC info_down state = state
+nopC = return ()
 
 absC :: AbstractC -> Code
-absC more_absC info_down state@(MkCgState absC binds usage)
-  = MkCgState (mkAbsCStmts absC more_absC) binds usage
+absC more_absC = do
+       state@(MkCgState absC binds usage) <- getState
+       setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
 \end{code}
 
 These two are just like @absC@, except they examine the compilation
@@ -507,26 +539,23 @@ info (whether SCC profiling or profiling-ctrs going) and possibly emit
 nothing.
 
 \begin{code}
-costCentresC :: FAST_STRING -> [CAddrMode] -> Code
-
-costCentresC macro args _ state@(MkCgState absC binds usage)
-  = if opt_SccProfilingOn
-    then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
-    else state
-
-profCtrC :: FAST_STRING -> [CAddrMode] -> Code
+costCentresC :: FastString -> [CAddrMode] -> Code
+costCentresC macro args
+ | opt_SccProfilingOn  = absC (CCallProfCCMacro macro args)
+ | otherwise           = nopC
 
-profCtrC macro args _ state@(MkCgState absC binds usage)
-  = if not opt_DoTickyProfiling
-    then state
-    else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
-
-profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
+profCtrC :: FastString -> [CAddrMode] -> Code
+profCtrC macro args
+ | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args)
+ | otherwise            = nopC
 
+profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC
 profCtrAbsC macro args
-  = if not opt_DoTickyProfiling
-    then AbsCNop
-    else CCallProfCtrMacro macro args
+ | opt_DoTickyProfiling = CCallProfCtrMacro macro args
+ | otherwise            = AbsCNop
+
+ldvEnter :: Code
+ldvEnter = costCentresC FSLIT("LDV_ENTER") [CReg node]
 
 {- Try to avoid adding too many special compilation strategies here.
    It's better to modify the header files as necessary for particular
@@ -543,48 +572,69 @@ obtained from the compilation.
 
 \begin{code}
 getAbsC :: Code -> FCode AbstractC
-
-getAbsC code info_down (MkCgState absC binds usage)
-  = (absC2, MkCgState absC binds2 usage2)
-  where
-    (MkCgState absC2 binds2 usage2) 
-       = code info_down (MkCgState AbsCNop binds usage)
+getAbsC code = do
+       MkCgState absC binds usage <- getState
+       ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage)
+       setState $ MkCgState absC binds2 usage2
+       return absC2
 \end{code}
 
 \begin{code}
-
 moduleName :: FCode Module
-moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) state
-  = (mod_name, state)
-
+moduleName = do
+       (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
+       return mod_name
 \end{code}
 
 \begin{code}
 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
-setEndOfBlockInfo eob_info code        (MkCgInfoDown c_info statics srt ticky _) state
-  = code (MkCgInfoDown c_info statics srt ticky eob_info) state
+setEndOfBlockInfo eob_info code        = do
+       (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
+       withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
 
 getEndOfBlockInfo :: FCode EndOfBlockInfo
-getEndOfBlockInfo (MkCgInfoDown c_info statics _ _ eob_info) state
-  = (eob_info, state)
+getEndOfBlockInfo = do
+       (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
+       return eob_info
 \end{code}
 
-\begin{code}
-getSRTLabel :: FCode CLabel
-getSRTLabel (MkCgInfoDown _ _ srt _ _) state
-  = (srt, state)
+There is just one SRT for each top level binding; all the nested
+bindings use sub-sections of this SRT.  The label is passed down to
+the nested bindings via the monad.
 
-setSRTLabel :: CLabel -> Code -> Code
-setSRTLabel srt code (MkCgInfoDown c_info statics _ ticky eob_info) state
-  = code (MkCgInfoDown c_info statics srt ticky eob_info) state
+\begin{code}
+getSRTInfo :: Name -> SRT -> FCode C_SRT
+getSRTInfo id NoSRT = return NoC_SRT
+getSRTInfo id (SRT off len bmp)
+  | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do 
+       srt_lbl <- getSRTLabel
+       let srt_desc_lbl = mkSRTDescLabel id
+       absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp)
+       return (C_SRT srt_desc_lbl 0 srt_escape)
+  | otherwise = do
+       srt_lbl <- getSRTLabel
+       return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+
+srt_escape = (-1) :: StgHalfWord
+
+getSRTLabel :: FCode CLabel    -- Used only by cgPanic
+getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
+                return srt_lbl
+
+setSRTLabel :: CLabel -> FCode a -> FCode a
+setSRTLabel srt_lbl code
+  = do  MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
+       withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
 \end{code}
 
 \begin{code}
 getTickyCtrLabel :: FCode CLabel
-getTickyCtrLabel (MkCgInfoDown _ _ _ ticky _) state
-  = (ticky, state)
+getTickyCtrLabel = do
+       (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
+       return ticky
 
 setTickyCtrLabel :: CLabel -> Code -> Code
-setTickyCtrLabel ticky code (MkCgInfoDown c_info statics srt _ eob_info) state
-  = code (MkCgInfoDown c_info statics srt ticky eob_info) state
+setTickyCtrLabel ticky code = do
+       (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown
+       withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
 \end{code}