From d6e95f7aa43d6282bb7be4ca78e7f1a601222aea Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 30 Aug 2001 09:51:16 +0000 Subject: [PATCH] [project @ 2001-08-30 09:51:15 by sewardj] 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 --- ghc/compiler/codeGen/CgBindery.lhs | 233 ++++++++++++------------ ghc/compiler/codeGen/CgMonad.lhs | 335 +++++++++++++++-------------------- ghc/compiler/codeGen/CgStackery.lhs | 113 ++++++------ ghc/compiler/codeGen/CgUsages.lhs | 96 +++++----- 4 files changed, 365 insertions(+), 412 deletions(-) diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 514be45..2773bf1 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -176,40 +176,41 @@ The name should not already be bound. (nice ASSERT, eh?) \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:"), @@ -255,20 +256,20 @@ getCAddrModeAndInfo id -- 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} @@ -276,13 +277,13 @@ getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode) 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 @@ -295,50 +296,50 @@ forget the volatile one. \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 @@ -374,9 +375,9 @@ bindNewToTemp name -- 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 @@ -424,8 +425,6 @@ rebindToStack name offset %* * %************************************************************************ -ToDo: remove the dependency on 32-bit words. - There are four kinds of things on the stack: - pointer variables (bound in the environment) @@ -451,35 +450,34 @@ buildLivenessMask -> 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 @@ -499,10 +497,10 @@ listToLivenessMask slots = 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 @@ -512,9 +510,9 @@ the return address, which is on the stack at realSp. buildContLivenessMask :: Unique -> FCode Liveness -buildContLivenessMask uniq = do - realSp <- getRealSp - buildLivenessMask uniq (realSp-1) +buildContLivenessMask uniq + = getRealSp `thenFC` \ realSp -> + buildLivenessMask uniq (realSp-1) \end{code} %************************************************************************ @@ -541,15 +539,16 @@ Probably *naughty* to look inside monad... \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. diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index cb01374..9f0c93c 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (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} @@ -35,13 +35,6 @@ module CgMonad ( 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(..) @@ -260,12 +253,8 @@ stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1))) %************************************************************************ \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 #-} @@ -276,7 +265,7 @@ The Abstract~C is not in the environment so as to improve strictness. \begin{code} initC :: CompilationInfo -> Code -> AbstractC -initC cg_info (FCode code) +initC cg_info code = case (code (MkCgInfoDown cg_info (error "initC: statics") @@ -284,111 +273,83 @@ initC cg_info (FCode code) (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. @@ -408,39 +369,36 @@ bindings and usage information is otherwise 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 @@ -453,17 +411,17 @@ that \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. @@ -497,21 +455,23 @@ forkEvalHelp :: EndOfBlockInfo -- For the body -> 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), _)) @@ -535,12 +495,11 @@ stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage)) 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 @@ -550,21 +509,17 @@ nothing. \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 @@ -588,52 +543,48 @@ obtained from the compilation. \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} diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index 89dd93a..26e190f 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -1,7 +1,7 @@ % % (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} @@ -141,33 +141,34 @@ allocStack :: FCode VirtualSpOffset 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 @@ -180,12 +181,13 @@ free list. \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 @@ -193,31 +195,33 @@ de-allocating the return address in a case alternative. \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} @@ -240,12 +244,13 @@ Explicitly free some stack space. \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 diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs index 8c40c9a..6f3353d 100644 --- a/ghc/compiler/codeGen/CgUsages.lhs +++ b/ghc/compiler/codeGen/CgUsages.lhs @@ -39,47 +39,43 @@ heap usage. 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 @@ -106,29 +102,27 @@ It is used to initialise things at the beginning of a closure body. 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} %************************************************************************ @@ -150,21 +144,25 @@ That's done by functions which allocate stack space. \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} -- 1.7.10.4