%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.20 1999/05/18 15:03:49 simonpj Exp $
+% $Id: CgMonad.lhs,v 1.23 1999/10/13 16:39:16 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
forkEvalHelp, forkAbsC,
SemiTaggingStuff,
- addBindC, addBindsC, modifyBindC, lookupBindC,
-
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
setSRTLabel, getSRTLabel,
+ setTickyCtrLabel, getTickyCtrLabel,
- StackUsage, HeapUsage,
+ StackUsage, Slot(..), HeapUsage,
- profCtrC, cgPanic,
+ profCtrC, profCtrAbsC,
costCentresC, moduleName,
#include "HsVersions.h"
-import {-# SOURCE #-} CgBindery ( CgIdInfo(..), CgBindings, maybeStkLoc, nukeVolatileBinds )
+import {-# SOURCE #-} CgBindery ( CgIdInfo, CgBindings, nukeVolatileBinds )
import {-# SOURCE #-} CgUsages ( getSpRelOffset )
import AbsCSyn
import AbsCUtils ( mkAbsCStmts )
import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
-import CLabel ( CLabel, mkUpdInfoLabel, pprCLabel )
+import CLabel ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
import Module ( Module )
import DataCon ( ConTag )
import Id ( Id )
CLabel -- label of the current SRT
+ CLabel -- current destination for ticky counts
+
EndOfBlockInfo -- Info for stuff to do at end of basic block:
sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
sequelToAmode (CaseAlts amode _) = returnFC amode
-sequelToAmode (SeqFrame _ _) = cgPanic (text "sequelToAmode: SeqFrame")
+sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
type CgStksAndHeapUsage -- stacks and heap usage information
= (StackUsage, HeapUsage)
+data Slot = Free | NonPointer
+ deriving
+#ifdef DEBUG
+ (Eq,Show)
+#else
+ Eq
+#endif
+
type StackUsage =
(Int, -- virtSp: Virtual offset of topmost allocated slot
- [Int], -- free: List of free slots, in increasing order
+ [(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
initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
initUsage :: CgStksAndHeapUsage
-initUsage = ((0,[],0,0), (initVirtHp, initRealHp))
-initVirtHp = panic "Uninitialised virtual Hp"
-initRealHp = panic "Uninitialised real Hp"
+initUsage = ((0,[],0,0), (0,0))
\end{code}
"envInitForAlternatives" initialises the environment for a case alternative,
cg_info
(error "initC: statics")
(error "initC: srt")
+ (mkTopTickyCtrLabel)
initEobInfo)
initialStateC) of
MkCgState abc _ _ -> abc
forkClosureBody :: Code -> Code
forkClosureBody code
- (MkCgInfoDown cg_info statics srt _)
+ (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 initEobInfo
+ body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
forkStatics :: FCode a -> FCode a
-forkStatics fcode (MkCgInfoDown cg_info _ srt _)
+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 initEobInfo
+ rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
forkAbsC :: Code -> FCode AbstractC
forkAbsC code info_down (MkCgState absC1 bs usage)
a) -- Result of the FCode
forkEvalHelp body_eob_info env_code body_code
- info_down@(MkCgInfoDown cg_info statics srt _) state
+ 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 body_eob_info
+ 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
state_for_body = MkCgState AbsCNop
(nukeVolatileBinds binds)
- ((v,f,v,v),
- (initVirtHp, initRealHp))
+ ((v,f,v,v), (0,0))
stateIncUsageEval :: CgState -> CgState -> CgState
then state
else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
+profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
+
+profCtrAbsC macro args
+ = if not opt_DoTickyProfiling
+ then AbsCNop
+ else CCallProfCtrMacro macro args
+
{- Try to avoid adding too many special compilation strategies here.
It's better to modify the header files as necessary for particular
targets, so that we can get away with as few variants of .hc files
\begin{code}
moduleName :: FCode Module
-moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _) state
+moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) state
= (mod_name, state)
\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 (MkCgInfoDown c_info statics srt ticky _) state
+ = code (MkCgInfoDown c_info statics srt ticky eob_info) state
getEndOfBlockInfo :: FCode EndOfBlockInfo
-getEndOfBlockInfo (MkCgInfoDown c_info statics _ eob_info) state
+getEndOfBlockInfo (MkCgInfoDown c_info statics _ _ eob_info) state
= (eob_info, state)
\end{code}
\begin{code}
getSRTLabel :: FCode CLabel
-getSRTLabel (MkCgInfoDown _ _ srt _) state
+getSRTLabel (MkCgInfoDown _ _ srt _ _) state
= (srt, state)
setSRTLabel :: CLabel -> Code -> Code
-setSRTLabel srt code (MkCgInfoDown c_info statics _ eob_info) state
- = code (MkCgInfoDown c_info statics srt eob_info) state
+setSRTLabel srt code (MkCgInfoDown c_info statics _ ticky eob_info) state
+ = code (MkCgInfoDown c_info statics srt ticky eob_info) state
\end{code}
-%************************************************************************
-%* *
-\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
-%* *
-%************************************************************************
-
-There are three basic routines, for adding (@addBindC@), modifying
-(@modifyBindC@) and looking up (@lookupBindC@) bindings.
-
-A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
-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
+getTickyCtrLabel :: FCode CLabel
+getTickyCtrLabel (MkCgInfoDown _ _ _ ticky _) state
+ = (ticky, state)
-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
-
-modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
-modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
- = MkCgState absC (modifyVarEnv mangle_fn binds name) usage
-
-lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name info_down@(MkCgInfoDown _ static_binds srt _)
- 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 _)
- state@(MkCgState absC local_binds usage)
- = pprPanic "cgPanic"
- (vcat [doc,
- ptext SLIT("static binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
- ptext SLIT("local binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
- ptext SLIT("SRT label") <+> pprCLabel srt
- ])
+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
\end{code}
projects / ghc-hetmet.git / blobdiff