X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgMonad.lhs;h=99c776e34e9f083cd713efcd8159ecd0c0bd8e27;hb=a7d8f43718b167689c0a4a4c23b33a325e0239f1;hp=d649bc24aba61b414c3f9f06b3c8849dc0614106;hpb=3505f69a94879f85376e839cc535705fbc39d09a;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index d649bc2..99c776e 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.22 1999/06/09 14:28:38 simonmar Exp $ +% $Id: CgMonad.lhs,v 1.38 2003/05/14 09:13:56 simonmar Exp $ % \section[CgMonad]{The code generation monad} @@ -23,17 +23,25 @@ module CgMonad ( EndOfBlockInfo(..), setEndOfBlockInfo, getEndOfBlockInfo, - setSRTLabel, getSRTLabel, + setSRTLabel, getSRTLabel, getSRTInfo, + setTickyCtrLabel, getTickyCtrLabel, StackUsage, Slot(..), HeapUsage, - profCtrC, + profCtrC, profCtrAbsC, ldvEnter, costCentresC, moduleName, 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(..) @@ -41,19 +49,22 @@ module CgMonad ( #include "HsVersions.h" -import {-# SOURCE #-} CgBindery ( CgIdInfo, CgBindings, nukeVolatileBinds ) +import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) import {-# SOURCE #-} CgUsages ( getSpRelOffset ) import AbsCSyn +import CLabel +import StgSyn ( SRT(..) ) import AbsCUtils ( mkAbsCStmts ) import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling ) -import CLabel ( CLabel, mkUpdInfoLabel ) import Module ( Module ) import DataCon ( ConTag ) import Id ( Id ) +import Name ( Name ) import VarEnv import PrimRep ( PrimRep(..) ) -import StgSyn ( StgLiveVars ) +import SMRep ( StgHalfWord, hALF_WORD ) +import FastString import Outputable infixr 9 `thenC` -- Right-associative! @@ -80,6 +91,8 @@ data CgInfoDownwards -- information only passed *downwards* by the monad CLabel -- label of the current SRT + CLabel -- current destination for ticky counts + EndOfBlockInfo -- Info for stuff to do at end of basic block: @@ -132,9 +145,8 @@ data Sequel -- addressing mode (I think) SemiTaggingStuff - | SeqFrame -- like CaseAlts but push a seq frame too. - CAddrMode - SemiTaggingStuff + Bool -- True <=> polymorphic, push a SEQ frame too + type SemiTaggingStuff = Maybe -- Maybe[1] we don't have any semi-tagging stuff... @@ -174,8 +186,9 @@ sequelToAmode (OnStack virt_sp_offset) returnFC (CVal sp_rel RetRep) sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep) -sequelToAmode (CaseAlts amode _) = returnFC amode -sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame" + +sequelToAmode (CaseAlts amode _ False) = returnFC amode +sequelToAmode (CaseAlts amode _ True) = returnFC (CLbl mkSeqInfoLabel RetRep) type CgStksAndHeapUsage -- stacks and heap usage information = (StackUsage, HeapUsage) @@ -189,10 +202,19 @@ data Slot = Free | NonPointer #endif type StackUsage = - (Int, -- virtSp: Virtual offset of topmost allocated slot - [(Int,Slot)], -- free: List of free slots, in increasing order - Int, -- realSp: Virtual offset of real stack pointer - Int) -- hwSp: Highest value ever taken by virtSp + (Int, -- virtSp: Virtual offset of topmost allocated slot + Int, -- frameSp: End of the current stack frame + [(Int,Slot)], -- free: List of free slots, in increasing order + Int, -- realSp: Virtual offset of real stack pointer + Int) -- hwSp: Highest value ever taken by virtSp + +-- ToDo (SDM, 7 Jan 2003): I'm not sure that the distinction between +-- Free and NonPointer in the free list is needed any more. It used +-- to be needed because we constructed bitmaps from the free list, but +-- now we construct bitmaps by finding all the live pointer bindings +-- instead. Non-pointer stack slots (i.e. saved cost centres) can +-- just be removed from the free list instead of being recorded as a +-- NonPointer. type HeapUsage = (HeapOffset, -- virtHp: Virtual offset of highest-allocated word @@ -209,38 +231,20 @@ Initialisation. initialStateC = MkCgState AbsCNop emptyVarEnv initUsage initUsage :: CgStksAndHeapUsage -initUsage = ((0,[],0,0), (0,0)) +initUsage = ((0,0,[],0,0), (0,0)) \end{code} -"envInitForAlternatives" initialises the environment for a case alternative, -assuming that the alternative is entered after an evaluation. -This involves: - - - zapping any volatile bindings, which aren't valid. - - - zapping the heap usage. It should be restored by a heap check. - - - setting the virtual AND real stack pointer fields to the given - virtual stack offsets. this doesn't represent any {\em code}; it is a - prediction of where the real stack pointer will be when we come back - from the case analysis. - - - BUT LEAVING the rest of the stack-usage info because it is all - valid. In particular, we leave the tail stack pointers unchanged, - becuase the alternative has to de-allocate the original @case@ - expression's stack. \end{itemize} - @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water marks found in $e_2$. \begin{code} stateIncUsage :: CgState -> CgState -> CgState -stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1))) - (MkCgState _ _ ((_,_,_,h2),(vH2, _))) +stateIncUsage (MkCgState abs_c bs ((v,t,f,r,h1),(vH1,rH1))) + (MkCgState _ _ ((_,_,_,_,h2),(vH2, _))) = MkCgState abs_c bs - ((v,f,r,h1 `max` h2), + ((v,t,f,r,h1 `max` h2), (vH1 `max` vH2, rH1)) \end{code} @@ -251,8 +255,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 #-} @@ -263,90 +271,119 @@ 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") + emptyVarEnv -- (error "initC: statics") (error "initC: srt") + (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. @@ -366,36 +403,39 @@ bindings and usage information is otherwise unchanged. \begin{code} forkClosureBody :: Code -> Code -forkClosureBody code - (MkCgInfoDown cg_info statics srt _) - (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 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 _) - (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 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, t, f, r, h1), heap_usage) = usage + let new_usage = ((v, t, 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 @@ -408,17 +448,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. @@ -452,31 +492,29 @@ 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 _) state - = ((v,value_returned), state `stateIncUsageEval` state_at_end_return) - where - info_down_for_body = MkCgInfoDown cg_info statics srt 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,t,f,_,_),_)) = + doFCode env_code info_down_for_body state + let state_for_body = MkCgState AbsCNop (nukeVolatileBinds binds) - ((v,f,v,v), (0,0)) - - + ((v,t,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), _)) - = MkCgState (absC1 `AbsCStmts` absC2) +stateIncUsageEval (MkCgState absC1 bs ((v,t,f,r,h1),heap_usage)) + (MkCgState absC2 _ ((_,_,_,_,h2), _)) + = MkCgState (absC1 `mkAbsCStmts` absC2) -- The AbsC coming back should consist only of nested declarations, -- notably of the return vector! bs - ((v,f,r,h1 `max` h2), heap_usage) + ((v,t,f,r,h1 `max` h2), heap_usage) -- We don't max the heap high-watermark because stateIncUsageEval is -- used only in forkEval, which in turn is only used for blocks of code -- which do their own heap-check. @@ -492,11 +530,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 @@ -504,19 +543,23 @@ info (whether SCC profiling or profiling-ctrs going) and possibly emit nothing. \begin{code} -costCentresC :: FAST_STRING -> [CAddrMode] -> Code +costCentresC :: FastString -> [CAddrMode] -> Code +costCentresC macro args + | opt_SccProfilingOn = absC (CCallProfCCMacro macro args) + | otherwise = nopC -costCentresC macro args _ state@(MkCgState absC binds usage) - = if opt_SccProfilingOn - then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage - else state +profCtrC :: FastString -> [CAddrMode] -> Code +profCtrC macro args + | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args) + | otherwise = nopC -profCtrC :: FAST_STRING -> [CAddrMode] -> Code +profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC +profCtrAbsC macro args + | opt_DoTickyProfiling = CCallProfCtrMacro macro args + | otherwise = AbsCNop -profCtrC macro args _ state@(MkCgState absC binds usage) - = if not opt_DoTickyProfiling - then state - else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage +ldvEnter :: Code +ldvEnter = costCentresC FSLIT("LDV_ENTER") [CReg node] {- Try to avoid adding too many special compilation strategies here. It's better to modify the header files as necessary for particular @@ -533,38 +576,69 @@ 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 _) state - = code (MkCgInfoDown c_info statics srt 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} +There is just one SRT for each top level binding; all the nested +bindings use sub-sections of this SRT. The label is passed down to +the nested bindings via the monad. + \begin{code} -getSRTLabel :: FCode CLabel -getSRTLabel (MkCgInfoDown _ _ srt _) state - = (srt, state) +getSRTInfo :: Name -> SRT -> FCode C_SRT +getSRTInfo id NoSRT = return NoC_SRT +getSRTInfo id (SRT off len bmp) + | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do + srt_lbl <- getSRTLabel + let srt_desc_lbl = mkSRTDescLabel id + absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp) + return (C_SRT srt_desc_lbl 0 srt_escape) + | otherwise = do + srt_lbl <- getSRTLabel + return (C_SRT srt_lbl off (fromIntegral (head bmp))) + +srt_escape = (-1) :: StgHalfWord + +getSRTLabel :: FCode CLabel -- Used only by cgPanic +getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown + return srt_lbl + +setSRTLabel :: CLabel -> FCode a -> FCode a +setSRTLabel srt_lbl code + = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown + withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info) +\end{code} -setSRTLabel :: CLabel -> Code -> Code -setSRTLabel srt code (MkCgInfoDown c_info statics _ eob_info) state - = code (MkCgInfoDown c_info statics srt eob_info) state +\begin{code} +getTickyCtrLabel :: FCode CLabel +getTickyCtrLabel = do + (MkCgInfoDown _ _ _ ticky _) <- getInfoDown + return ticky + +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) \end{code}