X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgMonad.lhs;h=d9d0801a03fe7bef0df2c718cb826f656d0e7bda;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=bd7c9d673dc9b3ec37a7761e35c81300c7663553;hpb=89ea5818c80084440ea779bc93e6930a7a34752e;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index bd7c9d6..d9d0801 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,5 +1,7 @@ % -% (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} @@ -7,75 +9,74 @@ See the beginning of the top-level @CodeGen@ module, to see how this 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` @@ -93,25 +94,48 @@ along. \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, @@ -121,35 +145,15 @@ alternative. \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 @@ -158,146 +162,211 @@ block. \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 #-} @@ -306,98 +375,162 @@ type Code = CgInfoDownwards -> CgState -> CgState 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. @@ -406,37 +539,57 @@ bindings and usage information is otherwise unchanged. \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 @@ -446,55 +599,39 @@ that - 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 @@ -507,340 +644,204 @@ forkEval :: EndOfBlockInfo -- For the body -> 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}