\begin{code}
addBindC :: Id -> CgIdInfo -> Code
-addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
- = MkCgState absC (extendVarEnv binds name stuff_to_bind) usage
+addBindC name stuff_to_bind = do
+ binds <- getBinds
+ setBinds $ extendVarEnv binds name stuff_to_bind
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) -> extendVarEnv binds name info)
- binds
- new_bindings
+addBindsC new_bindings = do
+ binds <- getBinds
+ let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
+ binds
+ new_bindings
+ setBinds new_binds
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
-modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
- = MkCgState absC (modifyVarEnv mangle_fn binds name) usage
+modifyBindC name mangle_fn = do
+ binds <- getBinds
+ setBinds $ modifyVarEnv mangle_fn binds name
lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name info_down@(MkCgInfoDown _ static_binds srt ticky _)
- state@(MkCgState absC local_binds usage)
- = (val, state)
- where
- val = case (lookupVarEnv local_binds name) of
- Nothing -> try_static
- Just this -> this
-
- try_static =
- case (lookupVarEnv static_binds name) of
- Just this -> this
- Nothing
- -> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state
-
-cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a
-cgPanic doc info_down@(MkCgInfoDown _ static_binds srt ticky _)
- state@(MkCgState absC local_binds usage)
- = pprPanic "cgPanic"
- (vcat [doc,
+lookupBindC name = do
+ static_binds <- getStaticBinds
+ local_binds <- getBinds
+ case (lookupVarEnv local_binds name) of
+ Nothing -> case (lookupVarEnv static_binds name) of
+ Nothing -> cgPanic (text "lookupBindC: no info for" <+> ppr name)
+ Just this -> return this
+ Just this -> return this
+
+cgPanic :: SDoc -> FCode a
+cgPanic doc = do
+ static_binds <- getStaticBinds
+ local_binds <- getBinds
+ srt <- getSRTLabel
+ pprPanic "cgPanic"
+ (vcat [doc,
ptext SLIT("static binds for:"),
vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
ptext SLIT("local binds for:"),
-- deals with imported or locally defined but externally visible ids
-- (CoreTidy makes all these into global names).
- | otherwise = -- *might* be a nested defn: in any case, it's something whose
+ | otherwise = do -- *might* be a nested defn: in any case, it's something whose
-- definition we will know about...
- lookupBindC id `thenFC` \ (MkCgIdInfo id' volatile_loc stable_loc lf_info) ->
- idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
- returnFC (id', amode, lf_info)
+ (MkCgIdInfo id' volatile_loc stable_loc lf_info) <- lookupBindC id
+ amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
+ return (id', amode, lf_info)
where
name = getName id
global_amode = CLbl (mkClosureLabel name) kind
kind = idPrimRep id
getCAddrMode :: Id -> FCode CAddrMode
-getCAddrMode name
- = getCAddrModeAndInfo name `thenFC` \ (_, amode, _) ->
- returnFC amode
+getCAddrMode name = do
+ (_, amode, _) <- getCAddrModeAndInfo name
+ return amode
\end{code}
\begin{code}
getCAddrModeIfVolatile name
-- | toplevelishId name = returnFC Nothing
-- | otherwise
- = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
- case stable_loc of
- NoStableLoc -> -- Aha! So it is volatile!
- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
- returnFC (Just amode)
-
- a_stable_loc -> returnFC Nothing
+ = do
+ (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name
+ case stable_loc of
+ NoStableLoc -> do -- Aha! So it is volatile!
+ amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc
+ return $ Just amode
+ a_stable_loc -> return Nothing
\end{code}
@getVolatileRegs@ gets a set of live variables, and returns a list of
\begin{code}
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
-getVolatileRegs vars
- = mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff ->
- returnFC (catMaybes stuff)
- where
- snaffle_it var
- = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
- let
- -- commoned-up code...
- consider_reg reg
- = if not (isVolatileReg reg) then
- -- Potentially dies across C calls
- -- For now, that's everything; we leave
- -- it to the save-macros to decide which
- -- regs *really* need to be saved.
- returnFC Nothing
- else
- case stable_loc of
- NoStableLoc -> returnFC (Just reg) -- got one!
- is_a_stable_loc ->
- -- has both volatile & stable locations;
- -- force it to rely on the stable location
- modifyBindC var nuke_vol_bind `thenC`
- returnFC Nothing
- in
- case volatile_loc of
- RegLoc reg -> consider_reg reg
- VirHpLoc _ -> consider_reg Hp
- VirNodeLoc _ -> consider_reg node
- non_reg_loc -> returnFC Nothing
-
- nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
- = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
+getVolatileRegs vars = do
+ stuff <- mapFCs snaffle_it (varSetElems vars)
+ returnFC $ catMaybes stuff
+ where
+ snaffle_it var = do
+ (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var
+ let
+ -- commoned-up code...
+ consider_reg reg =
+ if not (isVolatileReg reg) then
+ -- Potentially dies across C calls
+ -- For now, that's everything; we leave
+ -- it to the save-macros to decide which
+ -- regs *really* need to be saved.
+ returnFC Nothing
+ else
+ case stable_loc of
+ NoStableLoc -> returnFC (Just reg) -- got one!
+ is_a_stable_loc -> do
+ -- has both volatile & stable locations;
+ -- force it to rely on the stable location
+ modifyBindC var nuke_vol_bind
+ return Nothing
+ in
+ case volatile_loc of
+ RegLoc reg -> consider_reg reg
+ VirHpLoc _ -> consider_reg Hp
+ VirNodeLoc _ -> consider_reg node
+ non_reg_loc -> returnFC Nothing
+
+ nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
+ = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
\end{code}
\begin{code}
getArgAmodes :: [StgArg] -> FCode [CAddrMode]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
- | isStgTypeArg atom
- = getArgAmodes atoms
- | otherwise
- = getArgAmode atom `thenFC` \ amode ->
- getArgAmodes atoms `thenFC` \ amodes ->
- returnFC ( amode : amodes )
+ | isStgTypeArg atom
+ = getArgAmodes atoms
+ | otherwise = do
+ amode <- getArgAmode atom
+ amodes <- getArgAmodes atoms
+ return ( amode : amodes )
getArgAmode :: StgArg -> FCode CAddrMode
-- This is used only for things we don't know
-- anything about; values returned by a case statement,
-- for example.
- in
- addBindC name id_info `thenC`
- returnFC temp_amode
+ in do
+ addBindC name id_info
+ return temp_amode
bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
bindNewToReg name magic_id lf_info
%* *
%************************************************************************
+ToDo: remove the dependency on 32-bit words.
+
There are four kinds of things on the stack:
- pointer variables (bound in the environment)
-> VirtualSpOffset -- offset from which the bitmap should start
-> FCode Liveness -- mask for free/unlifted slots
-buildLivenessMask uniq sp info_down
- state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage))
- = ASSERT(all (>=0) rel_slots)
- livenessToAbsC uniq liveness_mask info_down state
- where
+buildLivenessMask uniq sp = do
-- find all unboxed stack-resident ids
- unboxed_slots =
- [ (ofs, size) |
- (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
- let rep = idPrimRep id; size = getPrimRepSize rep,
+ binds <- getBinds
+ ((vsp, free, _, _), heap_usage) <- getUsage
+
+ let unboxed_slots =
+ [ (ofs, size) |
+ (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
+ let rep = idPrimRep id; size = getPrimRepSize rep,
not (isFollowableRep rep),
size > 0
- ]
-
+ ]
+
-- flatten this list into a list of unboxed stack slots
- flatten_slots = sortLt (<)
+ let flatten_slots = sortLt (<)
(foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
unboxed_slots)
-- merge in the free slots
- all_slots = mergeSlots flatten_slots (map fst free) ++
+ let all_slots = mergeSlots flatten_slots (map fst free) ++
if vsp < sp then [vsp+1 .. sp] else []
-- recalibrate the list to be sp-relative
- rel_slots = reverse (map (sp-) all_slots)
+ let rel_slots = reverse (map (sp-) all_slots)
-- build the bitmap
- liveness_mask = listToLivenessMask rel_slots
+ let liveness_mask = ASSERT(all (>=0) rel_slots) (listToLivenessMask rel_slots)
+
+ livenessToAbsC uniq liveness_mask
mergeSlots :: [Int] -> [Int] -> [Int]
mergeSlots cs [] = cs
where (this,rest) = span (<32) slots
livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
-livenessToAbsC uniq mask =
- absC (CBitmap lbl mask) `thenC`
- returnFC (Liveness lbl mask)
- where lbl = mkBitmapLabel uniq
+livenessToAbsC uniq mask =
+ absC (CBitmap lbl mask) `thenC`
+ returnFC (Liveness lbl mask)
+ where lbl = mkBitmapLabel uniq
\end{code}
In a continuation, we want a liveness mask that starts from just after
buildContLivenessMask
:: Unique
-> FCode Liveness
-buildContLivenessMask uniq
- = getRealSp `thenFC` \ realSp ->
- buildLivenessMask uniq (realSp-1)
+buildContLivenessMask uniq = do
+ realSp <- getRealSp
+ buildLivenessMask uniq (realSp-1)
\end{code}
%************************************************************************
\begin{code}
nukeDeadBindings :: StgLiveVars -- All the *live* variables
-> Code
-
-nukeDeadBindings live_vars info_down (MkCgState abs_c binds usage)
- = freeStackSlots extra_free info_down (MkCgState abs_c (mkVarEnv bs') usage)
- where
- (dead_stk_slots, bs')
- = dead_slots live_vars
- [] []
- [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
-
- extra_free = sortLt (<) dead_stk_slots
+nukeDeadBindings live_vars = do
+ binds <- getBinds
+ let (dead_stk_slots, bs') =
+ dead_slots live_vars
+ [] []
+ [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
+ let extra_free = sortLt (<) dead_stk_slots
+ setBinds $ mkVarEnv bs'
+ freeStackSlots extra_free
\end{code}
Several boring auxiliary functions to do the dirty work.
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.28 2001/08/30 09:51:16 sewardj Exp $
+% $Id: CgMonad.lhs,v 1.29 2001/08/31 12:39:06 rje Exp $
%
\section[CgMonad]{The code generation monad}
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(..)
%************************************************************************
\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
+initC cg_info (FCode code)
= case (code (MkCgInfoDown
cg_info
(error "initC: statics")
(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 srt ticky _)
- (MkCgState absC_in binds un_usage)
- = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
- where
- fork_state = code body_info_down initialStateC
- MkCgState absC_fork _ _ = fork_state
- body_info_down = MkCgInfoDown cg_info statics srt ticky 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 _ srt ticky _)
- (MkCgState absC_in statics un_usage)
- = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
- where
- (result, state) = fcode rhs_info_down initialStateC
- MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
- -- above or it becomes too strict!
- rhs_info_down = MkCgInfoDown cg_info statics srt ticky 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 _ ((_, _, _,h2), _) =
- code info_down (MkCgState AbsCNop bs usage)
- ((v, f, r, h1), heap_usage) = usage
-
- new_usage = ((v, f, r, h1 `max` h2), heap_usage)
- new_state = MkCgState absC1 bs new_usage
+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
\begin{code}
forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
-forkAlts branch_fcodes deflt_fcode info_down in_state
- = ((branch_results , deflt_result), out_state)
- where
- compile fc = fc info_down in_state
+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)
-
- (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
-
- out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
- -- NB foldl. in_state is the *left* argument to stateIncUsage
\end{code}
@forkEval@ takes two blocks of code.
-> FCode (Int, -- Sp
a) -- Result of the FCode
-forkEvalHelp body_eob_info env_code body_code
- info_down@(MkCgInfoDown cg_info statics srt ticky _) state
- = ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
- where
- info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
-
- (MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
- -- These v and f things are now set up as the body code expects them
-
- (value_returned, state_at_end_return)
- = body_code info_down_for_body state_for_body
-
- state_for_body = MkCgState AbsCNop
+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)
((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 ((v,f,r,h1),heap_usage))
(MkCgState absC2 _ ((_,_,_,h2), _))
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)
- = if not opt_DoTickyProfiling
- then state
- else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) 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
\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}
-
moduleName :: FCode Module
-moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) state
- = (mod_name, state)
-
+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 srt ticky _) state
- = code (MkCgInfoDown c_info statics srt ticky 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)
+getEndOfBlockInfo = do
+ (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
+ return eob_info
\end{code}
\begin{code}
getSRTLabel :: FCode CLabel
-getSRTLabel (MkCgInfoDown _ _ srt _ _) state
- = (srt, state)
+getSRTLabel = do
+ (MkCgInfoDown _ _ srt _ _) <- getInfoDown
+ return srt
setSRTLabel :: CLabel -> Code -> Code
-setSRTLabel srt code (MkCgInfoDown c_info statics _ ticky eob_info) state
- = code (MkCgInfoDown c_info statics srt ticky eob_info) state
+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}
getTickyCtrLabel :: FCode CLabel
-getTickyCtrLabel (MkCgInfoDown _ _ _ ticky _) state
- = (ticky, state)
+getTickyCtrLabel = do
+ (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
+ return ticky
setTickyCtrLabel :: CLabel -> Code -> Code
-setTickyCtrLabel ticky code (MkCgInfoDown c_info statics srt _ eob_info) state
- = code (MkCgInfoDown c_info statics srt ticky eob_info) state
+setTickyCtrLabel ticky code = do
+ (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown
+ withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.17 2001/08/30 09:51:16 sewardj Exp $
+% $Id: CgStackery.lhs,v 1.18 2001/08/31 12:39:06 rje Exp $
%
\section[CgStackery]{Stack management functions}
allocStack = allocPrimStack 1
allocPrimStack :: Int -> FCode VirtualSpOffset
-allocPrimStack size info_down (MkCgState absC binds
- ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
- = (chosen_slot, MkCgState absC binds (new_stk_usage, h_usage))
- where
- push_virt_sp = virt_sp + size
-
- (chosen_slot, new_stk_usage)
- = case find_block free_stk of
- Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp,
+allocPrimStack size = do
+ ((virt_sp, free_stk, real_sp, hw_sp),h_usage) <- getUsage
+ let push_virt_sp = virt_sp + size
+ let (chosen_slot, new_stk_usage) =
+ case find_block free_stk of
+ Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp,
hw_sp `max` push_virt_sp))
- -- Adjust high water mark
-
- Just slot -> (slot, (virt_sp,
- delete_block free_stk slot, real_sp, hw_sp))
-
- -- find_block looks for a contiguous chunk of free slots
- find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
- find_block [] = Nothing
- find_block ((off,free):slots)
- | take size ((off,free):slots) ==
- zip [off..top_slot] (repeat Free) = Just top_slot
- | otherwise = find_block slots
- -- The stack grows downwards, with increasing virtual offsets.
- -- Therefore, the address of a multi-word object is the *highest*
- -- virtual offset it occupies (top_slot below).
- where top_slot = off+size-1
-
- delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
+ -- Adjust high water mark
+ Just slot -> (slot, (virt_sp,
+ delete_block free_stk slot, real_sp, hw_sp))
+ setUsage (new_stk_usage, h_usage)
+ return chosen_slot
+
+ where
+ -- find_block looks for a contiguous chunk of free slots
+ find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
+ find_block [] = Nothing
+ find_block ((off,free):slots)
+ | take size ((off,free):slots) ==
+ zip [off..top_slot] (repeat Free) = Just top_slot
+ | otherwise = find_block slots
+ -- The stack grows downwards, with increasing virtual offsets.
+ -- Therefore, the address of a multi-word object is the *highest*
+ -- virtual offset it occupies (top_slot below).
+ where top_slot = off+size-1
+
+ delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
(s<=slot-size) || (s>slot) ]
-- Retain slots which are not in the range
-- slot-size+1..slot
\begin{code}
allocStackTop :: Int -> FCode VirtualSpOffset
-allocStackTop size info_down (MkCgState absC binds
- ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
- = (push_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
- where
- push_virt_sp = virt_sp + size
- new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
- -- Adjust high water mark
+allocStackTop size = do
+ ((virt_sp, free_stk, real_sp, hw_sp), h_usage) <- getUsage
+ let push_virt_sp = virt_sp + size
+ let new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
+ setUsage (new_stk_usage, h_usage)
+ return push_virt_sp
\end{code}
Pop some words from the current top of stack. This is used for
\begin{code}
deAllocStackTop :: Int -> FCode VirtualSpOffset
-deAllocStackTop size info_down (MkCgState absC binds
- ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
- = (pop_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
- where
- pop_virt_sp = virt_sp - size
- new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
+deAllocStackTop size = do
+ ((virt_sp, free_stk, real_sp, hw_sp), h_usage) <- getUsage
+ let pop_virt_sp = virt_sp - size
+ let new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
+ setUsage (new_stk_usage, h_usage)
+ return pop_virt_sp
\end{code}
\begin{code}
adjustStackHW :: VirtualSpOffset -> Code
-adjustStackHW offset info_down (MkCgState absC binds usage)
- = MkCgState absC binds new_usage
- where
- ((vSp,fSp,realSp,hwSp), h_usage) = usage
- new_usage = ((vSp, fSp, realSp, max offset hwSp), h_usage)
- -- No need to fiddle with virtual Sp etc because this call is
- -- only done just before the end of a block
+adjustStackHW offset = do
+ ((vSp,fSp,realSp,hwSp), h_usage) <- getUsage
+ setUsage ((vSp, fSp, realSp, max offset hwSp), h_usage)
\end{code}
A knot-tying beast.
\begin{code}
getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
-getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
- where
- state1 = fcode hwSp info_down (MkCgState absC binds usages)
- (MkCgState _ _ ((_,_,_, hwSp), _)) = state1
+getFinalStackHW fcode = do
+ fixC (\hwSp -> do
+ fcode hwSp
+ ((_,_,_, hwSp),_) <- getUsage
+ return hwSp)
+ return ()
\end{code}
\begin{code}
\begin{code}
addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
-addFreeStackSlots extra_free slot info_down
- state@(MkCgState abs_c binds ((vsp, free, real, hw), heap_usage))
- = MkCgState abs_c binds new_usage
- where
- new_usage = ((new_vsp, new_free, real, hw), heap_usage)
- (new_vsp, new_free) = trim vsp all_free
- all_free = addFreeSlots free (zip extra_free (repeat slot))
+addFreeStackSlots extra_free slot = do
+ ((vsp, free, real, hw),heap_usage) <- getUsage
+ let all_free = addFreeSlots free (zip extra_free (repeat slot))
+ let (new_vsp, new_free) = trim vsp all_free
+ let new_usage = ((new_vsp, new_free, real, hw), heap_usage)
+ setUsage new_usage
freeStackSlots :: [VirtualSpOffset] -> Code
freeStackSlots slots = addFreeStackSlots slots Free
It is usually a prelude to performing a GC check, so everything must
be in a tidy and consistent state.
+rje: Note the slightly suble fixed point behaviour needed here
\begin{code}
initHeapUsage :: (VirtualHeapOffset -> Code) -> Code
-initHeapUsage fcode info_down (MkCgState absC binds (stk_usage, heap_usage))
- = state3
- where
- state1 = MkCgState absC binds (stk_usage, (0, 0))
- state2 = fcode (heapHWM heap_usage2) info_down state1
- (MkCgState absC2 binds2 (stk_usage2, heap_usage2)) = state2
- state3 = MkCgState absC2
- binds2
- (stk_usage2, heap_usage {- unchanged -})
+initHeapUsage fcode = do
+ (stk_usage, heap_usage) <- getUsage
+ setUsage (stk_usage, (0,0))
+ fixC (\heap_usage2 -> do
+ fcode (heapHWM heap_usage2)
+ (_, heap_usage2) <- getUsage
+ return heap_usage2)
+ (stk_usage2, heap_usage2) <- getUsage
+ setUsage (stk_usage2, heap_usage {-unchanged -})
\end{code}
\begin{code}
setVirtHp :: VirtualHeapOffset -> Code
-setVirtHp new_virtHp info_down
- state@(MkCgState absC binds (stk, (virtHp, realHp)))
- = MkCgState absC binds (stk, (new_virtHp, realHp))
+setVirtHp new_virtHp = do
+ (stk, (virtHp, realHp)) <- getUsage
+ setUsage (stk, (new_virtHp, realHp))
\end{code}
\begin{code}
getVirtAndRealHp :: FCode (VirtualHeapOffset, VirtualHeapOffset)
-getVirtAndRealHp info_down state@(MkCgState _ _ (_, (virtHp, realHp)))
- = ((virtHp, realHp), state)
+getVirtAndRealHp = do
+ (_, (virtHp, realHp)) <- getUsage
+ return (virtHp, realHp)
\end{code}
\begin{code}
setRealHp :: VirtualHeapOffset -> Code
-setRealHp realHp info_down (MkCgState absC binds (stk_usage, (vHp, _)))
- = MkCgState absC binds (stk_usage, (vHp, realHp))
+setRealHp realHp = do
+ (stk_usage, (vHp, _)) <- getUsage
+ setUsage (stk_usage, (vHp, realHp))
\end{code}
\begin{code}
getHpRelOffset :: VirtualHeapOffset -> FCode RegRelative
-getHpRelOffset virtual_offset info_down state@(MkCgState _ _ (_,(_,realHp)))
- = (hpRel realHp virtual_offset, state)
+getHpRelOffset virtual_offset = do
+ (_,(_,realHp)) <- getUsage
+ return $ hpRel realHp virtual_offset
\end{code}
The heap high water mark is the larger of virtHp and hwHp. The latter is
setRealAndVirtualSp :: VirtualSpOffset -- New real Sp
-> Code
-setRealAndVirtualSp sp info_down (MkCgState absC binds
- ((vsp,f,realSp,hwsp), h_usage))
- = MkCgState absC binds new_usage
- where
- new_usage = ((sp, f, sp, sp), h_usage)
+setRealAndVirtualSp sp = do
+ ((vsp,f,realSp,hwsp), h_usage) <- getUsage
+ let new_usage = ((sp, f, sp, sp), h_usage)
+ setUsage new_usage
\end{code}
\begin{code}
getVirtSp :: FCode VirtualSpOffset
-getVirtSp info_down state@(MkCgState absC binds ((virtSp,_,_,_), _))
- = (virtSp, state)
+getVirtSp = do
+ ((virtSp,_,_,_), _) <- getUsage
+ return virtSp
getRealSp :: FCode VirtualSpOffset
-getRealSp info_down state@(MkCgState absC binds ((_,_,realSp,_),_))
- = (realSp,state)
+getRealSp = do
+ ((_,_,realSp,_),_) <- getUsage
+ return realSp
\end{code}
\begin{code}
getSpRelOffset :: VirtualSpOffset -> FCode RegRelative
-getSpRelOffset virtual_offset info_down state@(MkCgState _ _ ((_,_,realSp,_),_))
- = (spRel realSp virtual_offset, state)
+getSpRelOffset virtual_offset = do
+ ((_,_,realSp,_),_) <- getUsage
+ return $ spRel realSp virtual_offset
\end{code}
%************************************************************************
\begin{code}
adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr
-> Code
-adjustSpAndHp newRealSp (MkCgInfoDown _ _ _ ticky_ctr _)
- (MkCgState absC binds
- ((vSp,fSp,realSp,hwSp),
- (vHp, rHp)))
- = MkCgState (mkAbstractCs [absC,move_sp,move_hp]) binds new_usage
- where
-
- move_sp = if (newRealSp == realSp) then AbsCNop
+adjustSpAndHp newRealSp = do
+ (MkCgInfoDown _ _ _ ticky_ctr _) <- getInfoDown
+ (MkCgState absC binds
+ ((vSp,fSp,realSp,hwSp),
+ (vHp, rHp))) <- getState
+ let move_sp = if (newRealSp == realSp) then AbsCNop
else (CAssign (CReg Sp)
(CAddr (spRel realSp newRealSp)))
-
- -- Adjust the heap pointer backwards in case we over-allocated
- -- Analogously, we also remove bytes from the ticky counter
- move_hp = if (rHp == vHp) then AbsCNop
- else mkAbstractCs [
- CAssign (CReg Hp) (CAddr (hpRel rHp vHp)),
+ let move_hp =
+ if (rHp == vHp) then AbsCNop
+ else mkAbstractCs [
+ CAssign (CReg Hp) (CAddr (hpRel rHp vHp)),
profCtrAbsC SLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ]
- ]
-
- new_usage = ((vSp, fSp, newRealSp, hwSp), (vHp,vHp))
+ [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ]
+ ]
+ let new_usage = ((vSp, fSp, newRealSp, hwSp), (vHp,vHp))
+ setState $ MkCgState (mkAbstractCs [absC,move_sp,move_hp]) binds new_usage
\end{code}
projects / ghc-hetmet.git / commitdiff