%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgMonad.lhs,v 1.27 2001/08/29 14:20:14 rje Exp $
%
\section[CgMonad]{The code generation monad}
forkEvalHelp, forkAbsC,
SemiTaggingStuff,
- addBindC, addBindsC, modifyBindC, lookupBindC,
-
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- AStackUsage, BStackUsage, HeapUsage,
- StubFlag,
- isStubbed,
+ setSRTLabel, getSRTLabel,
+ setTickyCtrLabel, getTickyCtrLabel,
- nukeDeadBindings, getUnstubbedAStackSlots,
+ StackUsage, Slot(..), HeapUsage,
--- addFreeASlots, -- no need to export it
- addFreeBSlots, -- ToDo: Belong elsewhere
+ profCtrC, profCtrAbsC,
- noBlackHolingFlag,
- profCtrC,
-
- costCentresC, costCentresFlag, moduleName,
+ costCentresC, moduleName,
Sequel(..), -- ToDo: unabstract?
sequelToAmode,
+ -- ideally we wouldn't export these, but some other modules access internal state
+ getState, setState, getInfoDown,
+
+ -- more localised access to monad state
+ getUsage, setUsage,
+ getBinds, setBinds, getStaticBinds,
+
-- out of general friendliness, we also export ...
CgInfoDownwards(..), CgState(..), -- non-abstract
CompilationInfo(..)
#include "HsVersions.h"
-import List ( nub )
-
-import {-# SOURCE #-} CgBindery ( CgIdInfo(..), CgBindings, maybeAStkLoc, maybeBStkLoc, nukeVolatileBinds )
-import {-# SOURCE #-} CgUsages
+import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
+import {-# SOURCE #-} CgUsages ( getSpRelOffset )
import AbsCSyn
import AbsCUtils ( mkAbsCStmts )
-import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
- opt_OmitBlackHoling
- )
-import HeapOffs ( maxOff,
- VirtualSpAOffset, VirtualSpBOffset,
- HeapOffset
- )
-import CLabel ( CLabel )
-import Id ( idType,
- nullIdEnv, mkIdEnv, addOneToIdEnv,
- modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv,
- ConTag, GenId{-instance Outputable-},
- Id
- )
-import Literal ( Literal )
-import Maybes ( maybeToBool )
-import PrimRep ( getPrimRepSize, PrimRep(..) )
-import StgSyn ( StgLiveVars )
-import Type ( typePrimRep )
-import UniqSet ( elementOfUniqSet )
-import Util ( sortLt )
+import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
+import CLabel ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
+import Module ( Module )
+import DataCon ( ConTag )
+import Id ( Id )
+import VarEnv
+import PrimRep ( PrimRep(..) )
import Outputable
infixr 9 `thenC` -- Right-associative!
CgBindings -- [Id -> info] : static environment
+ CLabel -- label of the current SRT
+
+ CLabel -- current destination for ticky counts
+
EndOfBlockInfo -- Info for stuff to do at end of basic block:
data CompilationInfo
= MkCompInfo
- FAST_STRING -- the module name
+ Module -- the module name
data CgState
= MkCgState
\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 0)
\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
+ = OnStack
+ VirtualSpOffset -- Continuation is on the stack, at the
-- specified location
- | UpdateCode CAddrMode -- May be standard update code, or might be
- -- the data-type-specific one.
+ | UpdateCode
| CaseAlts
CAddrMode -- Jump to this; if the continuation is for a vectored
-- addressing mode (I think)
SemiTaggingStuff
+ | SeqFrame -- like CaseAlts but push a seq frame too.
+ CAddrMode
+ SemiTaggingStuff
+
type SemiTaggingStuff
= Maybe -- Maybe[1] we don't have any semi-tagging stuff...
([(ConTag, JoinDetails)], -- Alternatives
-- 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
+-- that Sp is pointing to the top word of the return address. This
-- seems unclean but there you go.
+-- sequelToAmode returns an amode which refers to an info table. The info
+-- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
+-- not to handle real code pointers, just in case we're compiling for
+-- an unregisterised/untailcallish architecture, where info pointers and
+-- code pointers aren't the same.
+
sequelToAmode :: Sequel -> FCode CAddrMode
-sequelToAmode (OnStack virt_spb_offset)
- = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
- returnFC (CVal spb_rel RetRep)
+sequelToAmode (OnStack virt_sp_offset)
+ = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
+ returnFC (CVal sp_rel RetRep)
-sequelToAmode InRetReg = returnFC (CReg RetReg)
---Andy/Simon's patch:
---WAS: sequelToAmode (UpdateCode amode) = returnFC amode
-sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
+sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
sequelToAmode (CaseAlts amode _) = returnFC amode
-\end{code}
-
-See the NOTES about the details of stack/heap usage tracking.
+sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
-\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
+ = (StackUsage, HeapUsage)
+
+data Slot = Free | NonPointer
+ deriving
+#ifdef DEBUG
+ (Eq,Show)
+#else
+ Eq
+#endif
+
+type StackUsage =
+ (Int, -- virtSp: Virtual offset of topmost allocated slot
+ [(Int,Slot)], -- free: List of free slots, in increasing order
+ Int, -- realSp: Virtual offset of real stack pointer
+ Int) -- hwSp: Highest value ever taken by virtSp
type HeapUsage =
- (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
+ (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
HeapOffset) -- realHp: Virtual offset of real heap ptr
\end{code}
+
NB: absolutely every one of the above Ints is really
a VirtualOffset of some description (the code generator
-works entirely in terms of VirtualOffsets; see NOTES).
+works entirely in terms of VirtualOffsets).
Initialisation.
\begin{code}
-initialStateC = MkCgState AbsCNop nullIdEnv initUsage
+initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
initUsage :: CgStksAndHeapUsage
-initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
-initVirtHp = panic "Uninitialised virtual Hp"
-initRealHp = panic "Uninitialised real Hp"
+initUsage = ((0,[],0,0), (0,0))
\end{code}
-@envInitForAlternatives@ initialises the environment for a case alternative,
+"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}
+
+ - zapping any volatile bindings, which aren't valid.
+
+ - zapping the heap usage. It should be restored by a heap check.
+
+ - setting the virtual AND real stack pointer fields to the given
+ virtual stack offsets. this doesn't represent any {\em code}; it is a
+ prediction of where the real stack pointer will be when we come back
+ from the case analysis.
+
+ - BUT LEAVING the rest of the stack-usage info because it is all
+ valid. In particular, we leave the tail stack pointers unchanged,
+ becuase the alternative has to de-allocate the original @case@
+ expression's stack. \end{itemize}
@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 (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
- (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
+stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
+ (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
= MkCgState abs_c
bs
- ((vA,fA,rA,hA1 `max` hA2),
- (vB,fB,rB,hB1 `max` hB2),
- (vH1 `maxOff` vH2, rH1))
+ ((v,f,r,h1 `max` h2),
+ (vH1 `max` vH2, rH1))
\end{code}
%************************************************************************
%************************************************************************
\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 #-}
\begin{code}
initC :: CompilationInfo -> Code -> AbstractC
-initC cg_info code
- = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
+initC cg_info (FCode code)
+ = case (code (MkCgInfoDown
+ cg_info
+ (error "initC: statics")
+ (error "initC: srt")
+ (mkTopTickyCtrLabel)
+ initEobInfo)
initialStateC) of
- MkCgState abc _ _ -> abc
+ ((),MkCgState abc _ _) -> abc
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".
+To maximise encapsulation, code should try to only get and set the
+state it actually uses.
+
+\begin{code}
+getState :: FCode CgState
+getState = FCode $ \info_down state -> (state,state)
+
+setState :: CgState -> FCode ()
+setState state = FCode $ \info_down _ -> ((),state)
+
+getUsage :: FCode CgStksAndHeapUsage
+getUsage = do
+ MkCgState absC binds usage <- getState
+ return usage
+
+setUsage :: CgStksAndHeapUsage -> FCode ()
+setUsage newusage = do
+ MkCgState absC binds usage <- getState
+ setState $ MkCgState absC binds newusage
+
+getBinds :: FCode CgBindings
+getBinds = do
+ MkCgState absC binds usage <- getState
+ return binds
+
+setBinds :: CgBindings -> FCode ()
+setBinds newbinds = do
+ MkCgState absC binds usage <- getState
+ setState $ MkCgState absC newbinds usage
+
+getStaticBinds :: FCode CgBindings
+getStaticBinds = do
+ (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
+ return static_binds
+
+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)
+
+getInfoDown :: FCode CgInfoDownwards
+getInfoDown = FCode $ \info_down state -> (info_down,state)
+
+withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
+
+doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
+doFCode (FCode fcode) info_down state = fcode info_down state
\end{code}
+
@forkClosureBody@ takes a code, $c$, and compiles it in a completely
fresh environment, except that:
- compilation info and statics are passed in 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 (FCode code) = do
+ (MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
+ (MkCgState absC_in binds un_usage) <- getState
+ let body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
+ let ((),fork_state) = code body_info_down initialStateC
+ let MkCgState absC_fork _ _ = fork_state
+ setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
+
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
+forkStatics (FCode fcode) = FCode (
+ \(MkCgInfoDown cg_info _ srt ticky _)
+ (MkCgState absC_in statics un_usage)
+ ->
+ let
+ (result, state) = fcode rhs_info_down initialStateC
+ MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
+ -- above or it becomes too strict!
+ rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
+ in
+ (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
+ )
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
+forkAbsC (FCode code) =
+ do
+ info_down <- getInfoDown
+ (MkCgState absC1 bs usage) <- getState
+ let ((),MkCgState absC2 _ ((_, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
+ let ((v, f, r, h1), heap_usage) = usage
+ let new_usage = ((v, f, r, h1 `max` h2), heap_usage)
+ setState $ MkCgState absC1 bs new_usage
+ return absC2
\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
+forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
+
+forkAlts branch_fcodes (FCode deflt_fcode) =
+ do
+ info_down <- getInfoDown
+ in_state <- getState
+ let compile (FCode fc) = fc info_down in_state
+ let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
+ let (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
+ setState $ foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
+ -- NB foldl. in_state is the *left* argument to stateIncUsage
+ return (branch_results, deflt_result)
- (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
\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)
+ = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
+ 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
+ -> FCode (Int, -- Sp
a) -- Result of the FCode
-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
+forkEvalHelp body_eob_info env_code body_code =
+ do
+ info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
+ state <- getState
+ let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
+ let (_,MkCgState _ binds ((v,f,_,_),_)) =
+ doFCode env_code info_down_for_body state
+ let 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
-
-
+ ((v,f,v,v), (0,0))
+ let (value_returned, state_at_end_return) =
+ doFCode body_code info_down_for_body state_for_body
+ setState $ state `stateIncUsageEval` state_at_end_return
+ return (v,value_returned)
+
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)
+stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
+ (MkCgState absC2 _ ((_,_,_,h2), _))
+ = MkCgState (absC1 `mkAbsCStmts` absC2)
-- The AbsC 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)
+ ((v,f,r,h1 `max` h2), heap_usage)
-- We don't max the heap high-watermark because stateIncUsageEval is
-- used only in forkEval, which in turn is only used for blocks of code
-- which do their own heap-check.
environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
\begin{code}
nopC :: Code
-nopC info_down state = state
+nopC = return ()
absC :: AbstractC -> Code
-absC more_absC info_down state@(MkCgState absC binds usage)
- = MkCgState (mkAbsCStmts absC more_absC) binds usage
+absC more_absC = do
+ state@(MkCgState absC binds usage) <- getState
+ setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
\end{code}
These two are just like @absC@, except they examine the compilation
\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
+costCentresC macro args =
+ if opt_SccProfilingOn then do
+ (MkCgState absC binds usage) <- getState
+ setState $ MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
+ else
+ nopC
profCtrC :: FAST_STRING -> [CAddrMode] -> Code
-profCtrC macro args _ state@(MkCgState absC binds usage)
+profCtrC macro args =
+ if not opt_DoTickyProfiling
+ then nopC
+ else do
+ (MkCgState absC binds usage) <- getState
+ setState $ MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
+
+profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
+
+profCtrAbsC macro args
= if not opt_DoTickyProfiling
- then state
- else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
+ then AbsCNop
+ else CCallProfCtrMacro macro args
{- 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.
+ as possible.
-}
\end{code}
\begin{code}
getAbsC :: Code -> FCode AbstractC
-
-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)
+getAbsC code = do
+ MkCgState absC binds usage <- getState
+ ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage)
+ setState $ MkCgState absC binds2 usage2
+ return absC2
\end{code}
\begin{code}
-noBlackHolingFlag, costCentresFlag :: FCode Bool
-
-noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
-costCentresFlag _ state = (opt_SccProfilingOn, state)
-\end{code}
-
-\begin{code}
-
-moduleName :: FCode FAST_STRING
-moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
- = (mod_name, state)
-
+moduleName :: FCode Module
+moduleName = do
+ (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
+ return mod_name
\end{code}
\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
+ (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
+ withInfoDown code (MkCgInfoDown c_info statics srt ticky 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
+getEndOfBlockInfo = do
+ (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
+ return eob_info
\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
+getSRTLabel :: FCode CLabel
+getSRTLabel = do
+ (MkCgInfoDown _ _ srt _ _) <- getInfoDown
+ return srt
+
+setSRTLabel :: CLabel -> Code -> Code
+setSRTLabel srt code = do
+ (MkCgInfoDown c_info statics _ ticky eob_info) <- getInfoDown
+ withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
\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 name],
- ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
- ptext SLIT("static binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
- ptext SLIT("local binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
- ])
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgMonad-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
+getTickyCtrLabel :: FCode CLabel
+getTickyCtrLabel = do
+ (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
+ return ticky
+
+setTickyCtrLabel :: CLabel -> Code -> Code
+setTickyCtrLabel ticky code = do
+ (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown
+ withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
\end{code}
projects / ghc-hetmet.git / blobdiff