X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgMonad.lhs;h=99c776e34e9f083cd713efcd8159ecd0c0bd8e27;hb=0c33b675b26b627963c7a2ac00d6dd4c551fbcac;hp=25c36cd3f58c16fcb6e9df8f75c5829d4c580386;hpb=beaf0404918eae2faf8a1783009a601f81984ac7;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 25c36cd..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.33 2002/01/03 11:44:17 simonmar Exp $ +% $Id: CgMonad.lhs,v 1.38 2003/05/14 09:13:56 simonmar Exp $ % \section[CgMonad]{The code generation monad} @@ -53,15 +53,18 @@ 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, mkTopTickyCtrLabel ) import Module ( Module ) import DataCon ( ConTag ) import Id ( Id ) +import Name ( Name ) import VarEnv import PrimRep ( PrimRep(..) ) +import SMRep ( StgHalfWord, hALF_WORD ) +import FastString import Outputable infixr 9 `thenC` -- Right-associative! @@ -142,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... @@ -184,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) @@ -199,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 @@ -219,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} @@ -437,9 +431,9 @@ 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) + 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} @@ -503,24 +497,24 @@ forkEvalHelp body_eob_info env_code body_code = 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,_,_),_)) = + 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), _)) +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. @@ -549,23 +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 -profCtrC :: FAST_STRING -> [CAddrMode] -> Code +profCtrC :: FastString -> [CAddrMode] -> Code profCtrC macro args | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args) | otherwise = nopC -profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC +profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC profCtrAbsC macro args | opt_DoTickyProfiling = CCallProfCtrMacro macro args | otherwise = AbsCNop ldvEnter :: Code -ldvEnter = costCentresC SLIT("LDV_ENTER") [CReg node] +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 @@ -613,16 +607,25 @@ bindings use sub-sections of this SRT. The label is passed down to the nested bindings via the monad. \begin{code} -getSRTInfo :: SRT -> FCode C_SRT -getSRTInfo NoSRT = return NoC_SRT -getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel - return (C_SRT srt_lbl off len) +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 -> Code -> Code +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)