From: rje Date: Fri, 31 Aug 2001 12:39:06 +0000 (+0000) Subject: [project @ 2001-08-31 12:39:06 by rje] X-Git-Tag: Approximately_9120_patches~1039 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=205383c22a13b39ed2fb9d9512d92927e53edf31;p=ghc-hetmet.git [project @ 2001-08-31 12:39:06 by rje] Reapplied my "FCode as a monad" patch, now that 5.02 has forked into a separate branch. I'm fairly sure that this doesn't change the behaviour of anything. --- diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 2773bf1..fb9916f 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 = do -- find all unboxed stack-resident ids - unboxed_slots = - [ (ofs, size) | - (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds, - let rep = idPrimRep id; size = getPrimRepSize rep, + binds <- getBinds + ((vsp, free, _, _), heap_usage) <- getUsage + + let unboxed_slots = + [ (ofs, size) | + (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds, + let rep = idPrimRep id; size = getPrimRepSize rep, not (isFollowableRep rep), size > 0 - ] - + ] + -- flatten this list into a list of unboxed stack slots - flatten_slots = sortLt (<) + let flatten_slots = sortLt (<) (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) [] unboxed_slots) -- merge in the free slots - all_slots = mergeSlots flatten_slots (map fst free) ++ + let all_slots = mergeSlots flatten_slots (map fst free) ++ if vsp < sp then [vsp+1 .. sp] else [] -- recalibrate the list to be sp-relative - rel_slots = reverse (map (sp-) all_slots) + let rel_slots = reverse (map (sp-) all_slots) -- build the bitmap - liveness_mask = listToLivenessMask rel_slots + let liveness_mask = ASSERT(all (>=0) rel_slots) (listToLivenessMask rel_slots) + + livenessToAbsC uniq liveness_mask mergeSlots :: [Int] -> [Int] -> [Int] mergeSlots cs [] = cs @@ -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 9f0c93c..ac50b28 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.28 2001/08/30 09:51:16 sewardj Exp $ +% $Id: CgMonad.lhs,v 1.29 2001/08/31 12:39:06 rje Exp $ % \section[CgMonad]{The code generation monad} @@ -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 26e190f..3a2598e 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.17 2001/08/30 09:51:16 sewardj Exp $ +% $Id: CgStackery.lhs,v 1.18 2001/08/31 12:39:06 rje Exp $ % \section[CgStackery]{Stack management functions} @@ -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}