X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgMonad.lhs;fp=ghc%2Fcompiler%2FcodeGen%2FCgMonad.lhs;h=0000000000000000000000000000000000000000;hb=0065d5ab628975892cea1ec7303f968c3338cbe1;hp=4f95c9b36a8a8e1d189d6b2b80aa6f42eb242e43;hpb=28a464a75e14cece5db40f2765a29348273ff2d2;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs deleted file mode 100644 index 4f95c9b..0000000 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ /dev/null @@ -1,853 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -% $Id: CgMonad.lhs,v 1.45 2005/06/21 10:44:41 simonmar Exp $ -% -\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, 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, - - setSRTLabel, getSRTLabel, - setTickyCtrLabel, getTickyCtrLabel, - - StackUsage(..), HeapUsage(..), - VirtualSpOffset, VirtualHpOffset, - initStkUsage, initHpUsage, - getHpUsage, setHpUsage, - heapHWM, - - moduleName, - - Sequel(..), -- ToDo: unabstract? - - -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getInfoDown, getDynFlags, getHomeModules, - - -- 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 ( DynFlags ) -import Packages ( HomeModules ) -import Cmm -import CmmUtils ( CmmStmts, isNopStmt ) -import CLabel -import SMRep ( WordOff ) -import Module ( Module ) -import Id ( Id ) -import VarEnv -import OrdList -import Unique ( Unique ) -import Util ( mapAccumL ) -import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply ) -import FastString -import Outputable - -import Control.Monad ( liftM ) - -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_hmods :: HomeModules, -- Packages we depend on - cgd_mod :: Module, -- Module being compiled - cgd_statics :: CgBindings, -- [Id -> info] : static environment - cgd_srt :: CLabel, -- label of 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 -> HomeModules -> Module -> CgInfoDownwards -initCgInfoDown dflags hmods mod - = MkCgInfoDown { cgd_dflags = dflags, - cgd_hmods = hmods, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - 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 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 - | UpdateCode -- Continuation is update - - | 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 - Bool -- True <=> polymorphic, push a SEQ frame too - -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] - = ( [], [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) - - 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 (CmmJump _ _) = True -isJump (CmmBranch _) = True -isJump _ = False - -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 -> HomeModules -> Module -> FCode a -> IO a - -initC dflags hmods mod (FCode code) - = do { uniqs <- mkSplitUniqSupply 'c' - ; case code (initCgInfoDown dflags hmods mod) (initCgState uniqs) of - (res, _) -> return res - } - -returnFC :: a -> FCode a -returnFC val = FCode (\info_down 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 - ) -\end{code} - -%************************************************************************ -%* * - Operators for getting and setting the state and "info_down". - -%* * -%************************************************************************ - -\begin{code} -getState :: FCode CgState -getState = FCode $ \info_down state -> (state,state) - -setState :: CgState -> FCode () -setState state = FCode $ \info_down _ -> ((),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 - -getHomeModules :: FCode HomeModules -getHomeModules = liftM cgd_hmods getInfoDown - -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 code = nopC - -stmtC :: CmmStmt -> Code -stmtC stmt = emitCgStmt (CgStmt stmt) - -labelC :: BlockId -> Code -labelC id = emitCgStmt (CgLabel id) - -newLabelC :: FCode BlockId -newLabelC = do { id <- newUnique; return (BlockId id) } - -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 :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code -emitProc lits lbl args blocks - = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args 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 [] lbl [] blks } - -getCmm :: Code -> FCode Cmm --- Get all the CmmTops (there should be no stmts) -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 - -moduleName :: FCode Module -moduleName = 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 info) - -setSRTLabel :: CLabel -> FCode a -> FCode a -setSRTLabel srt_lbl code - = do info <- getInfoDown - withInfoDown code (info { cgd_srt = srt_lbl}) - --- ---------------------------------------------------------------------------- --- 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}