path: root/compiler/codeGen/CgMonad.lhs

%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CgMonad]{The code generation monad}

See the beginning of the top-level @CodeGen@ module, to see how this monadic
stuff fits into the Big Picture.

\begin{code}

{-# LANGUAGE BangPatterns #-}
module CgMonad (
        Code, FCode,

        initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
        returnFC, fixC, fixC_, checkedAbsC,
        stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
        newUnique, newUniqSupply,

        CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
        getCgStmts', getCgStmts,
        noCgStmts, oneCgStmt, consCgStmt,

        getCmm,
        emitDecl, emitProc, emitSimpleProc,

        forkLabelledCode,
        forkClosureBody, forkStatics, forkAlts, forkEval,
        forkEvalHelp, forkProc, codeOnly,
        SemiTaggingStuff, ConTagZ,

        EndOfBlockInfo(..),
        setEndOfBlockInfo, getEndOfBlockInfo,

        setSRT, getSRT,
        setSRTLabel, getSRTLabel,
        setTickyCtrLabel, getTickyCtrLabel,

        StackUsage(..), HeapUsage(..),
        VirtualSpOffset, VirtualHpOffset,
        initStkUsage, initHpUsage,
        getHpUsage,  setHpUsage,
        heapHWM,

        getModuleName,

        Sequel(..),

        -- ideally we wouldn't export these, but some other modules access
        -- internal state
        getState, setState, getInfoDown, getDynFlags, getThisPackage,

        -- more localised access to monad state
        getStkUsage, setStkUsage,
        getBinds, setBinds, getStaticBinds,

        -- out of general friendliness, we also export ...
        CgInfoDownwards(..), CgState(..)
    ) where

#include "HsVersions.h"

import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )

import DynFlags
import BlockId
import OldCmm
import OldCmmUtils
import CLabel
import StgSyn (SRT)
import ClosureInfo( ConTagZ )
import SMRep
import Module
import Id
import VarEnv
import OrdList
import Unique
import UniqSupply
import Outputable

import Control.Monad
import Data.List

infixr 9 `thenC`
infixr 9 `thenFC`
\end{code}

%************************************************************************
%*                                                                      *
\subsection[CgMonad-environment]{Stuff for manipulating environments}
%*                                                                      *
%************************************************************************

This monadery has some information that it only passes {\em downwards}, as well
as some ``state'' which is modified as we go along.

\begin{code}

-- | State only passed *downwards* by the monad
data CgInfoDownwards
  = MkCgInfoDown {
        cgd_dflags  :: DynFlags,      -- current flag settings
        cgd_mod     :: Module,        -- Module being compiled
        cgd_statics :: CgBindings,    -- [Id -> info] : static environment
        cgd_srt_lbl :: CLabel,        -- label of the current SRT
        cgd_srt     :: SRT,           -- the current SRT
        cgd_ticky   :: CLabel,        -- current destination for ticky counts
        cgd_eob     :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
  }

-- | Setup initial @CgInfoDownwards@ for the code gen
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
  = MkCgInfoDown { cgd_dflags  = dflags,
                   cgd_mod     = mod,
                   cgd_statics = emptyVarEnv,
                   cgd_srt_lbl = error "initC: srt_lbl",
                   cgd_srt     = error "initC: srt",
                   cgd_ticky   = mkTopTickyCtrLabel,
                   cgd_eob     = initEobInfo
  }

-- | State passed around and modified during code generation
data CgState
  = MkCgState {
     cgs_stmts   :: OrdList CgStmt,
         -- Current proc
     cgs_tops    :: OrdList CmmDecl,
         -- Other procedures and data blocks in this compilation unit
         -- Both the latter two are ordered only so that we can
         -- reduce forward references, when it's easy to do so

     cgs_binds   :: CgBindings,
         -- [Id -> info] : *local* bindings environment Bindings for
         -- top-level things are given in the info-down part

     cgs_stk_usg :: StackUsage,
     cgs_hp_usg  :: HeapUsage,
     cgs_uniqs   :: UniqSupply
  }

-- | Setup initial @CgState@ for the code gen
initCgState :: UniqSupply -> CgState
initCgState uniqs
  = MkCgState { cgs_stmts   = nilOL,
                cgs_tops    = nilOL,
                cgs_binds   = emptyVarEnv,
                cgs_stk_usg = initStkUsage,
                cgs_hp_usg  = initHpUsage,
                cgs_uniqs   = uniqs
  }

-- | @EndOfBlockInfo@ tells what to do at the end of this block of code or, if
-- the expression is a @case@, what to do at the end of each alternative.
data EndOfBlockInfo
  = EndOfBlockInfo
        VirtualSpOffset -- Args Sp: trim the stack to this point at a
                        -- return; push arguments starting just
                        -- above this point on a tail call.
                        --
                        -- This is therefore the stk ptr as seen
                        -- by a case alternative.
        Sequel

-- | Standard @EndOfBlockInfo@ where the continuation is on the stack
initEobInfo :: EndOfBlockInfo
initEobInfo = EndOfBlockInfo 0 OnStack

-- | @Sequel@ is a representation of the next continuation to jump to
-- after the current function.
--
-- Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
-- that it must survive stack pointer adjustments at the end of the block.
data Sequel
  = OnStack          -- Continuation is on the stack

  | CaseAlts
          CLabel     -- Jump to this; if the continuation is for a vectored
                     -- case this might be the label of a return vector
          SemiTaggingStuff
          Id          -- The case binder, only used to see if it's dead

type SemiTaggingStuff
  = Maybe                  -- Maybe we don't have any semi-tagging stuff...
     ([(ConTagZ, CmmLit)], -- Alternatives
      CmmLit)              -- Default (will be a can't happen RTS label if can't happen)

-- The case branch is executed only from a successful semitagging
-- venture, when a case has looked at a variable, found that it's
-- evaluated, and wants to load up the contents and go to the join
-- point.
\end{code}

%************************************************************************
%*                                                                      *
                CgStmt type
%*                                                                      *
%************************************************************************

The CgStmts type is what the code generator outputs: it is a tree of
statements, including in-line labels. The job of flattenCgStmts is to turn
this into a list of basic blocks, each of which ends in a jump statement
(either a local branch or a non-local jump).

\begin{code}
type CgStmts = OrdList CgStmt

data CgStmt
  = CgStmt  CmmStmt
  | CgLabel BlockId
  | CgFork  BlockId CgStmts

flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
flattenCgStmts id stmts =
        case flatten (fromOL stmts) of
          ([],blocks)    -> blocks
          (block,blocks) -> BasicBlock id block : blocks
 where
  flatten [] = ([],[])

  -- A label at the end of a function or fork: this label must not be reachable,
  -- but it might be referred to from another BB that also isn't reachable.
  -- Eliminating these has to be done with a dead-code analysis.  For now,
  -- we just make it into a well-formed block by adding a recursive jump.
  flatten [CgLabel id]
    = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )

  -- A jump/branch: throw away all the code up to the next label, because
  -- it is unreachable.  Be careful to keep forks that we find on the way.
  flatten (CgStmt stmt : stmts)
    | isJump stmt
    = case dropWhile isOrdinaryStmt stmts of
        []                     -> ( [stmt], [] )
        [CgLabel id]           -> ( [stmt], [BasicBlock id [CmmBranch id]])
        (CgLabel id : stmts)   -> ( [stmt], BasicBlock id block : blocks )
            where (block,blocks) = flatten stmts
        (CgFork fork_id stmts : ss) ->
           flatten (CgFork fork_id stmts : CgStmt stmt : ss)
        (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"

  flatten (s:ss) =
        case s of
          CgStmt stmt -> (stmt:block,blocks)
          CgLabel id  -> ([CmmBranch id],BasicBlock id block:blocks)
          CgFork fork_id stmts ->
                (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
                where (fork_block, fork_blocks) = flatten (fromOL stmts)
    where (block,blocks) = flatten ss

isJump :: CmmStmt -> Bool
isJump (CmmJump   _ _) = True
isJump (CmmBranch _  ) = True
isJump (CmmSwitch _ _) = True
isJump (CmmReturn    ) = True
isJump _               = False

isOrdinaryStmt :: CgStmt -> Bool
isOrdinaryStmt (CgStmt _) = True
isOrdinaryStmt _          = False
\end{code}

%************************************************************************
%*                                                                      *
                Stack and heap models
%*                                                                      *
%************************************************************************

\begin{code}
type VirtualHpOffset = WordOff -- Both are in
type VirtualSpOffset = WordOff -- units of words

-- | Stack usage information during code generation.
--
-- INVARIANT: The environment contains no Stable references to
--            stack slots below (lower offset) frameSp
--            It can contain volatile references to this area though.
data StackUsage
  = StackUsage {
        virtSp :: VirtualSpOffset,
                -- Virtual offset of topmost allocated slot

        frameSp :: VirtualSpOffset,
                -- Virtual offset of the return address of the enclosing frame.
                -- This RA describes the liveness/pointedness of
                -- all the stack from frameSp downwards
                -- INVARIANT: less than or equal to virtSp

         freeStk :: [VirtualSpOffset],
                -- List of free slots, in *increasing* order
                -- INVARIANT: all <= virtSp
                --            All slots <= virtSp are taken except these ones

         realSp :: VirtualSpOffset,
                -- Virtual offset of real stack pointer register

         hwSp :: VirtualSpOffset
  }             -- Highest value ever taken by virtSp

-- | Heap usage information during code generation.
--
-- virtHp keeps track of the next location to allocate an object at. realHp
-- keeps track of what the Hp STG register actually points to. The reason these
-- aren't always the same is that we want to be able to move the realHp in one
-- go when allocating numerous objects to save having to bump it each time.
-- virtHp we do bump each time but it doesn't create corresponding inefficient
-- machine code.
data HeapUsage
  = HeapUsage {
        virtHp :: VirtualHpOffset, -- Virtual offset of highest allocated word
        realHp :: VirtualHpOffset  -- Virtual offset of real heap ptr
  }

-- | Return the heap usage high water mark
heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM = virtHp


-- | Initial stack usage
initStkUsage :: StackUsage
initStkUsage
  = StackUsage {
        virtSp  = 0,
        frameSp = 0,
        freeStk = [],
        realSp  = 0,
        hwSp    = 0
  }

-- | Initial heap usage
initHpUsage :: HeapUsage
initHpUsage
  = HeapUsage {
        virtHp = 0,
        realHp = 0
  }

-- | @stateIncUsafe@ sets the stack and heap high water marks of $arg1$ to
-- be the max of the high water marks of $arg1$ and $arg2$.
stateIncUsage :: CgState -> CgState -> CgState
stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
  = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg,
         cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
    `addCodeBlocksFrom` s2

-- | Similar to @stateIncUsafe@ but 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.
stateIncUsageEval :: CgState -> CgState -> CgState
stateIncUsageEval s1 s2
  = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
    `addCodeBlocksFrom` s2

-- | Add code blocks from the latter to the former
-- (The cgs_stmts will often be empty, but not always; see @codeOnly@)
addCodeBlocksFrom :: CgState -> CgState -> CgState
s1 `addCodeBlocksFrom` s2
  = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }

-- | Set @HeapUsage@ virtHp to max of current or $arg2$.
maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }

-- | Set @StackUsage@ hwSp to max of current or $arg2$.
maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
\end{code}

%************************************************************************
%*                                                                      *
                The FCode monad
%*                                                                      *
%************************************************************************

\begin{code}
newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
type Code       = FCode ()

instance Monad FCode where
        (>>=)  = thenFC
        return = returnFC

{-# INLINE thenC #-}
{-# INLINE thenFC #-}
{-# INLINE returnFC #-}

initC :: DynFlags -> Module -> FCode a -> IO a
initC dflags mod (FCode code) = do
    uniqs <- mkSplitUniqSupply 'c'
    case code (initCgInfoDown dflags mod) (initCgState uniqs) of
        (res, _) -> return res

returnFC :: a -> FCode a
returnFC val = FCode $ \_ state -> (val, 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 []       = return ()
listCs (fc:fcs) = fc >> listCs fcs

mapCs :: (a -> Code) -> [a] -> Code
mapCs = mapM_

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 = sequence

mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
mapFCs = mapM

-- | Knot-tying combinator for @FCode@
fixC :: (a -> FCode a) -> FCode a
fixC fcode = FCode $ \info_down state ->
    let FCode fc     = fcode v
        result@(v,_) = fc info_down state
    in result

-- | Knot-tying combinator that throws result away
fixC_ :: (a -> FCode a) -> FCode ()
fixC_ fcode = fixC fcode >> return ()
\end{code}

%************************************************************************
%*                                                                      *
        Operators for getting and setting the state and "info_down".
%*                                                                      *
%************************************************************************

\begin{code}
getState :: FCode CgState
getState = FCode $ \_ state -> (state, state)

setState :: CgState -> FCode ()
setState state = FCode $ \_ _ -> ((), state)

getStkUsage :: FCode StackUsage
getStkUsage = do
    state <- getState
    return $ cgs_stk_usg state

setStkUsage :: StackUsage -> Code
setStkUsage new_stk_usg = do
    state <- getState
    setState $ state {cgs_stk_usg = new_stk_usg}

getHpUsage :: FCode HeapUsage
getHpUsage = do
    state <- getState
    return $ cgs_hp_usg state

setHpUsage :: HeapUsage -> Code
setHpUsage new_hp_usg = do
    state <- getState
    setState $ state {cgs_hp_usg = new_hp_usg}

getBinds :: FCode CgBindings
getBinds = do
    state <- getState
    return $ cgs_binds state

setBinds :: CgBindings -> FCode ()
setBinds new_binds = do
    state <- getState
    setState $ state {cgs_binds = new_binds}

getStaticBinds :: FCode CgBindings
getStaticBinds = do
    info  <- getInfoDown
    return (cgd_statics info)

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)

newUniqSupply :: FCode UniqSupply
newUniqSupply = do
    state <- getState
    let (us1, us2) = splitUniqSupply (cgs_uniqs state)
    setState $ state { cgs_uniqs = us1 }
    return us2

newUnique :: FCode Unique
newUnique = do
    us <- newUniqSupply
    return (uniqFromSupply us)

getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down, state)

instance HasDynFlags FCode where
    getDynFlags = liftM cgd_dflags getInfoDown

getThisPackage :: FCode PackageId
getThisPackage = liftM thisPackage getDynFlags

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}

%************************************************************************
%*                                                                      *
                Forking
%*                                                                      *
%************************************************************************

\begin{code}

-- | Takes code and compiles it in a completely fresh environment, except that
-- compilation info and statics are passed in unchanged. The current
-- environment is passed on completely unaltered, except that the Cmm code
-- from the fork is incorporated.
forkClosureBody :: Code -> Code
forkClosureBody body_code = do
    info  <- getInfoDown
    us    <- newUniqSupply
    state <- getState
    let body_info_down   = info { cgd_eob = initEobInfo }
        ((), fork_state) = doFCode body_code body_info_down (initCgState us)

    ASSERT( isNilOL (cgs_stmts fork_state) )
      setState $ state `addCodeBlocksFrom` fork_state

-- | @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
-- from the current bindings, but which is otherwise freshly initialised.
-- The Cmm returned is attached to the current state, but the bindings and
-- usage information is otherwise unchanged.
forkStatics :: FCode a -> FCode a
forkStatics body_code = do
    info  <- getInfoDown
    us    <- newUniqSupply
    state <- getState
    let rhs_info_down = info { cgd_statics = cgs_binds state,
                               cgd_eob     = initEobInfo }
        (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us)

    ASSERT( isNilOL (cgs_stmts fork_state_out) )
      setState (state `addCodeBlocksFrom` fork_state_out)
    return result

-- | @forkProc@ takes a code and compiles it in the current environment,
-- returning the basic blocks thus constructed. The current environment is
-- passed on completely unchanged. It is pretty similar to @getBlocks@, except
-- that the latter does affect the environment.
forkProc :: Code -> FCode CgStmts
forkProc body_code = do
    info  <- getInfoDown
    us    <- newUniqSupply
    state <- getState
    let fork_state_in = (initCgState us)
                            { cgs_binds   = cgs_binds state,
                              cgs_stk_usg = cgs_stk_usg state,
                              cgs_hp_usg  = cgs_hp_usg state }
        (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
                                              info fork_state_in
    setState $ state `stateIncUsageEval` fork_state_out
    return code_blks

-- Emit any code from the inner thing into the outer thing
-- Do not affect anything else in the outer state
-- Used in almost-circular code to prevent false loop dependencies
codeOnly :: Code -> Code
codeOnly body_code = do
    info  <- getInfoDown
    us    <- newUniqSupply
    state <- getState
    let fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
                                           cgs_stk_usg = cgs_stk_usg state,
                                           cgs_hp_usg  = cgs_hp_usg state }
        ((), fork_state_out) = doFCode body_code info fork_state_in
    setState $ state `addCodeBlocksFrom` fork_state_out

-- | @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and an
-- an fcode for the default case $d$, and compiles each in the current
-- environment. The current environment is passed on unmodified, except that:
--     * the worst stack high-water mark is incorporated
--     * the virtual Hp is moved on to the worst virtual Hp for the branches
forkAlts :: [FCode a] -> FCode [a]
forkAlts branch_fcodes = do 
    info  <- getInfoDown
    us    <- newUniqSupply
    state <- getState
    let compile us branch = (us2, doFCode branch info branch_state)
            where
                (us1,us2)    = splitUniqSupply us
                branch_state = (initCgState us1) {
                                   cgs_binds   = cgs_binds state,
                                   cgs_stk_usg = cgs_stk_usg state,
                                   cgs_hp_usg  = cgs_hp_usg state }
        (_us, results) = mapAccumL compile us branch_fcodes
        (branch_results, branch_out_states) = unzip results
    -- NB foldl. state is the *left* argument to stateIncUsage
    setState $ foldl stateIncUsage state branch_out_states
    return branch_results

-- | @forkEval@ takes two blocks of code.
-- 
--   *  The first meddles with the environment to set it up as expected by
--      the alternatives of a @case@ which does an eval (or gc-possible primop).
--   *  The second block is the code for the alternatives.
--      (plus info for semi-tagging purposes)
--
-- @forkEval@ picks up the virtual stack pointer and returns a suitable
-- @EndOfBlockInfo@ for the caller to use, together with whatever value
-- is returned by the second block.
-- 
-- It uses @initEnvForAlternatives@ to initialise the environment, and
-- @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap usage.
forkEval :: EndOfBlockInfo       -- For the body
         -> Code                 -- Code to set environment
         -> FCode Sequel         -- Semi-tagging info to store
         -> FCode EndOfBlockInfo -- The new end of block info
forkEval body_eob_info env_code body_code = do
    (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
    returnFC (EndOfBlockInfo v sequel)

-- A disturbingly complicated function
forkEvalHelp :: EndOfBlockInfo  -- For the body
             -> Code            -- Code to set environment
             -> FCode a         -- The code to do after the eval
             -> FCode (VirtualSpOffset, -- Sp
                       a)               -- Result of the FCode
forkEvalHelp body_eob_info env_code body_code = do
    info  <- getInfoDown
    us    <- newUniqSupply
    state <- getState

    let info_body      = info { cgd_eob = body_eob_info }
        (_, env_state) = doFCode env_code info_body
                                 (state {cgs_uniqs = us})
        state_for_body = (initCgState (cgs_uniqs env_state))
                            { cgs_binds   = binds_for_body,
                              cgs_stk_usg = stk_usg_for_body }
        binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
        stk_usg_from_env = cgs_stk_usg env_state
        virtSp_from_env  = virtSp stk_usg_from_env
        stk_usg_for_body = stk_usg_from_env { realSp = virtSp_from_env,
                                              hwSp   = virtSp_from_env }
        (value_returned, state_at_end_return)
            = doFCode body_code info_body state_for_body

    -- The code coming back should consist only of nested declarations,
    -- notably of the return vector!
    ASSERT( isNilOL (cgs_stmts state_at_end_return) )
      setState $ state `stateIncUsageEval` state_at_end_return
    return (virtSp_from_env, value_returned)

-- ----------------------------------------------------------------------------
-- Combinators for emitting code

nopC :: Code
nopC = return ()

whenC :: Bool -> Code -> Code
whenC True  code = code
whenC False _    = nopC

-- Corresponds to 'emit' in new code generator with a smart constructor
-- from cmm/MkGraph.hs
stmtC :: CmmStmt -> Code
stmtC stmt = emitCgStmt (CgStmt stmt)

labelC :: BlockId -> Code
labelC id = emitCgStmt (CgLabel id)

newLabelC :: FCode BlockId
newLabelC = do
    u <- newUnique
    return $ mkBlockId u

-- Emit code, eliminating no-ops
checkedAbsC :: CmmStmt -> Code
checkedAbsC stmt = emitStmts $ if isNopStmt stmt then nilOL else unitOL stmt

stmtsC :: [CmmStmt] -> Code
stmtsC stmts = emitStmts $ toOL stmts

-- Emit code; no no-op checking
emitStmts :: CmmStmts -> Code
emitStmts stmts = emitCgStmts $ fmap CgStmt stmts

-- forkLabelledCode is for emitting a chunk of code with a label, outside
-- of the current instruction stream.
forkLabelledCode :: Code -> FCode BlockId
forkLabelledCode code = getCgStmts code >>= forkCgStmts

emitCgStmt :: CgStmt -> Code
emitCgStmt stmt = do
    state <- getState
    setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }

emitDecl :: CmmDecl -> Code
emitDecl decl = do
    state <- getState
    setState $ state { cgs_tops = cgs_tops state `snocOL` decl }

emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
emitProc info lbl [] blocks = do
    let proc_block = CmmProc info lbl (ListGraph blocks)
    state <- getState
    setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block }
emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"

-- Emit a procedure whose body is the specified code; no info table
emitSimpleProc :: CLabel -> Code -> Code
emitSimpleProc lbl code = do
    stmts <- getCgStmts code
    blks <- cgStmtsToBlocks stmts
    emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks

-- Get all the CmmTops (there should be no stmts)
-- Return a single Cmm which may be split from other Cmms by
-- object splitting (at a later stage)
getCmm :: Code -> FCode CmmGroup
getCmm code = do
    state1 <- getState
    ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
    setState $ state2 { cgs_tops = cgs_tops state1 }
    return (fromOL (cgs_tops state2))

-- ----------------------------------------------------------------------------
-- CgStmts

-- These functions deal in terms of CgStmts, which is an abstract type
-- representing the code in the current proc.

-- emit CgStmts into the current instruction stream
emitCgStmts :: CgStmts -> Code
emitCgStmts stmts = do
    state <- getState
    setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts }

-- emit CgStmts outside the current instruction stream, and return a label
forkCgStmts :: CgStmts -> FCode BlockId
forkCgStmts stmts = do
    id <- newLabelC
    emitCgStmt (CgFork id stmts)
    return id

-- turn CgStmts into [CmmBasicBlock], for making a new proc.
cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
cgStmtsToBlocks stmts = do
    id <- newLabelC
    return (flattenCgStmts id stmts)

-- collect the code emitted by an FCode computation
getCgStmts' :: FCode a -> FCode (a, CgStmts)
getCgStmts' fcode = do
    state1 <- getState
    (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
    setState $ state2 { cgs_stmts = cgs_stmts state1  }
    return (a, cgs_stmts state2)

getCgStmts :: FCode a -> FCode CgStmts
getCgStmts fcode = do
    (_,stmts) <- getCgStmts' fcode
    return stmts

-- Simple ways to construct CgStmts:
noCgStmts :: CgStmts
noCgStmts = nilOL

oneCgStmt :: CmmStmt -> CgStmts
oneCgStmt stmt = unitOL (CgStmt stmt)

consCgStmt :: CmmStmt -> CgStmts -> CgStmts
consCgStmt stmt stmts = CgStmt stmt `consOL` stmts

-- ----------------------------------------------------------------------------
-- Get the current module name

getModuleName :: FCode Module
getModuleName = do
    info <- getInfoDown
    return (cgd_mod info)

-- ----------------------------------------------------------------------------
-- Get/set the end-of-block info

setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
setEndOfBlockInfo eob_info code = do
    info  <- getInfoDown
    withInfoDown code (info {cgd_eob = eob_info})

getEndOfBlockInfo :: FCode EndOfBlockInfo
getEndOfBlockInfo = do
    info <- getInfoDown
    return (cgd_eob info)

-- ----------------------------------------------------------------------------
-- Get/set the current SRT label

-- 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.

getSRTLabel :: FCode CLabel     -- Used only by cgPanic
getSRTLabel = do
    info  <- getInfoDown
    return (cgd_srt_lbl info)

setSRTLabel :: CLabel -> FCode a -> FCode a
setSRTLabel srt_lbl code = do
    info <- getInfoDown
    withInfoDown code (info { cgd_srt_lbl = srt_lbl})

getSRT :: FCode SRT
getSRT = do
    info <- getInfoDown
    return (cgd_srt info)

setSRT :: SRT -> FCode a -> FCode a
setSRT srt code = do
    info <- getInfoDown
    withInfoDown code (info { cgd_srt = srt})

-- ----------------------------------------------------------------------------
-- Get/set the current ticky counter label

getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = do
    info <- getInfoDown
    return (cgd_ticky info)

setTickyCtrLabel :: CLabel -> Code -> Code
setTickyCtrLabel ticky code = do
    info <- getInfoDown
    withInfoDown code (info {cgd_ticky = ticky})
\end{code}