%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgMonad]{The code generation monad}
monadic stuff fits into the Big Picture.
\begin{code}
-#include "HsVersions.h"
-
module CgMonad (
- Code(..), -- type
- FCode(..), -- type
+ Code, -- type
+ FCode, -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, absC, nopC, getAbsC,
forkClosureBody, forkStatics, forkAlts, forkEval,
forkEvalHelp, forkAbsC,
- SemiTaggingStuff(..),
+ SemiTaggingStuff,
addBindC, addBindsC, modifyBindC, lookupBindC,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- AStackUsage(..), BStackUsage(..), HeapUsage(..),
+ AStackUsage, BStackUsage, HeapUsage,
StubFlag,
isStubbed,
-- addFreeASlots, -- no need to export it
addFreeBSlots, -- ToDo: Belong elsewhere
- isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC,
-
noBlackHolingFlag,
profCtrC,
sequelToAmode,
-- out of general friendliness, we also export ...
- CgBindings(..),
CgInfoDownwards(..), CgState(..), -- non-abstract
- CgIdInfo, -- abstract
- CompilationInfo(..), IntSwitchChecker(..),
+ CompilationInfo(..)
+ ) where
- stableAmodeIdInfo, heapIdInfo
+#include "HsVersions.h"
- -- and to make the interface self-sufficient...
- ) where
+import List ( nub )
+
+import {-# SOURCE #-} CgBindery ( CgIdInfo(..), CgBindings, maybeAStkLoc, maybeBStkLoc, nukeVolatileBinds )
+import {-# SOURCE #-} CgUsages
import AbsCSyn
-import Type ( primRepFromType, Type
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+import AbsCUtils ( mkAbsCStmts )
+import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
+ opt_OmitBlackHoling
+ )
+import HeapOffs ( maxOff,
+ VirtualSpAOffset, VirtualSpBOffset,
+ HeapOffset
)
-import CgBindery
-import CgUsages ( getSpBRelOffset )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( idType, ConTag(..), DataCon(..) )
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Pretty -- debugging only?
-import PrimRep ( getPrimRepSize, retPrimRepSize )
-import UniqSet -- ( elementOfUniqSet, UniqSet(..) )
-import CostCentre -- profiling stuff
-import StgSyn ( StgArg(..), StgLiveVars(..) )
-import Util
+import CLabel ( CLabel )
+import Id ( idType,
+ nullIdEnv, mkIdEnv, addOneToIdEnv,
+ modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv,
+ ConTag, GenId{-instance Outputable-},
+ Id
+ )
+import Literal ( Literal )
+import Maybes ( maybeToBool )
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import StgSyn ( StgLiveVars )
+import Type ( typePrimRep )
+import UniqSet ( elementOfUniqSet )
+import Util ( sortLt )
+import Outputable
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
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
- | UpdateCode CAddrMode -- May be standard update code, or might be
- -- the data-type-specific one.
+ | OnStack VirtualSpBOffset
+ -- Continuation is on the stack, at the
+ -- specified location
- | 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)
+ | UpdateCode CAddrMode -- May be standard update code, or might be
+ -- the data-type-specific one.
- 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,
-- 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
-- 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}
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
\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@.
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 name],
+ ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
+ ptext SLIT("static binds for:"),
+ vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
+ ptext SLIT("local binds for:"),
+ vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
])
\end{code}
%************************************************************************
%* *
-\subsection[CgStackery-deadslots]{Finding dead stack slots}
+\subsection[CgMonad-deadslots]{Finding dead stack slots}
%* *
%************************************************************************
_ -> dead_slots live_vars fbs das dbs bs
where
size :: Int
- size = (getPrimRepSize . primRepFromType . idType) v
+ size = (getPrimRepSize . typePrimRep . idType) v
-- addFreeSlots expects *both* args to be in increasing order
addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]