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