diff options
Diffstat (limited to 'compiler/codeGen/CgMonad.lhs')
| -rw-r--r-- | compiler/codeGen/CgMonad.lhs | 849 |
1 files changed, 0 insertions, 849 deletions
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs deleted file mode 100644 index f776af3b3b..0000000000 --- a/compiler/codeGen/CgMonad.lhs +++ /dev/null @@ -1,849 +0,0 @@ -% -% (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, runC, 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 Util -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 :: IO CgState -initC = do { uniqs <- mkSplitUniqSupply 'c' - ; return (initCgState uniqs) } - -runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState) -runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st - -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 :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code -emitProc mb_info lbl [] blocks = do - let proc_block = CmmProc infos lbl (ListGraph blocks) - state <- getState - setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } - where - infos = case (blocks,mb_info) of - (b:_, Just info) -> mapSingleton (blockId b) info - _other -> mapEmpty - -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 Nothing 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} |