%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (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}
monadic stuff fits into the Big Picture.
\begin{code}
-#include "HsVersions.h"
-
module CgMonad (
- Code(..), -- type
- FCode(..), -- type
+ Code, -- type
+ FCode, -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, absC, nopC, getAbsC,
forkClosureBody, forkStatics, forkAlts, forkEval,
forkEvalHelp, forkAbsC,
- SemiTaggingStuff(..),
-
- addBindC, addBindsC, modifyBindC, lookupBindC,
---UNUSED: grabBindsC,
+ SemiTaggingStuff,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- AStackUsage(..), BStackUsage(..), HeapUsage(..),
- StubFlag,
- isStubbed,
---UNUSED: grabStackSizeC,
+ setSRTLabel, getSRTLabel,
+ setTickyCtrLabel, getTickyCtrLabel,
- nukeDeadBindings, getUnstubbedAStackSlots,
+ StackUsage, Slot(..), HeapUsage,
--- addFreeASlots, -- no need to export it
- addFreeBSlots, -- ToDo: Belong elsewhere
+ profCtrC, profCtrAbsC,
- isSwitchSetC, isStringSwitchSetC,
-
- noBlackHolingFlag,
- profCtrC, --UNUSED: concurrentC,
-
- 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 ...
- CgBindings(..),
CgInfoDownwards(..), CgState(..), -- non-abstract
- CgIdInfo, -- abstract
- CompilationInfo(..),
- GlobalSwitch, -- abstract
-
- stableAmodeIdInfo, heapIdInfo,
-
- -- and to make the interface self-sufficient...
- AbstractC, CAddrMode, CLabel, LambdaFormInfo, IdEnv(..),
- Unique, HeapOffset, CostCentre, IsCafCC,
- Id, UniqSet(..), UniqFM,
- VirtualSpAOffset(..), VirtualSpBOffset(..),
- VirtualHeapOffset(..), DataCon(..), PlainStgLiveVars(..),
- Maybe
+ CompilationInfo(..)
) where
+#include "HsVersions.h"
+
+import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
+import {-# SOURCE #-} CgUsages ( getSpRelOffset )
+
import AbsCSyn
-import AbsUniType ( kindFromType, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import CgBindery
-import CgUsages ( getSpBRelOffset )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getIdUniType, ConTag(..), DataCon(..) )
-import IdEnv -- ops on CgBindings use these
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Pretty -- debugging only?
-import PrimKind ( getKindSize, retKindSize )
-import UniqSet -- ( elementOfUniqSet, UniqSet(..) )
-import CostCentre -- profiling stuff
-import StgSyn ( PlainStgAtom(..), PlainStgLiveVars(..) )
-import Unique ( UniqueSupply )
-import Util
+import AbsCUtils ( mkAbsCStmts )
+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!
infixr 9 `thenFC`
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
- (GlobalSwitch -> Bool)
- -- use it to look up whatever we like in command-line flags
- FAST_STRING -- the module name
-
+ Module -- the module name
data CgState
= MkCgState
CgStksAndHeapUsage
\end{code}
-@EndOfBlockInfo@ tells what to do at the end of this block of code
-or, if the expression is a @case@, what to do at the end of each alternative.
+@EndOfBlockInfo@ tells what to do at the end of this block of code or,
+if the expression is a @case@, what to do at the end of each
+alternative.
\begin{code}
data EndOfBlockInfo
= EndOfBlockInfo
- VirtualSpAOffset -- Args SpA: trim the A 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
- -- 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.
-
+ VirtualSpOffset -- Args Sp: trim the stack to this point at a
+ -- return; push arguments starting just
+ -- above this point on a tail call.
+
+ -- This is therefore the stk ptr as seen
+ -- by a case alternative.
Sequel
-
-initEobInfo = EndOfBlockInfo 0 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
- -- specified location
-
-
---UNUSED: | RestoreCostCentre
+ = 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
- -- case this might be the label of a return vector
- -- Guaranteed to be a non-volatile addressing mode (I think)
+ | CaseAlts
+ CAddrMode -- Jump to this; if the continuation is for a vectored
+ -- case this might be the label of a return
+ -- vector Guaranteed to be a non-volatile
+ -- addressing mode (I think)
+ SemiTaggingStuff
- 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...
)
type JoinDetails
- = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
+ = (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 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.
+-- The abstract C is executed only from a successful semitagging
+-- venture, when a case has looked at a variable, found that it's
+-- evaluated, and wants to load up the contents and go to the join
+-- point.
-- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only valid
--- just before the final control transfer, because it assumes that
--- SpB is pointing to the top word of the return address.
--- This seems unclean but there you go.
+-- The OnStack case of sequelToAmode delivers an Amode which is only
+-- valid just before the final control transfer, because it assumes
+-- that Sp is pointing to the top word of the return address. This
+-- seems unclean but there you go.
+
+-- sequelToAmode returns an amode which refers to an info table. The info
+-- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
+-- not to handle real code pointers, just in case we're compiling for
+-- an unregisterised/untailcallish architecture, where info pointers and
+-- code pointers aren't the same.
sequelToAmode :: Sequel -> FCode CAddrMode
-sequelToAmode (OnStack virt_spb_offset)
- = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
- returnFC (CVal spb_rel RetKind)
+sequelToAmode (OnStack virt_sp_offset)
+ = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
+ returnFC (CVal sp_rel RetRep)
-sequelToAmode InRetReg = returnFC (CReg RetReg)
---UNUSED:sequelToAmode RestoreCostCentre = returnFC mkRestoreCostCentreLbl
---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
+sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
--- ToDo: move/do something
---UNUSED:mkRestoreCostCentreLbl = panic "mkRestoreCostCentreLbl"
-\end{code}
-
-See the NOTES about the details of stack/heap usage tracking.
-
-\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
+ = (StackUsage, HeapUsage)
+
+data Slot = Free | NonPointer
+ deriving
+#ifdef DEBUG
+ (Eq,Show)
+#else
+ Eq
+#endif
-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 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))
+ bs
+ ((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
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenC #-}
{-# INLINE thenFC #-}
{-# INLINE returnFC #-}
-#endif
\end{code}
The Abstract~C is not in the environment so as to improve strictness.
\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
-
-(m `thenC` 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
-
-(m `thenFC` 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 Sequel -- Semi-tagging info to store
-> 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)
+forkEval body_eob_info env_code body_code
+ = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
+ returnFC (EndOfBlockInfo v sequel)
-forkEvalHelp :: EndOfBlockInfo -- For the body
+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)
+ bs
+ ((v,f,r,h1 `max` h2), heap_usage)
-- We don't max the heap high-watermark because stateIncUsageEval is
-- used only in forkEval, which in turn is only used for blocks of code
-- which do their own heap-check.
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
nothing.
\begin{code}
-isSwitchSetC :: GlobalSwitch -> FCode Bool
-
-isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
- = (sw_chkr switch, state)
-
-isStringSwitchSetC :: (String -> GlobalSwitch) -> FCode Bool
-
-isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
- = (sw_chkr (switch (panic "isStringSwitchSetC")), state)
-
costCentresC :: FAST_STRING -> [CAddrMode] -> Code
-costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
- state@(MkCgState absC binds usage)
- = if sw_chkr 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 (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
- state@(MkCgState absC binds usage)
- = if not (sw_chkr 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.
--}
+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
--- if compiling for concurrency...
-
-{- UNUSED, as it happens:
-concurrentC :: AbstractC -> Code
+profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
-concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
- state@(MkCgState absC binds usage)
- = if not (sw_chkr ForConcurrent)
- then state
- else MkCgState (mkAbsCStmts absC more_absC) binds usage
+profCtrAbsC macro args
+ = if not opt_DoTickyProfiling
+ 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.
-}
\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 (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
- = (sw_chkr OmitBlackHoling, state)
-
-costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
- = (sw_chkr 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.
-\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 binds mangle_fn 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"
- (ppAboves [
- ppCat [ppStr "for:", ppr PprShowAll name],
- ppStr "(probably: data dependencies broken by an optimisation pass)",
- ppStr "static binds for:",
- ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
- ppStr "local binds for:",
- ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
- ])
+getEndOfBlockInfo = do
+ (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
+ return eob_info
\end{code}
-For dumping debug information, we also have the ability to grab the
-local bindings environment.
-
-ToDo: Maybe do the pretty-printing here to restrict what people do
-with the environment.
-
\begin{code}
-{- UNUSED:
-grabBindsC :: FCode CgBindings
-grabBindsC info_down state@(MkCgState absC binds usage)
- = (binds, state)
--}
+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}
-{- UNUSED:
-grabStackSizeC :: FCode (Int, Int)
-grabStackSizeC info_down state -- @(MkCgState absC binds ((vA,_,_,_), (vB,_,_,_), _))
- = panic "grabStackSizeC" -- (vA, vB)
--}
-\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 :: PlainStgLiveVars -- 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 ]
- --OLD: (getIdEnvMapping 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 :: PlainStgLiveVars
- -> [(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 = (getKindSize . kindFromType . getIdUniType) 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