%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgMonad.lhs,v 1.42 2004/11/26 16:20:10 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
monadic stuff fits into the Big Picture.
\begin{code}
-#include "HsVersions.h"
-
module CgMonad (
- SYN_IE(Code), -- type
- SYN_IE(FCode), -- type
+ Code, -- type
+ 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,
- forkClosureBody, forkStatics, forkAlts, forkEval,
- forkEvalHelp, forkAbsC,
- SYN_IE(SemiTaggingStuff),
+ CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
+ getCgStmts', getCgStmts,
+ noCgStmts, oneCgStmt, consCgStmt,
+
+ getCmm,
+ emitData, emitProc, emitSimpleProc,
- addBindC, addBindsC, modifyBindC, lookupBindC,
+ forkLabelledCode,
+ forkClosureBody, forkStatics, forkAlts, forkEval,
+ forkEvalHelp, forkProc, codeOnly,
+ SemiTaggingStuff, ConTagZ,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- SYN_IE(AStackUsage), SYN_IE(BStackUsage), SYN_IE(HeapUsage),
- StubFlag,
- isStubbed,
+ setSRTLabel, getSRTLabel,
+ setTickyCtrLabel, getTickyCtrLabel,
- nukeDeadBindings, getUnstubbedAStackSlots,
+ StackUsage(..), HeapUsage(..),
+ VirtualSpOffset, VirtualHpOffset,
+ initStkUsage, initHpUsage,
+ getHpUsage, setHpUsage,
+ heapHWM,
--- addFreeASlots, -- no need to export it
- addFreeBSlots, -- ToDo: Belong elsewhere
+ moduleName,
- noBlackHolingFlag,
- profCtrC,
+ Sequel(..), -- ToDo: unabstract?
- costCentresC, costCentresFlag, moduleName,
+ -- ideally we wouldn't export these, but some other modules access internal state
+ getState, setState, getInfoDown, getDynFlags,
- Sequel(..), -- ToDo: unabstract?
- sequelToAmode,
+ -- 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
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages
-IMPORT_1_3(List(nub))
-
-import AbsCSyn
-import AbsCUtils ( mkAbsCStmts )
-import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
- opt_OmitBlackHoling
- )
-import HeapOffs ( maxOff,
- SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset),
- HeapOffset
- )
-import CLabel ( CLabel )
-import Id ( idType,
- nullIdEnv, mkIdEnv, addOneToIdEnv,
- modifyIdEnv, lookupIdEnv, rngIdEnv, SYN_IE(IdEnv),
- SYN_IE(ConTag), GenId{-instance Outputable-},
- SYN_IE(Id)
- )
-import Maybes ( maybeToBool )
-import Outputable ( PprStyle(..), Outputable(..) )
-import PprType ( GenType{-instance Outputable-} )
-import Pretty ( Doc, vcat, hsep, ptext )
-import PrimRep ( getPrimRepSize, PrimRep(..) )
-import StgSyn ( SYN_IE(StgLiveVars) )
-import Type ( typePrimRep )
-import UniqSet ( elementOfUniqSet )
-import Util ( sortLt, panic, pprPanic )
+#include "HsVersions.h"
+
+import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
+
+import CmdLineOpts ( DynFlags )
+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`
\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
-
- EndOfBlockInfo -- Info for stuff to do at end of basic block:
-
-
-data CompilationInfo
- = MkCompInfo
- FAST_STRING -- the module name
+ = MkCgInfoDown {
+ cgd_dflags :: DynFlags,
+ 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 -> Module -> CgInfoDownwards
+initCgInfoDown dflags mod
+ = MkCgInfoDown { cgd_dflags = dflags,
+ 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,
\begin{code}
data EndOfBlockInfo
= EndOfBlockInfo
- VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
+ 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 A-stk ptr as seen
+ -- This is therefore the stk ptr as seen
-- by a case alternative.
-
- -- Args SpA is used when we want to stub any
- -- currently-unstubbed dead A-stack (ptr)
- -- slots; we want to know what SpA in the
- -- continuation is so that we don't stub any
- -- slots which are off the top of the
- -- continuation's stack!
-
- VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
- -- Two main differences:
- -- 1. If Sequel isn't OnStack, then Args SpB points
- -- just below the slot in which the return address
- -- should be put. In effect, the Sequel
- -- is a pending argument. If it is
- -- OnStack, Args SpB
- -- points to the top word of the return
- -- address.
- --
- -- 2. It ain't used for stubbing because there are
- -- no ptrs on B stk.
Sequel
-initEobInfo = EndOfBlockInfo 0 0 InRetReg
+initEobInfo = EndOfBlockInfo 0 OnStack
\end{code}
Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
\begin{code}
data Sequel
- = InRetReg -- The continuation is in RetReg
-
- | OnStack VirtualSpBOffset
- -- Continuation is on the stack, at the
- -- specified location
-
- | UpdateCode CAddrMode -- May be standard update code, or might be
- -- the data-type-specific one.
+ = 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)
+ 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, 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}
--- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only
--- valid just before the final control transfer, because it assumes
--- that SpB is pointing to the top word of the return address. This
--- seems unclean but there you go.
+%************************************************************************
+%* *
+ CgStmt type
+%* *
+%************************************************************************
-sequelToAmode :: Sequel -> FCode CAddrMode
+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).
-sequelToAmode (OnStack virt_spb_offset)
- = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
- returnFC (CVal spb_rel RetRep)
+\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}
-sequelToAmode InRetReg = returnFC (CReg RetReg)
---Andy/Simon's patch:
---WAS: sequelToAmode (UpdateCode amode) = returnFC amode
-sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
-sequelToAmode (CaseAlts amode _) = returnFC amode
+%************************************************************************
+%* *
+ 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}
-See the NOTES about the details of stack/heap usage tracking.
+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}
-type CgStksAndHeapUsage -- stacks and heap usage information
- = (AStackUsage, -- A-stack usage
- BStackUsage, -- B-stack usage
- HeapUsage)
-
-type AStackUsage =
- (Int, -- virtSpA: Virtual offset of topmost allocated slot
- [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
- Int, -- realSpA: Virtual offset of real stack pointer
- Int) -- hwSpA: Highest value ever taken by virtSp
-
-data StubFlag = Stubbed | NotStubbed
-
-isStubbed Stubbed = True -- so the type can be abstract
-isStubbed NotStubbed = False
-
-type BStackUsage =
- (Int, -- virtSpB: Virtual offset of topmost allocated slot
- [Int], -- freeB: List of free slots, in increasing order
- Int, -- realSpB: Virtual offset of real stack pointer
- Int) -- hwSpB: Highest value ever taken by virtSp
-
-type HeapUsage =
- (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
- HeapOffset) -- realHp: Virtual offset of real heap ptr
+heapHWM :: HeapUsage -> VirtualHpOffset
+heapHWM = virtHp
\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; see NOTES).
Initialisation.
\begin{code}
-initialStateC = MkCgState AbsCNop nullIdEnv initUsage
-
-initUsage :: CgStksAndHeapUsage
-initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
-initVirtHp = panic "Uninitialised virtual Hp"
-initRealHp = panic "Uninitialised real Hp"
+initStkUsage :: StackUsage
+initStkUsage = StackUsage {
+ virtSp = 0,
+ frameSp = 0,
+ freeStk = [],
+ realSp = 0,
+ hwSp = 0
+ }
+
+initHpUsage :: HeapUsage
+initHpUsage = HeapUsage {
+ virtHp = 0,
+ realHp = 0
+ }
\end{code}
-@envInitForAlternatives@ initialises the environment for a case alternative,
-assuming that the alternative is entered after an evaluation.
-This involves:
-\begin{itemize}
-\item
-zapping any volatile bindings, which aren't valid.
-\item
-zapping the heap usage. It should be restored by a heap check.
-\item
-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.
-\item
-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}
-
@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 }
-stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
- (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
- = MkCgState abs_c
- bs
- ((vA,fA,rA,hA1 `max` hA2),
- (vB,fB,rB,hB1 `max` hB2),
- (vH1 `maxOff` vH2, rH1))
+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 :: DynFlags -> Module -> FCode a -> IO a
-initC cg_info code
- = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
- initialStateC) of
- MkCgState abc _ _ -> abc
+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 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)
+
+getDynFlags :: FCode DynFlags
+getDynFlags = liftM cgd_dflags 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.
-@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 _)
- (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 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 _ _)
- (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 initEobInfo
-
-forkAbsC :: Code -> FCode AbstractC
-forkAbsC code info_down (MkCgState absC1 bs usage)
- = (absC2, new_state)
- where
- MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
- code info_down (MkCgState AbsCNop bs usage)
- ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
-
- new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), 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 worst stack high-water mark is incorporated
- the virtual Hp is moved on to the worst virtual Hp for the branches
-The "extra branches" arise from handling the default case:
-
- case f x of
- C1 a b -> e1
- z -> e2
-
-Here we in effect expand to
-
- case f x of
- C1 a b -> e1
- C2 c -> let z = C2 c in JUMP(default)
- C3 d e f -> let z = C2 d e f in JUMP(default)
-
- default: e2
-
-The stuff for C2 and C3 are the extra branches. They are
-handled differently by forkAlts, because their
-heap usage is joined onto that for the default case.
-
\begin{code}
-forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
-
-forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
- = ((extra_branch_results ++ branch_results , deflt_result), out_state)
- where
- compile fc = fc info_down in_state
-
- (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
- (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
-
- -- The "in_state" for the default branch is got by worst-casing the
- -- heap usages etc from the "extra_branches"
- default_in_state = foldl stateIncUsage in_state extra_branch_out_states
- (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
-
- out_state = foldl stateIncUsage default_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.
-\begin{itemize}
-\item 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).
-\item The second block is the code for the alternatives.
- (plus info for semi-tagging purposes)
-\end{itemize}
-@forkEval@ picks up the virtual stack pointers and stubbed stack slots
-as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
-the caller to use, together with whatever value is returned by the second block.
+
+ - 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
-> 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` \ (vA, vB, sequel) ->
- returnFC (EndOfBlockInfo vA vB 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, -- SpA
- Int, -- SpB
- 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 _) state
- = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
- where
- info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
-
- (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
- -- These vA and fA things are now set up as the body code expects them
-
- state_at_end_return :: CgState
-
- (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
-
- state_for_body :: CgState
-
- state_for_body = MkCgState AbsCNop
- (nukeVolatileBinds binds)
- ((vA,stubbed_fA,vA,vA), -- Set real and hwms
- (vB,fB,vB,vB), -- to virtual ones
- (initVirtHp, initRealHp))
-
- stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
- -- In the branch, all free locations will have been stubbed
-
-
-stateIncUsageEval :: CgState -> CgState -> CgState
-stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
- (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
- = MkCgState (absC1 `AbsCStmts` absC2)
- -- The AbsC coming back should consist only of nested declarations,
+ = 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!
- bs
- ((vA,fA,rA,hA1 `max` hA2),
- (vB,fB,rB,hB1 `max` hB2),
- 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}
-nopC :: Code
-nopC info_down state = state
+-- ----------------------------------------------------------------------------
+-- Combinators for emitting code
-absC :: AbstractC -> Code
-absC more_absC info_down state@(MkCgState absC binds usage)
- = MkCgState (mkAbsCStmts absC more_absC) binds usage
-\end{code}
+nopC :: Code
+nopC = return ()
-These two are just like @absC@, except they examine the compilation
-info (whether SCC profiling or profiling-ctrs going) and possibly emit
-nothing.
+whenC :: Bool -> Code -> Code
+whenC True code = code
+whenC False code = nopC
-\begin{code}
-costCentresC :: FAST_STRING -> [CAddrMode] -> Code
-
-costCentresC macro args _ state@(MkCgState absC binds usage)
- = if opt_SccProfilingOn
- then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
- else state
-
-profCtrC :: FAST_STRING -> [CAddrMode] -> Code
-
-profCtrC macro args _ state@(MkCgState absC binds usage)
- = if not opt_DoTickyProfiling
- then state
- else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
-
-{- 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. 'ForConcurrent' is somewhat special anyway, as it
- changes entry conventions pretty significantly.
--}
-\end{code}
+stmtC :: CmmStmt -> Code
+stmtC stmt = emitCgStmt (CgStmt stmt)
-@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.
+labelC :: BlockId -> Code
+labelC id = emitCgStmt (CgLabel id)
-\begin{code}
-getAbsC :: Code -> FCode AbstractC
+newLabelC :: FCode BlockId
+newLabelC = do { id <- newUnique; return (BlockId id) }
-getAbsC code info_down (MkCgState absC binds usage)
- = (absC2, MkCgState absC binds2 usage2)
- where
- (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
-\end{code}
+checkedAbsC :: CmmStmt -> Code
+-- Emit code, eliminating no-ops
+checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
+ else unitOL stmt)
-\begin{code}
-noBlackHolingFlag, costCentresFlag :: FCode Bool
+stmtsC :: [CmmStmt] -> Code
+stmtsC stmts = emitStmts (toOL stmts)
-noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
-costCentresFlag _ state = (opt_SccProfilingOn, state)
-\end{code}
+-- Emit code; no no-op checking
+emitStmts :: CmmStmts -> Code
+emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
-\begin{code}
+-- 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
-moduleName :: FCode FAST_STRING
-moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
- = (mod_name, state)
+emitCgStmt :: CgStmt -> Code
+emitCgStmt stmt
+ = do { state <- getState
+ ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
+ }
-\end{code}
+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
-\begin{code}
setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
-setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
- = code (MkCgInfoDown c_info statics 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}
-
-%************************************************************************
-%* *
-\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
-%* *
-%************************************************************************
-
-There are three basic routines, for adding (@addBindC@), modifying
-(@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine
-is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
-on the end of each function name).
-
-A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
-The name should not already be bound. (nice ASSERT, eh?)
-\begin{code}
-addBindC :: Id -> CgIdInfo -> Code
-addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
- = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
-\end{code}
-
-\begin{code}
-addBindsC :: [(Id, CgIdInfo)] -> Code
-addBindsC new_bindings info_down (MkCgState absC binds usage)
- = MkCgState absC new_binds usage
- where
- new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
- binds
- new_bindings
-\end{code}
-
-\begin{code}
-modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
-modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
- = MkCgState absC (modifyIdEnv mangle_fn binds name) usage
-\end{code}
-
-Lookup is expected to find a binding for the @Id@.
-\begin{code}
-lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
- state@(MkCgState absC local_binds usage)
- = (val, state)
- where
- val = case (lookupIdEnv local_binds name) of
- Nothing -> try_static
- Just this -> this
-
- try_static = case (lookupIdEnv static_binds name) of
- Just this -> this
- Nothing
- -> pprPanic "lookupBindC:no info!\n"
- (vcat [
- hsep [ptext SLIT("for:"), ppr PprShowAll name],
- ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
- ptext SLIT("static binds for:"),
- vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
- ptext SLIT("local binds for:"),
- vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
- ])
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgStackery-deadslots]{Finding dead stack slots}
-%* *
-%************************************************************************
-
-@nukeDeadBindings@ does the following:
-\begin{itemize}
-\item Removes all bindings from the environment other than those
- for variables in the argument to @nukeDeadBindings@.
-\item Collects any stack slots so freed, and returns them to the appropriate
- stack free list.
-\item Moves the virtual stack pointers to point to the topmost used
- stack locations.
-\end{itemize}
-
-Find dead slots on the stacks *and* remove bindings for dead variables
-from the bindings.
-
-You can have multi-word slots on the B stack; if dead, such a slot
-will be reported as {\em several} offsets (one per word).
-
-NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
-set, so that no stack-stubbing will take place.
-
-Probably *naughty* to look inside monad...
-
-\begin{code}
-nukeDeadBindings :: StgLiveVars -- All the *live* variables
- -> Code
-nukeDeadBindings
- live_vars
- info_down
- state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
- (vsp_b, free_b, real_b, hw_b),
- heap_usage))
- = MkCgState abs_c (mkIdEnv bs') new_usage
- where
- new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
- (new_vsp_b, new_free_b, real_b, hw_b),
- heap_usage)
-
- (dead_a_slots, dead_b_slots, bs')
- = dead_slots live_vars
- [] [] []
- [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
-
- extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
- extra_free_b = sortLt (<) dead_b_slots
-
- (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
- (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b)
-
-getUnstubbedAStackSlots
- :: VirtualSpAOffset -- Ignore slots bigger than this
- -> FCode [VirtualSpAOffset] -- Return the list of slots found
-
-getUnstubbedAStackSlots tail_spa
- info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
- = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
-\end{code}
-
-Several boring auxiliary functions to do the dirty work.
-
-\begin{code}
-dead_slots :: StgLiveVars
- -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
- -> [(Id,CgIdInfo)]
- -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
-
--- dead_slots carries accumulating parameters for
--- filtered bindings, dead a and b slots
-dead_slots live_vars fbs das dbs []
- = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
-
-dead_slots live_vars fbs das dbs ((v,i):bs)
- | v `elementOfUniqSet` live_vars
- = dead_slots live_vars ((v,i):fbs) das dbs bs
- -- Live, so don't record it in dead slots
- -- Instead keep it in the filtered bindings
-
- | otherwise
- = case i of
- MkCgIdInfo _ _ stable_loc _
- | is_Astk_loc ->
- dead_slots live_vars fbs (offsetA : das) dbs bs
-
- | is_Bstk_loc ->
- dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
- where
- maybe_Astk_loc = maybeAStkLoc stable_loc
- is_Astk_loc = maybeToBool maybe_Astk_loc
- (Just offsetA) = maybe_Astk_loc
-
- maybe_Bstk_loc = maybeBStkLoc stable_loc
- is_Bstk_loc = maybeToBool maybe_Bstk_loc
- (Just offsetB) = maybe_Bstk_loc
-
- _ -> dead_slots live_vars fbs das dbs bs
- where
- size :: Int
- size = (getPrimRepSize . typePrimRep . idType) v
-
--- addFreeSlots expects *both* args to be in increasing order
-addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
-addFreeASlots = addFreeSlots fst
-
-addFreeBSlots :: [Int] -> [Int] -> [Int]
-addFreeBSlots = addFreeSlots id
-
-addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
-
-addFreeSlots get_offset cs [] = cs
-addFreeSlots get_offset [] ns = ns
-addFreeSlots get_offset (c:cs) (n:ns)
- = if off_c < off_n then
- (c : addFreeSlots get_offset cs (n:ns))
- else if off_c > off_n then
- (n : addFreeSlots get_offset (c:cs) ns)
- else
- panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
- where
- off_c = get_offset c
- off_n = get_offset n
-
-trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
-
-trim get_offset current_sp free_slots
- = try current_sp (reverse free_slots)
- where
- try csp [] = (csp, [])
- try csp (slot:slots)
- = if csp < slot_off then
- try csp slots -- Free slot off top of stk; ignore
-
- else if csp == slot_off then
- try (csp-1) slots -- Free slot at top of stk; trim
-
- else
- (csp, reverse (slot:slots)) -- Otherwise gap; give up
- where
- slot_off = get_offset slot
+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}
projects / ghc-hetmet.git / blobdiff