Back out recent changes to the code generator as too destabilising.
Revert files as follows:
revert to 1.35 CgBindery.lhs
revert to 1.26 CgMonad.lhs
revert to 1.15 CgStackery.lhs
revert to 1.10 CgUsages.lhs
\begin{code}
addBindC :: Id -> CgIdInfo -> Code
-addBindC name stuff_to_bind = do
- binds <- getBinds
- setBinds $ extendVarEnv binds name stuff_to_bind
+addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
+ = MkCgState absC (extendVarEnv binds name stuff_to_bind) usage
addBindsC :: [(Id, CgIdInfo)] -> Code
-addBindsC new_bindings = do
- binds <- getBinds
- let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
- binds
- new_bindings
- setBinds new_binds
+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
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
-modifyBindC name mangle_fn = do
- binds <- getBinds
- setBinds $ modifyVarEnv mangle_fn binds name
+modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
+ = MkCgState absC (modifyVarEnv mangle_fn binds name) usage
lookupBindC :: Id -> FCode CgIdInfo
-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,
+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,
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 = do -- *might* be a nested defn: in any case, it's something whose
+ | otherwise = -- *might* be a nested defn: in any case, it's something whose
-- definition we will know about...
- (MkCgIdInfo id' volatile_loc stable_loc lf_info) <- lookupBindC id
- amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
- return (id', amode, lf_info)
+ lookupBindC id `thenFC` \ (MkCgIdInfo id' volatile_loc stable_loc lf_info) ->
+ idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
+ returnFC (id', amode, lf_info)
where
name = getName id
global_amode = CLbl (mkClosureLabel name) kind
kind = idPrimRep id
getCAddrMode :: Id -> FCode CAddrMode
-getCAddrMode name = do
- (_, amode, _) <- getCAddrModeAndInfo name
- return amode
+getCAddrMode name
+ = getCAddrModeAndInfo name `thenFC` \ (_, amode, _) ->
+ returnFC amode
\end{code}
\begin{code}
getCAddrModeIfVolatile name
-- | toplevelishId name = returnFC Nothing
-- | otherwise
- = 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
+ = 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
\end{code}
@getVolatileRegs@ gets a set of live variables, and returns a list of
\begin{code}
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
-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
+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
\end{code}
\begin{code}
getArgAmodes :: [StgArg] -> FCode [CAddrMode]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
- | isStgTypeArg atom
- = getArgAmodes atoms
- | otherwise = do
- amode <- getArgAmode atom
- amodes <- getArgAmodes atoms
- return ( amode : amodes )
+ | isStgTypeArg atom
+ = getArgAmodes atoms
+ | otherwise
+ = getArgAmode atom `thenFC` \ amode ->
+ getArgAmodes atoms `thenFC` \ amodes ->
+ returnFC ( 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 do
- addBindC name id_info
- return temp_amode
+ in
+ addBindC name id_info `thenC`
+ returnFC 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 = do
+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
-- find all unboxed stack-resident ids
- 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,
+ 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
- let flatten_slots = sortLt (<)
+ flatten_slots = sortLt (<)
(foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
unboxed_slots)
-- merge in the free slots
- let all_slots = mergeSlots flatten_slots (map fst free) ++
+ all_slots = mergeSlots flatten_slots (map fst free) ++
if vsp < sp then [vsp+1 .. sp] else []
-- recalibrate the list to be sp-relative
- let rel_slots = reverse (map (sp-) all_slots)
+ rel_slots = reverse (map (sp-) all_slots)
-- build the bitmap
- let liveness_mask = ASSERT(all (>=0) rel_slots) (listToLivenessMask rel_slots)
-
- livenessToAbsC uniq liveness_mask
+ liveness_mask = listToLivenessMask rel_slots
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 = do
- realSp <- getRealSp
- buildLivenessMask uniq (realSp-1)
+buildContLivenessMask uniq
+ = getRealSp `thenFC` \ realSp ->
+ buildLivenessMask uniq (realSp-1)
\end{code}
%************************************************************************
\begin{code}
nukeDeadBindings :: StgLiveVars -- All the *live* variables
-> Code
-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
+
+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
\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.27 2001/08/29 14:20:14 rje Exp $
+% $Id: CgMonad.lhs,v 1.28 2001/08/30 09:51:16 sewardj 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}
-newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
-type Code = FCode ()
-
-instance Monad FCode where
- (>>=) = thenFC
- return = returnFC
+type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
+type Code = CgInfoDownwards -> CgState -> CgState
{-# INLINE thenC #-}
{-# INLINE thenFC #-}
\begin{code}
initC :: CompilationInfo -> Code -> AbstractC
-initC cg_info (FCode code)
+initC cg_info 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 = FCode (\info_down state -> (val, state))
+
+returnFC val info_down state = (val, state)
\end{code}
\begin{code}
-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)
+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
listCs :: [Code] -> Code
-listCs [] = return ()
-listCs (fc:fcs) = do
- fc
- listCs fcs
-
+
+listCs [] info_down state = state
+listCs (c:cs) info_down state = stateN
+ where
+ state1 = c info_down state
+ stateN = listCs cs info_down state1
+
mapCs :: (a -> Code) -> [a] -> Code
-mapCs = mapM_
+
+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
\end{code}
\begin{code}
-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
- )
+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
listFCs :: [FCode a] -> FCode [a]
-listFCs = sequence
+
+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
mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
-mapFCs = mapM
+
+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
\end{code}
And the knot-tying combinator:
\begin{code}
fixC :: (a -> FCode a) -> FCode a
-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
+fixC fcode info_down state = result
+ where
+ result@(v, _) = fcode v 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 (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
-
+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
+
forkStatics :: FCode a -> FCode a
-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)
- )
+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
forkAbsC :: Code -> FCode AbstractC
-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
+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
\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 (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)
+forkAlts branch_fcodes deflt_fcode info_down in_state
+ = ((branch_results , deflt_result), out_state)
+ where
+ compile fc = fc info_down in_state
+ (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 =
- 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
+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
(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 = return ()
+nopC info_down state = state
absC :: AbstractC -> Code
-absC more_absC = do
- state@(MkCgState absC binds usage) <- getState
- setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
+absC more_absC info_down state@(MkCgState absC binds usage)
+ = 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 =
- if opt_SccProfilingOn then do
- (MkCgState absC binds usage) <- getState
- setState $ MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
- else
- nopC
+costCentresC macro args _ state@(MkCgState absC binds usage)
+ = if opt_SccProfilingOn
+ then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
+ else state
profCtrC :: FAST_STRING -> [CAddrMode] -> Code
-profCtrC macro args =
- if not opt_DoTickyProfiling
- then nopC
- else do
- (MkCgState absC binds usage) <- getState
- setState $ MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
+profCtrC macro args _ state@(MkCgState absC binds usage)
+ = if not opt_DoTickyProfiling
+ then state
+ else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
\begin{code}
getAbsC :: Code -> FCode AbstractC
-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
+
+getAbsC code info_down (MkCgState absC binds usage)
+ = (absC2, MkCgState absC binds2 usage2)
+ where
+ (MkCgState absC2 binds2 usage2)
+ = code info_down (MkCgState AbsCNop binds usage)
\end{code}
\begin{code}
+
moduleName :: FCode Module
-moduleName = do
- (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
- return mod_name
+moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) state
+ = (mod_name, state)
+
\end{code}
\begin{code}
setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
-setEndOfBlockInfo eob_info code = do
- (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
- withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
+setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt ticky _) state
+ = code (MkCgInfoDown c_info statics srt ticky eob_info) state
getEndOfBlockInfo :: FCode EndOfBlockInfo
-getEndOfBlockInfo = do
- (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
- return eob_info
+getEndOfBlockInfo (MkCgInfoDown c_info statics _ _ eob_info) state
+ = (eob_info, state)
\end{code}
\begin{code}
getSRTLabel :: FCode CLabel
-getSRTLabel = do
- (MkCgInfoDown _ _ srt _ _) <- getInfoDown
- return srt
+getSRTLabel (MkCgInfoDown _ _ srt _ _) state
+ = (srt, state)
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)
+setSRTLabel srt code (MkCgInfoDown c_info statics _ ticky eob_info) state
+ = code (MkCgInfoDown c_info statics srt ticky eob_info) state
\end{code}
\begin{code}
getTickyCtrLabel :: FCode CLabel
-getTickyCtrLabel = do
- (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
- return ticky
+getTickyCtrLabel (MkCgInfoDown _ _ _ ticky _) state
+ = (ticky, state)
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)
+setTickyCtrLabel ticky code (MkCgInfoDown c_info statics srt _ eob_info) state
+ = code (MkCgInfoDown c_info statics srt ticky eob_info) state
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.16 2001/08/29 14:20:14 rje Exp $
+% $Id: CgStackery.lhs,v 1.17 2001/08/30 09:51:16 sewardj Exp $
%
\section[CgStackery]{Stack management functions}
allocStack = allocPrimStack 1
allocPrimStack :: Int -> FCode VirtualSpOffset
-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,
+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,
hw_sp `max` push_virt_sp))
- -- 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,
+ -- 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,
(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 = 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
+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
\end{code}
Pop some words from the current top of stack. This is used for
\begin{code}
deAllocStackTop :: Int -> FCode VirtualSpOffset
-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
+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)
\end{code}
\begin{code}
adjustStackHW :: VirtualSpOffset -> Code
-adjustStackHW offset = do
- ((vSp,fSp,realSp,hwSp), h_usage) <- getUsage
- setUsage ((vSp, fSp, realSp, max offset hwSp), h_usage)
+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
\end{code}
A knot-tying beast.
\begin{code}
getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
-getFinalStackHW fcode = do
- fixC (\hwSp -> do
- fcode hwSp
- ((_,_,_, hwSp),_) <- getUsage
- return hwSp)
- return ()
+getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
+ where
+ state1 = fcode hwSp info_down (MkCgState absC binds usages)
+ (MkCgState _ _ ((_,_,_, hwSp), _)) = state1
\end{code}
\begin{code}
\begin{code}
addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
-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
+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))
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 = 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 -})
+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 -})
\end{code}
\begin{code}
setVirtHp :: VirtualHeapOffset -> Code
-setVirtHp new_virtHp = do
- (stk, (virtHp, realHp)) <- getUsage
- setUsage (stk, (new_virtHp, realHp))
+setVirtHp new_virtHp info_down
+ state@(MkCgState absC binds (stk, (virtHp, realHp)))
+ = MkCgState absC binds (stk, (new_virtHp, realHp))
\end{code}
\begin{code}
getVirtAndRealHp :: FCode (VirtualHeapOffset, VirtualHeapOffset)
-getVirtAndRealHp = do
- (_, (virtHp, realHp)) <- getUsage
- return (virtHp, realHp)
+getVirtAndRealHp info_down state@(MkCgState _ _ (_, (virtHp, realHp)))
+ = ((virtHp, realHp), state)
\end{code}
\begin{code}
setRealHp :: VirtualHeapOffset -> Code
-setRealHp realHp = do
- (stk_usage, (vHp, _)) <- getUsage
- setUsage (stk_usage, (vHp, realHp))
+setRealHp realHp info_down (MkCgState absC binds (stk_usage, (vHp, _)))
+ = MkCgState absC binds (stk_usage, (vHp, realHp))
\end{code}
\begin{code}
getHpRelOffset :: VirtualHeapOffset -> FCode RegRelative
-getHpRelOffset virtual_offset = do
- (_,(_,realHp)) <- getUsage
- return $ hpRel realHp virtual_offset
+getHpRelOffset virtual_offset info_down state@(MkCgState _ _ (_,(_,realHp)))
+ = (hpRel realHp virtual_offset, state)
\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 = do
- ((vsp,f,realSp,hwsp), h_usage) <- getUsage
- let new_usage = ((sp, f, sp, sp), h_usage)
- setUsage new_usage
+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)
\end{code}
\begin{code}
getVirtSp :: FCode VirtualSpOffset
-getVirtSp = do
- ((virtSp,_,_,_), _) <- getUsage
- return virtSp
+getVirtSp info_down state@(MkCgState absC binds ((virtSp,_,_,_), _))
+ = (virtSp, state)
getRealSp :: FCode VirtualSpOffset
-getRealSp = do
- ((_,_,realSp,_),_) <- getUsage
- return realSp
+getRealSp info_down state@(MkCgState absC binds ((_,_,realSp,_),_))
+ = (realSp,state)
\end{code}
\begin{code}
getSpRelOffset :: VirtualSpOffset -> FCode RegRelative
-getSpRelOffset virtual_offset = do
- ((_,_,realSp,_),_) <- getUsage
- return $ spRel realSp virtual_offset
+getSpRelOffset virtual_offset info_down state@(MkCgState _ _ ((_,_,realSp,_),_))
+ = (spRel realSp virtual_offset, state)
\end{code}
%************************************************************************
\begin{code}
adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr
-> Code
-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
+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
else (CAssign (CReg Sp)
(CAddr (spRel realSp newRealSp)))
- let move_hp =
- if (rHp == vHp) then AbsCNop
- else mkAbstractCs [
- CAssign (CReg Hp) (CAddr (hpRel rHp vHp)),
+
+ -- 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)),
profCtrAbsC SLIT("TICK_ALLOC_HEAP")
- [ 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
+ [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ]
+ ]
+
+ new_usage = ((vSp, fSp, newRealSp, hwSp), (vHp,vHp))
\end{code}
projects / ghc-hetmet.git / commitdiff