% % (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}

    module CgMonad (
    	Code,	-- type
    	FCode,	-- type

    	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,
    	emitData, 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(..), -- ToDo: unabstract?

    	-- 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(..)	-- non-abstract
        ) where

    #include "HsVersions.h"

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

    import DynFlags
    import BlockId
    import Cmm
    import CmmUtils
    import CLabel
    import StgSyn (SRT)
    import SMRep
    import Module
    import Id
    import VarEnv
    import OrdList
    import Unique
    import Util()
    import UniqSupply
    import FastString()
    import Outputable

    import Control.Monad
    import Data.List

    infixr 9 `thenC`	-- Right-associative!
    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}

    data CgInfoDownwards	-- information only passed *downwards* by the monad
      = MkCgInfoDown {
    	cgd_dflags  :: DynFlags,
    	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:
      }

    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 }

    data CgState
      = MkCgState {
         cgs_stmts :: OrdList CgStmt,	  -- Current proc
         cgs_tops  :: OrdList CmmTop,
    	-- 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 }

    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 }

\end{code} @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. \begin{code}

    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

    initEobInfo :: EndOfBlockInfo
    initEobInfo = EndOfBlockInfo 0 OnStack

\end{code} Any addressing modes inside @Sequel@ must be ``robust,'' in the sense that it must survive stack pointer adjustments at the end of the block. \begin{code}

    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[1] 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)

    type ConTagZ = Int	-- A *zero-indexed* contructor tag

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

    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

    -- INVARIANT: The environment contains no Stable references to
    -- 	      stack slots below (lower offset) frameSp
    --	      It can contain volatile references to this area though.

    data HeapUsage =
      HeapUsage {
    	virtHp :: VirtualHpOffset,	-- Virtual offset of highest-allocated word
    	realHp :: VirtualHpOffset	-- realHp: Virtual offset of real heap ptr
      }

\end{code} The heap high water mark is the larger of virtHp and hwHp. The latter is only records the high water marks of forked-off branches, so to find the heap high water mark you have to take the max of virtHp and hwHp. Remember, virtHp never retreats! Note Jan 04: ok, so why do we only look at the virtual Hp?? \begin{code}

    heapHWM :: HeapUsage -> VirtualHpOffset
    heapHWM = virtHp

\end{code} Initialisation. \begin{code}

    initStkUsage :: StackUsage
    initStkUsage = StackUsage {
    			virtSp = 0,
    			frameSp = 0,
    			freeStk = [],
    			realSp = 0,
    			hwSp = 0
    	       }

    initHpUsage :: HeapUsage
    initHpUsage = HeapUsage {
    	      	virtHp = 0,
    		realHp = 0
    	      }

\end{code} @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 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

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

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

    maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
    hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }

    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 #-}

\end{code} The Abstract~C is not in the environment so as to improve strictness. \begin{code}

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

\end{code} \begin{code}

    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) = do
    	fc
    	listCs fcs

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

\end{code} \begin{code}

    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

\end{code} And the knot-tying combinator: \begin{code}

    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
    	)

    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)

    getDynFlags :: FCode DynFlags
    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 %* * %************************************************************************ @forkClosureBody@ takes a code, $c$, 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 abstract C from the fork is incorporated. @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. @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come from the current bindings, but which is otherwise freshly initialised. The Abstract~C returned is attached to the current state, but the bindings and usage information is otherwise unchanged. \begin{code}

    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 :: 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 :: Code -> FCode CgStmts
    forkProc body_code
      = do	{ info_down <- 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 }
    			-- ToDo: is the hp usage necesary?
    		(code_blks, fork_state_out) = doFCode (getCgStmts body_code)
    						      info_down fork_state_in
    	; setState $ state `stateIncUsageEval` fork_state_out
    	; return code_blks }

    codeOnly :: Code -> Code
    -- 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 body_code
      = do	{ info_down <- 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_down fork_state_in
    	; setState $ state `addCodeBlocksFrom` fork_state_out }

\end{code} @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and 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 \begin{code}

    forkAlts :: [FCode a] -> FCode [a]

    forkAlts branch_fcodes
      = do	{ info_down <- getInfoDown
    	; us <- newUniqSupply
    	; state <- getState
    	; let compile us branch
    		= (us2, doFCode branch info_down 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
    	; setState $ foldl stateIncUsage state branch_out_states
    		-- NB foldl.  state is the *left* argument to stateIncUsage
    	; return branch_results }

\end{code} @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. \begin{code}

    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) }

    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
    	-- A disturbingly complicated function
    forkEvalHelp body_eob_info env_code body_code
      = do	{ info_down <- getInfoDown
    	; us   <- newUniqSupply
    	; state <- getState
    	; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
    	      ; (_, env_state) = doFCode env_code info_down_for_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_down_for_body state_for_body
    	  }
    	; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
    		 -- The code coming back should consist only of nested declarations,
    		 -- notably of the return vector!
    	  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

    stmtC :: CmmStmt -> Code
    stmtC stmt = emitCgStmt (CgStmt stmt)

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

    newLabelC :: FCode BlockId
    newLabelC = do { u <- newUnique
                   ; return $ BlockId u }

    checkedAbsC :: CmmStmt -> Code
    -- Emit code, eliminating no-ops
    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 }
    	}

    emitData :: Section -> [CmmStatic] -> Code
    emitData sect lits
      = do 	{ state <- getState
    	; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
      where
        data_block = CmmData sect lits

    emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
    emitProc info lbl args blocks
      = do  { let proc_block = CmmProc info lbl args (ListGraph blocks)
    	; state <- getState
    	; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }

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

    getCmm :: Code -> FCode Cmm
    -- 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
      = do	{ state1 <- getState
    	; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
    	; setState $ state2 { cgs_tops = cgs_tops state1 }
    	; return (Cmm (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}