%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.22 1999/06/09 14:28:38 simonmar Exp $
+% $Id: CgMonad.lhs,v 1.40 2004/08/13 13:06:03 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
FCode, -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
- returnFC, fixC, absC, nopC, getAbsC,
+ 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, forkAbsC,
- SemiTaggingStuff,
+ forkEvalHelp, forkProc, codeOnly,
+ SemiTaggingStuff, ConTagZ,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- setSRTLabel, getSRTLabel,
+ setSRTLabel, getSRTLabel,
+ setTickyCtrLabel, getTickyCtrLabel,
- StackUsage, Slot(..), HeapUsage,
+ StackUsage(..), HeapUsage(..),
+ VirtualSpOffset, VirtualHpOffset,
+ initStkUsage, initHpUsage,
+ getHpUsage, setHpUsage,
+ heapHWM,
- profCtrC,
-
- costCentresC, moduleName,
+ moduleName,
Sequel(..), -- ToDo: unabstract?
- sequelToAmode,
+
+ -- ideally we wouldn't export these, but some other modules access internal state
+ getState, setState, getInfoDown,
+
+ -- more localised access to monad state
+ getStkUsage, setStkUsage,
+ getBinds, setBinds, getStaticBinds,
-- out of general friendliness, we also export ...
- CgInfoDownwards(..), CgState(..), -- non-abstract
- CompilationInfo(..)
+ CgInfoDownwards(..), CgState(..) -- non-abstract
) where
#include "HsVersions.h"
-import {-# SOURCE #-} CgBindery ( CgIdInfo, CgBindings, nukeVolatileBinds )
-import {-# SOURCE #-} CgUsages ( getSpRelOffset )
+import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
-import AbsCSyn
-import AbsCUtils ( mkAbsCStmts )
-import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
-import CLabel ( CLabel, mkUpdInfoLabel )
+import Cmm
+import CmmUtils ( CmmStmts, isNopStmt )
+import CLabel
+import SMRep ( WordOff )
import Module ( Module )
-import DataCon ( ConTag )
import Id ( Id )
import VarEnv
-import PrimRep ( PrimRep(..) )
-import StgSyn ( StgLiveVars )
+import OrdList
+import Unique ( Unique )
+import Util ( mapAccumL )
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
+import FastString
import Outputable
infixr 9 `thenC` -- Right-associative!
\begin{code}
data CgInfoDownwards -- information only passed *downwards* by the monad
- = MkCgInfoDown
- CompilationInfo -- COMPLETELY STATIC info about this compilation
- -- (e.g., what flags were passed to the compiler)
-
- CgBindings -- [Id -> info] : static environment
-
- CLabel -- label of the current SRT
-
- EndOfBlockInfo -- Info for stuff to do at end of basic block:
-
-
-data CompilationInfo
- = MkCompInfo
- Module -- the module name
+ = MkCgInfoDown {
+ 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 :: Module -> CgInfoDownwards
+initCgInfoDown mod
+ = MkCgInfoDown { cgd_mod = mod,
+ cgd_statics = emptyVarEnv,
+ cgd_srt = error "initC: srt",
+ cgd_ticky = mkTopTickyCtrLabel,
+ cgd_eob = initEobInfo }
data CgState
- = MkCgState
- AbstractC -- code accumulated so far
- CgBindings -- [Id -> info] : *local* bindings environment
- -- Bindings for top-level things are given in the info-down part
- CgStksAndHeapUsage
+ = 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,
-- by a case alternative.
Sequel
-initEobInfo = EndOfBlockInfo 0 (OnStack 0)
+initEobInfo = EndOfBlockInfo 0 OnStack
\end{code}
Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
\begin{code}
data Sequel
- = OnStack
- VirtualSpOffset -- Continuation is on the stack, at the
- -- specified location
-
- | UpdateCode
+ = OnStack -- Continuation is on the stack
+ | UpdateCode -- Continuation is update
| CaseAlts
- CAddrMode -- Jump to this; if the continuation is for a vectored
- -- case this might be the label of a return
- -- vector Guaranteed to be a non-volatile
- -- addressing mode (I think)
- SemiTaggingStuff
-
- | SeqFrame -- like CaseAlts but push a seq frame too.
- CAddrMode
+ 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...
- ([(ConTag, JoinDetails)], -- Alternatives
- Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
- -- Maybe[3] the default is a
- -- bind-default (Just b); that is,
- -- it expects a ptr to the thing
- -- in Node, bound to b
- )
-
-type JoinDetails
- = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
- -- and join point label
-
--- The abstract C is executed only from a successful semitagging
+ = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
+ ([(ConTagZ, CLabel)], -- Alternatives
+ CLabel) -- 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.
-
--- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only
--- valid just before the final control transfer, because it assumes
--- that Sp is pointing to the top word of the return address. This
--- seems unclean but there you go.
-
--- sequelToAmode returns an amode which refers to an info table. The info
--- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
--- not to handle real code pointers, just in case we're compiling for
--- an unregisterised/untailcallish architecture, where info pointers and
--- code pointers aren't the same.
-
-sequelToAmode :: Sequel -> FCode CAddrMode
-
-sequelToAmode (OnStack virt_sp_offset)
- = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
- returnFC (CVal sp_rel RetRep)
-
-sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
-sequelToAmode (CaseAlts amode _) = returnFC amode
-sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
-
-type CgStksAndHeapUsage -- stacks and heap usage information
- = (StackUsage, HeapUsage)
-
-data Slot = Free | NonPointer
- deriving
-#ifdef DEBUG
- (Eq,Show)
-#else
- Eq
-#endif
-
-type StackUsage =
- (Int, -- virtSp: Virtual offset of topmost allocated slot
- [(Int,Slot)], -- free: List of free slots, in increasing order
- Int, -- realSp: Virtual offset of real stack pointer
- Int) -- hwSp: Highest value ever taken by virtSp
-
-type HeapUsage =
- (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
- HeapOffset) -- realHp: Virtual offset of real heap ptr
\end{code}
-NB: absolutely every one of the above Ints is really
-a VirtualOffset of some description (the code generator
-works entirely in terms of VirtualOffsets).
+%************************************************************************
+%* *
+ CgStmt type
+%* *
+%************************************************************************
-Initialisation.
+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}
-initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
+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
+
+-- INVARAINT: 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}
-initUsage :: CgStksAndHeapUsage
-initUsage = ((0,[],0,0), (0,0))
+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}
-"envInitForAlternatives" initialises the environment for a case alternative,
-assuming that the alternative is entered after an evaluation.
-This involves:
-
- - zapping any volatile bindings, which aren't valid.
-
- - zapping the heap usage. It should be restored by a heap check.
-
- - setting the virtual AND real stack pointer fields to the given
- virtual stack offsets. this doesn't represent any {\em code}; it is a
- prediction of where the real stack pointer will be when we come back
- from the case analysis.
-
- - BUT LEAVING the rest of the stack-usage info because it is all
- valid. In particular, we leave the tail stack pointers unchanged,
- becuase the alternative has to de-allocate the original @case@
- expression's stack. \end{itemize}
+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 }
-stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
- (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
- = MkCgState abs_c
- bs
- ((v,f,r,h1 `max` h2),
- (vH1 `max` vH2, rH1))
+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}
%************************************************************************
%* *
-\subsection[CgMonad-basics]{Basic code-generation monad magic}
+ The FCode monad
%* *
%************************************************************************
\begin{code}
-type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
-type Code = CgInfoDownwards -> CgState -> CgState
+newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
+type Code = FCode ()
+
+instance Monad FCode where
+ (>>=) = thenFC
+ return = returnFC
{-# INLINE thenC #-}
{-# INLINE thenFC #-}
The Abstract~C is not in the environment so as to improve strictness.
\begin{code}
-initC :: CompilationInfo -> Code -> AbstractC
+initC :: Module -> FCode a -> IO a
-initC cg_info code
- = case (code (MkCgInfoDown
- cg_info
- (error "initC: statics")
- (error "initC: srt")
- initEobInfo)
- initialStateC) of
- MkCgState abc _ _ -> abc
+initC mod (FCode code)
+ = do { uniqs <- mkSplitUniqSupply 'c'
+ ; case code (initCgInfoDown mod) (initCgState uniqs) of
+ (res, _) -> return res
+ }
returnFC :: a -> FCode a
-
-returnFC val info_down state = (val, state)
+returnFC val = FCode (\info_down state -> (val, state))
\end{code}
\begin{code}
-thenC :: Code
- -> (CgInfoDownwards -> CgState -> a)
- -> CgInfoDownwards -> CgState -> a
-
--- thenC has both of the following types:
--- thenC :: Code -> Code -> Code
--- thenC :: Code -> FCode a -> FCode a
-
-thenC m k info_down state
- = k info_down new_state
- where
- new_state = m info_down 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 [] info_down state = state
-listCs (c:cs) info_down state = stateN
- where
- state1 = c info_down state
- stateN = listCs cs info_down state1
-
+listCs [] = return ()
+listCs (fc:fcs) = do
+ fc
+ listCs fcs
+
mapCs :: (a -> Code) -> [a] -> Code
-
-mapCs f [] info_down state = state
-mapCs f (c:cs) info_down state = stateN
- where
- state1 = (f c) info_down state
- stateN = mapCs f cs info_down state1
+mapCs = mapM_
\end{code}
\begin{code}
-thenFC :: FCode a
- -> (a -> CgInfoDownwards -> CgState -> c)
- -> CgInfoDownwards -> CgState -> c
-
--- thenFC :: FCode a -> (a -> FCode b) -> FCode b
--- thenFC :: FCode a -> (a -> Code) -> Code
-
-thenFC m k info_down state
- = k m_result info_down new_state
- where
- (m_result, new_state) = m info_down state
+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 [] info_down state = ([], state)
-listFCs (fc:fcs) info_down state = (thing : things, stateN)
- where
- (thing, state1) = fc info_down state
- (things, stateN) = listFCs fcs info_down state1
+listFCs = sequence
mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
-
-mapFCs f [] info_down state = ([], state)
-mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
- where
- (thing, state1) = (f fc) info_down state
- (things, stateN) = mapFCs f fcs info_down state1
+mapFCs = mapM
\end{code}
And the knot-tying combinator:
\begin{code}
fixC :: (a -> FCode a) -> FCode a
-fixC fcode info_down state = result
- where
- result@(v, _) = fcode v info_down state
- -- ^-------------^
+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)
+
+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.
-@forkAbsC@ takes a code and compiles it in the current environment,
-returning the abstract C thus constructed. The current environment
-is passed on completely unchanged. It is pretty similar to @getAbsC@,
-except that the latter does affect the environment. ToDo: combine?
+@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.
\begin{code}
forkClosureBody :: Code -> Code
-
-forkClosureBody code
- (MkCgInfoDown cg_info statics srt _)
- (MkCgState absC_in binds un_usage)
- = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
- where
- fork_state = code body_info_down initialStateC
- MkCgState absC_fork _ _ = fork_state
- body_info_down = MkCgInfoDown cg_info statics srt initEobInfo
-
+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 fcode (MkCgInfoDown cg_info _ srt _)
- (MkCgState absC_in statics un_usage)
- = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
- where
- (result, state) = fcode rhs_info_down initialStateC
- MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
- -- above or it becomes too strict!
- rhs_info_down = MkCgInfoDown cg_info statics srt initEobInfo
-
-forkAbsC :: Code -> FCode AbstractC
-forkAbsC code info_down (MkCgState absC1 bs usage)
- = (absC2, new_state)
- where
- MkCgState absC2 _ ((_, _, _,h2), _) =
- code info_down (MkCgState AbsCNop bs usage)
- ((v, f, r, h1), heap_usage) = usage
-
- new_usage = ((v, f, r, h1 `max` h2), heap_usage)
- new_state = MkCgState absC1 bs new_usage
+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
- the virtual Hp is moved on to the worst virtual Hp for the branches
\begin{code}
-forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
-
-forkAlts branch_fcodes deflt_fcode info_down in_state
- = ((branch_results , deflt_result), out_state)
- where
- compile fc = fc info_down in_state
-
- (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
-
- (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
-
- out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
- -- NB foldl. in_state is the *left* argument to stateIncUsage
+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.
-> FCode EndOfBlockInfo -- The new end of block info
forkEval body_eob_info env_code body_code
- = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
- returnFC (EndOfBlockInfo v sequel)
+ = 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 (Int, -- Sp
- a) -- Result of the FCode
-
+ -> FCode (VirtualSpOffset, -- Sp
+ a) -- Result of the FCode
+ -- A disturbingly complicated function
forkEvalHelp body_eob_info env_code body_code
- info_down@(MkCgInfoDown cg_info statics srt _) state
- = ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
- where
- info_down_for_body = MkCgInfoDown cg_info statics srt body_eob_info
-
- (MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
- -- These v and f things are now set up as the body code expects them
-
- (value_returned, state_at_end_return)
- = body_code info_down_for_body state_for_body
-
- state_for_body = MkCgState AbsCNop
- (nukeVolatileBinds binds)
- ((v,f,v,v), (0,0))
-
-
-stateIncUsageEval :: CgState -> CgState -> CgState
-stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
- (MkCgState absC2 _ ((_,_,_,h2), _))
- = MkCgState (absC1 `AbsCStmts` absC2)
- -- The AbsC coming back should consist only of nested declarations,
+ = do { info_down@(MkCgInfoDown cg_info statics srt ticky _) <- 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!
- bs
- ((v,f,r,h1 `max` h2), heap_usage)
- -- 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.
-\end{code}
+ setState $ state `stateIncUsageEval` state_at_end_return
+ ; return (virtSp_from_env, value_returned) }
-%************************************************************************
-%* *
-\subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
-%* *
-%************************************************************************
-@nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
-environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
-\begin{code}
+-- ----------------------------------------------------------------------------
+-- Combinators for emitting code
+
nopC :: Code
-nopC info_down state = state
+nopC = return ()
-absC :: AbstractC -> Code
-absC more_absC info_down state@(MkCgState absC binds usage)
- = MkCgState (mkAbsCStmts absC more_absC) binds usage
-\end{code}
+whenC :: Bool -> Code -> Code
+whenC True code = code
+whenC False code = nopC
-These two are just like @absC@, except they examine the compilation
-info (whether SCC profiling or profiling-ctrs going) and possibly emit
-nothing.
+stmtC :: CmmStmt -> Code
+stmtC stmt = emitCgStmt (CgStmt stmt)
-\begin{code}
-costCentresC :: FAST_STRING -> [CAddrMode] -> Code
+labelC :: BlockId -> Code
+labelC id = emitCgStmt (CgLabel id)
-costCentresC macro args _ state@(MkCgState absC binds usage)
- = if opt_SccProfilingOn
- then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
- else state
+newLabelC :: FCode BlockId
+newLabelC = do { id <- newUnique; return (BlockId id) }
-profCtrC :: FAST_STRING -> [CAddrMode] -> Code
+checkedAbsC :: CmmStmt -> Code
+-- Emit code, eliminating no-ops
+checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
+ else unitOL stmt)
-profCtrC macro args _ state@(MkCgState absC binds usage)
- = if not opt_DoTickyProfiling
- then state
- else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
+stmtsC :: [CmmStmt] -> Code
+stmtsC stmts = emitStmts (toOL stmts)
-{- Try to avoid adding too many special compilation strategies here.
- It's better to modify the header files as necessary for particular
- targets, so that we can get away with as few variants of .hc files
- as possible.
--}
-\end{code}
+-- Emit code; no no-op checking
+emitStmts :: CmmStmts -> Code
+emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
-@getAbsC@ compiles the code in the current environment, and returns
-the abstract C thus constructed (leaving the abstract C being carried
-around in the state untouched). @getAbsC@ does not generate any
-in-line Abstract~C itself, but the environment it returns is that
-obtained from the compilation.
+-- 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
-\begin{code}
-getAbsC :: Code -> FCode AbstractC
+emitCgStmt :: CgStmt -> Code
+emitCgStmt stmt
+ = do { state <- getState
+ ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
+ }
-getAbsC code info_down (MkCgState absC binds usage)
- = (absC2, MkCgState absC binds2 usage2)
+emitData :: Section -> [CmmStatic] -> Code
+emitData sect lits
+ = do { state <- getState
+ ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
where
- (MkCgState absC2 binds2 usage2)
- = code info_down (MkCgState AbsCNop binds usage)
-\end{code}
-
-\begin{code}
+ 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 (MkCgInfoDown (MkCompInfo mod_name) _ _ _) state
- = (mod_name, state)
+moduleName = do { info <- getInfoDown; return (cgd_mod info) }
-\end{code}
+-- ----------------------------------------------------------------------------
+-- Get/set the end-of-block info
-\begin{code}
setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
-setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt _) state
- = code (MkCgInfoDown c_info statics srt eob_info) state
+setEndOfBlockInfo eob_info code = do
+ info <- getInfoDown
+ withInfoDown code (info {cgd_eob = eob_info})
getEndOfBlockInfo :: FCode EndOfBlockInfo
-getEndOfBlockInfo (MkCgInfoDown c_info statics _ eob_info) state
- = (eob_info, state)
-\end{code}
-
-\begin{code}
-getSRTLabel :: FCode CLabel
-getSRTLabel (MkCgInfoDown _ _ srt _) state
- = (srt, state)
-
-setSRTLabel :: CLabel -> Code -> Code
-setSRTLabel srt code (MkCgInfoDown c_info statics _ eob_info) state
- = code (MkCgInfoDown c_info statics srt eob_info) state
+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}