Ticket #7758: 0001-Detabify-StgCmmMonad.patch

File 0001-Detabify-StgCmmMonad.patch, 23.7 KB (added by bosu, 2 years ago)
  • compiler/codeGen/StgCmmMonad.hs

    From e49121fdfaad4f62f7a2fbb73e6ecb99c4123f7a Mon Sep 17 00:00:00 2001
    From: Boris Sukholitko <[email protected]>
    Date: Sat, 9 Mar 2013 10:35:52 +0200
    Subject: [PATCH 1/3] Detabify StgCmmMonad
    
    ---
     compiler/codeGen/StgCmmMonad.hs |  343 +++++++++++++++++++--------------------
     1 file changed, 168 insertions(+), 175 deletions(-)
    
    diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
    index 7a0816f..def0ffe 100644
    a b  
    77--
    88-----------------------------------------------------------------------------
    99
    10 {-# OPTIONS -fno-warn-tabs #-}
    11 -- The above warning supression flag is a temporary kludge.
    12 -- While working on this module you are encouraged to remove it and
    13 -- detab the module (please do the detabbing in a separate patch). See
    14 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
    15 -- for details
    16 
    1710module StgCmmMonad (
    18         FCode,  -- type
     11        FCode,        -- type
    1912
    2013        initC, runC, thenC, thenFC, listCs,
    2114        returnFC, fixC,
    22         newUnique, newUniqSupply,
     15        newUnique, newUniqSupply,
    2316
    2417        newLabelC, emitLabel,
    2518
    module StgCmmMonad ( 
    2821        emitOutOfLine, emitAssign, emitStore, emitComment,
    2922
    3023        getCmm, aGraphToGraph,
    31         getCodeR, getCode, getHeapUsage,
     24        getCodeR, getCode, getHeapUsage,
    3225
    3326        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
    3427        mkCall, mkCmmCall,
    3528
    3629        forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
    3730
    38         ConTagZ,
     31        ConTagZ,
    3932
    4033        Sequel(..), ReturnKind(..),
    41         withSequel, getSequel,
     34        withSequel, getSequel,
    4235
    4336        setTickyCtrLabel, getTickyCtrLabel,
    4437
    45         withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
     38        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
    4639
    47         HeapUsage(..), VirtualHpOffset, initHpUsage,
    48         getHpUsage,  setHpUsage, heapHWM,
    49         setVirtHp, getVirtHp, setRealHp,
     40        HeapUsage(..), VirtualHpOffset,        initHpUsage,
     41        getHpUsage,  setHpUsage, heapHWM,
     42        setVirtHp, getVirtHp, setRealHp,
    5043
    51         getModuleName,
     44        getModuleName,
    5245
    53         -- ideally we wouldn't export these, but some other modules access internal state
    54         getState, setState, getInfoDown, getDynFlags, getThisPackage,
     46        -- ideally we wouldn't export these, but some other modules access internal state
     47        getState, setState, getInfoDown, getDynFlags, getThisPackage,
    5548
    56         -- more localised access to monad state
    57         CgIdInfo(..), CgLoc(..),
    58         getBinds, setBinds, getStaticBinds,
     49        -- more localised access to monad state       
     50        CgIdInfo(..), CgLoc(..),
     51        getBinds, setBinds, getStaticBinds,
    5952
    60         -- out of general friendliness, we also export ...
    61         CgInfoDownwards(..), CgState(..)        -- non-abstract
     53        -- out of general friendliness, we also export ...
     54        CgInfoDownwards(..), CgState(..)        -- non-abstract
    6255    ) where
    6356
    6457#include "HsVersions.h"
    import Data.List 
    8578import Prelude hiding( sequence, succ )
    8679import qualified Prelude( sequence )
    8780
    88 infixr 9 `thenC`        -- Right-associative!
     81infixr 9 `thenC`        -- Right-associative!
    8982infixr 9 `thenFC`
    9083
    9184
    instance Functor FCode where 
    122115  fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #)
    123116
    124117instance Monad FCode where
    125         (>>=) = thenFC
    126         return = returnFC
     118        (>>=) = thenFC
     119        return = returnFC
    127120
    128121{-# INLINE thenC #-}
    129122{-# INLINE thenFC #-}
    thenC (FCode m) (FCode k) = 
    147140listCs :: [FCode ()] -> FCode ()
    148141listCs [] = return ()
    149142listCs (fc:fcs) = do
    150         fc
    151         listCs fcs
    152         
     143        fc
     144        listCs fcs
     145          
    153146thenFC  :: FCode a -> (a -> FCode c) -> FCode c
    154147thenFC (FCode m) k = FCode $
    155         \info_down state ->
     148        \info_down state ->
    156149            case m info_down state of
    157150              (# m_result, new_state #) ->
    158151                 case k m_result of
    thenFC (FCode m) k = FCode $ 
    160153
    161154fixC :: (a -> FCode a) -> FCode a
    162155fixC fcode = FCode (
    163         \info_down state ->
    164                 let
     156        \info_down state ->
     157                let
    165158                        (v,s) = doFCode (fcode v) info_down state
    166159                in
    167160                        (# v, s #)
    168         )
     161        )
    169162
    170163--------------------------------------------------------
    171 --      The code generator environment
     164--        The code generator environment
    172165--------------------------------------------------------
    173166
    174167-- This monadery has some information that it only passes
    175168-- *downwards*, as well as some ``state'' which is modified
    176169-- as we go along.
    177170
    178 data CgInfoDownwards    -- information only passed *downwards* by the monad
     171data CgInfoDownwards        -- information only passed *downwards* by the monad
    179172  = MkCgInfoDown {
    180         cgd_dflags     :: DynFlags,
    181         cgd_mod        :: Module,         -- Module being compiled
    182         cgd_statics    :: CgBindings,     -- [Id -> info] : static environment
     173        cgd_dflags     :: DynFlags,
     174        cgd_mod        :: Module,          -- Module being compiled
     175        cgd_statics    :: CgBindings,          -- [Id -> info] : static environment
    183176        cgd_updfr_off  :: UpdFrameOffset, -- Size of current update frame
    184         cgd_ticky      :: CLabel,         -- Current destination for ticky counts
    185         cgd_sequel     :: Sequel          -- What to do at end of basic block
     177        cgd_ticky      :: CLabel,          -- Current destination for ticky counts
     178        cgd_sequel     :: Sequel          -- What to do at end of basic block
    186179  }
    187180
    188181type CgBindings = IdEnv CgIdInfo
    189182
    190183data CgIdInfo
    191   = CgIdInfo   
    192         { cg_id :: Id   -- Id that this is the info for
    193                         -- Can differ from the Id at occurrence sites by
    194                         -- virtue of being externalised, for splittable C
    195         , cg_lf  :: LambdaFormInfo
    196         , cg_loc :: CgLoc                    -- CmmExpr for the *tagged* value
     184  = CgIdInfo       
     185        { cg_id :: Id        -- Id that this is the info for
     186                        -- Can differ from the Id at occurrence sites by
     187                        -- virtue of being externalised, for splittable C
     188        , cg_lf  :: LambdaFormInfo
     189        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value
    197190        , cg_tag :: {-# UNPACK #-} !DynTag   -- Cache for (lfDynTag cg_lf)
    198191        }
    199192
    200193data CgLoc
    201   = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning
    202                         -- Hp, so that it remains valid across calls
     194  = CmmLoc CmmExpr        -- A stable CmmExpr; that is, one not mentioning
     195                        -- Hp, so that it remains valid across calls
    203196
    204   | LneLoc BlockId [LocalReg]      -- A join point
    205         -- A join point (= let-no-escape) should only
    206         -- be tail-called, and in a saturated way.
    207         -- To tail-call it, assign to these locals,
    208         -- and branch to the block id
     197  | LneLoc BlockId [LocalReg]             -- A join point
     198        -- A join point (= let-no-escape) should only
     199        -- be tail-called, and in a saturated way.
     200        -- To tail-call it, assign to these locals,
     201        -- and branch to the block id
    209202
    210203instance Outputable CgIdInfo where
    211204  ppr (CgIdInfo { cg_id = id, cg_loc = loc })
    instance Outputable CgLoc where 
    218211
    219212-- Sequel tells what to do with the result of this expression
    220213data Sequel
    221   = Return Bool           -- Return result(s) to continuation found on the stack
    222                           --    True <=> the continuation is update code (???)
     214  = Return Bool                  -- Return result(s) to continuation found on the stack
     215                          --         True <=> the continuation is update code (???)
    223216
    224217  | AssignTo
    225         [LocalReg]      -- Put result(s) in these regs and fall through
    226                         --      NB: no void arguments here
     218        [LocalReg]        -- Put result(s) in these regs and fall through
     219                        --         NB: no void arguments here
    227220                        --
    228221        Bool            -- Should we adjust the heap pointer back to
    229222                        -- recover space that's unused on this path?
    data ReturnKind 
    306299
    307300initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
    308301initCgInfoDown dflags mod
    309   = MkCgInfoDown {      cgd_dflags    = dflags,
    310                         cgd_mod       = mod,
    311                         cgd_statics   = emptyVarEnv,
     302  = MkCgInfoDown {      cgd_dflags    = dflags,
     303                        cgd_mod       = mod,
     304                        cgd_statics   = emptyVarEnv,
    312305                        cgd_updfr_off = initUpdFrameOff dflags,
    313                         cgd_ticky     = mkTopTickyCtrLabel,
    314                         cgd_sequel    = initSequel }
     306                        cgd_ticky     = mkTopTickyCtrLabel,
     307                        cgd_sequel    = initSequel }
    315308
    316309initSequel :: Sequel
    317310initSequel = Return False
    initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA 
    321314
    322315
    323316--------------------------------------------------------
    324 --      The code generator state
     317--        The code generator state
    325318--------------------------------------------------------
    326319
    327320data CgState
    328321  = MkCgState {
    329      cgs_stmts :: CmmAGraph,      -- Current procedure
     322     cgs_stmts :: CmmAGraph,          -- Current procedure
    330323
    331324     cgs_tops  :: OrdList CmmDecl,
    332         -- Other procedures and data blocks in this compilation unit
    333         -- Both are ordered only so that we can
    334         -- reduce forward references, when it's easy to do so
     325        -- Other procedures and data blocks in this compilation unit
     326        -- Both are ordered only so that we can
     327        -- reduce forward references, when it's easy to do so
    335328     
    336      cgs_binds :: CgBindings,   -- [Id -> info] : *local* bindings environment
    337                                 -- Bindings for top-level things are given in
    338                                 -- the info-down part
     329     cgs_binds :: CgBindings,        -- [Id -> info] : *local* bindings environment
     330                                     -- Bindings for top-level things are given in
     331                                -- the info-down part
    339332
    340333     cgs_hp_usg  :: HeapUsage,
    341334
    data CgState 
    343336
    344337data HeapUsage =
    345338  HeapUsage {
    346         virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
    347                                         --   Incremented whenever we allocate
    348         realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
    349                                         --   Used in instruction addressing modes
     339        virtHp :: VirtualHpOffset,        -- Virtual offset of highest-allocated word
     340                                                 --   Incremented whenever we allocate
     341        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr
     342                                                 --   Used in instruction addressing modes
    350343  }
    351344
    352345type VirtualHpOffset = WordOff
    type VirtualHpOffset = WordOff 
    356349initCgState :: UniqSupply -> CgState
    357350initCgState uniqs
    358351  = MkCgState { cgs_stmts      = mkNop, cgs_tops = nilOL,
    359                 cgs_binds      = emptyVarEnv,
    360                 cgs_hp_usg     = initHpUsage,
    361                 cgs_uniqs      = uniqs }
     352                cgs_binds      = emptyVarEnv,
     353                cgs_hp_usg     = initHpUsage,
     354                cgs_uniqs      = uniqs }
    362355
    363356stateIncUsage :: CgState -> CgState -> CgState
    364357-- stateIncUsage@ e1 e2 incorporates in e1
    stateIncUsage :: CgState -> CgState -> CgState 
    366359stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
    367360     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }
    368361       `addCodeBlocksFrom` s2
    369                
     362               
    370363addCodeBlocksFrom :: CgState -> CgState -> CgState
    371364-- Add code blocks from the latter to the former
    372365-- (The cgs_stmts will often be empty, but not always; see codeOnly)
    373366s1 `addCodeBlocksFrom` s2
    374367  = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
    375         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
     368        cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
    376369
    377370
    378371-- The heap high water mark is the larger of virtHp and hwHp.  The latter is
    setState state = FCode $ \_info_down _ -> (# (), state #) 
    403396
    404397getHpUsage :: FCode HeapUsage
    405398getHpUsage = do
    406         state <- getState
    407         return $ cgs_hp_usg state
    408        
     399        state <- getState
     400        return $ cgs_hp_usg state
     401       
    409402setHpUsage :: HeapUsage -> FCode ()
    410403setHpUsage new_hp_usg = do
    411         state <- getState
    412         setState $ state {cgs_hp_usg = new_hp_usg}
     404        state <- getState
     405        setState $ state {cgs_hp_usg = new_hp_usg}
    413406
    414407setVirtHp :: VirtualHpOffset -> FCode ()
    415408setVirtHp new_virtHp
    416   = do  { hp_usage <- getHpUsage
    417         ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
     409  = do        { hp_usage <- getHpUsage
     410        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
    418411
    419412getVirtHp :: FCode VirtualHpOffset
    420413getVirtHp
    421   = do  { hp_usage <- getHpUsage
    422         ; return (virtHp hp_usage) }
     414  = do        { hp_usage <- getHpUsage
     415        ; return (virtHp hp_usage) }
    423416
    424417setRealHp ::  VirtualHpOffset -> FCode ()
    425418setRealHp new_realHp
    426   = do  { hp_usage <- getHpUsage
    427         ; setHpUsage (hp_usage {realHp = new_realHp}) }
     419  = do        { hp_usage <- getHpUsage
     420        ; setHpUsage (hp_usage {realHp = new_realHp}) }
    428421
    429422getBinds :: FCode CgBindings
    430423getBinds = do
    431         state <- getState
    432         return $ cgs_binds state
    433        
     424        state <- getState
     425        return $ cgs_binds state
     426       
    434427setBinds :: CgBindings -> FCode ()
    435428setBinds new_binds = do
    436         state <- getState
    437         setState $ state {cgs_binds = new_binds}
     429        state <- getState
     430        setState $ state {cgs_binds = new_binds}
    438431
    439432getStaticBinds :: FCode CgBindings
    440433getStaticBinds = do
    441         info  <- getInfoDown
    442         return (cgd_statics info)
     434        info  <- getInfoDown
     435        return (cgd_statics info)
    443436
    444437withState :: FCode a -> CgState -> FCode (a,CgState)
    445438withState (FCode fcode) newstate = FCode $ \info_down state ->
    withState (FCode fcode) newstate = FCode $ \info_down state -> 
    448441
    449442newUniqSupply :: FCode UniqSupply
    450443newUniqSupply = do
    451         state <- getState
    452         let (us1, us2) = splitUniqSupply (cgs_uniqs state)
    453         setState $ state { cgs_uniqs = us1 }
    454         return us2
     444        state <- getState
     445        let (us1, us2) = splitUniqSupply (cgs_uniqs state)
     446        setState $ state { cgs_uniqs = us1 }
     447        return us2
    455448
    456449newUnique :: FCode Unique
    457450newUnique = do
    458         us <- newUniqSupply
    459         return (uniqFromSupply us)
     451        us <- newUniqSupply
     452        return (uniqFromSupply us)
    460453
    461454------------------
    462455getInfoDown :: FCode CgInfoDownwards
    getModuleName = do { info <- getInfoDown; return (cgd_mod info) } 
    487480
    488481withSequel :: Sequel -> FCode a -> FCode a
    489482withSequel sequel code
    490   = do  { info  <- getInfoDown
    491         ; withInfoDown code (info {cgd_sequel = sequel }) }
     483  = do        { info  <- getInfoDown
     484        ; withInfoDown code (info {cgd_sequel = sequel }) }
    492485
    493486getSequel :: FCode Sequel
    494487getSequel = do  { info <- getInfoDown
    495                 ; return (cgd_sequel info) }
     488                ; return (cgd_sequel info) }
    496489
    497490-- ----------------------------------------------------------------------------
    498491-- Get/set the size of the update frame
    getSequel = do { info <- getInfoDown 
    506499
    507500withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
    508501withUpdFrameOff size code
    509   = do  { info  <- getInfoDown
    510         ; withInfoDown code (info {cgd_updfr_off = size }) }
     502  = do        { info  <- getInfoDown
     503        ; withInfoDown code (info {cgd_updfr_off = size }) }
    511504
    512505getUpdFrameOff :: FCode UpdFrameOffset
    513506getUpdFrameOff
    514   = do  { info  <- getInfoDown
    515         ; return $ cgd_updfr_off info }
     507  = do        { info  <- getInfoDown
     508        ; return $ cgd_updfr_off info }
    516509
    517510-- ----------------------------------------------------------------------------
    518511-- Get/set the current ticky counter label
    519512
    520513getTickyCtrLabel :: FCode CLabel
    521514getTickyCtrLabel = do
    522         info <- getInfoDown
    523         return (cgd_ticky info)
     515        info <- getInfoDown
     516        return (cgd_ticky info)
    524517
    525518setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
    526519setTickyCtrLabel ticky code = do
    527         info <- getInfoDown
    528         withInfoDown code (info {cgd_ticky = ticky})
     520        info <- getInfoDown
     521        withInfoDown code (info {cgd_ticky = ticky})
    529522
    530523
    531524--------------------------------------------------------
    532 --              Forking
     525--                 Forking
    533526--------------------------------------------------------
    534527
    535528forkClosureBody :: FCode () -> FCode ()
    536529-- forkClosureBody takes a code, $c$, and compiles it in a
    537530-- fresh environment, except that:
    538 --      - compilation info and statics are passed in unchanged.
    539 --      - local bindings are passed in unchanged
    540 --        (it's up to the enclosed code to re-bind the
    541 --         free variables to a field of the closure)
     531--        - compilation info and statics are passed in unchanged.
     532--        - local bindings are passed in unchanged
     533--          (it's up to the enclosed code to re-bind the
     534--           free variables to a field of the closure)
    542535--
    543536-- The current state is passed on completely unaltered, except that
    544537-- C-- from the fork is incorporated.
    545538
    546539forkClosureBody body_code
    547   = do  { dflags <- getDynFlags
    548         ; info <- getInfoDown
    549         ; us   <- newUniqSupply
    550         ; state <- getState
    551         ; let   body_info_down = info { cgd_sequel    = initSequel
     540  = do        { dflags <- getDynFlags
     541              ; info <- getInfoDown
     542        ; us   <- newUniqSupply
     543        ; state <- getState
     544           ; let body_info_down = info { cgd_sequel    = initSequel
    552545                                      , cgd_updfr_off = initUpdFrameOff dflags }
    553                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
    554                 ((),fork_state_out)
    555                     = doFCode body_code body_info_down fork_state_in
    556         ; setState $ state `addCodeBlocksFrom` fork_state_out }
    557        
     546                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
     547                 ((),fork_state_out)
     548                    = doFCode body_code body_info_down fork_state_in
     549        ; setState $ state `addCodeBlocksFrom` fork_state_out }
     550       
    558551forkStatics :: FCode a -> FCode a
    559552-- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come
    560553-- from the current *local bindings*, but which is otherwise freshly initialised.
    561554-- The Abstract~C returned is attached to the current state, but the
    562555-- bindings and usage information is otherwise unchanged.
    563556forkStatics body_code
    564   = do  { dflags <- getDynFlags
    565         ; info  <- getInfoDown
    566         ; us    <- newUniqSupply
    567         ; state <- getState
    568         ; let   rhs_info_down = info { cgd_statics = cgs_binds state
    569                                      , cgd_sequel  = initSequel
    570                                      , cgd_updfr_off = initUpdFrameOff dflags }
    571                 (result, fork_state_out) = doFCode body_code rhs_info_down
    572                                                    (initCgState us)
    573         ; setState (state `addCodeBlocksFrom` fork_state_out)
    574         ; return result }
     557  = do        { dflags <- getDynFlags
     558              ; info  <- getInfoDown
     559        ; us    <- newUniqSupply
     560        ; state <- getState
     561        ; let   rhs_info_down = info { cgd_statics = cgs_binds state
     562                                     , cgd_sequel  = initSequel
     563                                     , cgd_updfr_off = initUpdFrameOff dflags }
     564                (result, fork_state_out) = doFCode body_code rhs_info_down
     565                                                   (initCgState us)
     566        ; setState (state `addCodeBlocksFrom` fork_state_out)
     567        ; return result }
    575568
    576569forkProc :: FCode a -> FCode a
    577570-- 'forkProc' takes a code and compiles it in the *current* environment,
    forkProc :: FCode a -> FCode a 
    581574-- the successor.  In particular, any heap usage from the enclosed
    582575-- code is discarded; it should deal with its own heap consumption
    583576forkProc body_code
    584   = do  { info_down <- getInfoDown
    585         ; us    <- newUniqSupply
    586         ; state <- getState
    587         ; let   info_down' = info_down -- { cgd_sequel = initSequel }
    588                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
    589                 (result, fork_state_out) = doFCode body_code info_down' fork_state_in
    590         ; setState $ state `addCodeBlocksFrom` fork_state_out
    591         ; return result }
     577  = do        { info_down <- getInfoDown
     578        ; us    <- newUniqSupply
     579        ; state <- getState
     580           ; let info_down' = info_down -- { cgd_sequel = initSequel }
     581                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
     582                 (result, fork_state_out) = doFCode body_code info_down' fork_state_in
     583          ; setState $ state `addCodeBlocksFrom` fork_state_out
     584        ; return result }
    592585
    593586codeOnly :: FCode () -> FCode ()
    594587-- Emit any code from the inner thing into the outer thing
    595588-- Do not affect anything else in the outer state
    596589-- Used in almost-circular code to prevent false loop dependencies
    597590codeOnly body_code
    598   = do  { info_down <- getInfoDown
    599         ; us   <- newUniqSupply
    600         ; state <- getState
    601         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
    602                                                    cgs_hp_usg  = cgs_hp_usg state }
    603                 ((), fork_state_out) = doFCode body_code info_down fork_state_in
    604         ; setState $ state `addCodeBlocksFrom` fork_state_out }
     591  = do        { info_down <- getInfoDown
     592        ; us   <- newUniqSupply
     593        ; state <- getState
     594        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
     595                                                   cgs_hp_usg  = cgs_hp_usg state }
     596                ((), fork_state_out) = doFCode body_code info_down fork_state_in
     597        ; setState $ state `addCodeBlocksFrom` fork_state_out }
    605598
    606599forkAlts :: [FCode a] -> FCode [a]
    607600-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
    forkAlts branch_fcodes 
    630623-- collect the code emitted by an FCode computation
    631624getCodeR :: FCode a -> FCode (a, CmmAGraph)
    632625getCodeR fcode
    633   = do  { state1 <- getState
    634         ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
    635         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
    636         ; return (a, cgs_stmts state2) }
     626  = do        { state1 <- getState
     627        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
     628        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
     629        ; return (a, cgs_stmts state2) }
    637630
    638631getCode :: FCode a -> FCode CmmAGraph
    639632getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
    getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts } 
    649642
    650643getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
    651644getHeapUsage fcode
    652   = do  { info_down <- getInfoDown
    653         ; state <- getState
    654         ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }
    655                 (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
    656                 hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here!
    657                
    658         ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
    659         ; return r }
     645  = do        { info_down <- getInfoDown
     646        ; state <- getState
     647        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }
     648                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
     649                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!
     650               
     651        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
     652        ; return r }
    660653
    661654-- ----------------------------------------------------------------------------
    662655-- Combinators for emitting code
    newLabelC = do { u <- newUnique 
    690683
    691684emit :: CmmAGraph -> FCode ()
    692685emit ag
    693   = do  { state <- getState
    694         ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
     686  = do        { state <- getState
     687        ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
    695688
    696689emitDecl :: CmmDecl -> FCode ()
    697690emitDecl decl
    698   = do  { state <- getState
    699         ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
     691  = do         { state <- getState
     692        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
    700693
    701694emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
    702695emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
    getCmm :: FCode () -> FCode CmmGroup 
    761754-- Return a single Cmm which may be split from other Cmms by
    762755-- object splitting (at a later stage)
    763756getCmm code
    764   = do  { state1 <- getState
    765         ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
    766         ; setState $ state2 { cgs_tops = cgs_tops state1 }
     757  = do        { state1 <- getState
     758        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
     759        ; setState $ state2 { cgs_tops = cgs_tops state1 }
    767760        ; return (fromOL (cgs_tops state2)) }
    768761
    769762