From c31a55d1d200e9d1d72d0f09fce5204c425b801d Mon Sep 17 00:00:00 2001 From: rje Date: Wed, 29 Aug 2001 14:20:14 +0000 Subject: [PATCH] [project @ 2001-08-29 14:20:14 by rje] FCode/Code is now a monad, and thus now also a constructed type, rather than a type synonym. This requires quite a lot of changes in quite a lot of files, but none of these changes should have changed the behaviour of anything. Being a Monad allows code that used FCode to be IMHO rather more readable as it can use do notation, and other common Monad idioms. In addition, state has been abstracted away with getter and setter functions, so that functions mess with the innards of FCode as little as possible - making it easier to change FCode in future. --- 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, 412 insertions(+), 365 deletions(-) diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 2773bf1..872c103 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -176,41 +176,40 @@ The name should not already be bound. (nice ASSERT, eh?) \begin{code} addBindC :: Id -> CgIdInfo -> Code -addBindC name stuff_to_bind info_down (MkCgState absC binds usage) - = MkCgState absC (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:"), @@ -256,20 +255,20 @@ getCAddrModeAndInfo id -- 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} @@ -277,13 +276,13 @@ getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode) 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 @@ -296,50 +295,50 @@ forget the volatile one. \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 @@ -375,9 +374,9 @@ bindNewToTemp name -- 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 @@ -425,6 +424,8 @@ 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) @@ -450,34 +451,35 @@ buildLivenessMask -> 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 = ASSERT (all (>=0) rel_slots) 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 = listToLivenessMask rel_slots + + livenessToAbsC uniq liveness_mask mergeSlots :: [Int] -> [Int] -> [Int] mergeSlots cs [] = cs @@ -497,10 +499,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 @@ -510,9 +512,9 @@ the return address, which is on the stack at realSp. buildContLivenessMask :: Unique -> FCode Liveness -buildContLivenessMask uniq - = getRealSp `thenFC` \ realSp -> - buildLivenessMask uniq (realSp-1) +buildContLivenessMask uniq = do + realSp <- getRealSp + buildLivenessMask uniq (realSp-1) \end{code} %************************************************************************ @@ -539,16 +541,15 @@ Probably *naughty* to look inside monad... \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. diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 9c6d172..cb01374 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.26 2000/11/06 08:15:21 simonpj Exp $ +% $Id: CgMonad.lhs,v 1.27 2001/08/29 14:20:14 rje Exp $ % \section[CgMonad]{The code generation monad} @@ -35,6 +35,13 @@ 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(..) @@ -253,8 +260,12 @@ stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1))) %************************************************************************ \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 #-} @@ -265,7 +276,7 @@ The Abstract~C is not in the environment so as to improve strictness. \begin{code} initC :: CompilationInfo -> Code -> AbstractC -initC cg_info code +initC cg_info (FCode code) = case (code (MkCgInfoDown cg_info (error "initC: statics") @@ -273,83 +284,111 @@ initC cg_info code (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. @@ -369,36 +408,39 @@ bindings and usage information is otherwise 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 @@ -411,17 +453,17 @@ that \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. @@ -455,23 +497,21 @@ forkEvalHelp :: EndOfBlockInfo -- For the body -> 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), _)) @@ -495,11 +535,12 @@ 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 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 @@ -509,17 +550,21 @@ nothing. \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 @@ -543,48 +588,52 @@ obtained from the compilation. \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} diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index d4fc31f..89dd93a 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.15 2000/10/24 07:35:00 simonpj Exp $ +% $Id: CgStackery.lhs,v 1.16 2001/08/29 14:20:14 rje Exp $ % \section[CgStackery]{Stack management functions} @@ -141,34 +141,33 @@ allocStack :: FCode VirtualSpOffset 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 @@ -181,13 +180,12 @@ free list. \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 @@ -195,33 +193,31 @@ de-allocating the return address in a case alternative. \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} @@ -244,13 +240,12 @@ Explicitly free some stack space. \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 diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs index 6f3353d..8c40c9a 100644 --- a/ghc/compiler/codeGen/CgUsages.lhs +++ b/ghc/compiler/codeGen/CgUsages.lhs @@ -39,43 +39,47 @@ 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 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 @@ -102,27 +106,29 @@ It is used to initialise things at the beginning of a closure body. 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} %************************************************************************ @@ -144,25 +150,21 @@ That's done by functions which allocate stack space. \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} -- 1.7.10.4