%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgMonad]{The code generation monad}
#include "HsVersions.h"
module CgMonad (
- Code(..), -- type
- FCode(..), -- type
+ SYN_IE(Code), -- type
+ SYN_IE(FCode), -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, absC, nopC, getAbsC,
forkClosureBody, forkStatics, forkAlts, forkEval,
forkEvalHelp, forkAbsC,
- SemiTaggingStuff(..),
+ SYN_IE(SemiTaggingStuff),
addBindC, addBindsC, modifyBindC, lookupBindC,
---UNUSED: grabBindsC,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- AStackUsage(..), BStackUsage(..), HeapUsage(..),
+ SYN_IE(AStackUsage), SYN_IE(BStackUsage), SYN_IE(HeapUsage),
StubFlag,
isStubbed,
---UNUSED: grabStackSizeC,
nukeDeadBindings, getUnstubbedAStackSlots,
-- addFreeASlots, -- no need to export it
addFreeBSlots, -- ToDo: Belong elsewhere
- isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC,
-
noBlackHolingFlag,
- profCtrC, --UNUSED: concurrentC,
+ profCtrC,
costCentresC, costCentresFlag, moduleName,
sequelToAmode,
-- out of general friendliness, we also export ...
- CgBindings(..),
CgInfoDownwards(..), CgState(..), -- non-abstract
- CgIdInfo, -- abstract
- CompilationInfo(..), IntSwitchChecker(..),
- GlobalSwitch, -- abstract
-
- stableAmodeIdInfo, heapIdInfo,
-
- -- and to make the interface self-sufficient...
- AbstractC, CAddrMode, CLabel, LambdaFormInfo, IdEnv(..),
- Unique, HeapOffset, CostCentre, IsCafCC,
- Id, UniqSet(..), UniqFM,
- VirtualSpAOffset(..), VirtualSpBOffset(..),
- VirtualHeapOffset(..), DataCon(..), PlainStgLiveVars(..),
- Maybe
+ CompilationInfo(..)
) where
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages
+IMPORT_1_3(List(nub))
+
import AbsCSyn
-import AbsUniType ( kindFromType, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+import AbsCUtils ( mkAbsCStmts )
+import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
+ opt_OmitBlackHoling
+ )
+import HeapOffs ( maxOff,
+ SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset),
+ HeapOffset
)
-import CgBindery
-import CgUsages ( getSpBRelOffset )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getIdUniType, ConTag(..), DataCon(..) )
-import IdEnv -- ops on CgBindings use these
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Pretty -- debugging only?
-import PrimKind ( getKindSize, retKindSize )
-import UniqSet -- ( elementOfUniqSet, UniqSet(..) )
-import CostCentre -- profiling stuff
-import StgSyn ( PlainStgAtom(..), PlainStgLiveVars(..) )
-import Unique ( UniqueSupply )
-import Util
+import CLabel ( CLabel )
+import Id ( idType,
+ nullIdEnv, mkIdEnv, addOneToIdEnv,
+ modifyIdEnv, lookupIdEnv, rngIdEnv, SYN_IE(IdEnv),
+ SYN_IE(ConTag), GenId{-instance Outputable-},
+ SYN_IE(Id)
+ )
+import Maybes ( maybeToBool )
+import Outputable ( PprStyle(..), Outputable(..) )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( Doc, vcat, hsep, ptext )
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import StgSyn ( SYN_IE(StgLiveVars) )
+import Type ( typePrimRep )
+import UniqSet ( elementOfUniqSet )
+import Util ( sortLt, panic, pprPanic )
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
data CompilationInfo
= MkCompInfo
- (GlobalSwitch -> Bool)
- -- use it to look up whatever we like in command-line flags
- IntSwitchChecker-- similar; for flags that have an Int assoc.
- -- with them, notably number of regs available.
FAST_STRING -- the module name
-type IntSwitchChecker = (Int -> GlobalSwitch) -> Maybe Int
-
data CgState
= MkCgState
AbstractC -- code accumulated so far
CgStksAndHeapUsage
\end{code}
-@EndOfBlockInfo@ tells what to do at the end of this block of code
-or, if the expression is a @case@, what to do at the end of each alternative.
+@EndOfBlockInfo@ tells what to do at the end of this block of code or,
+if the expression is a @case@, what to do at the end of each
+alternative.
\begin{code}
data EndOfBlockInfo
= EndOfBlockInfo
- VirtualSpAOffset -- Args SpA: trim the A stack to this point at a return;
- -- push arguments starting just above this point on
- -- a tail call.
-
- -- This is therefore the A-stk ptr as seen
- -- by a case alternative.
-
- -- Args SpA is used when we want to stub any
- -- currently-unstubbed dead A-stack (ptr) slots;
- -- we want to know what SpA in the continuation is
- -- so that we don't stub any slots which are off the
- -- top of the continuation's stack!
-
- VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
-
- -- Two main differences:
- -- 1. If Sequel isn't OnStack, then Args SpB points
- -- just below the slot in which the return address
- -- should be put. In effect, the Sequel is
- -- a pending argument. If it is OnStack, Args SpB
- -- points to the top word of the return address.
- --
- -- 2. It ain't used for stubbing because there are
- -- no ptrs on B stk.
-
+ VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
+ -- return; push arguments starting just
+ -- above this point on a tail call.
+
+ -- This is therefore the A-stk ptr as seen
+ -- by a case alternative.
+
+ -- Args SpA is used when we want to stub any
+ -- currently-unstubbed dead A-stack (ptr)
+ -- slots; we want to know what SpA in the
+ -- continuation is so that we don't stub any
+ -- slots which are off the top of the
+ -- continuation's stack!
+
+ VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
+ -- Two main differences:
+ -- 1. If Sequel isn't OnStack, then Args SpB points
+ -- just below the slot in which the return address
+ -- should be put. In effect, the Sequel
+ -- is a pending argument. If it is
+ -- OnStack, Args SpB
+ -- points to the top word of the return
+ -- address.
+ --
+ -- 2. It ain't used for stubbing because there are
+ -- no ptrs on B stk.
Sequel
-
initEobInfo = EndOfBlockInfo 0 0 InRetReg
-
-
\end{code}
Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
\begin{code}
data Sequel
- = InRetReg -- The continuation is in RetReg
-
- | OnStack VirtualSpBOffset
- -- Continuation is on the stack, at the
- -- specified location
+ = InRetReg -- The continuation is in RetReg
+ | OnStack VirtualSpBOffset
+ -- Continuation is on the stack, at the
+ -- specified location
---UNUSED: | RestoreCostCentre
+ | UpdateCode CAddrMode -- May be standard update code, or might be
+ -- the data-type-specific one.
- | UpdateCode CAddrMode -- May be standard update code, or might be
- -- the data-type-specific one.
-
- | CaseAlts
- CAddrMode -- Jump to this; if the continuation is for a vectored
- -- case this might be the label of a return vector
- -- Guaranteed to be a non-volatile addressing mode (I think)
-
- SemiTaggingStuff
+ | CaseAlts
+ CAddrMode -- Jump to this; if the continuation is for a vectored
+ -- case this might be the label of a return
+ -- vector Guaranteed to be a non-volatile
+ -- addressing mode (I think)
+ SemiTaggingStuff
type SemiTaggingStuff
= Maybe -- Maybe[1] we don't have any semi-tagging stuff...
)
type JoinDetails
- = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
+ = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
-- and join point label
--- The abstract C is executed only from a successful
--- semitagging venture, when a case has looked at a variable, found
--- that it's evaluated, and wants to load up the contents and go to the
--- join point.
+-- The abstract C is executed only from a successful semitagging
+-- venture, when a case has looked at a variable, found that it's
+-- evaluated, and wants to load up the contents and go to the join
+-- point.
-- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only valid
--- just before the final control transfer, because it assumes that
--- SpB is pointing to the top word of the return address.
--- This seems unclean but there you go.
+-- The OnStack case of sequelToAmode delivers an Amode which is only
+-- valid just before the final control transfer, because it assumes
+-- that SpB is pointing to the top word of the return address. This
+-- seems unclean but there you go.
sequelToAmode :: Sequel -> FCode CAddrMode
sequelToAmode (OnStack virt_spb_offset)
= getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
- returnFC (CVal spb_rel RetKind)
+ returnFC (CVal spb_rel RetRep)
sequelToAmode InRetReg = returnFC (CReg RetReg)
---UNUSED:sequelToAmode RestoreCostCentre = returnFC mkRestoreCostCentreLbl
--Andy/Simon's patch:
--WAS: sequelToAmode (UpdateCode amode) = returnFC amode
sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
sequelToAmode (CaseAlts amode _) = returnFC amode
-
--- ToDo: move/do something
---UNUSED:mkRestoreCostCentreLbl = panic "mkRestoreCostCentreLbl"
\end{code}
See the NOTES about the details of stack/heap usage tracking.
stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
(MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
= MkCgState abs_c
- bs
+ bs
((vA,fA,rA,hA1 `max` hA2),
(vB,fB,rB,hB1 `max` hB2),
(vH1 `maxOff` vH2, rH1))
type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
type Code = CgInfoDownwards -> CgState -> CgState
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenC #-}
{-# INLINE thenFC #-}
{-# INLINE returnFC #-}
-#endif
\end{code}
The Abstract~C is not in the environment so as to improve strictness.
-- thenC :: Code -> Code -> Code
-- thenC :: Code -> FCode a -> FCode a
-(m `thenC` k) info_down state
+thenC m k info_down state
= k info_down new_state
where
new_state = m info_down state
-- thenFC :: FCode a -> (a -> FCode b) -> FCode b
-- thenFC :: FCode a -> (a -> Code) -> Code
-(m `thenFC` k) info_down state
+thenFC m k info_down state
= k m_result info_down new_state
where
(m_result, new_state) = m info_down state
\begin{code}
forkClosureBody :: Code -> Code
-forkClosureBody code
- (MkCgInfoDown cg_info statics _)
+forkClosureBody code
+ (MkCgInfoDown cg_info statics _)
(MkCgState absC_in binds un_usage)
= MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
where
forkAbsC code info_down (MkCgState absC1 bs usage)
= (absC2, new_state)
where
- MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
+ MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
code info_down (MkCgState AbsCNop bs usage)
((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
C1 a b -> e1
z -> e2
-Here we in effect expand to
+Here we in effect expand to
- case f x of
+ case f x of
C1 a b -> e1
C2 c -> let z = C2 c in JUMP(default)
C3 d e f -> let z = C2 d e f in JUMP(default)
-
+
default: e2
The stuff for C2 and C3 are the extra branches. They are
-> FCode Sequel -- Semi-tagging info to store
-> FCode EndOfBlockInfo -- The new end of block info
-forkEval body_eob_info env_code body_code
+forkEval body_eob_info env_code body_code
= forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
returnFC (EndOfBlockInfo vA vB sequel)
-forkEvalHelp :: EndOfBlockInfo -- For the body
+forkEvalHelp :: EndOfBlockInfo -- For the body
-> Code -- Code to set environment
-> FCode a -- The code to do after the eval
-> FCode (Int, -- SpA
Int, -- SpB
a) -- Result of the FCode
-forkEvalHelp body_eob_info env_code body_code
+forkEvalHelp body_eob_info env_code body_code
info_down@(MkCgInfoDown cg_info statics _) state
= ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
where
state_for_body = MkCgState AbsCNop
(nukeVolatileBinds binds)
- ((vA,stubbed_fA,vA,vA), -- Set real and hwms
+ ((vA,stubbed_fA,vA,vA), -- Set real and hwms
(vB,fB,vB,vB), -- to virtual ones
(initVirtHp, initRealHp))
stateIncUsageEval :: CgState -> CgState -> CgState
stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
(MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
- = MkCgState (absC1 `AbsCStmts` absC2)
+ = MkCgState (absC1 `AbsCStmts` absC2)
-- The AbsC coming back should consist only of nested declarations,
-- notably of the return vector!
- bs
+ bs
((vA,fA,rA,hA1 `max` hA2),
(vB,fB,rB,hB1 `max` hB2),
heap_usage)
nothing.
\begin{code}
-isSwitchSetC :: GlobalSwitch -> FCode Bool
-
-isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr switch, state)
-
-isStringSwitchSetC :: (String -> GlobalSwitch) -> FCode Bool
-
-isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr (switch (panic "isStringSwitchSetC")), state)
-
-getIntSwitchChkrC :: FCode IntSwitchChecker
-
-getIntSwitchChkrC (MkCgInfoDown (MkCompInfo _ isw_chkr _) _ _) state
- = (isw_chkr, state)
-
costCentresC :: FAST_STRING -> [CAddrMode] -> Code
-costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
- state@(MkCgState absC binds usage)
- = if sw_chkr SccProfilingOn
+costCentresC macro args _ state@(MkCgState absC binds usage)
+ = if opt_SccProfilingOn
then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
else state
profCtrC :: FAST_STRING -> [CAddrMode] -> Code
-profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
- state@(MkCgState absC binds usage)
- = if not (sw_chkr DoTickyProfiling)
+profCtrC macro args _ state@(MkCgState absC binds usage)
+ = if not opt_DoTickyProfiling
then state
else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
-{- 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 as possible.
- 'ForConcurrent' is somewhat special anyway, as it changes entry conventions
- pretty significantly.
--}
-
--- if compiling for concurrency...
-
-{- UNUSED, as it happens:
-concurrentC :: AbstractC -> Code
-
-concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
- state@(MkCgState absC binds usage)
- = if not (sw_chkr ForConcurrent)
- then state
- else MkCgState (mkAbsCStmts absC more_absC) binds usage
+{- 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
+ as possible. 'ForConcurrent' is somewhat special anyway, as it
+ changes entry conventions pretty significantly.
-}
\end{code}
\begin{code}
noBlackHolingFlag, costCentresFlag :: FCode Bool
-noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr OmitBlackHoling, state)
-
-costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr SccProfilingOn, state)
+noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
+costCentresFlag _ state = (opt_SccProfilingOn, state)
\end{code}
\begin{code}
moduleName :: FCode FAST_STRING
-moduleName (MkCgInfoDown (MkCompInfo _ _ mod_name) _ _) state
+moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
= (mod_name, state)
\end{code}
on the end of each function name).
A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
-The name should not already be bound.
+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)
\begin{code}
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
- = MkCgState absC (modifyIdEnv binds mangle_fn name) usage
+ = MkCgState absC (modifyIdEnv mangle_fn binds name) usage
\end{code}
Lookup is expected to find a binding for the @Id@.
\begin{code}
lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
+lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
state@(MkCgState absC local_binds usage)
= (val, state)
where
Just this -> this
Nothing
-> pprPanic "lookupBindC:no info!\n"
- (ppAboves [
- ppCat [ppStr "for:", ppr PprShowAll name],
- ppStr "(probably: data dependencies broken by an optimisation pass)",
- ppStr "static binds for:",
- ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
- ppStr "local binds for:",
- ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
+ (vcat [
+ hsep [ptext SLIT("for:"), ppr PprShowAll name],
+ ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
+ ptext SLIT("static binds for:"),
+ vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
+ ptext SLIT("local binds for:"),
+ vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
])
\end{code}
-For dumping debug information, we also have the ability to grab the
-local bindings environment.
-
-ToDo: Maybe do the pretty-printing here to restrict what people do
-with the environment.
-
-\begin{code}
-{- UNUSED:
-grabBindsC :: FCode CgBindings
-grabBindsC info_down state@(MkCgState absC binds usage)
- = (binds, state)
--}
-\end{code}
-
-\begin{code}
-{- UNUSED:
-grabStackSizeC :: FCode (Int, Int)
-grabStackSizeC info_down state -- @(MkCgState absC binds ((vA,_,_,_), (vB,_,_,_), _))
- = panic "grabStackSizeC" -- (vA, vB)
--}
-\end{code}
-
%************************************************************************
%* *
\subsection[CgStackery-deadslots]{Finding dead stack slots}
Probably *naughty* to look inside monad...
\begin{code}
-nukeDeadBindings :: PlainStgLiveVars -- All the *live* variables
+nukeDeadBindings :: StgLiveVars -- All the *live* variables
-> Code
nukeDeadBindings
live_vars
heap_usage)
(dead_a_slots, dead_b_slots, bs')
- = dead_slots live_vars
- [] [] []
+ = dead_slots live_vars
+ [] [] []
[ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
- --OLD: (getIdEnvMapping binds)
extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
extra_free_b = sortLt (<) dead_b_slots
Several boring auxiliary functions to do the dirty work.
\begin{code}
-dead_slots :: PlainStgLiveVars
+dead_slots :: StgLiveVars
-> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
-> [(Id,CgIdInfo)]
-> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
_ -> dead_slots live_vars fbs das dbs bs
where
size :: Int
- size = (getKindSize . kindFromType . getIdUniType) v
+ size = (getPrimRepSize . typePrimRep . idType) v
-- addFreeSlots expects *both* args to be in increasing order
addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
projects / ghc-hetmet.git / blobdiff