#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg))
#define ASSERTM(e) ASSERT(e) do
#else
-#define ASSERT(e)
-#define ASSERT2(e,msg)
+#define ASSERT(e) if False then error "ASSERT" else
+#define ASSERT2(e,msg) if False then error "ASSERT2" else
#define ASSERTM(e)
-#define WARN(e,msg)
+#define WARN(e,msg) if False then error "WARN" else
#endif
-- temporary usage assertion control KSW 2000-10
ALL_DIRS = \
utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
- specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
- profiling parser cprAnalysis compMan ndpFlatten cbits iface
+ specialise simplCore stranal stgSyn simplStg codeGen main \
+ profiling parser cprAnalysis compMan ndpFlatten cbits iface cmm
# Make sure we include Config.hs even if it doesn't exist yet...
ALL_SRCS += $(CONFIG_HS)
main/SysTools_HC_OPTS += '-\#include <windows.h>' '-\#include <process.h>'
endif
-# Required due to use of Concurrent.myThreadId
-utils/Panic_HC_OPTS += -fvia-C
-
parser/Lexer_HC_OPTS += -funbox-strict-fields
# ghc_strlen percolates through so many modules that it is easier to get its
# typecheck/TcTyDecls_HC_OPTS += -auto-all
# typecheck/TcType_HC_OPTS += -auto-all
# typecheck/TcUnify_HC_OPTS += -auto-all
-#
-# absCSyn/PprAbsC_HC_OPTS += -auto-all
coreSyn/CorePrep_HC_OPTS += -auto-all
-* Can a scoped type variable denote a type scheme?
+ New back end thoughts
+-----------------------------------------------------------------------------
+Codegen notes
+
+* jumps to ImpossibleBranch should be removed.
+
+* Profiling:
+ - when updating a closure with an indirection to a function,
+ we should make a permanent indirection.
+
+ - check that we're bumping the scc count appropriately
+
+* check perf & binary sizes against the HEAD
+
+-----------------------------------------------------------------------------
+C backend notes
+
+* use STGCALL macros for foreign calls (doesn't look like volatile regs
+ are handled properly at the mo).
+
+-----------------------------------------------------------------------------
+Cmm parser notes
+
+* switches
+
+* need to cater for unexported procedures/info tables?
+
+* We should be able to get rid of entry labels, use info labels only.
+ - we need a %ENTRY_LBL(info_lbl) macro, so that instead of
+ JMP_(foo_entry) we can write jump %ENTRY_LBL(foo_info).
+
+-----------------------------------------------------------------------------
+
+* Move arg-descr from LFInfo to ClosureInfo?
+ But: only needed for functions
+
+* Move all of CgClosure.link_caf into NewCaf, and newDynCaf
+
+* If the case binder is dead, and the constr is nullary,
+ do we need to assign to Node?
+
+
+-------------------------
* Relation between separate type sigs and pattern type sigs
f :: forall a. a->a
f :: b->b = e -- No: monomorphic
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-% $Id: AbsCSyn.lhs,v 1.56 2003/11/17 14:47:53 simonmar Exp $
-%
-\section[AbstractC]{Abstract C: the last stop before machine code}
-
-This ``Abstract C'' data type describes the raw Spineless Tagless
-machine model at a C-ish level; it is ``abstract'' in that it only
-includes C-like structures that we happen to need. The conversion of
-programs from @StgSyntax@ (basically a functional language) to
-@AbstractC@ (basically imperative C) is the heart of code generation.
-From @AbstractC@, one may convert to real C (for portability) or to
-raw assembler/machine code.
-
-\begin{code}
-module AbsCSyn where -- export everything
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} ClosureInfo ( ClosureInfo )
-
-import CLabel
-import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
- mAX_Double_REG, spRelToInt )
-import CostCentre ( CostCentre, CostCentreStack )
-import Literal ( mkMachInt, Literal(..) )
-import ForeignCall ( CCallSpec )
-import PrimRep ( PrimRep(..) )
-import MachOp ( MachOp(..) )
-import Unique ( Unique )
-import StgSyn ( StgOp )
-import TyCon ( TyCon )
-import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE )
-import SMRep ( StgWord, StgHalfWord )
-import FastTypes
-import FastString
-\end{code}
-
-@AbstractC@ is a list of Abstract~C statements, but the data structure
-is tree-ish, for easier and more efficient putting-together.
-\begin{code}
-data AbstractC
- = AbsCNop
- | AbsCStmts AbstractC AbstractC
-
- -- and the individual stmts...
-\end{code}
-
-A note on @CAssign@: In general, the type associated with an assignment
-is the type of the lhs. However, when the lhs is a pointer to mixed
-types (e.g. SpB relative), the type of the assignment is the type of
-the rhs for float types, or the generic StgWord for all other types.
-(In particular, a CharRep on the rhs is promoted to IntRep when
-stored in a mixed type location.)
-
-\begin{code}
- | CAssign
- !CAddrMode -- target
- !CAddrMode -- source
-
- | CJump
- CAddrMode -- Put this in the program counter
- -- eg `CJump (CReg (VanillaReg PtrRep 1))' puts Ret1 in PC
- -- Enter can be done by:
- -- CJump (CVal NodeRel zeroOff)
-
- | CFallThrough
- CAddrMode -- Fall through into this routine
- -- (for the benefit of the native code generators)
- -- Equivalent to CJump in C land
-
- | CReturn -- Perform a return
- CAddrMode -- Address of a RET_<blah> info table
- ReturnInfo -- Whether it's a direct or vectored return
-
- | CSwitch !CAddrMode
- [(Literal, AbstractC)] -- alternatives
- AbstractC -- default; if there is no real Abstract C in here
- -- (e.g., all comments; see function "nonemptyAbsC"),
- -- then that means the default _cannot_ occur.
- -- If there is only one alternative & no default code,
- -- then there is no need to check the tag.
- -- Therefore, e.g.:
- -- CSwitch m [(tag,code)] AbsCNop == code
-
- | CCodeBlock CLabel AbstractC
- -- A labelled block of code; this "statement" is not
- -- executed; rather, the labelled code will be hoisted
- -- out to the top level (out of line) & it can be
- -- jumped to.
-
- | CInitHdr -- to initialise the header of a closure (both fixed/var parts)
- ClosureInfo
- CAddrMode -- address of the info ptr
- !CAddrMode -- cost centre to place in closure
- -- CReg CurCostCentre or CC_HDR(R1.p{-Node-})
- Int -- size of closure, for profiling
-
- -- NEW CASES FOR EXPANDED PRIMOPS
-
- | CMachOpStmt -- Machine-level operation
- CAddrMode -- result
- MachOp
- [CAddrMode] -- Arguments
- (Maybe [MagicId]) -- list of regs which need to be preserved
- -- across the primop. This is allowed to be Nothing only if
- -- machOpIsDefinitelyInline returns True. And that in turn may
- -- only return True if we are absolutely sure that the mach op
- -- can be done inline on all platforms.
-
- | CSequential -- Do the nested AbstractCs sequentially.
- [AbstractC] -- In particular, as far as the AbsCUtils.doSimultaneously
- -- is concerned, these stmts are to be treated as atomic
- -- and are not to be reordered.
-
- -- end of NEW CASES FOR EXPANDED PRIMOPS
-
- | COpStmt
- [CAddrMode] -- Results
- StgOp
- [CAddrMode] -- Arguments
- [MagicId] -- Potentially volatile/live registers
- -- (to save/restore around the call/op)
-
- -- INVARIANT: When a PrimOp which can cause GC is used, the
- -- only live data is tidily on the STG stacks or in the STG
- -- registers (the code generator ensures this).
- --
- -- Why this? Because if the arguments were arbitrary
- -- addressing modes, they might be things like (Hp+6) which
- -- will get utterly spongled by GC.
-
- | CSimultaneous -- Perform simultaneously all the statements
- AbstractC -- in the nested AbstractC. They are only
- -- allowed to be CAssigns, COpStmts and AbsCNops, so the
- -- "simultaneous" part just concerns making
- -- sure that permutations work.
- -- For example { a := b, b := a }
- -- needs to go via (at least one) temporary
-
- | CCheck -- heap or stack checks, or both.
- CCheckMacro -- These might include some code to fill in tags
- [CAddrMode] -- on the stack, so we can't use CMacroStmt below.
- AbstractC
-
- | CRetDirect -- Direct return
- !Unique -- for making labels
- AbstractC -- return code
- C_SRT -- SRT info
- Liveness -- stack liveness at the return point
-
- -- see the notes about these next few; they follow below...
- | CMacroStmt CStmtMacro [CAddrMode]
- | CCallProfCtrMacro FastString [CAddrMode]
- | CCallProfCCMacro FastString [CAddrMode]
-
- {- The presence of this constructor is a makeshift solution;
- it being used to work around a gcc-related problem of
- handling typedefs within statement blocks (or, rather,
- the inability to do so.)
-
- The AbstractC flattener takes care of lifting out these
- typedefs if needs be (i.e., when generating .hc code and
- compiling 'foreign import dynamic's)
- -}
- | CCallTypedef Bool {- True => use "typedef"; False => use "extern"-}
- CCallSpec Unique [CAddrMode] [CAddrMode]
-
- -- *** the next three [or so...] are DATA (those above are CODE) ***
-
- | CStaticClosure
- CLabel -- The closure's label
- ClosureInfo -- Todo: maybe info_lbl & closure_lbl instead?
- CAddrMode -- cost centre identifier to place in closure
- [CAddrMode] -- free vars; ptrs, then non-ptrs.
-
- | CSRT CLabel [CLabel] -- SRT declarations: basically an array of
- -- pointers to static closures.
-
- | CBitmap Liveness -- A "large" bitmap to be emitted
-
- | CSRTDesc -- A "large" SRT descriptor (one that doesn't
- -- fit into the half-word bitmap in the itbl).
- !CLabel -- Label for this SRT descriptor
- !CLabel -- Pointer to the SRT
- !Int -- Offset within the SRT
- !Int -- Length
- !Bitmap -- Bitmap
-
- | CClosureInfoAndCode
- ClosureInfo -- Explains placement and layout of closure
- AbstractC -- Entry point code
-
- | CRetVector -- A labelled block of static data
- CLabel
- [CAddrMode]
- C_SRT -- SRT info
- Liveness -- stack liveness at the return point
-
- | CClosureTbl -- table of constructors for enumerated types
- TyCon -- which TyCon this table is for
-
- | CModuleInitBlock -- module initialisation block
- CLabel -- "plain" label for init block
- CLabel -- label for init block (with ver + way info)
- AbstractC -- initialisation code
-
- | CCostCentreDecl -- A cost centre *declaration*
- Bool -- True <=> local => full declaration
- -- False <=> extern; just say so
- CostCentre
-
- | CCostCentreStackDecl -- A cost centre stack *declaration*
- CostCentreStack -- this is the declaration for a
- -- pre-defined singleton CCS (see
- -- CostCentre.lhs)
-
- | CSplitMarker -- Split into separate object modules here
-
--- C_SRT is what StgSyn.SRT gets translated to...
--- we add a label for the table, and expect only the 'offset/length' form
-
-data C_SRT = NoC_SRT
- | C_SRT !CLabel !Int{-offset-} !StgHalfWord{-bitmap or escape-}
-
-needsSRT :: C_SRT -> Bool
-needsSRT NoC_SRT = False
-needsSRT (C_SRT _ _ _) = True
-\end{code}
-
-About @CMacroStmt@, etc.: notionally, they all just call some
-arbitrary C~macro or routine, passing the @CAddrModes@ as arguments.
-However, we distinguish between various flavours of these things,
-mostly just to keep things somewhat less wild and wooly.
-
-\begin{description}
-\item[@CMacroStmt@:]
-Some {\em essential} bits of the STG execution model are done with C
-macros. An example is @STK_CHK@, which checks for stack-space
-overflow. This enumeration type lists all such macros:
-\begin{code}
-data CStmtMacro
- = UPD_CAF -- update CAF closure with indirection
- | UPD_BH_UPDATABLE -- eager backholing
- | UPD_BH_SINGLE_ENTRY -- more eager blackholing
- | PUSH_UPD_FRAME -- push update frame
- | SET_TAG -- set TagReg if it exists
- -- dataToTag# primop -- *only* used in unregisterised builds.
- -- (see AbsCUtils.dsCOpStmt)
- | DATA_TO_TAGZH
-
- | REGISTER_FOREIGN_EXPORT -- register a foreign exported fun
- | REGISTER_IMPORT -- register an imported module
- | REGISTER_DIMPORT -- register an imported module from
- -- another DLL
-
- | GRAN_FETCH -- for GrAnSim only -- HWL
- | GRAN_RESCHEDULE -- for GrAnSim only -- HWL
- | GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL
- | THREAD_CONTEXT_SWITCH -- for GrAnSim only -- HWL
- | GRAN_YIELD -- for GrAnSim only -- HWL
-\end{code}
-
-Heap/Stack checks. There are far too many of these.
-
-\begin{code}
-data CCheckMacro
-
- = HP_CHK_NP -- heap/stack checks when
- | STK_CHK_NP -- node points to the closure
- | HP_STK_CHK_NP
-
- | HP_CHK_FUN -- heap/stack checks when
- | STK_CHK_FUN -- node doesn't point
- | HP_STK_CHK_FUN
- -- case alternative heap checks:
-
- | HP_CHK_NOREGS -- no registers live
- | HP_CHK_UNPT_R1 -- R1 is boxed/unlifted
- | HP_CHK_UNBX_R1 -- R1 is unboxed
- | HP_CHK_F1 -- FloatReg1 (only) is live
- | HP_CHK_D1 -- DblReg1 (only) is live
- | HP_CHK_L1 -- LngReg1 (only) is live
-
- | HP_CHK_UNBX_TUPLE -- unboxed tuple heap check
-\end{code}
-
-\item[@CCallProfCtrMacro@:]
-The @String@ names a macro that, if \tr{#define}d, will bump one/some
-of the STG-event profiling counters.
-
-\item[@CCallProfCCMacro@:]
-The @String@ names a macro that, if \tr{#define}d, will perform some
-cost-centre-profiling-related action.
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[CAddrMode]{C addressing modes}
-%* *
-%************************************************************************
-
-\begin{code}
-data CAddrMode
- = CVal RegRelative PrimRep
- -- On RHS of assign: Contents of Magic[n]
- -- On LHS of assign: location Magic[n]
- -- (ie at addr Magic+n)
-
- | CAddr RegRelative
- -- On RHS of assign: Address of Magic[n]; ie Magic+n
- -- n=0 gets the Magic location itself
- -- (NB: n=0 case superceded by CReg)
- -- On LHS of assign: only sensible if n=0,
- -- which gives the magic location itself
- -- (NB: superceded by CReg)
-
- -- JRS 2002-02-05: CAddr is really scummy and should be fixed.
- -- The effect is that the semantics of CAddr depend on what the
- -- contained RegRelative is; it is decidely non-orthogonal.
-
- | CReg MagicId -- To replace (CAddr MagicId 0)
-
- | CTemp !Unique !PrimRep -- Temporary locations
- -- ``Temporaries'' correspond to local variables in C, and registers in
- -- native code.
-
- | CLbl CLabel -- Labels in the runtime system, etc.
- PrimRep -- the kind is so we can generate accurate C decls
-
- | CCharLike CAddrMode -- The address of a static char-like closure for
- -- the specified character. It is guaranteed to be in
- -- the range mIN_CHARLIKE..mAX_CHARLIKE
-
- | CIntLike CAddrMode -- The address of a static int-like closure for the
- -- specified small integer. It is guaranteed to be in
- -- the range mIN_INTLIKE..mAX_INTLIKE
-
- | CLit Literal
-
- | CJoinPoint -- This is used as the amode of a let-no-escape-bound
- -- variable.
- VirtualSpOffset -- Sp value after any volatile free vars
- -- of the rhs have been saved on stack.
- -- Just before the code for the thing is jumped to,
- -- Sp will be set to this value,
- -- and then any stack-passed args pushed,
- -- then the code for this thing will be entered
- | CMacroExpr
- !PrimRep -- the kind of the result
- CExprMacro -- the macro to generate a value
- [CAddrMode] -- and its arguments
-\end{code}
-
-Various C macros for values which are dependent on the back-end layout.
-
-\begin{code}
-
-data CExprMacro
- = ENTRY_CODE
- | ARG_TAG -- stack argument tagging
- | GET_TAG -- get current constructor tag
- | CCS_HDR
- | BYTE_ARR_CTS -- used when passing a ByteArray# to a ccall
- | PTRS_ARR_CTS -- similarly for an Array#
- | ForeignObj_CLOSURE_DATA -- and again for a ForeignObj#
-\end{code}
-
-Convenience functions:
-
-\begin{code}
-mkIntCLit :: Int -> CAddrMode
-mkIntCLit i = CLit (mkMachInt (toInteger i))
-
-mkWordCLit :: StgWord -> CAddrMode
-mkWordCLit wd = CLit (MachWord (fromIntegral wd))
-
-mkCString :: FastString -> CAddrMode
-mkCString s = CLit (MachStr s)
-
-mkCCostCentre :: CostCentre -> CAddrMode
-mkCCostCentre cc = CLbl (mkCC_Label cc) DataPtrRep
-
-mkCCostCentreStack :: CostCentreStack -> CAddrMode
-mkCCostCentreStack ccs = CLbl (mkCCS_Label ccs) DataPtrRep
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[RegRelative]{@RegRelatives@: ???}
-%* *
-%************************************************************************
-
-\begin{code}
-data RegRelative
- = HpRel FastInt -- }
- | SpRel FastInt -- }- offsets in StgWords
- | NodeRel FastInt -- }
- | CIndex CAddrMode CAddrMode PrimRep -- pointer arithmetic :-)
- -- CIndex a b k === (k*)a[b]
-
-data ReturnInfo
- = DirectReturn -- Jump directly, if possible
- | StaticVectoredReturn Int -- Fixed tag, starting at zero
- | DynamicVectoredReturn CAddrMode -- Dynamic tag given by amode, starting at zero
-
-hpRel :: VirtualHeapOffset -- virtual offset of Hp
- -> VirtualHeapOffset -- virtual offset of The Thing
- -> RegRelative -- integer offset
-hpRel hp off = HpRel (iUnbox (hp - off))
-
-spRel :: VirtualSpOffset -- virtual offset of Sp
- -> VirtualSpOffset -- virtual offset of The Thing
- -> RegRelative -- integer offset
-spRel sp off = SpRel (iUnbox (spRelToInt sp off))
-
-nodeRel :: VirtualHeapOffset
- -> RegRelative
-nodeRel off = NodeRel (iUnbox off)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Liveness]{Liveness Masks}
-%* *
-%************************************************************************
-
-We represent liveness bitmaps as a BitSet (whose internal
-representation really is a bitmap). These are pinned onto case return
-vectors to indicate the state of the stack for the garbage collector.
-
-In the compiled program, liveness bitmaps that fit inside a single
-word (StgWord) are stored as a single word, while larger bitmaps are
-stored as a pointer to an array of words.
-
-\begin{code}
-data Liveness = Liveness CLabel !Int Bitmap
-
-maybeLargeBitmap :: Liveness -> AbstractC
-maybeLargeBitmap liveness@(Liveness _ size _)
- | size <= mAX_SMALL_BITMAP_SIZE = AbsCNop
- | otherwise = CBitmap liveness
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[HeapOffset]{@Heap Offsets@}
-%* *
-%************************************************************************
-
-This used to be a grotesquely complicated datatype in an attempt to
-hide the details of header sizes from the compiler itself. Now these
-constants are imported from the RTS, and we deal in real Ints.
-
-\begin{code}
-type HeapOffset = Int -- ToDo: remove
-
-type VirtualHeapOffset = HeapOffset
-type VirtualSpOffset = Int
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[MagicId]{@MagicIds@: registers and such}
-%* *
-%************************************************************************
-
-\begin{code}
-data MagicId
- = BaseReg -- mentioned only in nativeGen
-
- -- Argument and return registers
- | VanillaReg -- pointers, unboxed ints and chars
- PrimRep
- FastInt -- its number (1 .. mAX_Vanilla_REG)
-
- | FloatReg -- single-precision floating-point registers
- FastInt -- its number (1 .. mAX_Float_REG)
-
- | DoubleReg -- double-precision floating-point registers
- FastInt -- its number (1 .. mAX_Double_REG)
-
- -- STG registers
- | Sp -- Stack ptr; points to last occupied stack location.
- | SpLim -- Stack limit
- | Hp -- Heap ptr; points to last occupied heap location.
- | HpLim -- Heap limit register
- | CurCostCentre -- current cost centre register.
- | VoidReg -- see "VoidPrim" type; just a placeholder;
- -- no actual register
- | LongReg -- long int registers (64-bit, really)
- PrimRep -- Int64Rep or Word64Rep
- FastInt -- its number (1 .. mAX_Long_REG)
-
- | CurrentTSO -- pointer to current thread's TSO
- | CurrentNursery -- pointer to allocation area
- | HpAlloc -- allocation count for heap check failure
-
-
-node = VanillaReg PtrRep (_ILIT 1) -- A convenient alias for Node
-tagreg = VanillaReg WordRep (_ILIT 2) -- A convenient alias for TagReg
-
-nodeReg = CReg node
-\end{code}
-
-We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
-
-\begin{code}
-instance Eq MagicId where
- reg1 == reg2 = tag reg1 ==# tag reg2
- where
- tag BaseReg = (_ILIT(0) :: FastInt)
- tag Sp = _ILIT(1)
- tag SpLim = _ILIT(3)
- tag Hp = _ILIT(4)
- tag HpLim = _ILIT(5)
- tag CurCostCentre = _ILIT(6)
- tag VoidReg = _ILIT(7)
-
- tag (VanillaReg _ i) = _ILIT(8) +# i
-
- tag (FloatReg i) = _ILIT(8) +# maxv +# i
- tag (DoubleReg i) = _ILIT(8) +# maxv +# maxf +# i
- tag (LongReg _ i) = _ILIT(8) +# maxv +# maxf +# maxd +# i
-
- maxv = iUnbox mAX_Vanilla_REG
- maxf = iUnbox mAX_Float_REG
- maxd = iUnbox mAX_Double_REG
-\end{code}
-
-Returns True for any register that {\em potentially} dies across
-C calls (or anything near equivalent). We just say @True@ and
-let the (machine-specific) registering macros sort things out...
-
-\begin{code}
-isVolatileReg :: MagicId -> Bool
-isVolatileReg any = True
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section[AbsCUtils]{Help functions for Abstract~C datatype}
-
-\begin{code}
-module AbsCUtils (
- nonemptyAbsC,
- mkAbstractCs, mkAbsCStmts,
- mkAlgAltsCSwitch,
- magicIdPrimRep,
- getAmodeRep,
- mixedTypeLocn, mixedPtrLocn,
- flattenAbsC,
- mkAbsCStmtList,
- shimFCallArg
- -- printing/forcing stuff comes from PprAbsC
- ) where
-
-#include "HsVersions.h"
-#include "../includes/config.h"
-
-import AbsCSyn
-import Type ( tyConAppTyCon, repType )
-import TysPrim ( foreignObjPrimTyCon, arrayPrimTyCon,
- byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
- mutableArrayPrimTyCon )
-import CLabel ( mkMAP_FROZEN_infoLabel )
-import Digraph ( stronglyConnComp, SCC(..) )
-import DataCon ( fIRST_TAG, dataConTag )
-import Literal ( literalPrimRep, mkMachWord, mkMachInt )
-import PrimRep ( getPrimRepSize, PrimRep(..) )
-import PrimOp ( PrimOp(..) )
-import MachOp ( MachOp(..), isDefinitelyInlineMachOp )
-import Unique ( Unique{-instance Eq-} )
-import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
- UniqSupply )
-import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised )
-import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
-import StgSyn ( StgOp(..), stgArgType )
-import CoreSyn ( AltCon(..) )
-import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
-import Outputable
-import Panic ( panic )
-import FastTypes
-import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS )
-
-infixr 9 `thenFlt`
-\end{code}
-
-Check if there is any real code in some Abstract~C. If so, return it
-(@Just ...@); otherwise, return @Nothing@. Don't be too strict!
-
-It returns the "reduced" code in the Just part so that the work of
-discarding AbsCNops isn't lost, and so that if the caller uses
-the reduced version there's less danger of a big tree of AbsCNops getting
-materialised and causing a space leak.
-
-\begin{code}
-nonemptyAbsC :: AbstractC -> Maybe AbstractC
-nonemptyAbsC AbsCNop = Nothing
-nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
- Nothing -> nonemptyAbsC s2
- Just x -> Just (AbsCStmts x s2)
-nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
- Nothing -> Nothing
- Just x -> Just s
-nonemptyAbsC other = Just other
-\end{code}
-
-\begin{code}
-mkAbstractCs :: [AbstractC] -> AbstractC
-mkAbstractCs [] = AbsCNop
-mkAbstractCs cs = foldr1 mkAbsCStmts cs
-
--- for fiddling around w/ killing off AbsCNops ... (ToDo)
-mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
-mkAbsCStmts AbsCNop c = c
-mkAbsCStmts c AbsCNop = c
-mkAbsCStmts c1 c2 = c1 `AbsCStmts` c2
-
-{- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
- = case (case (nonemptyAbsC abc2) of
- Nothing -> AbsCNop
- Just d2 -> d2) of { abc2b ->
-
- case (nonemptyAbsC abc1) of {
- Nothing -> abc2b;
- Just d1 -> AbsCStmts d1 abc2b
- } }
--}
-\end{code}
-
-Get the sho' 'nuff statements out of an @AbstractC@.
-\begin{code}
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-
-mkAbsCStmtList absC = mkAbsCStmtList' absC []
-
--- Optimised a la foldr/build!
-
-mkAbsCStmtList' AbsCNop r = r
-
-mkAbsCStmtList' (AbsCStmts s1 s2) r
- = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
-
-mkAbsCStmtList' s@(CSimultaneous c) r
- = if null (mkAbsCStmtList c) then r else s : r
-
-mkAbsCStmtList' other r = other : r
-\end{code}
-
-\begin{code}
-mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC
-
-mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts)
- = CSwitch scrutinee (adjust rest_alts) first_alt
- where
- -- We use the first alt as the default. Either it *is* the DEFAULT,
- -- (which is always first if present), or the case is exhaustive,
- -- in which case we can use the first as the default anyway
-
- -- Adjust the tags in the switch to start at zero.
- -- This is the convention used by primitive ops which return algebraic
- -- data types. Why? Because for two-constructor types, zero is faster
- -- to create and distinguish from 1 than are 1 and 2.
-
- -- We also need to convert to Literals to keep the CSwitch happy
- adjust tagged_alts
- = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c)
- | (DataAlt dc, abs_c) <- tagged_alts ]
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
-%* *
-%************************************************************************
-
-\begin{code}
-magicIdPrimRep BaseReg = PtrRep
-magicIdPrimRep (VanillaReg kind _) = kind
-magicIdPrimRep (FloatReg _) = FloatRep
-magicIdPrimRep (DoubleReg _) = DoubleRep
-magicIdPrimRep (LongReg kind _) = kind
-magicIdPrimRep Sp = PtrRep
-magicIdPrimRep SpLim = PtrRep
-magicIdPrimRep Hp = PtrRep
-magicIdPrimRep HpLim = PtrRep
-magicIdPrimRep CurCostCentre = CostCentreRep
-magicIdPrimRep VoidReg = VoidRep
-magicIdPrimRep CurrentTSO = PtrRep
-magicIdPrimRep CurrentNursery = PtrRep
-magicIdPrimRep HpAlloc = WordRep
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
-%* *
-%************************************************************************
-
-See also the return conventions for unboxed things; currently living
-in @CgCon@ (next to the constructor return conventions).
-
-ToDo: tiny tweaking may be in order
-\begin{code}
-getAmodeRep :: CAddrMode -> PrimRep
-
-getAmodeRep (CVal _ kind) = kind
-getAmodeRep (CAddr _) = PtrRep
-getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
-getAmodeRep (CTemp uniq kind) = kind
-getAmodeRep (CLbl _ kind) = kind
-getAmodeRep (CCharLike _) = PtrRep
-getAmodeRep (CIntLike _) = PtrRep
-getAmodeRep (CLit lit) = literalPrimRep lit
-getAmodeRep (CMacroExpr kind _ _) = kind
-getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
-\end{code}
-
-@mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
-location; that is, one which can contain values of various types.
-
-\begin{code}
-mixedTypeLocn :: CAddrMode -> Bool
-
-mixedTypeLocn (CVal (NodeRel _) _) = True
-mixedTypeLocn (CVal (SpRel _) _) = True
-mixedTypeLocn (CVal (HpRel _) _) = True
-mixedTypeLocn other = False -- All the rest
-\end{code}
-
-@mixedPtrLocn@ tells whether an amode identifies a
-location which can contain values of various pointer types.
-
-\begin{code}
-mixedPtrLocn :: CAddrMode -> Bool
-
-mixedPtrLocn (CVal (SpRel _) _) = True
-mixedPtrLocn other = False -- All the rest
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsCUtils-flattening]{Flatten Abstract~C}
-%* *
-%************************************************************************
-
-The following bits take ``raw'' Abstract~C, which may have all sorts of
-nesting, and flattens it into one long @AbsCStmtList@. Mainly,
-@CClosureInfos@ and code for switches are pulled out to the top level.
-
-The various functions herein tend to produce
-\begin{enumerate}
-\item
-A {\em flattened} \tr{<something>} of interest for ``here'', and
-\item
-Some {\em unflattened} Abstract~C statements to be carried up to the
-top-level. The only real reason (now) that it is unflattened is
-because it means the recursive flattening can be done in just one
-place rather than having to remember lots of places.
-\end{enumerate}
-
-Care is taken to reduce the occurrence of forward references, while still
-keeping laziness a much as possible. Essentially, this means that:
-\begin{itemize}
-\item
-{\em All} the top-level C statements resulting from flattening a
-particular AbsC statement (whether the latter is nested or not) appear
-before {\em any} of the code for a subsequent AbsC statement;
-\item
-but stuff nested within any AbsC statement comes
-out before the code for the statement itself.
-\end{itemize}
-
-The ``stuff to be carried up'' always includes a label: a
-@CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
-@CCodeBlock@. The latter turns into a C function, and is never
-actually produced by the code generator. Rather it always starts life
-as a @CCodeBlock@ addressing mode; when such an addr mode is
-flattened, the ``tops'' stuff is a @CCodeBlock@.
-
-\begin{code}
-flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
-
-flattenAbsC us abs_C
- = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
- here `mkAbsCStmts` tops }
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Flattening monadery}
-%* *
-%************************************************************************
-
-The flattener is monadised. It's just a @UniqueSupply@.
-
-\begin{code}
-type FlatM result = UniqSupply -> result
-
-initFlt :: UniqSupply -> FlatM a -> a
-
-initFlt init_us m = m init_us
-
-{-# INLINE thenFlt #-}
-{-# INLINE returnFlt #-}
-
-thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
-
-thenFlt expr cont us
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (expr s1) of { result ->
- cont result s2 }}
-
-returnFlt :: a -> FlatM a
-returnFlt result us = result
-
-mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
-
-mapFlt f [] = returnFlt []
-mapFlt f (x:xs)
- = f x `thenFlt` \ r ->
- mapFlt f xs `thenFlt` \ rs ->
- returnFlt (r:rs)
-
-mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
-
-mapAndUnzipFlt f [] = returnFlt ([],[])
-mapAndUnzipFlt f (x:xs)
- = f x `thenFlt` \ (r1, r2) ->
- mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
- returnFlt (r1:rs1, r2:rs2)
-
-getUniqFlt :: FlatM Unique
-getUniqFlt us = uniqFromSupply us
-
-getUniqsFlt :: FlatM [Unique]
-getUniqsFlt us = uniqsFromSupply us
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Flattening the top level}
-%* *
-%************************************************************************
-
-\begin{code}
-flatAbsC :: AbstractC
- -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
- AbstractC) -- Stuff to put at top level flattened]
-
-flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
-
-flatAbsC (AbsCStmts s1 s2)
- = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
- flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
- returnFlt (mkAbsCStmts inline_s1 inline_s2,
- mkAbsCStmts top_s1 top_s2)
-
-flatAbsC (CClosureInfoAndCode cl_info entry)
- = flatAbsC entry `thenFlt` \ (entry_heres, entry_tops) ->
- returnFlt (AbsCNop, mkAbstractCs [entry_tops,
- CClosureInfoAndCode cl_info entry_heres]
- )
-
-flatAbsC (CCodeBlock lbl abs_C)
- = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
- returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
-
-flatAbsC (CRetDirect uniq slow_code srt liveness)
- = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
- returnFlt (AbsCNop,
- mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
-
-flatAbsC (CSwitch discrim alts deflt)
- = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
- flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
- returnFlt (
- CSwitch discrim flat_alts flat_def_alt,
- mkAbstractCs (def_tops : flat_alts_tops)
- )
- where
- flat_alt (tag, absC)
- = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
- returnFlt ( (tag, alt_heres), alt_tops )
-
-flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
- | is_dynamic -- Emit a typedef if its a dynamic call
- || (opt_EmitCExternDecls) -- or we want extern decls
- = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
- where
- is_dynamic = isDynamicTarget target
-
-flatAbsC stmt@(CSimultaneous abs_c)
- = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
- doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
- returnFlt (new_stmts_here, tops)
-
-flatAbsC stmt@(CCheck macro amodes code)
- = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
- returnFlt (CCheck macro amodes code_here, code_tops)
-
--- the TICKY_CTR macro always needs to be hoisted out to the top level.
--- This is a HACK.
-flatAbsC stmt@(CCallProfCtrMacro str amodes)
- | str == FSLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
- | otherwise = returnFlt (stmt, AbsCNop)
-
--- Some statements need no flattening at all:
-flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CInitHdr a b cc sz) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CMachOpStmt res mop args m_vols) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
- = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
- = dscCOpStmt (filter non_void_amode results) op
- (filter non_void_amode args) vol_regs
- `thenFlt` \ simpl ->
- case simpl of
- COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt" -- make sure we don't loop!
- other -> flatAbsC other
- {-
- A gruesome hack for printing the names of inline primops when they
- are used.
- oink other
- where
- oink xxx
- = getUniqFlt `thenFlt` \ uu ->
- flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
-
- moo uu op_str
- = COpStmt
- []
- (StgFCallOp
- (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str)))
- defaultCCallConv (PlaySafe False)))
- uu
- )
- [CReg VoidReg]
- []
- mktxt op_str
- = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
- -}
-
-flatAbsC (CSequential abcs)
- = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
- returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
-
-
--- Some statements only make sense at the top level, so we always float
--- them. This probably isn't necessary.
-flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CSRTDesc _ _ _ _ _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CBitmap _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[flat-simultaneous]{Doing things simultaneously}
-%* *
-%************************************************************************
-
-\begin{code}
-doSimultaneously :: AbstractC -> FlatM AbstractC
-\end{code}
-
-Generate code to perform the @CAssign@s and @COpStmt@s in the
-input simultaneously, using temporary variables when necessary.
-
-We use the strongly-connected component algorithm, in which
- * the vertices are the statements
- * an edge goes from s1 to s2 iff
- s1 assigns to something s2 uses
- that is, if s1 should *follow* s2 in the final order
-
-\begin{code}
-type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
- -- for fast comparison
-
-doSimultaneously abs_c
- = let
- enlisted = en_list abs_c
- in
- case enlisted of -- it's often just one stmt
- [] -> returnFlt AbsCNop
- [x] -> returnFlt x
- _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
-
--- en_list puts all the assignments in a list, filtering out Nops and
--- assignments which do nothing
-en_list AbsCNop = []
-en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
-en_list (CAssign am1 am2) | sameAmode am1 am2 = []
-en_list other = [other]
-
-sameAmode :: CAddrMode -> CAddrMode -> Bool
--- ToDo: Move this function, or make CAddrMode an instance of Eq
--- At the moment we put in just enough to catch the cases we want:
--- the second (destination) argument is always a CVal.
-sameAmode (CReg r1) (CReg r2) = r1 == r2
-sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2
-sameAmode other1 other2 = False
-
-doSimultaneously1 :: [CVertex] -> FlatM AbstractC
-doSimultaneously1 vertices
- = let
- edges = [ (vertex, key1, edges_from stmt1)
- | vertex@(key1, stmt1) <- vertices
- ]
- edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
- stmt1 `should_follow` stmt2
- ]
- components = stronglyConnComp edges
-
- -- do_components deal with one strongly-connected component
- -- Not cyclic, or singleton? Just do it
- do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
- do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
-
- -- Cyclic? Then go via temporaries. Pick one to
- -- break the loop and try again with the rest.
- do_component (CyclicSCC ((n,first_stmt) : rest))
- = doSimultaneously1 rest `thenFlt` \ abs_cs ->
- go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
- returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
-
- go_via_temps (CAssign dest src)
- = getUniqFlt `thenFlt` \ uniq ->
- let
- the_temp = CTemp uniq (getAmodeRep dest)
- in
- returnFlt (CAssign the_temp src, CAssign dest the_temp)
-
- go_via_temps (COpStmt dests op srcs vol_regs)
- = getUniqsFlt `thenFlt` \ uniqs ->
- let
- the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
- in
- returnFlt (COpStmt the_temps op srcs vol_regs,
- mkAbstractCs (zipWith CAssign dests the_temps))
- in
- mapFlt do_component components `thenFlt` \ abs_cs ->
- returnFlt (mkAbstractCs abs_cs)
-
- where
- should_follow :: AbstractC -> AbstractC -> Bool
- (CAssign dest1 _) `should_follow` (CAssign _ src2)
- = dest1 `conflictsWith` src2
- (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
- = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
- (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
- = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
- (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
- = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-\end{code}
-
-@conflictsWith@ tells whether an assignment to its first argument will
-screw up an access to its second.
-
-\begin{code}
-conflictsWith :: CAddrMode -> CAddrMode -> Bool
-(CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
-(CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
-(CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
-(CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
-(CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
- = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
-
-other1 `conflictsWith` other2 = False
--- CAddr and literals are impossible on the LHS of an assignment
-
-regConflictsWithRR :: MagicId -> RegRelative -> Bool
-
-regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1) = True
-regConflictsWithRR Sp (SpRel _) = True
-regConflictsWithRR Hp (HpRel _) = True
-regConflictsWithRR _ _ = False
-
-rrConflictsWithRR :: Int -> Int -- Sizes of two things
- -> RegRelative -> RegRelative -- The two amodes
- -> Bool
-
-rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
- where
- s1 = iUnbox s1b
- s2 = iUnbox s2b
-
- rr (SpRel o1) (SpRel o2)
- | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
- | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
- | otherwise = (o1 +# s1) >=# o2 &&
- (o2 +# s2) >=# o1
-
- rr (NodeRel o1) (NodeRel o2)
- | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
- | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
- | otherwise = True -- Give up
-
- rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
-
- rr other1 other2 = False
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
-%* *
-%************************************************************************
-
-\begin{code}
-
--- We begin with some helper functions. The main Dude here is
--- dscCOpStmt, defined a little further down.
-
-------------------------------------------------------------------------------
-
--- Assumes no volatiles
--- Creates
--- res = arg >> (bits-per-word / 2) when little-endian
--- or
--- res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian
---
--- In other words, if arg had been stored in memory, makes res the
--- halfword of arg which would have had the higher address. This is
--- why it needs to take into account endianness.
---
-mkHalfWord_HIADDR res arg
- = mkTemp WordRep `thenFlt` \ t_hw_mask1 ->
- mkTemp WordRep `thenFlt` \ t_hw_mask2 ->
- let
- hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2)
-
-# if WORDS_BIGENDIAN
- a_hw_mask1
- = CMachOpStmt t_hw_mask1
- MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing
- a_hw_mask2
- = CMachOpStmt t_hw_mask2
- MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
- final
- = CSequential [ a_hw_mask1, a_hw_mask2,
- CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
- ]
-# else
- final = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
-# endif
- in
- returnFlt final
-
-
-mkTemp :: PrimRep -> FlatM CAddrMode
-mkTemp rep
- = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
-
-mkTemps = mapFlt mkTemp
-
--- Sigh. This is done in 3 seperate places. Should be
--- commoned up (here, in pprAbsC of COpStmt, and presumably
--- somewhere in the NCG).
-non_void_amode amode
- = case getAmodeRep amode of
- VoidRep -> False
- k -> True
-
--- Helpers for translating various minor variants of array indexing.
-
-mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
-mkDerefOff rep base off
- = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep
-
-mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
-mkNoDerefOff rep base off
- = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
-
-
--- Generates an address as follows
--- base + sizeof(machine_word)*offw + sizeof(rep)*idx
-mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative
-mk_OSBI_addr offw rep base idx
- = CIndex (CAddr (CIndex base idx rep))
- (CLit (mkMachWord (fromIntegral offw)))
- PtrRep
-
-mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode
-mk_OSBI_ref offw rep base idx
- = CVal (mk_OSBI_addr offw rep base idx) rep
-
-
-doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
- = mkBasicIndexedRead 0 maybe_post_read_cast rep res (mkDerefOff WordRep addr fixedHdrSize) idx
-
-doIndexOffAddrOp maybe_post_read_cast rep res addr idx
- = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
-
-doIndexByteArrayOp maybe_post_read_cast rep res addr idx
- = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
-
-doReadPtrArrayOp res addr idx
- = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx
-
-
-doWriteOffAddrOp maybe_pre_write_cast rep addr idx val
- = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
-
-doWriteByteArrayOp maybe_pre_write_cast rep addr idx val
- = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
-
-doWritePtrArrayOp addr idx val
- = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val
-
-
-
-mkBasicIndexedRead offw Nothing read_rep res base idx
- = returnFlt (
- CAssign res (mk_OSBI_ref offw read_rep base idx)
- )
-mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx
- = mkTemp read_rep `thenFlt` \ tmp ->
- (returnFlt . CSequential) [
- CAssign tmp (mk_OSBI_ref offw read_rep base idx),
- CMachOpStmt res cast_to_mop [tmp] Nothing
- ]
-
-mkBasicIndexedWrite offw Nothing write_rep base idx val
- = returnFlt (
- CAssign (mk_OSBI_ref offw write_rep base idx) val
- )
-mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val
- = mkTemp write_rep `thenFlt` \ tmp ->
- (returnFlt . CSequential) [
- CMachOpStmt tmp cast_to_mop [val] Nothing,
- CAssign (mk_OSBI_ref offw write_rep base idx) tmp
- ]
-
-
--- Simple dyadic op but one for which we need to cast first arg to
--- be sure of correctness
-translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
- = mkTemp cast_arg1_to `thenFlt` \ arg1casted ->
- (returnFlt . CSequential) [
- CAssign arg1casted arg1,
- CMachOpStmt res mop [arg1casted,arg2]
- (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
- ]
-
--- IA64 mangler doesn't place tables next to code
-tablesNextToCode :: Bool
-#ifdef ia64_TARGET_ARCH
-tablesNextToCode = False
-#else
-tablesNextToCode = not opt_Unregisterised
-#endif
-
-------------------------------------------------------------------------------
-
--- This is the main top-level desugarer PrimOps into MachOps. First we
--- handle various awkward cases specially. The remaining easy cases are
--- then handled by translateOp, defined below.
-
-
-dscCOpStmt :: [CAddrMode] -- Results
- -> PrimOp
- -> [CAddrMode] -- Arguments
- -> [MagicId] -- Potentially volatile/live registers
- -- (to save/restore around the op)
- -> FlatM AbstractC
-
-
-dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
-{-
- With some bit-twiddling, we can define int{Add,Sub}Czh portably in
- C, and without needing any comparisons. This may not be the
- fastest way to do it - if you have better code, please send it! --SDM
-
- Return : r = a + b, c = 0 if no overflow, 1 on overflow.
-
- We currently don't make use of the r value if c is != 0 (i.e.
- overflow), we just convert to big integers and try again. This
- could be improved by making r and c the correct values for
- plugging into a new J#.
-
- { r = ((I_)(a)) + ((I_)(b)); \
- c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
- >> (BITS_IN (I_) - 1); \
- }
- Wading through the mass of bracketry, it seems to reduce to:
- c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
-
- SSA-form:
- t1 = a^b
- t2 = ~t1
- t3 = a^r
- t4 = t2 & t3
- c = t4 >>unsigned BITS_IN(I_)-1
--}
- = mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] ->
- let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
- (returnFlt . CSequential) [
- CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
- CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
- CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
- CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
- CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
- CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing
- ]
-
-
-dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
-{- Similarly:
- #define subIntCzh(r,c,a,b) \
- { r = ((I_)(a)) - ((I_)(b)); \
- c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
- >> (BITS_IN (I_) - 1); \
- }
-
- c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
-
- t1 = a^b
- t2 = a^r
- t3 = t1 & t2
- c = t3 >>unsigned BITS_IN(I_)-1
--}
- = mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] ->
- let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
- (returnFlt . CSequential) [
- CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
- CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
- CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
- CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
- CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing
- ]
-
-
--- #define parzh(r,node) r = 1
-dscCOpStmt [res] ParOp [arg] vols
- = returnFlt
- (CAssign res (CLit (mkMachInt 1)))
-
--- #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
-dscCOpStmt [res] ReadMutVarOp [mutv] vols
- = returnFlt
- (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
-
--- #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
-dscCOpStmt [] WriteMutVarOp [mutv,var] vols
- = returnFlt
- (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
-
-
--- #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
--- #define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo)
-dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
- = returnFlt
- (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
-
--- #define writeForeignObjzh(res,datum) \
--- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
-dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
- = returnFlt
- (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
-
-
--- #define sizzeofByteArrayzh(r,a) \
--- r = (((StgArrWords *)(a))->words * sizeof(W_))
-dscCOpStmt [res] SizeofByteArrayOp [arg] vols
- = mkTemp WordRep `thenFlt` \ w ->
- (returnFlt . CSequential) [
- CAssign w (mkDerefOff WordRep arg fixedHdrSize),
- CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (Just vols),
- CAssign res w
- ]
-
--- #define sizzeofMutableByteArrayzh(r,a) \
--- r = (((StgArrWords *)(a))->words * sizeof(W_))
-dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
- = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
-
-
--- #define touchzh(o) /* nothing */
-dscCOpStmt [] TouchOp [arg] vols
- = returnFlt AbsCNop
-
--- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
-dscCOpStmt [res] ByteArrayContents_Char [arg] vols
- = mkTemp PtrRep `thenFlt` \ ptr ->
- (returnFlt . CSequential) [
- CMachOpStmt ptr MO_NatU_to_NatP [arg] Nothing,
- CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
- CAssign res ptr
- ]
-
--- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
-dscCOpStmt [res] StableNameToIntOp [arg] vols
- = returnFlt
- (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
-
--- #define eqStableNamezh(r,sn1,sn2) \
--- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
-dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
- = mkTemps [WordRep, WordRep] `thenFlt` \ [sn1,sn2] ->
- (returnFlt . CSequential) [
- CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
- CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
- CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing
- ]
-
-dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols
- = mkTemps [WordRep, WordRep] `thenFlt` \ [w1,w2] ->
- (returnFlt . CSequential) [
- CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing,
- CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing,
- CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -}
- ]
-
--- #define addrToHValuezh(r,a) r=(P_)a
-dscCOpStmt [res] AddrToHValueOp [arg] vols
- = returnFlt
- (CAssign res arg)
-
--- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
---
--- In the unregisterised case, we don't attempt to compute the location
--- of the tag halfword, just a macro. For this build, fixing on layout
--- info has only got drawbacks.
---
--- Should this arrangement deeply offend you for some reason, code which
--- computes the offset can be found below also.
--- -- sof 3/02
---
-dscCOpStmt [res] DataToTagOp [arg] vols
- | not tablesNextToCode
- = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg])
- | otherwise
- = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] ->
- mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops ->
- (returnFlt . CSequential) [
- CAssign t_infoptr (mkDerefOff PtrRep arg 0),
- {-
- Get at the tag within the info table; two cases to consider:
-
- - reversed info tables next to the entry point code;
- one word above the end of the info table (which is
- what t_infoptr is really pointing to).
- - info tables with their entry points stored somewhere else,
- which is how the unregisterised (nee TABLES_NEXT_TO_CODE)
- world operates.
-
- The t_infoptr points to the start of the info table, so add
- the length of the info table & subtract one word.
- -}
- CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
-{- UNUSED - see above comment.
- (if opt_Unregisterised then
- (fixedItblSize - 1)
- else (-1))),
--}
- select_ops
- ]
-
-
-{- Freezing arrays-of-ptrs requires changing an info table, for the
- benefit of the generational collector. It needs to scavenge mutable
- objects, even if they are in old space. When they become immutable,
- they can be removed from this scavenge list. -}
-
--- #define unsafeFreezzeArrayzh(r,a) \
--- { \
--- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \
--- r = a; \
--- }
-dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
- = (returnFlt . CSequential) [
- CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
- CAssign res arg
- ]
-
--- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
-dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
- = returnFlt
- (CAssign res arg)
-
--- This ought to be trivial, but it's difficult to insert the casts
--- required to keep the C compiler happy.
-dscCOpStmt [r] AddrRemOp [a1,a2] vols
- = mkTemp WordRep `thenFlt` \ a1casted ->
- (returnFlt . CSequential) [
- CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing,
- CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing
- ]
-
--- not handled by translateOp because they need casts
-dscCOpStmt [r] SllOp [a1,a2] vols
- = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
-dscCOpStmt [r] SrlOp [a1,a2] vols
- = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
-
-dscCOpStmt [r] ISllOp [a1,a2] vols
- = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
-dscCOpStmt [r] ISrlOp [a1,a2] vols
- = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
-dscCOpStmt [r] ISraOp [a1,a2] vols
- = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
-
--- Reading/writing pointer arrays
-
-dscCOpStmt [r] ReadArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
-dscCOpStmt [r] IndexArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
-dscCOpStmt [] WriteArrayOp [obj,ix,v] vols = doWritePtrArrayOp obj ix v
-
--- IndexXXXoffForeignObj
-
-dscCOpStmt [r] IndexOffForeignObjOp_Char [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_WideChar [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Int [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Word [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Addr [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Float [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Double [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i
-
-dscCOpStmt [r] IndexOffForeignObjOp_Int8 [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Int16 [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Int32 [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Int64 [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i
-
-dscCOpStmt [r] IndexOffForeignObjOp_Word8 [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Word16 [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Word32 [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
-dscCOpStmt [r] IndexOffForeignObjOp_Word64 [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i
-
--- IndexXXXoffAddr
-
-dscCOpStmt [r] IndexOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
-dscCOpStmt [r] IndexOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
-dscCOpStmt [r] IndexOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
-dscCOpStmt [r] IndexOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
-dscCOpStmt [r] IndexOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
-dscCOpStmt [r] IndexOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
-dscCOpStmt [r] IndexOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
-dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
-
-dscCOpStmt [r] IndexOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
-dscCOpStmt [r] IndexOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
-dscCOpStmt [r] IndexOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
-dscCOpStmt [r] IndexOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
-
-dscCOpStmt [r] IndexOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
-dscCOpStmt [r] IndexOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
-dscCOpStmt [r] IndexOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
-dscCOpStmt [r] IndexOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
-
--- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
-
-dscCOpStmt [r] ReadOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
-dscCOpStmt [r] ReadOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
-dscCOpStmt [r] ReadOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
-dscCOpStmt [r] ReadOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
-dscCOpStmt [r] ReadOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
-dscCOpStmt [r] ReadOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
-dscCOpStmt [r] ReadOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
-dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
-
-dscCOpStmt [r] ReadOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
-dscCOpStmt [r] ReadOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
-dscCOpStmt [r] ReadOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
-dscCOpStmt [r] ReadOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
-
-dscCOpStmt [r] ReadOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
-dscCOpStmt [r] ReadOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
-dscCOpStmt [r] ReadOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
-dscCOpStmt [r] ReadOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
-
--- IndexXXXArray
-
-dscCOpStmt [r] IndexByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
-dscCOpStmt [r] IndexByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
-dscCOpStmt [r] IndexByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
-dscCOpStmt [r] IndexByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
-dscCOpStmt [r] IndexByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
-dscCOpStmt [r] IndexByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
-dscCOpStmt [r] IndexByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
-dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
-
-dscCOpStmt [r] IndexByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
-dscCOpStmt [r] IndexByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
-dscCOpStmt [r] IndexByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
-dscCOpStmt [r] IndexByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
-
-dscCOpStmt [r] IndexByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
-dscCOpStmt [r] IndexByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
-dscCOpStmt [r] IndexByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
-dscCOpStmt [r] IndexByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
-
--- ReadXXXArray, identical to IndexXXXArray.
-
-dscCOpStmt [r] ReadByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
-dscCOpStmt [r] ReadByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
-dscCOpStmt [r] ReadByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
-dscCOpStmt [r] ReadByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
-dscCOpStmt [r] ReadByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
-dscCOpStmt [r] ReadByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
-dscCOpStmt [r] ReadByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
-dscCOpStmt [r] ReadByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
-
-dscCOpStmt [r] ReadByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
-dscCOpStmt [r] ReadByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
-dscCOpStmt [r] ReadByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
-dscCOpStmt [r] ReadByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
-
-dscCOpStmt [r] ReadByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
-dscCOpStmt [r] ReadByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
-dscCOpStmt [r] ReadByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
-dscCOpStmt [r] ReadByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
-
--- WriteXXXoffAddr
-
-dscCOpStmt [] WriteOffAddrOp_Char [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x
-dscCOpStmt [] WriteOffAddrOp_WideChar [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
-dscCOpStmt [] WriteOffAddrOp_Int [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x
-dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
-dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
-dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
-dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing PtrRep a i x
-dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
-dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
-
-dscCOpStmt [] WriteOffAddrOp_Int8 [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep a i x
-dscCOpStmt [] WriteOffAddrOp_Int16 [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x
-dscCOpStmt [] WriteOffAddrOp_Int32 [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x
-dscCOpStmt [] WriteOffAddrOp_Int64 [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x
-
-dscCOpStmt [] WriteOffAddrOp_Word8 [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep a i x
-dscCOpStmt [] WriteOffAddrOp_Word16 [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x
-dscCOpStmt [] WriteOffAddrOp_Word32 [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
-dscCOpStmt [] WriteOffAddrOp_Word64 [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x
-
--- WriteXXXArray
-
-dscCOpStmt [] WriteByteArrayOp_Char [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x
-dscCOpStmt [] WriteByteArrayOp_WideChar [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
-dscCOpStmt [] WriteByteArrayOp_Int [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x
-dscCOpStmt [] WriteByteArrayOp_Word [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x
-dscCOpStmt [] WriteByteArrayOp_Addr [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x
-dscCOpStmt [] WriteByteArrayOp_Float [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x
-dscCOpStmt [] WriteByteArrayOp_Double [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x
-dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x
-
-dscCOpStmt [] WriteByteArrayOp_Int8 [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep a i x
-dscCOpStmt [] WriteByteArrayOp_Int16 [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep a i x
-dscCOpStmt [] WriteByteArrayOp_Int32 [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep a i x
-dscCOpStmt [] WriteByteArrayOp_Int64 [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep a i x
-
-dscCOpStmt [] WriteByteArrayOp_Word8 [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep a i x
-dscCOpStmt [] WriteByteArrayOp_Word16 [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep a i x
-dscCOpStmt [] WriteByteArrayOp_Word32 [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
-dscCOpStmt [] WriteByteArrayOp_Word64 [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep a i x
-
-
--- Handle all others as simply as possible.
-dscCOpStmt ress op args vols
- = case translateOp ress op args of
- Nothing
- -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
- Just (maybe_res, mop, args)
- -> returnFlt (
- CMachOpStmt maybe_res mop args
- (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
- )
-
--- Native word signless ops
-
-translateOp [r] IntAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
-translateOp [r] IntSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
-translateOp [r] WordAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
-translateOp [r] WordSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
-translateOp [r] AddrAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
-translateOp [r] AddrSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
-
-translateOp [r] IntEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-translateOp [r] IntNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
-translateOp [r] WordEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-translateOp [r] WordNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
-translateOp [r] AddrEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-translateOp [r] AddrNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
-
-translateOp [r] AndOp [a1,a2] = Just (r, MO_Nat_And, [a1,a2])
-translateOp [r] OrOp [a1,a2] = Just (r, MO_Nat_Or, [a1,a2])
-translateOp [r] XorOp [a1,a2] = Just (r, MO_Nat_Xor, [a1,a2])
-translateOp [r] NotOp [a1] = Just (r, MO_Nat_Not, [a1])
-
--- Native word signed ops
-
-translateOp [r] IntMulOp [a1,a2] = Just (r, MO_NatS_Mul, [a1,a2])
-translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2])
-translateOp [r] IntQuotOp [a1,a2] = Just (r, MO_NatS_Quot, [a1,a2])
-translateOp [r] IntRemOp [a1,a2] = Just (r, MO_NatS_Rem, [a1,a2])
-translateOp [r] IntNegOp [a1] = Just (r, MO_NatS_Neg, [a1])
-
-translateOp [r] IntGeOp [a1,a2] = Just (r, MO_NatS_Ge, [a1,a2])
-translateOp [r] IntLeOp [a1,a2] = Just (r, MO_NatS_Le, [a1,a2])
-translateOp [r] IntGtOp [a1,a2] = Just (r, MO_NatS_Gt, [a1,a2])
-translateOp [r] IntLtOp [a1,a2] = Just (r, MO_NatS_Lt, [a1,a2])
-
-
--- Native word unsigned ops
-
-translateOp [r] WordGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
-translateOp [r] WordLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
-translateOp [r] WordGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
-translateOp [r] WordLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
-
-translateOp [r] WordMulOp [a1,a2] = Just (r, MO_NatU_Mul, [a1,a2])
-translateOp [r] WordQuotOp [a1,a2] = Just (r, MO_NatU_Quot, [a1,a2])
-translateOp [r] WordRemOp [a1,a2] = Just (r, MO_NatU_Rem, [a1,a2])
-
-translateOp [r] AddrGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
-translateOp [r] AddrLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
-translateOp [r] AddrGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
-translateOp [r] AddrLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
-
--- 32-bit unsigned ops
-
-translateOp [r] CharEqOp [a1,a2] = Just (r, MO_32U_Eq, [a1,a2])
-translateOp [r] CharNeOp [a1,a2] = Just (r, MO_32U_Ne, [a1,a2])
-translateOp [r] CharGeOp [a1,a2] = Just (r, MO_32U_Ge, [a1,a2])
-translateOp [r] CharLeOp [a1,a2] = Just (r, MO_32U_Le, [a1,a2])
-translateOp [r] CharGtOp [a1,a2] = Just (r, MO_32U_Gt, [a1,a2])
-translateOp [r] CharLtOp [a1,a2] = Just (r, MO_32U_Lt, [a1,a2])
-
--- Double ops
-
-translateOp [r] DoubleEqOp [a1,a2] = Just (r, MO_Dbl_Eq, [a1,a2])
-translateOp [r] DoubleNeOp [a1,a2] = Just (r, MO_Dbl_Ne, [a1,a2])
-translateOp [r] DoubleGeOp [a1,a2] = Just (r, MO_Dbl_Ge, [a1,a2])
-translateOp [r] DoubleLeOp [a1,a2] = Just (r, MO_Dbl_Le, [a1,a2])
-translateOp [r] DoubleGtOp [a1,a2] = Just (r, MO_Dbl_Gt, [a1,a2])
-translateOp [r] DoubleLtOp [a1,a2] = Just (r, MO_Dbl_Lt, [a1,a2])
-
-translateOp [r] DoubleAddOp [a1,a2] = Just (r, MO_Dbl_Add, [a1,a2])
-translateOp [r] DoubleSubOp [a1,a2] = Just (r, MO_Dbl_Sub, [a1,a2])
-translateOp [r] DoubleMulOp [a1,a2] = Just (r, MO_Dbl_Mul, [a1,a2])
-translateOp [r] DoubleDivOp [a1,a2] = Just (r, MO_Dbl_Div, [a1,a2])
-translateOp [r] DoublePowerOp [a1,a2] = Just (r, MO_Dbl_Pwr, [a1,a2])
-
-translateOp [r] DoubleSinOp [a1] = Just (r, MO_Dbl_Sin, [a1])
-translateOp [r] DoubleCosOp [a1] = Just (r, MO_Dbl_Cos, [a1])
-translateOp [r] DoubleTanOp [a1] = Just (r, MO_Dbl_Tan, [a1])
-translateOp [r] DoubleSinhOp [a1] = Just (r, MO_Dbl_Sinh, [a1])
-translateOp [r] DoubleCoshOp [a1] = Just (r, MO_Dbl_Cosh, [a1])
-translateOp [r] DoubleTanhOp [a1] = Just (r, MO_Dbl_Tanh, [a1])
-translateOp [r] DoubleAsinOp [a1] = Just (r, MO_Dbl_Asin, [a1])
-translateOp [r] DoubleAcosOp [a1] = Just (r, MO_Dbl_Acos, [a1])
-translateOp [r] DoubleAtanOp [a1] = Just (r, MO_Dbl_Atan, [a1])
-translateOp [r] DoubleLogOp [a1] = Just (r, MO_Dbl_Log, [a1])
-translateOp [r] DoubleExpOp [a1] = Just (r, MO_Dbl_Exp, [a1])
-translateOp [r] DoubleSqrtOp [a1] = Just (r, MO_Dbl_Sqrt, [a1])
-translateOp [r] DoubleNegOp [a1] = Just (r, MO_Dbl_Neg, [a1])
-
--- Float ops
-
-translateOp [r] FloatEqOp [a1,a2] = Just (r, MO_Flt_Eq, [a1,a2])
-translateOp [r] FloatNeOp [a1,a2] = Just (r, MO_Flt_Ne, [a1,a2])
-translateOp [r] FloatGeOp [a1,a2] = Just (r, MO_Flt_Ge, [a1,a2])
-translateOp [r] FloatLeOp [a1,a2] = Just (r, MO_Flt_Le, [a1,a2])
-translateOp [r] FloatGtOp [a1,a2] = Just (r, MO_Flt_Gt, [a1,a2])
-translateOp [r] FloatLtOp [a1,a2] = Just (r, MO_Flt_Lt, [a1,a2])
-
-translateOp [r] FloatAddOp [a1,a2] = Just (r, MO_Flt_Add, [a1,a2])
-translateOp [r] FloatSubOp [a1,a2] = Just (r, MO_Flt_Sub, [a1,a2])
-translateOp [r] FloatMulOp [a1,a2] = Just (r, MO_Flt_Mul, [a1,a2])
-translateOp [r] FloatDivOp [a1,a2] = Just (r, MO_Flt_Div, [a1,a2])
-translateOp [r] FloatPowerOp [a1,a2] = Just (r, MO_Flt_Pwr, [a1,a2])
-
-translateOp [r] FloatSinOp [a1] = Just (r, MO_Flt_Sin, [a1])
-translateOp [r] FloatCosOp [a1] = Just (r, MO_Flt_Cos, [a1])
-translateOp [r] FloatTanOp [a1] = Just (r, MO_Flt_Tan, [a1])
-translateOp [r] FloatSinhOp [a1] = Just (r, MO_Flt_Sinh, [a1])
-translateOp [r] FloatCoshOp [a1] = Just (r, MO_Flt_Cosh, [a1])
-translateOp [r] FloatTanhOp [a1] = Just (r, MO_Flt_Tanh, [a1])
-translateOp [r] FloatAsinOp [a1] = Just (r, MO_Flt_Asin, [a1])
-translateOp [r] FloatAcosOp [a1] = Just (r, MO_Flt_Acos, [a1])
-translateOp [r] FloatAtanOp [a1] = Just (r, MO_Flt_Atan, [a1])
-translateOp [r] FloatLogOp [a1] = Just (r, MO_Flt_Log, [a1])
-translateOp [r] FloatExpOp [a1] = Just (r, MO_Flt_Exp, [a1])
-translateOp [r] FloatSqrtOp [a1] = Just (r, MO_Flt_Sqrt, [a1])
-translateOp [r] FloatNegOp [a1] = Just (r, MO_Flt_Neg, [a1])
-
--- Conversions
-
-translateOp [r] Int2DoubleOp [a1] = Just (r, MO_NatS_to_Dbl, [a1])
-translateOp [r] Double2IntOp [a1] = Just (r, MO_Dbl_to_NatS, [a1])
-
-translateOp [r] Int2FloatOp [a1] = Just (r, MO_NatS_to_Flt, [a1])
-translateOp [r] Float2IntOp [a1] = Just (r, MO_Flt_to_NatS, [a1])
-
-translateOp [r] Float2DoubleOp [a1] = Just (r, MO_Flt_to_Dbl, [a1])
-translateOp [r] Double2FloatOp [a1] = Just (r, MO_Dbl_to_Flt, [a1])
-
-translateOp [r] Int2WordOp [a1] = Just (r, MO_NatS_to_NatU, [a1])
-translateOp [r] Word2IntOp [a1] = Just (r, MO_NatU_to_NatS, [a1])
-
-translateOp [r] Int2AddrOp [a1] = Just (r, MO_NatS_to_NatP, [a1])
-translateOp [r] Addr2IntOp [a1] = Just (r, MO_NatP_to_NatS, [a1])
-
-translateOp [r] OrdOp [a1] = Just (r, MO_32U_to_NatS, [a1])
-translateOp [r] ChrOp [a1] = Just (r, MO_NatS_to_32U, [a1])
-
-translateOp [r] Narrow8IntOp [a1] = Just (r, MO_8S_to_NatS, [a1])
-translateOp [r] Narrow16IntOp [a1] = Just (r, MO_16S_to_NatS, [a1])
-translateOp [r] Narrow32IntOp [a1] = Just (r, MO_32S_to_NatS, [a1])
-
-translateOp [r] Narrow8WordOp [a1] = Just (r, MO_8U_to_NatU, [a1])
-translateOp [r] Narrow16WordOp [a1] = Just (r, MO_16U_to_NatU, [a1])
-translateOp [r] Narrow32WordOp [a1] = Just (r, MO_32U_to_NatU, [a1])
-
--- Word comparisons masquerading as more exotic things.
-
-translateOp [r] SameMutVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-translateOp [r] SameMVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-translateOp [r] SameMutableArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-translateOp [r] SameMutableByteArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-translateOp [r] EqForeignObj [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-translateOp [r] EqStablePtrOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
-
-translateOp _ _ _ = Nothing
-\end{code}
-
-
-\begin{code}
-shimFCallArg arg amode
- | tycon == foreignObjPrimTyCon
- = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
- | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
- = CMacroExpr PtrRep PTRS_ARR_CTS [amode]
- | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
- = CMacroExpr AddrRep BYTE_ARR_CTS [amode]
- | otherwise = amode
- where
- -- should be a tycon app, since this is a foreign call
- tycon = tyConAppTyCon (repType (stgArgType arg))
-\end{code}
+++ /dev/null
-%
-% (c) The University of Glasgow, 1992-2002
-%
-\section[CLabel]{@CLabel@: Information to make C Labels}
-
-\begin{code}
-module CLabel (
- CLabel, -- abstract type
-
- mkClosureLabel,
- mkSRTLabel,
- mkSRTDescLabel,
- mkInfoTableLabel,
- mkEntryLabel,
- mkSlowEntryLabel,
- mkConEntryLabel,
- mkStaticConEntryLabel,
- mkRednCountsLabel,
- mkConInfoTableLabel,
- mkStaticInfoTableLabel,
- mkApEntryLabel,
- mkApInfoTableLabel,
-
- mkReturnPtLabel,
- mkReturnInfoLabel,
- mkVecTblLabel,
- mkAltLabel,
- mkDefaultLabel,
- mkBitmapLabel,
-
- mkClosureTblLabel,
-
- mkAsmTempLabel,
-
- mkModuleInitLabel,
- mkPlainModuleInitLabel,
-
- mkErrorStdEntryLabel,
-
- mkStgUpdatePAPLabel,
- mkSplitMarkerLabel,
- mkUpdInfoLabel,
- mkSeqInfoLabel,
- mkIndInfoLabel,
- mkIndStaticInfoLabel,
- mkRtsGCEntryLabel,
- mkMainCapabilityLabel,
- mkCharlikeClosureLabel,
- mkIntlikeClosureLabel,
- mkMAP_FROZEN_infoLabel,
- mkEMPTY_MVAR_infoLabel,
-
- mkTopTickyCtrLabel,
- mkBlackHoleInfoTableLabel,
- mkBlackHoleBQInfoTableLabel,
- mkCAFBlackHoleInfoTableLabel,
- mkSECAFBlackHoleInfoTableLabel,
- mkRtsPrimOpLabel,
-
- moduleRegdLabel,
-
- mkSelectorInfoLabel,
- mkSelectorEntryLabel,
-
- mkRtsApplyInfoLabel,
- mkRtsApplyEntryLabel,
-
- mkForeignLabel,
-
- mkCC_Label, mkCCS_Label,
-
- needsCDecl, isAsmTemp, externallyVisibleCLabel,
-
- CLabelType(..), labelType, labelDynamic,
-
- pprCLabel
- ) where
-
-
-#include "HsVersions.h"
-
-#if ! OMIT_NATIVE_CODEGEN
-import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
-#endif
-
-import CmdLineOpts ( opt_Static, opt_DoTickyProfiling )
-import CStrings ( pp_cSEP )
-import DataCon ( ConTag )
-import Module ( moduleName, moduleNameFS,
- Module, isHomeModule )
-import Name ( Name, getName, isDllName, isExternalName )
-import TyCon ( TyCon )
-import Unique ( pprUnique, Unique )
-import PrimOp ( PrimOp )
-import CostCentre ( CostCentre, CostCentreStack )
-import Outputable
-import FastString
-\end{code}
-
-things we want to find out:
-
-* should the labelled things be declared "static" (visible only in this file)?
-
-* should it be declared "const" (read-only text space)?
-
-* does it need declarations at all? (v common Prelude things are pre-declared)
-
-* what type does it have? (for generating accurate enough C declarations
- so that the C compiler won't complain).
-
-\begin{code}
-data CLabel
- = IdLabel -- A family of labels related to the
- Name -- definition of a particular Id
- IdLabelInfo
-
- | DataConLabel -- Ditto data constructors
- Name
- DataConLabelInfo
-
- | CaseLabel -- A family of labels related to a particular case expression
- Unique -- Unique says which case expression
- CaseLabelInfo
-
- | TyConLabel TyCon -- currently only one kind of TyconLabel,
- -- a 'Closure Table'.
-
- | AsmTempLabel Unique
-
- | ModuleInitLabel
- Module -- the module name
- String -- its "way"
- -- at some point we might want some kind of version number in
- -- the module init label, to guard against compiling modules in
- -- the wrong order. We can't use the interface file version however,
- -- because we don't always recompile modules which depend on a module
- -- whose version has changed.
-
- | PlainModuleInitLabel Module -- without the vesrion & way info
-
- | RtsLabel RtsLabelInfo
-
- | ForeignLabel FastString Bool -- a 'C' (or otherwise foreign) label
- -- Bool <=> is dynamic
-
- | CC_Label CostCentre
- | CCS_Label CostCentreStack
-
- deriving (Eq, Ord)
-\end{code}
-
-\begin{code}
-data IdLabelInfo
- = Closure -- Label for (static???) closure
- | SRT -- Static reference table
- | SRTDesc -- Static reference table descriptor
- | InfoTbl -- Info tables for closures; always read-only
- | Entry -- entry point
- | Slow -- slow entry point
-
- -- Ticky-ticky counting
- | RednCounts -- Label of place to keep reduction-count info for
- -- this Id
-
- | Bitmap -- A bitmap (function or case return)
-
- deriving (Eq, Ord)
-
-data DataConLabelInfo
- = ConEntry -- the only kind of entry pt for constructors
- | ConInfoTbl -- corresponding info table
- | StaticConEntry -- static constructor entry point
- | StaticInfoTbl -- corresponding info table
- deriving (Eq, Ord)
-
-data CaseLabelInfo
- = CaseReturnPt
- | CaseReturnInfo
- | CaseVecTbl
- | CaseAlt ConTag
- | CaseDefault
- deriving (Eq, Ord)
-
-data RtsLabelInfo
- = RtsShouldNeverHappenCode
-
- | RtsBlackHoleInfoTbl LitString -- black hole with info table name
-
- | RtsUpdInfo -- upd_frame_info
- | RtsSeqInfo -- seq_frame_info
- | RtsGCEntryLabel String -- a heap check fail handler, eg stg_chk_2
- | RtsMainCapability -- MainCapability
- | Rts_Closure String -- misc rts closures, eg CHARLIKE_closure
- | Rts_Info String -- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info
- | Rts_Code String -- misc rts code
-
- | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks
- | RtsSelectorEntry Bool{-updatable-} Int{-offset-}
-
- | RtsApInfoTbl Bool{-updatable-} Int{-arity-} -- AP thunks
- | RtsApEntry Bool{-updatable-} Int{-arity-}
-
- | RtsPrimOp PrimOp
-
- | RtsTopTickyCtr
-
- | RtsModuleRegd
-
- | RtsApplyInfoLabel LitString
- | RtsApplyEntryLabel LitString
-
- deriving (Eq, Ord)
-
--- Label Type: for generating C declarations.
-
-data CLabelType
- = RetInfoTblType
- | InfoTblType
- | ClosureType
- | VecTblType
- | ClosureTblType
- | CodeType
- | DataType
-\end{code}
-
-\begin{code}
-mkClosureLabel id = IdLabel id Closure
-mkSRTLabel id = IdLabel id SRT
-mkSRTDescLabel id = IdLabel id SRTDesc
-mkInfoTableLabel id = IdLabel id InfoTbl
-mkEntryLabel id = IdLabel id Entry
-mkSlowEntryLabel id = IdLabel id Slow
-mkBitmapLabel id = IdLabel id Bitmap
-mkRednCountsLabel id = IdLabel id RednCounts
-
-mkStaticInfoTableLabel con = DataConLabel con StaticInfoTbl
-mkConInfoTableLabel con = DataConLabel con ConInfoTbl
-mkConEntryLabel con = DataConLabel con ConEntry
-mkStaticConEntryLabel con = DataConLabel con StaticConEntry
-
-
-mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
-mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
-mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl
-mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
-mkDefaultLabel uniq = CaseLabel uniq CaseDefault
-
-
-mkClosureTblLabel tycon = TyConLabel tycon
-
-mkAsmTempLabel = AsmTempLabel
-
-mkModuleInitLabel = ModuleInitLabel
-mkPlainModuleInitLabel = PlainModuleInitLabel
-
- -- Some fixed runtime system labels
-
-mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
-mkStgUpdatePAPLabel = RtsLabel (Rts_Code "stg_update_PAP")
-mkSplitMarkerLabel = RtsLabel (Rts_Code "__stg_split_marker")
-mkUpdInfoLabel = RtsLabel RtsUpdInfo
-mkSeqInfoLabel = RtsLabel RtsSeqInfo
-mkIndInfoLabel = RtsLabel (Rts_Info "stg_IND_info")
-mkIndStaticInfoLabel = RtsLabel (Rts_Info "stg_IND_STATIC_info")
-mkRtsGCEntryLabel str = RtsLabel (RtsGCEntryLabel str)
-mkMainCapabilityLabel = RtsLabel RtsMainCapability
-mkCharlikeClosureLabel = RtsLabel (Rts_Closure "stg_CHARLIKE_closure")
-mkIntlikeClosureLabel = RtsLabel (Rts_Closure "stg_INTLIKE_closure")
-mkMAP_FROZEN_infoLabel = RtsLabel (Rts_Info "stg_MUT_ARR_PTRS_FROZEN_info")
-mkEMPTY_MVAR_infoLabel = RtsLabel (Rts_Info "stg_EMPTY_MVAR_info")
-
-mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr
-mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_info"))
-mkBlackHoleBQInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_BLACKHOLE_BQ_info"))
-mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_CAF_BLACKHOLE_info"))
-mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
- RtsLabel (RtsBlackHoleInfoTbl SLIT("stg_SE_CAF_BLACKHOLE_info"))
- else -- RTS won't have info table unless -ticky is on
- panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
-mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
-
-moduleRegdLabel = RtsLabel RtsModuleRegd
-
-mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off)
-mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off)
-
-mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTbl upd off)
-mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
-
- -- Foreign labels
-
-mkForeignLabel :: FastString -> Bool -> CLabel
-mkForeignLabel str is_dynamic = ForeignLabel str is_dynamic
-
- -- Cost centres etc.
-
-mkCC_Label cc = CC_Label cc
-mkCCS_Label ccs = CCS_Label ccs
-
--- Std RTS application routines
-
-mkRtsApplyInfoLabel = RtsLabel . RtsApplyInfoLabel
-mkRtsApplyEntryLabel = RtsLabel . RtsApplyEntryLabel
-\end{code}
-
-\begin{code}
-needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother
-isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
-externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
-\end{code}
-
-@needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
-object. {\em Also:} No need to spit out labels for things generated
-by the flattener (in @AbsCUtils@)---it is careful to ensure references
-to them are always backwards. These are return-point and vector-table
-labels.
-
-Declarations for (non-prelude) @Id@-based things are needed because of
-mutual recursion.
-
-Declarations for direct return points are needed, because they may be
-let-no-escapes, which can be recursive.
-
-\begin{code}
- -- don't bother declaring SRT & Bitmap labels, we always make sure
- -- they are defined before use.
-needsCDecl (IdLabel _ SRT) = False
-needsCDecl (IdLabel _ SRTDesc) = False
-needsCDecl (IdLabel _ Bitmap) = False
-needsCDecl (IdLabel _ _) = True
-needsCDecl (CaseLabel _ CaseReturnPt) = True
-needsCDecl (DataConLabel _ _) = True
-needsCDecl (TyConLabel _) = True
-needsCDecl (ModuleInitLabel _ _) = True
-needsCDecl (PlainModuleInitLabel _) = True
-
-needsCDecl (CaseLabel _ _) = False
-needsCDecl (AsmTempLabel _) = False
-needsCDecl (RtsLabel _) = False
-needsCDecl (ForeignLabel _ _) = False
-needsCDecl (CC_Label _) = False
-needsCDecl (CCS_Label _) = False
-\end{code}
-
-Whether the label is an assembler temporary:
-
-\begin{code}
-isAsmTemp (AsmTempLabel _) = True
-isAsmTemp _ = False
-\end{code}
-
-C ``static'' or not...
-From the point of view of the code generator, a name is
-externally visible if it has to be declared as exported
-in the .o file's symbol table; that is, made non-static.
-
-\begin{code}
-externallyVisibleCLabel (DataConLabel _ _) = True
-externallyVisibleCLabel (TyConLabel tc) = True
-externallyVisibleCLabel (CaseLabel _ _) = False
-externallyVisibleCLabel (AsmTempLabel _) = False
-externallyVisibleCLabel (ModuleInitLabel _ _)= True
-externallyVisibleCLabel (PlainModuleInitLabel _)= True
-externallyVisibleCLabel (RtsLabel RtsModuleRegd) = False --hack
-externallyVisibleCLabel (RtsLabel _) = True
-externallyVisibleCLabel (ForeignLabel _ _) = True
-externallyVisibleCLabel (IdLabel id _) = isExternalName id
-externallyVisibleCLabel (CC_Label _) = False -- not strictly true
-externallyVisibleCLabel (CCS_Label _) = False -- not strictly true
-\end{code}
-
-For generating correct types in label declarations, and also for
-deciding whether the C compiler would like us to use '&' before the
-label to get its address:
-
-\begin{code}
-labelType :: CLabel -> CLabelType
-labelType (RtsLabel (RtsBlackHoleInfoTbl _)) = InfoTblType
-labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
-labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType
-labelType (RtsLabel RtsUpdInfo) = RetInfoTblType
-labelType (RtsLabel RtsSeqInfo) = RetInfoTblType
-labelType (RtsLabel RtsTopTickyCtr) = CodeType -- XXX
-labelType (RtsLabel (Rts_Info _)) = InfoTblType
-labelType (RtsLabel (RtsApplyInfoLabel _)) = RetInfoTblType
-labelType (RtsLabel (RtsApplyEntryLabel _)) = CodeType
-labelType (CaseLabel _ CaseReturnInfo) = RetInfoTblType
-labelType (CaseLabel _ CaseReturnPt) = CodeType
-labelType (CaseLabel _ CaseVecTbl) = VecTblType
-labelType (TyConLabel _) = ClosureTblType
-labelType (ModuleInitLabel _ _) = CodeType
-labelType (PlainModuleInitLabel _) = CodeType
-labelType (CC_Label _) = CodeType -- hack
-labelType (CCS_Label _) = CodeType -- hack
-
-labelType (IdLabel _ info) =
- case info of
- InfoTbl -> InfoTblType
- Closure -> ClosureType
- Bitmap -> DataType
- _ -> CodeType
-
-labelType (DataConLabel _ info) =
- case info of
- ConInfoTbl -> InfoTblType
- StaticInfoTbl -> InfoTblType
- _ -> CodeType
-
-labelType _ = DataType
-\end{code}
-
-When referring to data in code, we need to know whether
-that data resides in a DLL or not. [Win32 only.]
-@labelDynamic@ returns @True@ if the label is located
-in a DLL, be it a data reference or not.
-
-\begin{code}
-labelDynamic :: CLabel -> Bool
-labelDynamic lbl =
- case lbl of
- -- The special case for RtsShouldNeverHappenCode is because the associated address is
- -- NULL, i.e. not a DLL entry point
- RtsLabel RtsShouldNeverHappenCode -> False
- RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not?
- IdLabel n k -> isDllName n
- DataConLabel n k -> isDllName n
- TyConLabel tc -> isDllName (getName tc)
- ForeignLabel _ d -> d
- ModuleInitLabel m _ -> (not opt_Static) && (not (isHomeModule m))
- PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
- _ -> False
-\end{code}
-
-
-OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
-right places. It is used to detect when the abstractC statement of an
-CCodeBlock actually contains the code for a slow entry point. -- HWL
-
-We need at least @Eq@ for @CLabels@, because we want to avoid
-duplicate declarations in generating C (see @labelSeenTE@ in
-@PprAbsC@).
-
------------------------------------------------------------------------------
-Printing out CLabels.
-
-Convention:
-
- <name>_<type>
-
-where <name> is <Module>_<name> for external names and <unique> for
-internal names. <type> is one of the following:
-
- info Info table
- srt Static reference table
- srtd Static reference table descriptor
- entry Entry code
- slow Slow entry code (if any)
- ret Direct return address
- vtbl Vector table
- <n>_alt Case alternative (tag n)
- dflt Default case alternative
- btm Large bitmap vector
- closure Static closure
- con_entry Dynamic Constructor entry code
- con_info Dynamic Constructor info table
- static_entry Static Constructor entry code
- static_info Static Constructor info table
- sel_info Selector info table
- sel_entry Selector entry code
- cc Cost centre
- ccs Cost centre stack
-
-\begin{code}
-pprCLabel :: CLabel -> SDoc
-
-#if ! OMIT_NATIVE_CODEGEN
-pprCLabel (AsmTempLabel u)
- = text (fmtAsmLbl (show u))
-#endif
-
-pprCLabel lbl =
-#if ! OMIT_NATIVE_CODEGEN
- getPprStyle $ \ sty ->
- if asmStyle sty && underscorePrefix then
- pp_cSEP <> pprCLbl lbl
- else
-#endif
- pprCLbl lbl
-
-pprCLbl (CaseLabel u CaseReturnPt)
- = hcat [pprUnique u, pp_cSEP, ptext SLIT("ret")]
-pprCLbl (CaseLabel u CaseReturnInfo)
- = hcat [pprUnique u, pp_cSEP, ptext SLIT("info")]
-pprCLbl (CaseLabel u CaseVecTbl)
- = hcat [pprUnique u, pp_cSEP, ptext SLIT("vtbl")]
-pprCLbl (CaseLabel u (CaseAlt tag))
- = hcat [pprUnique u, pp_cSEP, int tag, pp_cSEP, ptext SLIT("alt")]
-pprCLbl (CaseLabel u CaseDefault)
- = hcat [pprUnique u, pp_cSEP, ptext SLIT("dflt")]
-
-pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("NULL")
--- used to be stg_error_entry but Windows can't have DLL entry points as static
--- initialisers, and besides, this ShouldNeverHappen, right?
-
-pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("stg_upd_frame_info")
-pprCLbl (RtsLabel RtsSeqInfo) = ptext SLIT("stg_seq_frame_info")
-pprCLbl (RtsLabel RtsMainCapability) = ptext SLIT("MainCapability")
-pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
-pprCLbl (RtsLabel (Rts_Closure str)) = text str
-pprCLbl (RtsLabel (Rts_Info str)) = text str
-pprCLbl (RtsLabel (Rts_Code str)) = text str
-
-pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
-
-pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
-
-pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
- = hcat [ptext SLIT("stg_sel_"), text (show offset),
- ptext (if upd_reqd
- then SLIT("_upd_info")
- else SLIT("_noupd_info"))
- ]
-
-pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
- = hcat [ptext SLIT("stg_sel_"), text (show offset),
- ptext (if upd_reqd
- then SLIT("_upd_entry")
- else SLIT("_noupd_entry"))
- ]
-
-pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
- = hcat [ptext SLIT("stg_ap_"), text (show arity),
- ptext (if upd_reqd
- then SLIT("_upd_info")
- else SLIT("_noupd_info"))
- ]
-
-pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
- = hcat [ptext SLIT("stg_ap_"), text (show arity),
- ptext (if upd_reqd
- then SLIT("_upd_entry")
- else SLIT("_noupd_entry"))
- ]
-
-pprCLbl (RtsLabel (RtsApplyInfoLabel fs))
- = ptext SLIT("stg_ap_") <> ptext fs <> ptext SLIT("_info")
-
-pprCLbl (RtsLabel (RtsApplyEntryLabel fs))
- = ptext SLIT("stg_ap_") <> ptext fs <> ptext SLIT("_ret")
-
-pprCLbl (RtsLabel (RtsPrimOp primop))
- = ppr primop <> ptext SLIT("_fast")
-
-pprCLbl (RtsLabel RtsModuleRegd)
- = ptext SLIT("module_registered")
-
-pprCLbl (ForeignLabel str _)
- = ftext str
-
-pprCLbl (TyConLabel tc)
- = hcat [ppr tc, pp_cSEP, ptext SLIT("closure_tbl")]
-
-pprCLbl (IdLabel id flavor) = ppr id <> ppIdFlavor flavor
-pprCLbl (DataConLabel con flavor) = ppr con <> ppConFlavor flavor
-
-pprCLbl (CC_Label cc) = ppr cc
-pprCLbl (CCS_Label ccs) = ppr ccs
-
-pprCLbl (ModuleInitLabel mod way)
- = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
- <> char '_' <> text way
-pprCLbl (PlainModuleInitLabel mod)
- = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
-
-ppIdFlavor :: IdLabelInfo -> SDoc
-
-ppIdFlavor x = pp_cSEP <>
- (case x of
- Closure -> ptext SLIT("closure")
- SRT -> ptext SLIT("srt")
- SRTDesc -> ptext SLIT("srtd")
- InfoTbl -> ptext SLIT("info")
- Entry -> ptext SLIT("entry")
- Slow -> ptext SLIT("slow")
- RednCounts -> ptext SLIT("ct")
- Bitmap -> ptext SLIT("btm")
- )
-
-ppConFlavor x = pp_cSEP <>
- (case x of
- ConEntry -> ptext SLIT("con_entry")
- ConInfoTbl -> ptext SLIT("con_info")
- StaticConEntry -> ptext SLIT("static_entry")
- StaticInfoTbl -> ptext SLIT("static_info")
- )
-\end{code}
+++ /dev/null
-This module deals with printing C string literals
-
-\begin{code}
-module CStrings(
- CLabelString, isCLabelString, pprCLabelString,
-
- pp_cSEP,
-
- pprFSInCStyle, pprStringInCStyle
- ) where
-
-#include "HsVersions.h"
-
-import Char ( ord, chr, isAlphaNum )
-import FastString
-import Outputable
-\end{code}
-
-
-\begin{code}
-type CLabelString = FastString -- A C label, completely unencoded
-
-pprCLabelString :: CLabelString -> SDoc
-pprCLabelString lbl = ftext lbl
-
-isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
-isCLabelString lbl
- = all ok (unpackFS lbl)
- where
- ok c = isAlphaNum c || c == '_' || c == '.'
- -- The '.' appears in e.g. "foo.so" in the
- -- module part of a ExtName. Maybe it should be separate
-
-pp_cSEP = char '_'
-\end{code}
-
-\begin{code}
-pprFSInCStyle :: FastString -> SDoc
--- Assumes it contains only characters '\0'..'\xFF'!
-pprFSInCStyle fs = pprStringInCStyle (unpackFS fs)
-
-pprStringInCStyle :: String -> SDoc
-pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
-
-charToC :: Char -> String
-charToC '\"' = "\\\""
-charToC '\'' = "\\\'"
-charToC '\\' = "\\\\"
-charToC c | c >= ' ' && c <= '~' = [c]
- | c > '\xFF' = panic ("charToC "++show c)
- | otherwise = ['\\',
- chr (ord '0' + ord c `div` 64),
- chr (ord '0' + ord c `div` 8 `mod` 8),
- chr (ord '0' + ord c `mod` 8)]
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-% $Id: Costs.lhs,v 1.33 2003/07/28 16:05:30 simonmar Exp $
-%
-% Only needed in a GranSim setup -- HWL
-% ---------------------------------------------------------------------------
-
-\section[Costs]{Evaluating the costs of computing some abstract C code}
-
-This module provides all necessary functions for computing for a given
-abstract~C Program the costs of executing that program. This is done by the
-exported function:
-
-\begin{quote}
- {\verb type CostRes = (Int, Int, Int, Int, Int)}
- {\verb costs :: AbstractC -> CostRes }
-\end{quote}
-
-The meaning of the result tuple is:
-\begin{itemize}
- \item The first component ({\tt i}) counts the number of integer,
- arithmetic and bit-manipulating instructions.
- \item The second component ({\tt b}) counts the number of branches (direct
- branches as well as indirect ones).
- \item The third component ({\tt l}) counts the number of load instructions.
- \item The fourth component ({\tt s}) counts the number of store
- instructions.
- \item The fifth component ({\tt f}) counts the number of floating point
- instructions.
-\end{itemize}
-
-This function is needed in GranSim for costing pieces of abstract C.
-
-These are first suggestions for scaling the costs. But, this scaling should
-be done in the RTS rather than the compiler (this really should be
-tunable!):
-
-\begin{pseudocode}
-
-#define LOAD_COSTS 2
-#define STORE_COSTS 2
-#define INT_ARITHM_COSTS 1
-#define GMP_ARITHM_COSTS 3 {- any clue for GMP costs ? -}
-#define FLOAT_ARITHM_COSTS 3 {- any clue for float costs ? -}
-#define BRANCH_COSTS 2
-
-\end{pseudocode}
-
-\begin{code}
-#define ACCUM_COSTS(i,b,l,s,f) (i+b+l+s+f)
-
-#define NUM_REGS 10 {- PprAbsCSyn.lhs -} {- runtime/c-as-asm/CallWrap_C.lc -}
-#define RESTORE_COSTS (Cost (0, 0, NUM_REGS, 0, 0) :: CostRes)
-#define SAVE_COSTS (Cost (0, 0, 0, NUM_REGS, 0) :: CostRes)
-#define CCALL_COSTS_GUESS (Cost (50, 0, 0, 0, 0) :: CostRes)
-
-module Costs( costs,
- addrModeCosts, CostRes(Cost), nullCosts, Side(..)
- ) where
-
-#include "HsVersions.h"
-
-import AbsCSyn
-import StgSyn ( StgOp(..) )
-import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
-import Panic ( trace )
-
--- --------------------------------------------------------------------------
-data CostRes = Cost (Int, Int, Int, Int, Int)
- deriving (Show)
-
-nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes
-initHdrCosts = Cost (2, 0, 0, 1, 0) :: CostRes
-
-instance Eq CostRes where
- (==) t1 t2 = i && b && l && s && f
- where (i,b,l,s,f) = binOp' (==) t1 t2
-
-instance Num CostRes where
- (+) = binOp (+)
- (-) = binOp (-)
- (*) = binOp (*)
- negate = mapOp negate
- abs = mapOp abs
- signum = mapOp signum
- fromInteger _ = error "fromInteger not defined"
-
-mapOp :: (Int -> Int) -> CostRes -> CostRes
-mapOp g ( Cost (i, b, l, s, f) ) = Cost (g i, g b, g l, g s, g f)
-
-binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes
-binOp o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) =
- ( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) )
-
-binOp' :: (Int -> Int -> a) -> CostRes -> CostRes -> (a,a,a,a,a)
-binOp' o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) =
- (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2)
-
--- --------------------------------------------------------------------------
-
-data Side = Lhs | Rhs
- deriving (Eq)
-
--- --------------------------------------------------------------------------
-
-costs :: AbstractC -> CostRes
-
-costs absC =
- case absC of
- AbsCNop -> nullCosts
-
- AbsCStmts absC1 absC2 -> costs absC1 + costs absC2
-
- CAssign (CReg _) (CReg _) -> Cost (1,0,0,0,0) -- typ.: mov %reg1,%reg2
-
- CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0)
-
- CAssign (CReg _) source_m -> addrModeCosts source_m Rhs
-
- CAssign target_m source_m -> addrModeCosts target_m Lhs +
- addrModeCosts source_m Rhs
-
- CJump (CLbl _ _) -> Cost (0,1,0,0,0) -- no ld for call necessary
-
- CJump mode -> addrModeCosts mode Rhs +
- Cost (0,1,0,0,0)
-
- CFallThrough mode -> addrModeCosts mode Rhs + -- chu' 0.24
- Cost (0,1,0,0,0)
-
- CReturn mode info -> case info of
- DirectReturn -> addrModeCosts mode Rhs +
- Cost (0,1,0,0,0)
-
- -- i.e. ld address to reg and call reg
-
- DynamicVectoredReturn mode' ->
- addrModeCosts mode Rhs +
- addrModeCosts mode' Rhs +
- Cost (0,1,1,0,0)
-
- {- generates code like this:
- JMP_(<mode>)[RVREL(<mode'>)];
- i.e. 1 possb ld for mode'
- 1 ld for RVREL
- 1 possb ld for mode
- 1 call -}
-
- StaticVectoredReturn _ -> addrModeCosts mode Rhs +
- Cost (0,1,1,0,0)
-
- -- as above with mode' fixed to CLit
- -- typically 2 ld + 1 call; 1st ld due
- -- to CVal as mode
-
- CSwitch mode alts absC -> nullCosts
- {- for handling costs of all branches of
- a CSwitch see PprAbsC.
- Basically:
- Costs for branch =
- Costs before CSwitch +
- addrModeCosts of head +
- Costs for 1 cond branch +
- Costs for body of branch
- -}
-
- CCodeBlock _ absC -> costs absC
-
- CInitHdr cl_info reg_rel cost_centre _ -> initHdrCosts
-
- {- This is more fancy but superflous: The addr modes
- are fixed and so the costs are const!
-
- argCosts + initHdrCosts
- where argCosts = addrModeCosts (CAddr reg_rel) Rhs +
- addrModeCosts base_lbl + -- CLbl!
- 3*addrModeCosts (mkIntCLit 1{- any val -})
- -}
- {- this extends to something like
- SET_SPEC_HDR(...)
- For costing the args of this macro
- see PprAbsC.lhs where args are inserted -}
-
- COpStmt modes_res op modes_args _ ->
- {-
- let
- n = length modes_res
- in
- (0, 0, n, n, 0) +
- primOpCosts primOp +
- if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
- else nullCosts
- -- ^^HWL
- -}
- foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res] +
- foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args] +
- opCosts op
-
- CSimultaneous absC -> costs absC
-
- CCheck _ amodes code -> Cost (2, 1, 0, 0, 0) -- ToDo: refine this by
- -- looking at the first arg
-
- CRetDirect _ _ _ _ -> nullCosts
-
- CMacroStmt macro modes -> stmtMacroCosts macro modes
-
- CCallProfCtrMacro _ _ -> nullCosts
- {- we don't count profiling in GrAnSim -}
-
- CCallProfCCMacro _ _ -> nullCosts
- {- we don't count profiling in GrAnSim -}
-
- -- *** the next three [or so...] are DATA (those above are CODE) ***
- -- as they are data rather than code they all have nullCosts -- HWL
-
- CCallTypedef _ _ _ _ _ -> nullCosts
-
- CStaticClosure _ _ _ _ -> nullCosts
-
- CSRT _ _ -> nullCosts
-
- CBitmap _ -> nullCosts
-
- CClosureInfoAndCode _ _ -> nullCosts
-
- CRetVector _ _ _ _ -> nullCosts
-
- CClosureTbl _ -> nullCosts
-
- CCostCentreDecl _ _ -> nullCosts
-
- CCostCentreStackDecl _ -> nullCosts
-
- CSplitMarker -> nullCosts
-
- _ -> trace ("Costs.costs") nullCosts
-
-
--- ---------------------------------------------------------------------------
-
-addrModeCosts :: CAddrMode -> Side -> CostRes
-
--- addrModeCosts _ _ = nullCosts
-
-addrModeCosts addr_mode side =
- let
- lhs = side == Lhs
- in
- case addr_mode of
- CVal _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
-
- CAddr (CIndex _ n _ ) -> Cost (1, 0, 1, 0, 0) -- does pointer arithmetic
-
- CAddr _ -> nullCosts
-
- CReg _ -> nullCosts {- loading from, storing to reg is free ! -}
- {- for costing CReg->Creg ops see special -}
- {- case in costs fct -}
-
- CTemp _ _ -> nullCosts {- if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0) -}
- -- ``Temporaries'' correspond to local variables in C, and registers in
- -- native code.
- -- I assume they can be somewhat optimized by gcc -- HWL
-
- CLbl _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (2, 0, 0, 0, 0)
- -- Rhs: typically: sethi %hi(lbl),%tmp_reg
- -- or %tmp_reg,%lo(lbl),%target_reg
-
- -- Check the following 3 (checked form CLit on)
-
- CCharLike mode -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
-
- CIntLike mode -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
-
- CLit _ -> if lhs then nullCosts -- should never occur
- else Cost (1, 0, 0, 0, 0) -- typ.: mov lit,%reg
-
- CJoinPoint _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
-
- CMacroExpr _ macro mode_list -> exprMacroCosts side macro mode_list
-
--- ---------------------------------------------------------------------------
-
-exprMacroCosts :: Side -> CExprMacro -> [CAddrMode] -> CostRes
-
-exprMacroCosts side macro mode_list =
- let
- arg_costs = foldl (+) nullCosts
- (map (\ x -> addrModeCosts x Rhs) mode_list)
- in
- arg_costs +
- case macro of
- ENTRY_CODE -> nullCosts -- nothing
- ARG_TAG -> nullCosts -- nothing
- GET_TAG -> Cost (0, 0, 1, 0, 0) -- indirect load
-
--- ---------------------------------------------------------------------------
-
-stmtMacroCosts :: CStmtMacro -> [CAddrMode] -> CostRes
-
-stmtMacroCosts macro modes =
- case macro of
- UPD_CAF -> Cost (7, 0, 1, 3, 0) {- SMupdate.lh -}
- UPD_BH_UPDATABLE -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
- UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
- PUSH_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- Updates.h -}
- SET_TAG -> nullCosts {- COptRegs.lh -}
- GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -}
- GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
- GRAN_FETCH_AND_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
- GRAN_YIELD -> nullCosts {- GrAnSim bookkeeping -- added SOF -}
- THREAD_CONTEXT_SWITCH -> nullCosts {- GrAnSim bookkeeping -}
- _ -> trace ("Costs.stmtMacroCosts") nullCosts
-
--- ---------------------------------------------------------------------------
-
-floatOps :: [PrimOp]
-floatOps =
- [ FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp
- , DoubleGtOp , DoubleGeOp , DoubleEqOp , DoubleNeOp , DoubleLtOp , DoubleLeOp
- , FloatAddOp , FloatSubOp , FloatMulOp , FloatDivOp , FloatNegOp
- , Float2IntOp , Int2FloatOp
- , FloatExpOp , FloatLogOp , FloatSqrtOp
- , FloatSinOp , FloatCosOp , FloatTanOp
- , FloatAsinOp , FloatAcosOp , FloatAtanOp
- , FloatSinhOp , FloatCoshOp , FloatTanhOp
- , FloatPowerOp
- , DoubleAddOp , DoubleSubOp , DoubleMulOp , DoubleDivOp , DoubleNegOp
- , Double2IntOp , Int2DoubleOp
- , Double2FloatOp , Float2DoubleOp
- , DoubleExpOp , DoubleLogOp , DoubleSqrtOp
- , DoubleSinOp , DoubleCosOp , DoubleTanOp
- , DoubleAsinOp , DoubleAcosOp , DoubleAtanOp
- , DoubleSinhOp , DoubleCoshOp , DoubleTanhOp
- , DoublePowerOp
- , FloatDecodeOp
- , DoubleDecodeOp
- ]
-
-gmpOps :: [PrimOp]
-gmpOps =
- [ IntegerAddOp , IntegerSubOp , IntegerMulOp
- , IntegerQuotRemOp , IntegerDivModOp
- , IntegerCmpOp
- , Integer2IntOp , Int2IntegerOp
- ]
-
-
-umul_costs = Cost (21,4,0,0,0) -- due to spy counts
-rem_costs = Cost (30,15,0,0,0) -- due to spy counts
-div_costs = Cost (30,15,0,0,0) -- due to spy counts
-
-
-
--- ---------------------------------------------------------------------------
-
-opCosts :: StgOp -> CostRes
-
-opCosts (StgFCallOp _ _) = SAVE_COSTS + RESTORE_COSTS
- -- Don't guess costs of ccall proper
- -- for exact costing use a GRAN_EXEC in the C code
-
-opCosts (StgPrimOp primop)
- = primOpCosts primop +
- if primOpNeedsWrapper primop then SAVE_COSTS + RESTORE_COSTS
- else nullCosts
-
-primOpCosts :: PrimOp -> CostRes
-
--- Usually 3 mov instructions are needed to get args and res in right place.
-primOpCosts IntMulOp = Cost (3, 1, 0, 0, 0) + umul_costs
-primOpCosts IntQuotOp = Cost (3, 1, 0, 0, 0) + div_costs
-primOpCosts IntRemOp = Cost (3, 1, 0, 0, 0) + rem_costs
-primOpCosts IntNegOp = Cost (1, 1, 0, 0, 0) -- translates into 1 sub
-
-primOpCosts FloatGtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-primOpCosts FloatGeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-primOpCosts FloatEqOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp
-primOpCosts FloatNeOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp
-primOpCosts FloatLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-primOpCosts FloatLeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-primOpCosts DoubleGtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-primOpCosts DoubleGeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-primOpCosts DoubleEqOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp
-primOpCosts DoubleNeOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp
-primOpCosts DoubleLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-primOpCosts DoubleLeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-
-primOpCosts FloatExpOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatLogOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatSqrtOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatSinOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatCosOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatTanOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatAsinOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatAcosOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatAtanOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatSinhOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatCoshOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatTanhOp = Cost (2, 1, 4, 4, 3)
---primOpCosts FloatAsinhOp = Cost (2, 1, 4, 4, 3)
---primOpCosts FloatAcoshOp = Cost (2, 1, 4, 4, 3)
---primOpCosts FloatAtanhOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatPowerOp = Cost (2, 1, 4, 4, 3)
-
-{- There should be special handling of the Array PrimOps in here HWL -}
-
-primOpCosts primOp
- | primOp `elem` floatOps = Cost (0, 0, 0, 0, 1) :: CostRes
- | primOp `elem` gmpOps = Cost (30, 5, 10, 10, 0) :: CostRes -- GUESS; check it
- | otherwise = Cost (1, 0, 0, 0, 0)
-
-\end{code}
+++ /dev/null
-
-module MachOp ( MachOp(..), pprMachOp,
- isDefinitelyInlineMachOp,
- isCommutableMachOp,
- isComparisonMachOp,
- resultRepOfMachOp
- )
-where
-
-#include "HsVersions.h"
-
-import PrimRep ( PrimRep(..) )
-import Outputable
-
-
-{- Machine-level primops; ones which we can reasonably delegate to the
- native code generators to handle. Basically contains C's primops
- and no others.
-
- Nomenclature: all ops indicate width and signedness, where
- appropriate. Widths: 8/16/32/64 means the given size, obviously.
- Nat means the operation works on STG word sized objects.
- Signedness: S means signed, U means unsigned. For operations where
- signedness is irrelevant or makes no difference (for example
- integer add), the signedness component is omitted.
-
- An exception: NatP is a ptr-typed native word. From the point of
- view of the native code generators this distinction is irrelevant,
- but the C code generator sometimes needs this info to emit the
- right casts.
--}
-
-data MachOp
-
- -- OPS at the native word size
- = MO_Nat_Add -- +
- | MO_Nat_Sub -- -
- | MO_Nat_Eq
- | MO_Nat_Ne
-
- | MO_NatS_Ge
- | MO_NatS_Le
- | MO_NatS_Gt
- | MO_NatS_Lt
-
- | MO_NatU_Ge
- | MO_NatU_Le
- | MO_NatU_Gt
- | MO_NatU_Lt
-
- | MO_NatS_Mul -- low word of signed *
- | MO_NatS_MulMayOflo -- nonzero if high word of signed * might contain useful info
- | MO_NatS_Quot -- signed / (same semantics as IntQuotOp)
- | MO_NatS_Rem -- signed % (same semantics as IntRemOp)
- | MO_NatS_Neg -- unary -
-
- | MO_NatU_Mul -- low word of unsigned *
- | MO_NatU_Quot -- unsigned / (same semantics as WordQuotOp)
- | MO_NatU_Rem -- unsigned % (same semantics as WordRemOp)
-
- | MO_Nat_And
- | MO_Nat_Or
- | MO_Nat_Xor
- | MO_Nat_Not
- | MO_Nat_Shl
- | MO_Nat_Shr
- | MO_Nat_Sar
-
- -- OPS at 32 bits regardless of word size
- | MO_32U_Eq
- | MO_32U_Ne
- | MO_32U_Ge
- | MO_32U_Le
- | MO_32U_Gt
- | MO_32U_Lt
-
- -- IEEE754 Double ops
- | MO_Dbl_Eq
- | MO_Dbl_Ne
- | MO_Dbl_Ge
- | MO_Dbl_Le
- | MO_Dbl_Gt
- | MO_Dbl_Lt
-
- | MO_Dbl_Add
- | MO_Dbl_Sub
- | MO_Dbl_Mul
- | MO_Dbl_Div
- | MO_Dbl_Pwr
-
- | MO_Dbl_Sin
- | MO_Dbl_Cos
- | MO_Dbl_Tan
- | MO_Dbl_Sinh
- | MO_Dbl_Cosh
- | MO_Dbl_Tanh
- | MO_Dbl_Asin
- | MO_Dbl_Acos
- | MO_Dbl_Atan
- | MO_Dbl_Log
- | MO_Dbl_Exp
- | MO_Dbl_Sqrt
- | MO_Dbl_Neg
-
- -- IEEE754 Float ops
- | MO_Flt_Add
- | MO_Flt_Sub
- | MO_Flt_Mul
- | MO_Flt_Div
- | MO_Flt_Pwr
-
- | MO_Flt_Eq
- | MO_Flt_Ne
- | MO_Flt_Ge
- | MO_Flt_Le
- | MO_Flt_Gt
- | MO_Flt_Lt
-
- | MO_Flt_Sin
- | MO_Flt_Cos
- | MO_Flt_Tan
- | MO_Flt_Sinh
- | MO_Flt_Cosh
- | MO_Flt_Tanh
- | MO_Flt_Asin
- | MO_Flt_Acos
- | MO_Flt_Atan
- | MO_Flt_Log
- | MO_Flt_Exp
- | MO_Flt_Neg
- | MO_Flt_Sqrt
-
- -- Conversions. Some of these are NOPs, in which case they
- -- are here usually to placate the C code generator.
- | MO_32U_to_NatS
- | MO_NatS_to_32U
-
- | MO_NatS_to_Dbl
- | MO_Dbl_to_NatS
-
- | MO_NatS_to_Flt
- | MO_Flt_to_NatS
-
- | MO_NatS_to_NatU
- | MO_NatU_to_NatS
-
- | MO_NatS_to_NatP
- | MO_NatP_to_NatS
- | MO_NatU_to_NatP
- | MO_NatP_to_NatU
-
- | MO_Dbl_to_Flt
- | MO_Flt_to_Dbl
-
- | MO_8S_to_NatS
- | MO_16S_to_NatS
- | MO_32S_to_NatS
- | MO_8U_to_NatU
- | MO_16U_to_NatU
- | MO_32U_to_NatU
-
- | MO_8U_to_32U -- zero extend
- | MO_32U_to_8U -- mask out all but lowest byte
-
- deriving Eq
-
-
-
--- Almost, but not quite == text . derived show
-pprMachOp :: MachOp -> SDoc
-
-pprMachOp MO_Nat_Add = text "MO_Nat_Add"
-pprMachOp MO_Nat_Sub = text "MO_Nat_Sub"
-pprMachOp MO_Nat_Eq = text "MO_Nat_Eq"
-pprMachOp MO_Nat_Ne = text "MO_Nat_Ne"
-
-pprMachOp MO_NatS_Ge = text "MO_NatS_Ge"
-pprMachOp MO_NatS_Le = text "MO_NatS_Le"
-pprMachOp MO_NatS_Gt = text "MO_NatS_Gt"
-pprMachOp MO_NatS_Lt = text "MO_NatS_Lt"
-
-pprMachOp MO_NatU_Ge = text "MO_NatU_Ge"
-pprMachOp MO_NatU_Le = text "MO_NatU_Le"
-pprMachOp MO_NatU_Gt = text "MO_NatU_Gt"
-pprMachOp MO_NatU_Lt = text "MO_NatU_Lt"
-
-pprMachOp MO_NatS_Mul = text "MO_NatS_Mul"
-pprMachOp MO_NatS_MulMayOflo = text "MO_NatS_MulMayOflo"
-pprMachOp MO_NatS_Quot = text "MO_NatS_Quot"
-pprMachOp MO_NatS_Rem = text "MO_NatS_Rem"
-pprMachOp MO_NatS_Neg = text "MO_NatS_Neg"
-
-pprMachOp MO_NatU_Mul = text "MO_NatU_Mul"
-pprMachOp MO_NatU_Quot = text "MO_NatU_Quot"
-pprMachOp MO_NatU_Rem = text "MO_NatU_Rem"
-
-pprMachOp MO_Nat_And = text "MO_Nat_And"
-pprMachOp MO_Nat_Or = text "MO_Nat_Or"
-pprMachOp MO_Nat_Xor = text "MO_Nat_Xor"
-pprMachOp MO_Nat_Not = text "MO_Nat_Not"
-pprMachOp MO_Nat_Shl = text "MO_Nat_Shl"
-pprMachOp MO_Nat_Shr = text "MO_Nat_Shr"
-pprMachOp MO_Nat_Sar = text "MO_Nat_Sar"
-
-pprMachOp MO_32U_Eq = text "MO_32U_Eq"
-pprMachOp MO_32U_Ne = text "MO_32U_Ne"
-pprMachOp MO_32U_Ge = text "MO_32U_Ge"
-pprMachOp MO_32U_Le = text "MO_32U_Le"
-pprMachOp MO_32U_Gt = text "MO_32U_Gt"
-pprMachOp MO_32U_Lt = text "MO_32U_Lt"
-
-pprMachOp MO_Dbl_Eq = text "MO_Dbl_Eq"
-pprMachOp MO_Dbl_Ne = text "MO_Dbl_Ne"
-pprMachOp MO_Dbl_Ge = text "MO_Dbl_Ge"
-pprMachOp MO_Dbl_Le = text "MO_Dbl_Le"
-pprMachOp MO_Dbl_Gt = text "MO_Dbl_Gt"
-pprMachOp MO_Dbl_Lt = text "MO_Dbl_Lt"
-
-pprMachOp MO_Dbl_Add = text "MO_Dbl_Add"
-pprMachOp MO_Dbl_Sub = text "MO_Dbl_Sub"
-pprMachOp MO_Dbl_Mul = text "MO_Dbl_Mul"
-pprMachOp MO_Dbl_Div = text "MO_Dbl_Div"
-pprMachOp MO_Dbl_Pwr = text "MO_Dbl_Pwr"
-
-pprMachOp MO_Dbl_Sin = text "MO_Dbl_Sin"
-pprMachOp MO_Dbl_Cos = text "MO_Dbl_Cos"
-pprMachOp MO_Dbl_Tan = text "MO_Dbl_Tan"
-pprMachOp MO_Dbl_Sinh = text "MO_Dbl_Sinh"
-pprMachOp MO_Dbl_Cosh = text "MO_Dbl_Cosh"
-pprMachOp MO_Dbl_Tanh = text "MO_Dbl_Tanh"
-pprMachOp MO_Dbl_Asin = text "MO_Dbl_Asin"
-pprMachOp MO_Dbl_Acos = text "MO_Dbl_Acos"
-pprMachOp MO_Dbl_Atan = text "MO_Dbl_Atan"
-pprMachOp MO_Dbl_Log = text "MO_Dbl_Log"
-pprMachOp MO_Dbl_Exp = text "MO_Dbl_Exp"
-pprMachOp MO_Dbl_Sqrt = text "MO_Dbl_Sqrt"
-pprMachOp MO_Dbl_Neg = text "MO_Dbl_Neg"
-
-pprMachOp MO_Flt_Add = text "MO_Flt_Add"
-pprMachOp MO_Flt_Sub = text "MO_Flt_Sub"
-pprMachOp MO_Flt_Mul = text "MO_Flt_Mul"
-pprMachOp MO_Flt_Div = text "MO_Flt_Div"
-pprMachOp MO_Flt_Pwr = text "MO_Flt_Pwr"
-
-pprMachOp MO_Flt_Eq = text "MO_Flt_Eq"
-pprMachOp MO_Flt_Ne = text "MO_Flt_Ne"
-pprMachOp MO_Flt_Ge = text "MO_Flt_Ge"
-pprMachOp MO_Flt_Le = text "MO_Flt_Le"
-pprMachOp MO_Flt_Gt = text "MO_Flt_Gt"
-pprMachOp MO_Flt_Lt = text "MO_Flt_Lt"
-
-pprMachOp MO_Flt_Sin = text "MO_Flt_Sin"
-pprMachOp MO_Flt_Cos = text "MO_Flt_Cos"
-pprMachOp MO_Flt_Tan = text "MO_Flt_Tan"
-pprMachOp MO_Flt_Sinh = text "MO_Flt_Sinh"
-pprMachOp MO_Flt_Cosh = text "MO_Flt_Cosh"
-pprMachOp MO_Flt_Tanh = text "MO_Flt_Tanh"
-pprMachOp MO_Flt_Asin = text "MO_Flt_Asin"
-pprMachOp MO_Flt_Acos = text "MO_Flt_Acos"
-pprMachOp MO_Flt_Atan = text "MO_Flt_Atan"
-pprMachOp MO_Flt_Log = text "MO_Flt_Log"
-pprMachOp MO_Flt_Exp = text "MO_Flt_Exp"
-pprMachOp MO_Flt_Sqrt = text "MO_Flt_Sqrt"
-pprMachOp MO_Flt_Neg = text "MO_Flt_Neg"
-
-pprMachOp MO_32U_to_NatS = text "MO_32U_to_NatS"
-pprMachOp MO_NatS_to_32U = text "MO_NatS_to_32U"
-
-pprMachOp MO_NatS_to_Dbl = text "MO_NatS_to_Dbl"
-pprMachOp MO_Dbl_to_NatS = text "MO_Dbl_to_NatS"
-
-pprMachOp MO_NatS_to_Flt = text "MO_NatS_to_Flt"
-pprMachOp MO_Flt_to_NatS = text "MO_Flt_to_NatS"
-
-pprMachOp MO_NatS_to_NatU = text "MO_NatS_to_NatU"
-pprMachOp MO_NatU_to_NatS = text "MO_NatU_to_NatS"
-
-pprMachOp MO_NatS_to_NatP = text "MO_NatS_to_NatP"
-pprMachOp MO_NatP_to_NatS = text "MO_NatP_to_NatS"
-pprMachOp MO_NatU_to_NatP = text "MO_NatU_to_NatP"
-pprMachOp MO_NatP_to_NatU = text "MO_NatP_to_NatU"
-
-pprMachOp MO_Dbl_to_Flt = text "MO_Dbl_to_Flt"
-pprMachOp MO_Flt_to_Dbl = text "MO_Flt_to_Dbl"
-
-pprMachOp MO_8S_to_NatS = text "MO_8S_to_NatS"
-pprMachOp MO_16S_to_NatS = text "MO_16S_to_NatS"
-pprMachOp MO_32S_to_NatS = text "MO_32S_to_NatS"
-
-pprMachOp MO_8U_to_NatU = text "MO_8U_to_NatU"
-pprMachOp MO_16U_to_NatU = text "MO_16U_to_NatU"
-pprMachOp MO_32U_to_NatU = text "MO_32U_to_NatU"
-
-pprMachOp MO_8U_to_32U = text "MO_8U_to_32U"
-pprMachOp MO_32U_to_8U = text "MO_32U_to_8U"
-
-
-
--- Non-exported helper enumeration:
-data MO_Prop
- = MO_Commutable
- | MO_DefinitelyInline
- | MO_Comparison
- deriving Eq
-
-comm = MO_Commutable
-inline = MO_DefinitelyInline
-comp = MO_Comparison
-
-
--- If in doubt, return False. This generates worse code on the
--- via-C route, but has no effect on the native code routes.
--- Remember that claims about definitely inline have to be true
--- regardless of what the C compiler does, so we need to be
--- careful about boundary cases like sqrt which are sometimes
--- implemented in software and sometimes in hardware.
-isDefinitelyInlineMachOp :: MachOp -> Bool
-isDefinitelyInlineMachOp mop = inline `elem` snd (machOpProps mop)
-
--- If in doubt, return False. This generates worse code on the
--- native routes, but is otherwise harmless.
-isCommutableMachOp :: MachOp -> Bool
-isCommutableMachOp mop = comm `elem` snd (machOpProps mop)
-
--- If in doubt, return False. This generates worse code on the
--- native routes, but is otherwise harmless.
-isComparisonMachOp :: MachOp -> Bool
-isComparisonMachOp mop = comp `elem` snd (machOpProps mop)
-
--- Find the PrimRep for the returned value of the MachOp.
-resultRepOfMachOp :: MachOp -> PrimRep
-resultRepOfMachOp mop = fst (machOpProps mop)
-
--- This bit does the real work.
-machOpProps :: MachOp -> (PrimRep, [MO_Prop])
-
-machOpProps MO_Nat_Add = (IntRep, [inline, comm])
-machOpProps MO_Nat_Sub = (IntRep, [inline])
-machOpProps MO_Nat_Eq = (IntRep, [inline, comp, comm])
-machOpProps MO_Nat_Ne = (IntRep, [inline, comp, comm])
-
-machOpProps MO_NatS_Ge = (IntRep, [inline, comp])
-machOpProps MO_NatS_Le = (IntRep, [inline, comp])
-machOpProps MO_NatS_Gt = (IntRep, [inline, comp])
-machOpProps MO_NatS_Lt = (IntRep, [inline, comp])
-
-machOpProps MO_NatU_Ge = (IntRep, [inline, comp])
-machOpProps MO_NatU_Le = (IntRep, [inline, comp])
-machOpProps MO_NatU_Gt = (IntRep, [inline, comp])
-machOpProps MO_NatU_Lt = (IntRep, [inline, comp])
-
-machOpProps MO_NatS_Mul = (IntRep, [inline, comm])
-machOpProps MO_NatS_MulMayOflo = (IntRep, [inline, comm])
-machOpProps MO_NatS_Quot = (IntRep, [inline])
-machOpProps MO_NatS_Rem = (IntRep, [inline])
-machOpProps MO_NatS_Neg = (IntRep, [inline])
-
-machOpProps MO_NatU_Mul = (WordRep, [inline, comm])
-machOpProps MO_NatU_Quot = (WordRep, [inline])
-machOpProps MO_NatU_Rem = (WordRep, [inline])
-
-machOpProps MO_Nat_And = (IntRep, [inline, comm])
-machOpProps MO_Nat_Or = (IntRep, [inline, comm])
-machOpProps MO_Nat_Xor = (IntRep, [inline, comm])
-machOpProps MO_Nat_Not = (IntRep, [inline])
-machOpProps MO_Nat_Shl = (IntRep, [inline])
-machOpProps MO_Nat_Shr = (IntRep, [inline])
-machOpProps MO_Nat_Sar = (IntRep, [inline])
-
-machOpProps MO_32U_Eq = (IntRep, [inline, comp, comm])
-machOpProps MO_32U_Ne = (IntRep, [inline, comp, comm])
-machOpProps MO_32U_Ge = (IntRep, [inline, comp])
-machOpProps MO_32U_Le = (IntRep, [inline, comp])
-machOpProps MO_32U_Gt = (IntRep, [inline, comp])
-machOpProps MO_32U_Lt = (IntRep, [inline, comp])
-
-machOpProps MO_Dbl_Eq = (IntRep, [inline, comp, comm])
-machOpProps MO_Dbl_Ne = (IntRep, [inline, comp, comm])
-machOpProps MO_Dbl_Ge = (IntRep, [inline, comp])
-machOpProps MO_Dbl_Le = (IntRep, [inline, comp])
-machOpProps MO_Dbl_Gt = (IntRep, [inline, comp])
-machOpProps MO_Dbl_Lt = (IntRep, [inline, comp])
-
-machOpProps MO_Dbl_Add = (DoubleRep, [inline, comm])
-machOpProps MO_Dbl_Sub = (DoubleRep, [inline])
-machOpProps MO_Dbl_Mul = (DoubleRep, [inline, comm])
-machOpProps MO_Dbl_Div = (DoubleRep, [inline])
-machOpProps MO_Dbl_Pwr = (DoubleRep, [])
-
-machOpProps MO_Dbl_Sin = (DoubleRep, [])
-machOpProps MO_Dbl_Cos = (DoubleRep, [])
-machOpProps MO_Dbl_Tan = (DoubleRep, [])
-machOpProps MO_Dbl_Sinh = (DoubleRep, [])
-machOpProps MO_Dbl_Cosh = (DoubleRep, [])
-machOpProps MO_Dbl_Tanh = (DoubleRep, [])
-machOpProps MO_Dbl_Asin = (DoubleRep, [])
-machOpProps MO_Dbl_Acos = (DoubleRep, [])
-machOpProps MO_Dbl_Atan = (DoubleRep, [])
-machOpProps MO_Dbl_Log = (DoubleRep, [])
-machOpProps MO_Dbl_Exp = (DoubleRep, [])
-machOpProps MO_Dbl_Sqrt = (DoubleRep, [])
-machOpProps MO_Dbl_Neg = (DoubleRep, [inline])
-
-machOpProps MO_Flt_Add = (FloatRep, [inline, comm])
-machOpProps MO_Flt_Sub = (FloatRep, [inline])
-machOpProps MO_Flt_Mul = (FloatRep, [inline, comm])
-machOpProps MO_Flt_Div = (FloatRep, [inline])
-machOpProps MO_Flt_Pwr = (FloatRep, [])
-
-machOpProps MO_Flt_Eq = (IntRep, [inline, comp, comm])
-machOpProps MO_Flt_Ne = (IntRep, [inline, comp, comm])
-machOpProps MO_Flt_Ge = (IntRep, [inline, comp])
-machOpProps MO_Flt_Le = (IntRep, [inline, comp])
-machOpProps MO_Flt_Gt = (IntRep, [inline, comp])
-machOpProps MO_Flt_Lt = (IntRep, [inline, comp])
-
-machOpProps MO_Flt_Sin = (FloatRep, [])
-machOpProps MO_Flt_Cos = (FloatRep, [])
-machOpProps MO_Flt_Tan = (FloatRep, [])
-machOpProps MO_Flt_Sinh = (FloatRep, [])
-machOpProps MO_Flt_Cosh = (FloatRep, [])
-machOpProps MO_Flt_Tanh = (FloatRep, [])
-machOpProps MO_Flt_Asin = (FloatRep, [])
-machOpProps MO_Flt_Acos = (FloatRep, [])
-machOpProps MO_Flt_Atan = (FloatRep, [])
-machOpProps MO_Flt_Log = (FloatRep, [])
-machOpProps MO_Flt_Exp = (FloatRep, [])
-machOpProps MO_Flt_Sqrt = (FloatRep, [])
-machOpProps MO_Flt_Neg = (FloatRep, [inline])
-
-machOpProps MO_32U_to_NatS = (IntRep, [inline])
-machOpProps MO_NatS_to_32U = (Word32Rep, [inline])
-
-machOpProps MO_NatS_to_Dbl = (DoubleRep, [inline])
-machOpProps MO_Dbl_to_NatS = (IntRep, [inline])
-
-machOpProps MO_NatS_to_Flt = (FloatRep, [inline])
-machOpProps MO_Flt_to_NatS = (IntRep, [inline])
-
-machOpProps MO_NatS_to_NatU = (WordRep, [inline])
-machOpProps MO_NatU_to_NatS = (IntRep, [inline])
-
-machOpProps MO_NatS_to_NatP = (PtrRep, [inline])
-machOpProps MO_NatP_to_NatS = (IntRep, [inline])
-machOpProps MO_NatU_to_NatP = (PtrRep, [inline])
-machOpProps MO_NatP_to_NatU = (WordRep, [inline])
-
-machOpProps MO_Dbl_to_Flt = (FloatRep, [inline])
-machOpProps MO_Flt_to_Dbl = (DoubleRep, [inline])
-
-machOpProps MO_8S_to_NatS = (IntRep, [inline])
-machOpProps MO_16S_to_NatS = (IntRep, [inline])
-machOpProps MO_32S_to_NatS = (IntRep, [inline])
-
-machOpProps MO_8U_to_NatU = (WordRep, [inline])
-machOpProps MO_16U_to_NatU = (WordRep, [inline])
-machOpProps MO_32U_to_NatU = (WordRep, [inline])
-
-machOpProps MO_8U_to_32U = (Word32Rep, [inline])
-machOpProps MO_32U_to_8U = (Word8Rep, [inline])
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-%************************************************************************
-%* *
-\section[PprAbsC]{Pretty-printing Abstract~C}
-%* *
-%************************************************************************
-
-\begin{code}
-module PprAbsC (
- writeRealC,
- dumpRealC,
- pprAmode,
- pprMagicId
- ) where
-
-#include "HsVersions.h"
-
-import IO ( Handle )
-
-import PrimRep
-import AbsCSyn
-import ClosureInfo
-import AbsCUtils ( getAmodeRep, nonemptyAbsC,
- mixedPtrLocn, mixedTypeLocn
- )
-
-import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
- playThreadSafe, ccallConvAttribute,
- ForeignCall(..), DNCallSpec(..),
- DNType(..), DNKind(..) )
-import CLabel ( externallyVisibleCLabel,
- needsCDecl, pprCLabel, mkClosureLabel,
- mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
- CLabel, CLabelType(..), labelType, labelDynamic
- )
-
-import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
-import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
-
-import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
-import CStrings ( pprCLabelString )
-import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
-import Literal ( Literal(..) )
-import TyCon ( tyConDataCons )
-import Name ( NamedThing(..) )
-import Maybes ( catMaybes )
-import PrimOp ( primOpNeedsWrapper )
-import MachOp ( MachOp(..) )
-import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
-import Unique ( pprUnique, Unique{-instance NamedThing-} )
-import UniqSet ( emptyUniqSet, elementOfUniqSet,
- addOneToUniqSet, UniqSet
- )
-import StgSyn ( StgOp(..) )
-import Outputable
-import FastString
-import Util ( lengthExceeds )
-
-#if __GLASGOW_HASKELL__ >= 504
-import Data.Array.ST
-#endif
-
-#ifdef DEBUG
-import Util ( listLengthCmp )
-#endif
-
-import Maybe ( isJust )
-import GLAEXTS
-import MONAD_ST
-
-infixr 9 `thenTE`
-\end{code}
-
-For spitting out the costs of an abstract~C expression, @writeRealC@
-now not only prints the C~code of the @absC@ arg but also adds a macro
-call to a cost evaluation function @GRAN_EXEC@. For that,
-@pprAbsC@ has a new ``costs'' argument. %% HWL
-
-\begin{code}
-{-
-writeRealC :: Handle -> AbstractC -> IO ()
-writeRealC handle absC
- -- avoid holding on to the whole of absC in the !Gransim case.
- if opt_GranMacros
- then printForCFast fp (pprAbsC absC (costs absC))
- else printForCFast fp (pprAbsC absC (panic "costs"))
- --printForC handle (pprAbsC absC (panic "costs"))
-dumpRealC :: AbstractC -> SDoc
-dumpRealC absC = pprAbsC absC (costs absC)
--}
-
-writeRealC :: Handle -> AbstractC -> IO ()
---writeRealC handle absC =
--- _scc_ "writeRealC"
--- printDoc LeftMode handle (pprAbsC absC (costs absC))
-
-writeRealC handle absC
- | opt_GranMacros = _scc_ "writeRealC" printForC handle $
- pprCode CStyle (pprAbsC absC (costs absC))
- | otherwise = _scc_ "writeRealC" printForC handle $
- pprCode CStyle (pprAbsC absC (panic "costs"))
-
-dumpRealC :: AbstractC -> SDoc
-dumpRealC absC
- | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC))
- | otherwise = pprCode CStyle (pprAbsC absC (panic "costs"))
-
-\end{code}
-
-This emits the macro, which is used in GrAnSim to compute the total costs
-from a cost 5 tuple. %% HWL
-
-\begin{code}
-emitMacro :: CostRes -> SDoc
-
-emitMacro _ | not opt_GranMacros = empty
-
-emitMacro (Cost (i,b,l,s,f))
- = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
- int i, comma, int b, comma, int l, comma,
- int s, comma, int f, pp_paren_semi ]
-
-pp_paren_semi = text ");"
-\end{code}
-
-New type: Now pprAbsC also takes the costs for evaluating the Abstract C
-code as an argument (that's needed when spitting out the GRAN_EXEC macro
-which must be done before the return i.e. inside absC code) HWL
-
-\begin{code}
-pprAbsC :: AbstractC -> CostRes -> SDoc
-pprAbsC AbsCNop _ = empty
-pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
-
-pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
-
-pprAbsC (CJump target) c
- = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
- (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
-
-pprAbsC (CFallThrough target) c
- = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ])
- (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
-
--- --------------------------------------------------------------------------
--- Spit out GRAN_EXEC macro immediately before the return HWL
-
-pprAbsC (CReturn am return_info) c
- = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ])
- (hcat [text jmp_lit, target, pp_paren_semi ])
- where
- target = case return_info of
- DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen,
- pprAmode am, rparen]
- DynamicVectoredReturn am' -> mk_vector (pprAmode am')
- StaticVectoredReturn n -> mk_vector (int n) -- Always positive
- mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma,
- x, rparen ]
-
-pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER")
-
--- we optimise various degenerate cases of CSwitches.
-
--- --------------------------------------------------------------------------
--- Assume: CSwitch is also end of basic block
--- costs function yields nullCosts for whole switch
--- ==> inherited costs c are those of basic block up to switch
--- ==> inherit c + costs for the corresponding branch
--- HWL
--- --------------------------------------------------------------------------
-
-pprAbsC (CSwitch discrim [] deflt) c
- = pprAbsC deflt (c + costs deflt)
- -- Empty alternative list => no costs for discrim as nothing cond. here HWL
-
-pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt
- = case (nonemptyAbsC deflt) of
- Nothing -> -- one alt and no default
- pprAbsC alt_code (c + costs alt_code)
- -- Nothing conditional in here either HWL
-
- Just dc -> -- make it an "if"
- do_if_stmt discrim tag alt_code dc c
-
--- What problem is the re-ordering trying to solve ?
-pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1),
- (tag2@(MachInt i2), alt_code2)] deflt) c
- | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0))
- = if (i1 == 0) then
- do_if_stmt discrim tag1 alt_code1 alt_code2 c
- else
- do_if_stmt discrim tag2 alt_code2 alt_code1 c
- where
- empty_deflt = not (isJust (nonemptyAbsC deflt))
-
-pprAbsC (CSwitch discrim alts deflt) c -- general case
- | isFloatingRep (getAmodeRep discrim)
- = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
- | otherwise
- = vcat [
- hcat [text "switch (", pp_discrim, text ") {"],
- nest 2 (vcat (map ppr_alt alts)),
- (case (nonemptyAbsC deflt) of
- Nothing -> empty
- Just dc ->
- nest 2 (vcat [ptext SLIT("default:"),
- pprAbsC dc (c + switch_head_cost
- + costs dc),
- ptext SLIT("break;")])),
- char '}' ]
- where
- pp_discrim
- = pprAmode discrim
-
- ppr_alt (lit, absC)
- = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'],
- nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC))
- (ptext SLIT("break;"))) ]
-
- -- Costs for addressing header of switch and cond. branching -- HWL
- switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
-
-pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _
- = pprFCall fcall uniq args results vol_regs
-
-pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _
- = let
- non_void_args = grab_non_void_amodes args
- non_void_results = grab_non_void_amodes results
- -- if just one result, we print in the obvious "assignment" style;
- -- if 0 or many results, we emit a macro call, w/ the results
- -- followed by the arguments. The macro presumably knows which
- -- are which :-)
-
- the_op = ppr_op_call non_void_results non_void_args
- -- liveness mask is *in* the non_void_args
- in
- if primOpNeedsWrapper op then
- case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
- vcat [ pp_saves,
- the_op,
- pp_restores
- ]
- }
- else
- the_op
- where
- ppr_op_call results args
- = hcat [ ppr op, lparen,
- hcat (punctuate comma (map ppr_op_result results)),
- if null results || null args then empty else comma,
- hcat (punctuate comma (map pprAmode args)),
- pp_paren_semi ]
-
- ppr_op_result r = ppr_amode r
- -- primop macros do their own casting of result;
- -- hence we can toss the provided cast...
-
--- NEW CASES FOR EXPANDED PRIMOPS
-
-pprAbsC stmt@(CMachOpStmt res mop [arg1,arg2] maybe_vols) _
- = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo]
- in
- case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
- saves $$
- hcat (
- [ppr_amode res, equals]
- ++ (if prefix_fn
- then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)]
- else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2])
- ++ [semi]
- )
- $$ restores
- }
-
-pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _
- = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
- saves $$
- hcat [ppr_amode res, equals,
- pprMachOp_for_C mop, parens (pprAmode arg1),
- semi]
- $$ restores
- }
-
-pprAbsC stmt@(CSequential stuff) c
- = vcat (map (flip pprAbsC c) stuff)
-
--- end of NEW CASES FOR EXPANDED PRIMOPS
-
-pprAbsC stmt@(CSRT lbl closures) c
- = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- pp_exts
- $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen
- $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
- <> ptext SLIT("};")
- }
-
-pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c
- = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask)
-
-pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c
- = pprWordArray desc_lbl (
- CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) :
- mkWordCLit (fromIntegral len) :
- bitmapAddrModes bitmap
- )
-
-pprAbsC (CSimultaneous abs_c) c
- = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
-
-pprAbsC (CCheck macro as code) c
- = hcat [ptext (cCheckMacroText macro), lparen,
- hcat (punctuate comma (map ppr_amode as)), comma,
- pprAbsC code c, pp_paren_semi
- ]
-pprAbsC (CMacroStmt macro as) _
- = hcat [ptext (cStmtMacroText macro), lparen,
- hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
-pprAbsC (CCallProfCtrMacro op as) _
- = hcat [ftext op, lparen,
- hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC (CCallProfCCMacro op as) _
- = hcat [ftext op, lparen,
- hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
-pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _
- = hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
- , ccall_res_ty
- , fun_nm
- , parens (hsep (punctuate comma ccall_decl_ty_args))
- ] <> semi
- where
- {-
- In the non-casm case, to ensure that we're entering the given external
- entry point using the correct calling convention, we have to do the following:
-
- - When entering via a function pointer (the `dynamic' case) using the specified
- calling convention, we emit a typedefn declaration attributed with the
- calling convention to use together with the result and parameter types we're
- assuming. Coerce the function pointer to this type and go.
-
- - to enter the function at a given code label, we emit an extern declaration
- for the label here, stating the calling convention together with result and
- argument types we're assuming.
-
- The C compiler will hopefully use this extern declaration to good effect,
- reporting any discrepancies between our extern decl and any other that
- may be in scope.
-
- Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for
- the external function `foo' use the calling convention of the first `foo'
- prototype it encounters (nor does it complain about conflicting attribute
- declarations). The consequence of this is that you cannot override the
- calling convention of `foo' using an extern declaration (you'd have to use
- a typedef), but why you would want to do such a thing in the first place
- is totally beyond me.
-
- ToDo: petition the gcc folks to add code to warn about conflicting attribute
- declarations.
-
- -}
-
- fun_nm
- | is_tdef = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
- | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty
-
- ccall_fun_ty =
- case op_str of
- DynamicTarget -> ptext SLIT("_ccall_fun_ty") <> ppr uniq
- StaticTarget x -> pprCLabelString x
-
- ccall_res_ty =
- case non_void_results of
- [] -> ptext SLIT("void")
- [amode] -> ppr (getAmodeRep amode)
- _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
-
- ccall_decl_ty_args
- | is_tdef = tail ccall_arg_tys
- | otherwise = ccall_arg_tys
-
- ccall_arg_tys = map (ppr . getAmodeRep) non_void_args
-
- -- the first argument will be the "I/O world" token (a VoidRep)
- -- all others should be non-void
- non_void_args =
- let nvas = init args
- in ASSERT (all non_void nvas) nvas
-
- -- there will usually be two results: a (void) state which we
- -- should ignore and a (possibly void) result.
- non_void_results =
- let nvrs = grab_non_void_amodes results
- in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
-
-pprAbsC (CCodeBlock lbl abs_C) _
- = if not (isJust(nonemptyAbsC abs_C)) then
- pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty
- else
- case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
- vcat [
- empty,
- pp_exts,
- hcat [text (if (externallyVisibleCLabel lbl)
- then "FN_(" -- abbreviations to save on output
- else "IF_("),
- pprCLabel lbl, text ") {"],
-
- pp_temps,
-
- nest 8 (ptext SLIT("FB_")),
- nest 8 (pprAbsC abs_C (costs abs_C)),
- nest 8 (ptext SLIT("FE_")),
- char '}',
- char ' ' ]
- }
-
-
-pprAbsC (CInitHdr cl_info amode cost_centre size) _
- = hcat [ ptext SLIT("SET_HDR_"), char '(',
- ppr_amode amode, comma,
- pprCLabelAddr info_lbl, comma,
- if_profiling (pprAmode cost_centre), comma,
- if_profiling (int size),
- pp_paren_semi ]
- where
- info_lbl = infoTableLabelFromCI cl_info
-
-
-pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
- = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- vcat [
- pp_exts,
- hcat [
- ptext SLIT("SET_STATIC_HDR"), char '(',
- pprCLabel closure_lbl, comma,
- pprCLabel info_lbl, comma,
- if_profiling (pprAmode cost_centre), comma,
- ppLocalness closure_lbl, comma,
- ppLocalnessMacro True{-include dyn-} info_lbl,
- char ')'
- ],
- nest 2 (ppr_payload amodes),
- ptext SLIT("};") ]
- }
- where
- info_lbl = infoTableLabelFromCI cl_info
-
- ppr_payload [] = empty
- ppr_payload ls =
- comma <+>
- (braces $ hsep $ punctuate comma $
- map (text "(L_)" <>) (foldr ppr_item [] ls))
-
- ppr_item item rest
- | rep == VoidRep = rest
- | rep == FloatRep = ppr_amode (floatToWord item) : rest
- | rep == DoubleRep = map ppr_amode (doubleToWords item) ++ rest
- | otherwise = ppr_amode item : rest
- where
- rep = getAmodeRep item
-
-pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _
- = pprWordArray info_lbl (mkInfoTable cl_info)
- $$ let stuff = CCodeBlock entry_lbl entry in
- pprAbsC stuff (costs stuff)
- where
- entry_lbl = entryLabelFromCI cl_info
- info_lbl = infoTableLabelFromCI cl_info
-
-pprAbsC stmt@(CClosureTbl tycon) _
- = vcat (
- ptext SLIT("CLOSURE_TBL") <>
- lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
- punctuate comma (
- map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon)
- )
- ) $$ ptext SLIT("};")
-
-pprAbsC stmt@(CRetDirect uniq code srt liveness) _
- = pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness)
- $$ let stuff = CCodeBlock entry_lbl code in
- pprAbsC stuff (costs stuff)
- where
- info_lbl = mkReturnInfoLabel uniq
- entry_lbl = mkReturnPtLabel uniq
-
-pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
- = pprWordArray lbl (mkVecInfoTable amodes srt liveness)
-
-pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
- = vcat [
- ptext SLIT("START_MOD_INIT") <>
- parens (pprCLabel plain_lbl <> comma <> pprCLabel lbl),
- case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
- pprAbsC code (costs code),
- hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
- ]
-
-pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
-pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
-\end{code}
-
-Info tables... just arrays of words (the translation is done in
-ClosureInfo).
-
-\begin{code}
-pprWordArray lbl amodes
- = (case snd (initTE (ppr_decls_Amodes amodes)) of
- Just pp -> pp
- Nothing -> empty)
- $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "),
- pprCLabel lbl, ptext SLIT("[] = {") ]
- $$ hcat (punctuate comma (map (castToWord.pprAmode) amodes))
- $$ ptext SLIT("};")
-
-castToWord s = text "(W_)(" <> s <> char ')'
-\end{code}
-
-\begin{code}
--- Print a CMachOp in a way suitable for emitting via C.
-pprMachOp_for_C MO_Nat_Add = char '+'
-pprMachOp_for_C MO_Nat_Sub = char '-'
-pprMachOp_for_C MO_Nat_Eq = text "=="
-pprMachOp_for_C MO_Nat_Ne = text "!="
-
-pprMachOp_for_C MO_NatS_Ge = text ">="
-pprMachOp_for_C MO_NatS_Le = text "<="
-pprMachOp_for_C MO_NatS_Gt = text ">"
-pprMachOp_for_C MO_NatS_Lt = text "<"
-
-pprMachOp_for_C MO_NatU_Ge = text ">="
-pprMachOp_for_C MO_NatU_Le = text "<="
-pprMachOp_for_C MO_NatU_Gt = text ">"
-pprMachOp_for_C MO_NatU_Lt = text "<"
-
-pprMachOp_for_C MO_NatS_Mul = char '*'
-pprMachOp_for_C MO_NatS_MulMayOflo = text "mulIntMayOflo"
-pprMachOp_for_C MO_NatS_Quot = char '/'
-pprMachOp_for_C MO_NatS_Rem = char '%'
-pprMachOp_for_C MO_NatS_Neg = char '-'
-
-pprMachOp_for_C MO_NatU_Mul = char '*'
-pprMachOp_for_C MO_NatU_Quot = char '/'
-pprMachOp_for_C MO_NatU_Rem = char '%'
-
-pprMachOp_for_C MO_Nat_And = text "&"
-pprMachOp_for_C MO_Nat_Or = text "|"
-pprMachOp_for_C MO_Nat_Xor = text "^"
-pprMachOp_for_C MO_Nat_Not = text "~"
-pprMachOp_for_C MO_Nat_Shl = text "<<"
-pprMachOp_for_C MO_Nat_Shr = text ">>"
-pprMachOp_for_C MO_Nat_Sar = text ">>"
-
-pprMachOp_for_C MO_32U_Eq = text "=="
-pprMachOp_for_C MO_32U_Ne = text "!="
-pprMachOp_for_C MO_32U_Ge = text ">="
-pprMachOp_for_C MO_32U_Le = text "<="
-pprMachOp_for_C MO_32U_Gt = text ">"
-pprMachOp_for_C MO_32U_Lt = text "<"
-
-pprMachOp_for_C MO_Dbl_Eq = text "=="
-pprMachOp_for_C MO_Dbl_Ne = text "!="
-pprMachOp_for_C MO_Dbl_Ge = text ">="
-pprMachOp_for_C MO_Dbl_Le = text "<="
-pprMachOp_for_C MO_Dbl_Gt = text ">"
-pprMachOp_for_C MO_Dbl_Lt = text "<"
-
-pprMachOp_for_C MO_Dbl_Add = text "+"
-pprMachOp_for_C MO_Dbl_Sub = text "-"
-pprMachOp_for_C MO_Dbl_Mul = text "*"
-pprMachOp_for_C MO_Dbl_Div = text "/"
-pprMachOp_for_C MO_Dbl_Pwr = text "pow"
-
-pprMachOp_for_C MO_Dbl_Sin = text "sin"
-pprMachOp_for_C MO_Dbl_Cos = text "cos"
-pprMachOp_for_C MO_Dbl_Tan = text "tan"
-pprMachOp_for_C MO_Dbl_Sinh = text "sinh"
-pprMachOp_for_C MO_Dbl_Cosh = text "cosh"
-pprMachOp_for_C MO_Dbl_Tanh = text "tanh"
-pprMachOp_for_C MO_Dbl_Asin = text "asin"
-pprMachOp_for_C MO_Dbl_Acos = text "acos"
-pprMachOp_for_C MO_Dbl_Atan = text "atan"
-pprMachOp_for_C MO_Dbl_Log = text "log"
-pprMachOp_for_C MO_Dbl_Exp = text "exp"
-pprMachOp_for_C MO_Dbl_Sqrt = text "sqrt"
-pprMachOp_for_C MO_Dbl_Neg = text "-"
-
-pprMachOp_for_C MO_Flt_Add = text "+"
-pprMachOp_for_C MO_Flt_Sub = text "-"
-pprMachOp_for_C MO_Flt_Mul = text "*"
-pprMachOp_for_C MO_Flt_Div = text "/"
-pprMachOp_for_C MO_Flt_Pwr = text "pow"
-
-pprMachOp_for_C MO_Flt_Eq = text "=="
-pprMachOp_for_C MO_Flt_Ne = text "!="
-pprMachOp_for_C MO_Flt_Ge = text ">="
-pprMachOp_for_C MO_Flt_Le = text "<="
-pprMachOp_for_C MO_Flt_Gt = text ">"
-pprMachOp_for_C MO_Flt_Lt = text "<"
-
-pprMachOp_for_C MO_Flt_Sin = text "sin"
-pprMachOp_for_C MO_Flt_Cos = text "cos"
-pprMachOp_for_C MO_Flt_Tan = text "tan"
-pprMachOp_for_C MO_Flt_Sinh = text "sinh"
-pprMachOp_for_C MO_Flt_Cosh = text "cosh"
-pprMachOp_for_C MO_Flt_Tanh = text "tanh"
-pprMachOp_for_C MO_Flt_Asin = text "asin"
-pprMachOp_for_C MO_Flt_Acos = text "acos"
-pprMachOp_for_C MO_Flt_Atan = text "atan"
-pprMachOp_for_C MO_Flt_Log = text "log"
-pprMachOp_for_C MO_Flt_Exp = text "exp"
-pprMachOp_for_C MO_Flt_Sqrt = text "sqrt"
-pprMachOp_for_C MO_Flt_Neg = text "-"
-
-pprMachOp_for_C MO_32U_to_NatS = text "(StgInt)"
-pprMachOp_for_C MO_NatS_to_32U = text "(StgWord32)"
-
-pprMachOp_for_C MO_NatS_to_Dbl = text "(StgDouble)"
-pprMachOp_for_C MO_Dbl_to_NatS = text "(StgInt)"
-
-pprMachOp_for_C MO_NatS_to_Flt = text "(StgFloat)"
-pprMachOp_for_C MO_Flt_to_NatS = text "(StgInt)"
-
-pprMachOp_for_C MO_NatS_to_NatU = text "(StgWord)"
-pprMachOp_for_C MO_NatU_to_NatS = text "(StgInt)"
-
-pprMachOp_for_C MO_NatS_to_NatP = text "(void*)"
-pprMachOp_for_C MO_NatP_to_NatS = text "(StgInt)"
-pprMachOp_for_C MO_NatU_to_NatP = text "(void*)"
-pprMachOp_for_C MO_NatP_to_NatU = text "(StgWord)"
-
-pprMachOp_for_C MO_Dbl_to_Flt = text "(StgFloat)"
-pprMachOp_for_C MO_Flt_to_Dbl = text "(StgDouble)"
-
-pprMachOp_for_C MO_8S_to_NatS = text "(StgInt8)(StgInt)"
-pprMachOp_for_C MO_16S_to_NatS = text "(StgInt16)(StgInt)"
-pprMachOp_for_C MO_32S_to_NatS = text "(StgInt32)(StgInt)"
-
-pprMachOp_for_C MO_8U_to_NatU = text "(StgWord8)(StgWord)"
-pprMachOp_for_C MO_16U_to_NatU = text "(StgWord16)(StgWord)"
-pprMachOp_for_C MO_32U_to_NatU = text "(StgWord32)(StgWord)"
-
-pprMachOp_for_C MO_8U_to_32U = text "(StgWord32)"
-pprMachOp_for_C MO_32U_to_8U = text "(StgWord8)"
-
-
-ppLocalness lbl
- = if (externallyVisibleCLabel lbl)
- then empty
- else ptext SLIT("static ")
-
--- Horrible macros for declaring the types and locality of labels (see
--- StgMacros.h).
-
-ppLocalnessMacro include_dyn_prefix clabel =
- hcat [
- visiblity_prefix,
- dyn_prefix,
- case label_type of
- ClosureType -> ptext SLIT("C_")
- CodeType -> ptext SLIT("F_")
- InfoTblType -> ptext SLIT("I_")
- RetInfoTblType -> ptext SLIT("RI_")
- ClosureTblType -> ptext SLIT("CP_")
- DataType -> ptext SLIT("D_")
- ]
- where
- is_visible = externallyVisibleCLabel clabel
- label_type = labelType clabel
-
- visiblity_prefix
- | is_visible = char 'E'
- | otherwise = char 'I'
-
- dyn_prefix
- | include_dyn_prefix && labelDynamic clabel = char 'D'
- | otherwise = empty
-
-\end{code}
-
-\begin{code}
-jmp_lit = "JMP_("
-
-grab_non_void_amodes amodes
- = filter non_void amodes
-
-non_void amode
- = case (getAmodeRep amode) of
- VoidRep -> False
- k -> True
-\end{code}
-
-\begin{code}
-ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc)
-ppr_maybe_vol_regs Nothing
- = (empty, empty)
-ppr_maybe_vol_regs (Just vrs)
- = case ppr_vol_regs vrs of
- (saves, restores)
- -> (pp_basic_saves $$ saves,
- pp_basic_restores $$ restores)
-
-ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
-
-ppr_vol_regs [] = (empty, empty)
-ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs
-ppr_vol_regs (r:rs)
- = let pp_reg = case r of
- VanillaReg pk n -> pprVanillaReg n
- _ -> pprMagicId r
- (more_saves, more_restores) = ppr_vol_regs rs
- in
- (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
- ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
-
--- pp_basic_{saves,restores}: The BaseReg, Sp, Hp and
--- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
--- depending on the platform. (The "volatile regs" stuff handles all
--- other registers.) Just be *sure* BaseReg is OK before trying to do
--- anything else. The correct sequence of saves&restores are
--- encoded by the CALLER_*_SYSTEM macros.
-pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM")
-pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM")
-\end{code}
-
-\begin{code}
-pp_closure_lbl lbl
- | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
- | otherwise = char '&' <> pprCLabel lbl
-\end{code}
-
-\begin{code}
-if_profiling pretty
- = if opt_SccProfilingOn
- then pretty
- else char '0' -- leave it out!
--- ---------------------------------------------------------------------------
--- Changes for GrAnSim:
--- draw costs for computation in head of if into both branches;
--- as no abstractC data structure is given for the head, one is constructed
--- guessing unknown values and fed into the costs function
--- ---------------------------------------------------------------------------
-
-do_if_stmt discrim tag alt_code deflt c
- = let
- cond = hcat [ pprAmode discrim
- , ptext SLIT(" == ")
- , tcast
- , pprAmode (CLit tag)
- ]
- -- to be absolutely sure that none of the
- -- conversion rules hit, e.g.,
- --
- -- minInt is different to (int)minInt
- --
- -- in C (when minInt is a number not a constant
- -- expression which evaluates to it.)
- --
- tcast = case tag of
- MachInt _ -> ptext SLIT("(I_)")
- _ -> empty
- in
- ppr_if_stmt cond
- alt_code deflt
- (addrModeCosts discrim Rhs) c
-
-ppr_if_stmt pp_pred then_part else_part discrim_costs c
- = vcat [
- hcat [text "if (", pp_pred, text ") {"],
- nest 8 (pprAbsC then_part (c + discrim_costs +
- (Cost (0, 2, 0, 0, 0)) +
- costs then_part)),
- (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
- nest 8 (pprAbsC else_part (c + discrim_costs +
- (Cost (0, 1, 0, 0, 0)) +
- costs else_part)),
- char '}' ]
- {- Total costs = inherited costs (before if) + costs for accessing discrim
- + costs for cond branch ( = (0, 1, 0, 0, 0) )
- + costs for that alternative
- -}
-\end{code}
-
-Historical note: this used to be two separate cases -- one for `ccall'
-and one for `casm'. To get round a potential limitation to only 10
-arguments, the numbering of arguments in @process_casm@ was beefed up a
-bit. ADR
-
-Some rough notes on generating code for @CCallOp@:
-
-1) Evaluate all arguments and stuff them into registers. (done elsewhere)
-2) Save any essential registers (heap, stack, etc).
-
- ToDo: If stable pointers are in use, these must be saved in a place
- where the runtime system can get at them so that the Stg world can
- be restarted during the call.
-
-3) Save any temporary registers that are currently in use.
-4) Do the call, putting result into a local variable
-5) Restore essential registers
-6) Restore temporaries
-
- (This happens after restoration of essential registers because we
- might need the @Base@ register to access all the others correctly.)
-
- Otherwise, copy local variable into result register.
-
-8) If ccall (not casm), declare the function being called as extern so
- that C knows if it returns anything other than an int.
-
-\begin{pseudocode}
-{ ResultType _ccall_result;
- basic_saves;
- saves;
- _ccall_result = f( args );
- basic_restores;
- restores;
-
- return_reg = _ccall_result;
-}
-\end{pseudocode}
-
-Amendment to the above: if we can GC, we have to:
-
-* make sure we save all our registers away where the garbage collector
- can get at them.
-* be sure that there are no live registers or we're in trouble.
- (This can cause problems if you try something foolish like passing
- an array or a foreign obj to a _ccall_GC_ thing.)
-* increment/decrement the @inCCallGC@ counter before/after the call so
- that the runtime check that PerformGC is being used sensibly will work.
-
-\begin{code}
-pprFCall call uniq args results vol_regs
- = case call of
- CCall (CCallSpec target _cconv safety) ->
- vcat [ char '{',
- declare_local_vars, -- local var for *result*
- vcat local_arg_decls,
- makeCall target safety
- (process_casm local_vars pp_non_void_args (call_str target)),
- assign_results,
- char '}'
- ]
- DNCall (DNCallSpec isStatic kind assem nm argTys resTy) ->
- let
- resultVar = "_ccall_result"
- hasAssemArg = isStatic || kind == DNConstructor
- invokeOp =
- case kind of
- DNMethod
- | isStatic -> "DN_invokeStatic"
- | otherwise -> "DN_invokeMethod"
- DNField
- | isStatic ->
- if resTy == DNUnit
- then "DN_setStatic"
- else "DN_getStatic"
- | otherwise ->
- if resTy == DNUnit
- then "DN_setField"
- else "DN_getField"
- DNConstructor -> "DN_createObject"
-
- (methArrDecl, methArrInit, methArrName, methArrLen)
- | null argTys = (empty, empty, text "NULL", text "0")
- | otherwise =
- ( text "DotnetArg __meth_args[" <> int (length argTys) <> text "];"
- , vcat (zipWith3 (\ idx arg argTy ->
- text "__meth_args[" <> int idx <> text "].arg." <> text (toDotnetArgField argTy) <> equals <> ppr_amode arg <> semi $$
- text "__meth_args[" <> int idx <> text "].arg_type=" <> text (toDotnetTy argTy) <> semi)
- [0..]
- non_void_args
- argTys)
- , text "__meth_args"
- , int (length non_void_args)
- )
- in
- vcat [ char '{',
- declare_local_vars,
- vcat local_arg_decls,
- vcat [ methArrDecl
- , methArrInit
- , text "_ccall_result1 =" <+> text invokeOp <> parens (
- hcat (punctuate comma $
- (if hasAssemArg then
- ((if null assem then
- text "NULL"
- else
- doubleQuotes (text assem)):)
- else
- id) $
- [ doubleQuotes $ text nm
- , methArrName
- , methArrLen
- , text (toDotnetTy resTy)
- , text "(void*)&" <> text resultVar
- ])) <> semi
- ],
- assign_results,
- char '}'
- ]
- where
- (pp_saves, pp_restores) = ppr_vol_regs vol_regs
-
- makeCall target safety theCall =
- vcat [ pp_save_context, theCall, pp_restore_context ]
- where
- (pp_save_context, pp_restore_context)
- | playSafe safety = ( text "{ I_" <+> ppr_uniq_token <>
- text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
- , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
- )
- | otherwise = ( pp_basic_saves $$ pp_saves,
- pp_basic_restores $$ pp_restores)
- where
- thread_macro_args = ppr_uniq_token <> comma <+>
- text "rts" <> ppr (playThreadSafe safety)
- ppr_uniq_token = text "tok_" <> ppr uniq
-
-
- non_void_args =
- let nvas = init args
- in ASSERT2 ( all non_void nvas, ppr call <+> hsep (map pprAmode args) )
- nvas
- -- the last argument will be the "I/O world" token (a VoidRep)
- -- all others should be non-void
-
- non_void_results =
- let nvrs = grab_non_void_amodes results
- in ASSERT (forDotnet || listLengthCmp nvrs 1 /= GT) nvrs
- -- there will usually be two results: a (void) state which we
- -- should ignore and a (possibly void) result.
-
- (local_arg_decls, pp_non_void_args)
- = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
-
- (declare_local_vars, local_vars, assign_results)
- = ppr_casm_results non_void_results forDotnet
-
- forDotnet
- = case call of
- DNCall{} -> True
- _ -> False
-
- call_str tgt
- = case tgt of
- StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
- DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
-
- ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
- dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
-
-
- -- Remainder only used for ccall
- mk_ccall_str fun_name ccall_fun_args = showSDoc
- (hcat [
- if null non_void_results
- then empty
- else text "%r = ",
- lparen, fun_name, lparen,
- hcat (punctuate comma ccall_fun_args),
- text "));"
- ])
-
-toDotnetTy :: DNType -> String
-toDotnetTy x =
- case x of
- DNByte -> "Dotnet_Byte"
- DNBool -> "Dotnet_Bool"
- DNChar -> "Dotnet_Char"
- DNDouble -> "Dotnet_Double"
- DNFloat -> "Dotnet_Float"
- DNInt -> "Dotnet_Int"
- DNInt8 -> "Dotnet_Int8"
- DNInt16 -> "Dotnet_Int16"
- DNInt32 -> "Dotnet_Int32"
- DNInt64 -> "Dotnet_Int64"
- DNWord8 -> "Dotnet_Word8"
- DNWord16 -> "Dotnet_Word16"
- DNWord32 -> "Dotnet_Word32"
- DNWord64 -> "Dotnet_Word64"
- DNPtr -> "Dotnet_Ptr"
- DNUnit -> "Dotnet_Unit"
- DNObject -> "Dotnet_Object"
- DNString -> "Dotnet_String"
-
-toDotnetArgField :: DNType -> String
-toDotnetArgField x =
- case x of
- DNByte -> "arg_byte"
- DNBool -> "arg_bool"
- DNChar -> "arg_char"
- DNDouble -> "arg_double"
- DNFloat -> "arg_float"
- DNInt -> "arg_int"
- DNInt8 -> "arg_int8"
- DNInt16 -> "arg_int16"
- DNInt32 -> "arg_int32"
- DNInt64 -> "arg_int64"
- DNWord8 -> "arg_word8"
- DNWord16 -> "arg_word16"
- DNWord32 -> "arg_word32"
- DNWord64 -> "arg_word64"
- DNPtr -> "arg_ptr"
- DNUnit -> "arg_ptr" -- can't happen
- DNObject -> "arg_obj"
- DNString -> "arg_str"
-
-ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
- -- (a) decl and assignment, (b) local var to be used later
-
-ppr_casm_arg amode a_num
- = let
- a_kind = getAmodeRep amode
- pp_amode = pprAmode amode
- pp_kind = pprPrimKind a_kind
-
- local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
-
- declare_local_var
- = hcat [ pp_kind, space, local_var, equals, pp_amode, semi ]
- in
- (declare_local_var, local_var)
-\end{code}
-
-For l-values, the critical questions are:
-
-1) Are there any results at all?
-
- We only allow zero or one results.
-
-\begin{code}
-ppr_casm_results
- :: [CAddrMode] -- list of results (length <= 1)
- -> Bool -- True => multiple results OK.
- ->
- ( SDoc, -- declaration of any local vars
- [SDoc], -- list of result vars (same length as results)
- SDoc ) -- assignment (if any) of results in local var to registers
-
-ppr_casm_results [] _
- = (empty, [], empty) -- no results
-
-ppr_casm_results (r:rs) multiResultsOK
- | not multiResultsOK && not (null rs) = panic "ppr_casm_results: ccall/casm with many results"
- | otherwise
- = foldr (\ (a,b,c) (as,bs,cs) -> (a $$ as, b ++ bs, c $$ cs))
- (empty,[],empty)
- (zipWith pprRes (r:rs) ("" : map show [(1::Int)..]))
- where
- pprRes r suf = (declare_local_var, [local_var], assign_result)
- where
- result_reg = ppr_amode r
- r_kind = getAmodeRep r
-
- local_var = ptext SLIT("_ccall_result") <> text suf
-
- (result_type, assign_result)
- = (pprPrimKind r_kind,
- hcat [ result_reg, equals, local_var, semi ])
-
- declare_local_var = hcat [ result_type, space, local_var, semi ]
-
-\end{code}
-
-
-Note the sneaky way _the_ result is represented by a list so that we
-can complain if it's used twice.
-
-ToDo: Any chance of giving line numbers when process-casm fails?
- Or maybe we should do a check _much earlier_ in compiler. ADR
-
-\begin{code}
-process_casm :: [SDoc] -- results (length <= 1)
- -> [SDoc] -- arguments
- -> String -- format string (with embedded %'s)
- -> SDoc -- code being generated
-
-process_casm results args string = process results args string
- where
- process [] _ "" = empty
- process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++
- string ++
- "\"\n(Try changing result type to IO ()\n")
-
- process ress args ('%':cs)
- = case cs of
- [] ->
- error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
-
- ('%':css) ->
- char '%' <> process ress args css
-
- ('r':css) ->
- case ress of
- [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
- [r] -> r <> (process [] args css)
- _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
-
- other ->
- let
- read_int :: ReadS Int
- read_int = reads
- in
- case (read_int other) of
- [(num,css)] ->
- if num >= 0 && args `lengthExceeds` num
- then parens (args !! num) <> process ress args css
- else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
- _ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
-
- process ress args (other_c:cs)
- = char other_c <> process ress args cs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[a2r-assignments]{Assignments}
-%* *
-%************************************************************************
-
-Printing assignments is a little tricky because of type coercion.
-
-First of all, the kind of the thing being assigned can be gotten from
-the destination addressing mode. (It should be the same as the kind
-of the source addressing mode.) If the kind of the assignment is of
-@VoidRep@, then don't generate any code at all.
-
-\begin{code}
-pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc
-
-pprAssign VoidRep dest src = empty
-\end{code}
-
-Special treatment for floats and doubles, to avoid unwanted conversions.
-
-\begin{code}
-pprAssign FloatRep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
-
-pprAssign DoubleRep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
-
-pprAssign Int64Rep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
-pprAssign Word64Rep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
-\end{code}
-
-Lastly, the question is: will the C compiler think the types of the
-two sides of the assignment match?
-
- We assume that the types will match if neither side is a
- @CVal@ addressing mode for any register which can point into
- the heap or stack.
-
-Why? Because the heap and stack are used to store miscellaneous
-things, whereas the temporaries, registers, etc., are only used for
-things of fixed type.
-
-\begin{code}
-pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
- = hcat [ pprVanillaReg dest, equals,
- pprVanillaReg src, semi ]
-
-pprAssign kind dest src
- | mixedTypeLocn dest
- -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
- = hcat [ ppr_amode dest, equals,
- text "(W_)(", -- Here is the cast
- ppr_amode src, pp_paren_semi ]
-
-pprAssign kind dest src
- | mixedPtrLocn dest && getAmodeRep src /= PtrRep
- -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
- = hcat [ ppr_amode dest, equals,
- text "(P_)(", -- Here is the cast
- ppr_amode src, pp_paren_semi ]
-
-pprAssign kind other_dest src
- = hcat [ ppr_amode other_dest, equals,
- pprAmode src, semi ]
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[a2r-CAddrModes]{Addressing modes}
-%* *
-%************************************************************************
-
-@pprAmode@ is used to print r-values (which may need casts), whereas
-@ppr_amode@ is used for l-values {\em and} as a help function for
-@pprAmode@.
-
-\begin{code}
-pprAmode, ppr_amode :: CAddrMode -> SDoc
-\end{code}
-
-For reasons discussed above under assignments, @CVal@ modes need
-to be treated carefully. First come special cases for floats and doubles,
-similar to those in @pprAssign@:
-
-(NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in
-question.)
-
-\begin{code}
-pprAmode (CVal reg_rel FloatRep)
- = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
-pprAmode (CVal reg_rel DoubleRep)
- = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
-pprAmode (CVal reg_rel Int64Rep)
- = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
-pprAmode (CVal reg_rel Word64Rep)
- = hcat [ text "PK_Word64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
-\end{code}
-
-Next comes the case where there is some other cast need, and the
-no-cast case:
-
-\begin{code}
-pprAmode amode
- | mixedTypeLocn amode
- = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("),
- ppr_amode amode ])
- | otherwise -- No cast needed
- = ppr_amode amode
-\end{code}
-
-When we have an indirection through a CIndex, we have to be careful to
-get the type casts right.
-
-this amode:
-
- CVal (CIndex kind1 base offset) kind2
-
-means (in C speak):
-
- *(kind2 *)((kind1 *)base + offset)
-
-That is, the indexing is done in units of kind1, but the resulting
-amode has kind2.
-
-\begin{code}
-ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
- = case (pprRegRelative False{-no sign wanted-} reg_rel) of
- (pp_reg, Nothing) -> panic "ppr_amode: CIndex"
- (pp_reg, Just offset) ->
- hcat [ char '*', parens (pprPrimKind kind <> char '*'),
- parens (pp_reg <> char '+' <> offset) ]
-\end{code}
-
-Now the rest of the cases for ``workhorse'' @ppr_amode@:
-
-\begin{code}
-ppr_amode (CVal reg_rel _)
- = case (pprRegRelative False{-no sign wanted-} reg_rel) of
- (pp_reg, Nothing) -> (<>) (char '*') pp_reg
- (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ]
-
-ppr_amode (CAddr reg_rel)
- = case (pprRegRelative True{-sign wanted-} reg_rel) of
- (pp_reg, Nothing) -> pp_reg
- (pp_reg, Just offset) -> pp_reg <> offset
-
-ppr_amode (CReg magic_id) = pprMagicId magic_id
-
-ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
-
-ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl
-
-ppr_amode (CCharLike ch)
- = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
-ppr_amode (CIntLike int)
- = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ]
-
-ppr_amode (CLit lit) = pprBasicLit lit
-
-ppr_amode (CJoinPoint _)
- = panic "ppr_amode: CJoinPoint"
-
-ppr_amode (CMacroExpr pk macro as)
- = parens (ptext (cExprMacroText macro) <>
- parens (hcat (punctuate comma (map pprAmode as))))
-\end{code}
-
-\begin{code}
-cExprMacroText ENTRY_CODE = SLIT("ENTRY_CODE")
-cExprMacroText ARG_TAG = SLIT("ARG_TAG")
-cExprMacroText GET_TAG = SLIT("GET_TAG")
-cExprMacroText CCS_HDR = SLIT("CCS_HDR")
-cExprMacroText BYTE_ARR_CTS = SLIT("BYTE_ARR_CTS")
-cExprMacroText PTRS_ARR_CTS = SLIT("PTRS_ARR_CTS")
-cExprMacroText ForeignObj_CLOSURE_DATA = SLIT("ForeignObj_CLOSURE_DATA")
-
-cStmtMacroText UPD_CAF = SLIT("UPD_CAF")
-cStmtMacroText UPD_BH_UPDATABLE = SLIT("UPD_BH_UPDATABLE")
-cStmtMacroText UPD_BH_SINGLE_ENTRY = SLIT("UPD_BH_SINGLE_ENTRY")
-cStmtMacroText PUSH_UPD_FRAME = SLIT("PUSH_UPD_FRAME")
-cStmtMacroText SET_TAG = SLIT("SET_TAG")
-cStmtMacroText DATA_TO_TAGZH = SLIT("dataToTagzh")
-cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
-cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT")
-cStmtMacroText REGISTER_DIMPORT = SLIT("REGISTER_DIMPORT")
-cStmtMacroText GRAN_FETCH = SLIT("GRAN_FETCH")
-cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE")
-cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
-cStmtMacroText THREAD_CONTEXT_SWITCH = SLIT("THREAD_CONTEXT_SWITCH")
-cStmtMacroText GRAN_YIELD = SLIT("GRAN_YIELD")
-
-cCheckMacroText HP_CHK_NP = SLIT("HP_CHK_NP")
-cCheckMacroText STK_CHK_NP = SLIT("STK_CHK_NP")
-cCheckMacroText HP_STK_CHK_NP = SLIT("HP_STK_CHK_NP")
-cCheckMacroText HP_CHK_FUN = SLIT("HP_CHK_FUN")
-cCheckMacroText STK_CHK_FUN = SLIT("STK_CHK_FUN")
-cCheckMacroText HP_STK_CHK_FUN = SLIT("HP_STK_CHK_FUN")
-cCheckMacroText HP_CHK_NOREGS = SLIT("HP_CHK_NOREGS")
-cCheckMacroText HP_CHK_UNPT_R1 = SLIT("HP_CHK_UNPT_R1")
-cCheckMacroText HP_CHK_UNBX_R1 = SLIT("HP_CHK_UNBX_R1")
-cCheckMacroText HP_CHK_F1 = SLIT("HP_CHK_F1")
-cCheckMacroText HP_CHK_D1 = SLIT("HP_CHK_D1")
-cCheckMacroText HP_CHK_L1 = SLIT("HP_CHK_L1")
-cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE")
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ppr-liveness-masks]{Liveness Masks}
-%* *
-%************************************************************************
-
-\begin{code}
-bitmapAddrModes [] = [mkWordCLit 0]
-bitmapAddrModes xs = map mkWordCLit xs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[a2r-MagicIds]{Magic ids}
-%* *
-%************************************************************************
-
-@pprRegRelative@ returns a pair of the @Doc@ for the register
-(some casting may be required), and a @Maybe Doc@ for the offset
-(zero offset gives a @Nothing@).
-
-\begin{code}
-addPlusSign :: Bool -> SDoc -> SDoc
-addPlusSign False p = p
-addPlusSign True p = (<>) (char '+') p
-
-pprSignedInt :: Bool -> Int -> Maybe SDoc -- Nothing => 0
-pprSignedInt sign_wanted n
- = if n == 0 then Nothing else
- if n > 0 then Just (addPlusSign sign_wanted (int n))
- else Just (int n)
-
-pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve)
- -> RegRelative
- -> (SDoc, Maybe SDoc)
-
-pprRegRelative sign_wanted (SpRel off)
- = (pprMagicId Sp, pprSignedInt sign_wanted (I# off))
-
-pprRegRelative sign_wanted r@(HpRel o)
- = let pp_Hp = pprMagicId Hp; off = I# o
- in
- if off == 0 then
- (pp_Hp, Nothing)
- else
- (pp_Hp, Just ((<>) (char '-') (int off)))
-
-pprRegRelative sign_wanted (NodeRel o)
- = let pp_Node = pprMagicId node; off = I# o
- in
- if off == 0 then
- (pp_Node, Nothing)
- else
- (pp_Node, Just (addPlusSign sign_wanted (int off)))
-
-pprRegRelative sign_wanted (CIndex base offset kind)
- = ( hcat [text "((", pprPrimKind kind, text " *)(", ppr_amode base, text "))"]
- , Just (hcat [if sign_wanted then char '+' else empty,
- text "(I_)(", ppr_amode offset, ptext SLIT(")")])
- )
-\end{code}
-
-@pprMagicId@ just prints the register name. @VanillaReg@ registers are
-represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
-to select the union tag.
-
-\begin{code}
-pprMagicId :: MagicId -> SDoc
-
-pprMagicId BaseReg = ptext SLIT("BaseReg")
-pprMagicId (VanillaReg pk n)
- = hcat [ pprVanillaReg n, char '.',
- pprUnionTag pk ]
-pprMagicId (FloatReg n) = ptext SLIT("F") <> int (I# n)
-pprMagicId (DoubleReg n) = ptext SLIT("D") <> int (I# n)
-pprMagicId (LongReg _ n) = ptext SLIT("L") <> int (I# n)
-pprMagicId Sp = ptext SLIT("Sp")
-pprMagicId SpLim = ptext SLIT("SpLim")
-pprMagicId Hp = ptext SLIT("Hp")
-pprMagicId HpLim = ptext SLIT("HpLim")
-pprMagicId CurCostCentre = ptext SLIT("CCCS")
-pprMagicId VoidReg = ptext SLIT("VoidReg")
-
-pprVanillaReg :: Int# -> SDoc
-pprVanillaReg n = char 'R' <> int (I# n)
-
-pprUnionTag :: PrimRep -> SDoc
-
-pprUnionTag PtrRep = char 'p'
-pprUnionTag CodePtrRep = ptext SLIT("fp")
-pprUnionTag DataPtrRep = char 'd'
-pprUnionTag RetRep = char 'p'
-pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
-
-pprUnionTag CharRep = char 'c'
-pprUnionTag Int8Rep = ptext SLIT("i8")
-pprUnionTag IntRep = char 'i'
-pprUnionTag WordRep = char 'w'
-pprUnionTag Int32Rep = char 'i'
-pprUnionTag Word32Rep = char 'w'
-pprUnionTag AddrRep = char 'a'
-pprUnionTag FloatRep = char 'f'
-pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
-
-pprUnionTag StablePtrRep = char 'p'
-
-pprUnionTag _ = panic "pprUnionTag:Odd kind"
-\end{code}
-
-
-Find and print local and external declarations for a list of
-Abstract~C statements.
-\begin{code}
-pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-})
-pprTempAndExternDecls AbsCNop = (empty, empty)
-
-pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
- = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
- ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
- case (catMaybes [t_p1, t_p2]) of { real_temps ->
- case (catMaybes [e_p1, e_p2]) of { real_exts ->
- returnTE (vcat real_temps, vcat real_exts) }}
- )
-
-pprTempAndExternDecls other_stmt
- = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
- returnTE (
- case maybe_t of
- Nothing -> empty
- Just pp -> pp,
-
- case maybe_e of
- Nothing -> empty
- Just pp -> pp )
- )
-
-pprBasicLit :: Literal -> SDoc
-pprPrimKind :: PrimRep -> SDoc
-
-pprBasicLit lit = ppr lit
-pprPrimKind k = ppr k
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[a2r-monad]{Monadery}
-%* *
-%************************************************************************
-
-We need some monadery to keep track of temps and externs we have already
-printed. This info must be threaded right through the Abstract~C, so
-it's most convenient to hide it in this monad.
-
-WDP 95/02: Switched from \tr{([Unique], [CLabel])} to
-\tr{(UniqSet, CLabelSet)}. Allegedly for efficiency.
-
-\begin{code}
-type CLabelSet = FiniteMap CLabel (){-any type will do-}
-emptyCLabelSet = emptyFM
-x `elementOfCLabelSet` labs
- = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
-
-addToCLabelSet set x = addToFM set x ()
-
-type TEenv = (UniqSet Unique, CLabelSet)
-
-type TeM result = TEenv -> (TEenv, result)
-
-initTE :: TeM a -> a
-initTE sa
- = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
- result }
-
-{-# INLINE thenTE #-}
-{-# INLINE returnTE #-}
-
-thenTE :: TeM a -> (a -> TeM b) -> TeM b
-thenTE a b u
- = case a u of { (u_1, result_of_a) ->
- b result_of_a u_1 }
-
-mapTE :: (a -> TeM b) -> [a] -> TeM [b]
-mapTE f [] = returnTE []
-mapTE f (x:xs)
- = f x `thenTE` \ r ->
- mapTE f xs `thenTE` \ rs ->
- returnTE (r : rs)
-
-returnTE :: a -> TeM a
-returnTE result env = (env, result)
-
--- these next two check whether the thing is already
--- recorded, and THEN THEY RECORD IT
--- (subsequent calls will return False for the same uniq/label)
-
-tempSeenTE :: Unique -> TeM Bool
-tempSeenTE uniq env@(seen_uniqs, seen_labels)
- = if (uniq `elementOfUniqSet` seen_uniqs)
- then (env, True)
- else ((addOneToUniqSet seen_uniqs uniq,
- seen_labels),
- False)
-
-labelSeenTE :: CLabel -> TeM Bool
-labelSeenTE lbl env@(seen_uniqs, seen_labels)
- = if (lbl `elementOfCLabelSet` seen_labels)
- then (env, True)
- else ((seen_uniqs,
- addToCLabelSet seen_labels lbl),
- False)
-\end{code}
-
-\begin{code}
-pprTempDecl :: Unique -> PrimRep -> SDoc
-pprTempDecl uniq kind
- = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ]
-
-pprExternDecl :: Bool -> CLabel -> SDoc
-pprExternDecl in_srt clabel
- | not (needsCDecl clabel) = empty -- do not print anything for "known external" things
- | otherwise =
- hcat [ ppLocalnessMacro (not in_srt) clabel,
- lparen, dyn_wrapper (pprCLabel clabel), pp_paren_semi ]
- where
- dyn_wrapper d
- | in_srt && labelDynamic clabel = text "DLL_IMPORT_DATA_VAR" <> parens d
- | otherwise = d
-
-\end{code}
-
-\begin{code}
-ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-})
-
-ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
-
-ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
- = ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
- ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
- returnTE (maybe_vcat [p1, p2])
-
-ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
-
-ppr_decls_AbsC (CAssign dest source)
- = ppr_decls_Amode dest `thenTE` \ p1 ->
- ppr_decls_Amode source `thenTE` \ p2 ->
- returnTE (maybe_vcat [p1, p2])
-
-ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
-
-ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target
-
-ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target
-
-ppr_decls_AbsC (CSwitch discrim alts deflt)
- = ppr_decls_Amode discrim `thenTE` \ pdisc ->
- mapTE ppr_alt_stuff alts `thenTE` \ palts ->
- ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
- returnTE (maybe_vcat (pdisc:pdeflt:palts))
- where
- ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
-
-ppr_decls_AbsC (CCodeBlock lbl absC)
- = ppr_decls_AbsC absC
-
-ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _)
- -- ToDo: strictly speaking, should chk "cost_centre" amode
- = labelSeenTE info_lbl `thenTE` \ label_seen ->
- returnTE (Nothing,
- if label_seen then
- Nothing
- else
- Just (pprExternDecl False{-not in an SRT decl-} info_lbl))
- where
- info_lbl = infoTableLabelFromCI cl_info
-
-ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (res : args)
-ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
-
-ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
-
-ppr_decls_AbsC (CSequential abcs)
- = mapTE ppr_decls_AbsC abcs `thenTE` \ t_and_e_s ->
- returnTE (maybe_vcat t_and_e_s)
-
-ppr_decls_AbsC (CCheck _ amodes code) =
- ppr_decls_Amodes amodes `thenTE` \p1 ->
- ppr_decls_AbsC code `thenTE` \p2 ->
- returnTE (maybe_vcat [p1,p2])
-
-ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes
-
-ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!!
- -- you get some nasty re-decls of stdio.h if you compile
- -- the prelude while looking inside those amodes;
- -- no real reason to, anyway.
-ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
-
-ppr_decls_AbsC (CStaticClosure _ closure_info cost_centre amodes)
- -- ToDo: strictly speaking, should chk "cost_centre" amode
- = ppr_decls_Amodes amodes
-
-ppr_decls_AbsC (CClosureInfoAndCode cl_info entry)
- = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 ->
- ppr_decls_AbsC entry `thenTE` \ p2 ->
- returnTE (maybe_vcat [p1, p2])
- where
- entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep
-
-ppr_decls_AbsC (CSRT _ closure_lbls)
- = mapTE labelSeenTE closure_lbls `thenTE` \ seen ->
- returnTE (Nothing,
- if and seen then Nothing
- else Just (vcat [ pprExternDecl True{-in SRT decl-} l
- | (l,False) <- zip closure_lbls seen ]))
-
-ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
-ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
-ppr_decls_AbsC (CModuleInitBlock _ _ code) = ppr_decls_AbsC code
-
-ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
-\end{code}
-
-\begin{code}
-ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc)
-ppr_decls_Amode (CVal (CIndex base offset _) _) = ppr_decls_Amodes [base,offset]
-ppr_decls_Amode (CAddr (CIndex base offset _)) = ppr_decls_Amodes [base,offset]
-ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
-ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
-ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
-ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing)
-
--- CIntLike must be a literal -- no decls
-ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing)
-
--- CCharLike too
-ppr_decls_Amode (CCharLike char) = returnTE (Nothing, Nothing)
-
--- now, the only place where we actually print temps/externs...
-ppr_decls_Amode (CTemp uniq kind)
- = case kind of
- VoidRep -> returnTE (Nothing, Nothing)
- other ->
- tempSeenTE uniq `thenTE` \ temp_seen ->
- returnTE
- (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
-
-ppr_decls_Amode (CLbl lbl VoidRep)
- = returnTE (Nothing, Nothing)
-
-ppr_decls_Amode (CLbl lbl kind)
- = labelSeenTE lbl `thenTE` \ label_seen ->
- returnTE (Nothing,
- if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl))
-
-ppr_decls_Amode (CMacroExpr _ _ amodes)
- = ppr_decls_Amodes amodes
-
-ppr_decls_Amode other = returnTE (Nothing, Nothing)
-
-
-maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc)
-maybe_vcat ps
- = case (unzip ps) of { (ts, es) ->
- case (catMaybes ts) of { real_ts ->
- case (catMaybes es) of { real_es ->
- (if (null real_ts) then Nothing else Just (vcat real_ts),
- if (null real_es) then Nothing else Just (vcat real_es))
- } } }
-\end{code}
-
-\begin{code}
-ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc)
-ppr_decls_Amodes amodes
- = mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
- returnTE ( maybe_vcat ps )
-\end{code}
-
-Print out a C Label where you want the *address* of the label, not the
-object it refers to. The distinction is important when the label may
-refer to a C structure (info tables and closures, for instance).
-
-When just generating a declaration for the label, use pprCLabel.
-
-\begin{code}
-pprCLabelAddr :: CLabel -> SDoc
-pprCLabelAddr clabel =
- case labelType clabel of
- InfoTblType -> addr_of_label
- RetInfoTblType -> addr_of_label
- ClosureType -> addr_of_label
- VecTblType -> addr_of_label
- DataType -> addr_of_label
-
- _ -> pp_label
- where
- addr_of_label = ptext SLIT("(P_)&") <> pp_label
- pp_label = pprCLabel clabel
-\end{code}
-
------------------------------------------------------------------------------
-Initialising static objects with floating-point numbers. We can't
-just emit the floating point number, because C will cast it to an int
-by rounding it. We want the actual bit-representation of the float.
-
-This is a hack to turn the floating point numbers into ints that we
-can safely initialise to static locations.
-
-\begin{code}
-big_doubles = (getPrimRepSize DoubleRep) /= 1
-
-#if __GLASGOW_HASKELL__ >= 504
-newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
-newFloatArray = newArray_
-
-newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
-newDoubleArray = newArray_
-
-castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
-castFloatToIntArray = castSTUArray
-
-castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
-castDoubleToIntArray = castSTUArray
-
-writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
-writeFloatArray = writeArray
-
-writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
-writeDoubleArray = writeArray
-
-readIntArray :: STUArray s Int Int -> Int -> ST s Int
-readIntArray = readArray
-
-#else
-
-castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
-castFloatToIntArray = return
-
-castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
-castDoubleToIntArray = return
-
-#endif
-
--- floats are always 1 word
-floatToWord :: CAddrMode -> CAddrMode
-floatToWord (CLit (MachFloat r))
- = runST (do
- arr <- newFloatArray ((0::Int),0)
- writeFloatArray arr 0 (fromRational r)
- arr' <- castFloatToIntArray arr
- i <- readIntArray arr' 0
- return (CLit (MachInt (toInteger i)))
- )
-
-doubleToWords :: CAddrMode -> [CAddrMode]
-doubleToWords (CLit (MachDouble r))
- | big_doubles -- doubles are 2 words
- = runST (do
- arr <- newDoubleArray ((0::Int),1)
- writeDoubleArray arr 0 (fromRational r)
- arr' <- castDoubleToIntArray arr
- i1 <- readIntArray arr' 0
- i2 <- readIntArray arr' 1
- return [ CLit (MachInt (toInteger i1))
- , CLit (MachInt (toInteger i2))
- ]
- )
- | otherwise -- doubles are 1 word
- = runST (do
- arr <- newDoubleArray ((0::Int),0)
- writeDoubleArray arr 0 (fromRational r)
- arr' <- castDoubleToIntArray arr
- i <- readIntArray arr' 0
- return [ CLit (MachInt (toInteger i)) ]
- )
-\end{code}
-- Taking an Id apart
idName, idType, idUnique, idInfo,
- idPrimRep, isId, globalIdDetails,
+ isId, globalIdDetails, idPrimRep,
recordSelectorFieldLabel,
-- Modifying an Id
globalIdDetails
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
-import Type ( Type, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe )
+import Type ( Type, typePrimRep, addFreeTyVars, seqType,
+ splitTyConApp_maybe, PrimRep )
import TysPrim ( statePrimTyCon )
import IdInfo
)
import Module ( Module )
import OccName ( EncodedFS, mkWorkerOcc )
-import PrimRep ( PrimRep )
import FieldLabel ( FieldLabel )
import Maybes ( orElse )
import SrcLoc ( SrcLoc )
, mkMachInt64, mkMachWord64
, litSize
, litIsDupable, litIsTrivial
- , literalType, literalPrimRep
+ , literalType,
, hashLiteral
, inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
)
-import PrimRep ( PrimRep(..) )
import Type ( Type )
-import CStrings ( pprFSInCStyle )
-
import Outputable
import FastTypes
import FastString
~~~~~
\begin{code}
literalType :: Literal -> Type
-literalType (MachChar _) = charPrimTy
-literalType (MachStr _) = addrPrimTy
-literalType (MachNullAddr) = addrPrimTy
-literalType (MachInt _) = intPrimTy
-literalType (MachWord _) = wordPrimTy
-literalType (MachInt64 _) = int64PrimTy
-literalType (MachWord64 _) = word64PrimTy
-literalType (MachFloat _) = floatPrimTy
-literalType (MachDouble _) = doublePrimTy
-literalType (MachLabel _ _) = addrPrimTy
-\end{code}
-
-\begin{code}
-literalPrimRep :: Literal -> PrimRep
-
-literalPrimRep (MachChar _) = CharRep
-literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
-literalPrimRep (MachNullAddr) = AddrRep
-literalPrimRep (MachInt _) = IntRep
-literalPrimRep (MachWord _) = WordRep
-literalPrimRep (MachInt64 _) = Int64Rep
-literalPrimRep (MachWord64 _) = Word64Rep
-literalPrimRep (MachFloat _) = FloatRep
-literalPrimRep (MachDouble _) = DoubleRep
-literalPrimRep (MachLabel _ _) = AddrRep
+literalType MachNullAddr = addrPrimTy
+literalType (MachChar _) = charPrimTy
+literalType (MachStr _) = addrPrimTy
+literalType (MachInt _) = intPrimTy
+literalType (MachWord _) = wordPrimTy
+literalType (MachInt64 _) = int64PrimTy
+literalType (MachWord64 _) = word64PrimTy
+literalType (MachFloat _) = floatPrimTy
+literalType (MachDouble _) = doublePrimTy
+literalType (MachLabel _ _) = addrPrimTy
\end{code}
exceptions: MachFloat gets an initial keyword prefix.
\begin{code}
-pprLit lit
- = getPprStyle $ \ sty ->
- let
- code_style = codeStyle sty
- in
- case lit of
- MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show (ord ch))]
- | otherwise -> pprHsChar ch
-
- MachStr s | code_style -> pprFSInCStyle s
- | otherwise -> pprHsString s
- -- Warning: printing MachStr in code_style assumes it contains
- -- only characters '\0'..'\xFF'!
-
- MachInt i | code_style && i == tARGET_MIN_INT -> parens (integer (i+1) <> text "-1")
- -- Avoid a problem whereby gcc interprets
- -- the constant minInt as unsigned.
- | otherwise -> pprIntVal i
-
- MachInt64 i | code_style -> pprIntVal i -- Same problem with gcc???
- | otherwise -> ptext SLIT("__int64") <+> integer i
-
- MachWord w | code_style -> pprHexVal w
- | otherwise -> ptext SLIT("__word") <+> integer w
-
- MachWord64 w | code_style -> pprHexVal w
- | otherwise -> ptext SLIT("__word64") <+> integer w
-
- MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> code_rational f
- | otherwise -> ptext SLIT("__float") <+> rational f
-
- MachDouble d | code_style -> code_rational d
- | otherwise -> rational d
-
- MachNullAddr | code_style -> ptext SLIT("(void*)0")
- | otherwise -> ptext SLIT("__NULL")
-
- MachLabel l mb
- | code_style -> ptext SLIT("(&") <> ftext l <> char ')'
- | otherwise -> ptext SLIT("__label") <+>
- case mb of
- Nothing -> pprHsString l
- Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
-
--- negative floating literals in code style need parentheses to avoid
--- interacting with surrounding syntax.
-code_rational d | d < 0 = parens (rational d)
- | otherwise = rational d
+pprLit (MachChar ch) = pprHsChar ch
+pprLit (MachStr s) = pprHsString s
+pprLit (MachInt i) = pprIntVal i
+pprLit (MachInt64 i) = ptext SLIT("__int64") <+> integer i
+pprLit (MachWord w) = ptext SLIT("__word") <+> integer w
+pprLit (MachWord64 w) = ptext SLIT("__word64") <+> integer w
+pprLit (MachFloat f) = ptext SLIT("__float") <+> rational f
+pprLit (MachDouble d) = rational d
+pprLit (MachNullAddr) = ptext SLIT("__NULL")
+pprLit (MachLabel l mb) = ptext SLIT("__label") <+>
+ case mb of
+ Nothing -> pprHsString l
+ Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
pprIntVal :: Integer -> SDoc
-- Print negative integers with parens to be sure it's unambiguous
pprIntVal i | i < 0 = parens (integer i)
| otherwise = integer i
-
-pprHexVal :: Integer -> SDoc
--- Print in C hex format: 0x13fa
-pprHexVal 0 = ptext SLIT("0x0")
-pprHexVal w = ptext SLIT("0x") <> go w
- where
- go 0 = empty
- go w = go quot <> dig
- where
- (quot,rem) = w `quotRem` 16
- dig | rem < 10 = char (chr (fromInteger rem + ord '0'))
- | otherwise = char (chr (fromInteger rem - 10 + ord 'a'))
\end{code}
pprInternal sty uniq occ
| codeStyle sty = pprUnique uniq
- | debugStyle sty = hsep [pprOccName occ, text "{-",
- text (briefOccNameFlavour occ),
- pprUnique uniq, text "-}"]
+ | debugStyle sty = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}"
| otherwise = pprOccName occ -- User style
-- Like Internal, except that we only omit the unique in Iface style
mkPArrDataConUnique,
mkBuiltinUnique,
- mkPseudoUnique3
+ mkPseudoUniqueC,
+ mkPseudoUniqueD,
+ mkPseudoUniqueE,
+ mkPseudoUniqueH
) where
#include "HsVersions.h"
Allocation of unique supply characters:
v,t,u : for renumbering value-, type- and usage- vars.
- other a-z: lower case chars for unique supplies (see Main.lhs)
B: builtin
C-E: pseudo uniques (used in native-code generator)
X: uniques derived by deriveUnique
_: unifiable tyvars (above)
0-9: prelude things below
+ other a-z: lower case chars for unique supplies. Used so far:
+
+ d desugarer
+ f AbsC flattener
+ g SimplStg
+ l ndpFlatten
+ n Native codegen
+ r Hsc name cache
+ s simplifier
+
\begin{code}
mkAlphaTyVarUnique i = mkUnique '1' i
initTyVarUnique :: Unique
initTyVarUnique = mkUnique 't' 0
-mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+mkPseudoUniqueC, mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,
mkBuiltinUnique :: Int -> Unique
-builtinUniques :: [Unique]
-builtinUniques = map mkBuiltinUnique [1..]
-
mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUnique1 i = mkUnique 'C' i -- used for getUnique on Regs
-mkPseudoUnique2 i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs
-mkPseudoUnique3 i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs
+mkPseudoUniqueC i = mkUnique 'C' i -- used for getUnique on Regs
+mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs
+mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs
+mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs
\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Object-file symbols (called CLabel for histerical raisins).
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CLabel (
+ CLabel, -- abstract type
+
+ mkClosureLabel,
+ mkSRTLabel,
+ mkSRTDescLabel,
+ mkInfoTableLabel,
+ mkEntryLabel,
+ mkSlowEntryLabel,
+ mkConEntryLabel,
+ mkStaticConEntryLabel,
+ mkRednCountsLabel,
+ mkConInfoTableLabel,
+ mkStaticInfoTableLabel,
+ mkApEntryLabel,
+ mkApInfoTableLabel,
+
+ mkReturnPtLabel,
+ mkReturnInfoLabel,
+ mkAltLabel,
+ mkDefaultLabel,
+ mkBitmapLabel,
+
+ mkClosureTblLabel,
+
+ mkAsmTempLabel,
+
+ mkModuleInitLabel,
+ mkPlainModuleInitLabel,
+
+ mkErrorStdEntryLabel,
+ mkSplitMarkerLabel,
+ mkUpdInfoLabel,
+ mkSeqInfoLabel,
+ mkIndStaticInfoLabel,
+ mkMainCapabilityLabel,
+ mkMAP_FROZEN_infoLabel,
+ mkEMPTY_MVAR_infoLabel,
+
+ mkTopTickyCtrLabel,
+ mkCAFBlackHoleInfoTableLabel,
+ mkSECAFBlackHoleInfoTableLabel,
+ mkRtsPrimOpLabel,
+ mkRtsSlowTickyCtrLabel,
+
+ moduleRegdLabel,
+
+ mkSelectorInfoLabel,
+ mkSelectorEntryLabel,
+
+ mkRtsInfoLabel,
+ mkRtsEntryLabel,
+ mkRtsRetInfoLabel,
+ mkRtsRetLabel,
+ mkRtsCodeLabel,
+ mkRtsDataLabel,
+
+ mkRtsInfoLabelFS,
+ mkRtsEntryLabelFS,
+ mkRtsRetInfoLabelFS,
+ mkRtsRetLabelFS,
+ mkRtsCodeLabelFS,
+ mkRtsDataLabelFS,
+
+ mkForeignLabel,
+
+ mkCCLabel, mkCCSLabel,
+
+ infoLblToEntryLbl, entryLblToInfoLbl,
+ needsCDecl, isAsmTemp, externallyVisibleCLabel,
+ CLabelType(..), labelType, labelDynamic, labelCouldBeDynamic,
+
+ pprCLabel
+ ) where
+
+
+#include "HsVersions.h"
+#include "../includes/ghcconfig.h"
+
+import CmdLineOpts ( opt_Static, opt_DoTickyProfiling )
+import DataCon ( ConTag )
+import Module ( moduleName, moduleNameFS,
+ Module, isHomeModule )
+import Name ( Name, isDllName, isExternalName )
+import Unique ( pprUnique, Unique )
+import PrimOp ( PrimOp )
+import Config ( cLeadingUnderscore )
+import CostCentre ( CostCentre, CostCentreStack )
+import Outputable
+import FastString
+
+
+-- -----------------------------------------------------------------------------
+-- The CLabel type
+
+{-
+CLabel is an abstract type that supports the following operations:
+
+ - Pretty printing
+
+ - In a C file, does it need to be declared before use? (i.e. is it
+ guaranteed to be already in scope in the places we need to refer to it?)
+
+ - If it needs to be declared, what type (code or data) should it be
+ declared to have?
+
+ - Is it visible outside this object file or not?
+
+ - Is it "dynamic" (see details below)
+
+ - Eq and Ord, so that we can make sets of CLabels (currently only
+ used in outputting C as far as I can tell, to avoid generating
+ more than one declaration for any given label).
+
+ - Converting an info table label into an entry label.
+-}
+
+data CLabel
+ = IdLabel -- A family of labels related to the
+ Name -- definition of a particular Id or Con
+ IdLabelInfo
+
+ | CaseLabel -- A family of labels related to a particular
+ -- case expression.
+ {-# UNPACK #-} !Unique -- Unique says which case expression
+ CaseLabelInfo
+
+ | AsmTempLabel
+ {-# UNPACK #-} !Unique
+
+ | ModuleInitLabel
+ Module -- the module name
+ String -- its "way"
+ -- at some point we might want some kind of version number in
+ -- the module init label, to guard against compiling modules in
+ -- the wrong order. We can't use the interface file version however,
+ -- because we don't always recompile modules which depend on a module
+ -- whose version has changed.
+
+ | PlainModuleInitLabel Module -- without the vesrion & way info
+
+ | ModuleRegdLabel
+
+ | RtsLabel RtsLabelInfo
+
+ | ForeignLabel FastString -- a 'C' (or otherwise foreign) label
+ (Maybe Int) -- possible '@n' suffix for stdcall functions
+ -- When generating C, the '@n' suffix is omitted, but when
+ -- generating assembler we must add it to the label.
+ Bool -- True <=> is dynamic
+
+ | CC_Label CostCentre
+ | CCS_Label CostCentreStack
+
+ deriving (Eq, Ord)
+
+
+data IdLabelInfo
+ = Closure -- Label for closure
+ | SRT -- Static reference table
+ | SRTDesc -- Static reference table descriptor
+ | InfoTbl -- Info tables for closures; always read-only
+ | Entry -- entry point
+ | Slow -- slow entry point
+
+ | RednCounts -- Label of place to keep Ticky-ticky info for
+ -- this Id
+
+ | Bitmap -- A bitmap (function or case return)
+
+ | ConEntry -- constructor entry point
+ | ConInfoTbl -- corresponding info table
+ | StaticConEntry -- static constructor entry point
+ | StaticInfoTbl -- corresponding info table
+
+ | ClosureTable -- table of closures for Enum tycons
+
+ deriving (Eq, Ord)
+
+
+data CaseLabelInfo
+ = CaseReturnPt
+ | CaseReturnInfo
+ | CaseAlt ConTag
+ | CaseDefault
+ deriving (Eq, Ord)
+
+
+data RtsLabelInfo
+ = RtsShouldNeverHappenCode
+
+ | RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks
+ | RtsSelectorEntry Bool{-updatable-} Int{-offset-}
+
+ | RtsApInfoTbl Bool{-updatable-} Int{-arity-} -- AP thunks
+ | RtsApEntry Bool{-updatable-} Int{-arity-}
+
+ | RtsPrimOp PrimOp
+
+ | RtsInfo LitString -- misc rts info tables
+ | RtsEntry LitString -- misc rts entry points
+ | RtsRetInfo LitString -- misc rts ret info tables
+ | RtsRet LitString -- misc rts return points
+ | RtsData LitString -- misc rts data bits, eg CHARLIKE_closure
+ | RtsCode LitString -- misc rts code
+
+ | RtsInfoFS FastString -- misc rts info tables
+ | RtsEntryFS FastString -- misc rts entry points
+ | RtsRetInfoFS FastString -- misc rts ret info tables
+ | RtsRetFS FastString -- misc rts return points
+ | RtsDataFS FastString -- misc rts data bits, eg CHARLIKE_closure
+ | RtsCodeFS FastString -- misc rts code
+
+ | RtsSlowTickyCtr String
+
+ deriving (Eq, Ord)
+ -- NOTE: Eq on LitString compares the pointer only, so this isn't
+ -- a real equality.
+
+-- -----------------------------------------------------------------------------
+-- Constructing CLabels
+
+mkClosureLabel id = IdLabel id Closure
+mkSRTLabel id = IdLabel id SRT
+mkSRTDescLabel id = IdLabel id SRTDesc
+mkInfoTableLabel id = IdLabel id InfoTbl
+mkEntryLabel id = IdLabel id Entry
+mkSlowEntryLabel id = IdLabel id Slow
+mkBitmapLabel id = IdLabel id Bitmap
+mkRednCountsLabel id = IdLabel id RednCounts
+
+mkConInfoTableLabel con = IdLabel con ConInfoTbl
+mkConEntryLabel con = IdLabel con ConEntry
+mkStaticInfoTableLabel con = IdLabel con StaticInfoTbl
+mkStaticConEntryLabel con = IdLabel con StaticConEntry
+
+mkClosureTblLabel id = IdLabel id ClosureTable
+
+mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
+mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
+mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
+mkDefaultLabel uniq = CaseLabel uniq CaseDefault
+
+mkAsmTempLabel = AsmTempLabel
+
+mkModuleInitLabel = ModuleInitLabel
+mkPlainModuleInitLabel = PlainModuleInitLabel
+
+ -- Some fixed runtime system labels
+
+mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
+mkSplitMarkerLabel = RtsLabel (RtsCode SLIT("__stg_split_marker"))
+mkUpdInfoLabel = RtsLabel (RtsInfo SLIT("stg_upd_frame"))
+mkSeqInfoLabel = RtsLabel (RtsInfo SLIT("stg_seq_frame"))
+mkIndStaticInfoLabel = RtsLabel (RtsInfo SLIT("stg_IND_STATIC"))
+mkMainCapabilityLabel = RtsLabel (RtsData SLIT("MainCapability"))
+mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_FROZEN"))
+mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo SLIT("stg_EMPTY_MVAR"))
+
+mkTopTickyCtrLabel = RtsLabel (RtsData SLIT("top_ct"))
+mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo SLIT("stg_CAF_BLACKHOLE"))
+mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
+ RtsLabel (RtsInfo SLIT("stg_SE_CAF_BLACKHOLE"))
+ else -- RTS won't have info table unless -ticky is on
+ panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
+mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
+
+moduleRegdLabel = ModuleRegdLabel
+
+mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off)
+mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off)
+
+mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTbl upd off)
+mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
+
+ -- Foreign labels
+
+mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel
+mkForeignLabel str mb_sz is_dynamic = ForeignLabel str mb_sz is_dynamic
+
+ -- Cost centres etc.
+
+mkCCLabel cc = CC_Label cc
+mkCCSLabel ccs = CCS_Label ccs
+
+mkRtsInfoLabel str = RtsLabel (RtsInfo str)
+mkRtsEntryLabel str = RtsLabel (RtsEntry str)
+mkRtsRetInfoLabel str = RtsLabel (RtsRetInfo str)
+mkRtsRetLabel str = RtsLabel (RtsRet str)
+mkRtsCodeLabel str = RtsLabel (RtsCode str)
+mkRtsDataLabel str = RtsLabel (RtsData str)
+
+mkRtsInfoLabelFS str = RtsLabel (RtsInfoFS str)
+mkRtsEntryLabelFS str = RtsLabel (RtsEntryFS str)
+mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str)
+mkRtsRetLabelFS str = RtsLabel (RtsRetFS str)
+mkRtsCodeLabelFS str = RtsLabel (RtsCodeFS str)
+mkRtsDataLabelFS str = RtsLabel (RtsDataFS str)
+
+mkRtsSlowTickyCtrLabel :: String -> CLabel
+mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
+
+-- -----------------------------------------------------------------------------
+-- Converting info labels to entry labels.
+
+infoLblToEntryLbl :: CLabel -> CLabel
+infoLblToEntryLbl (IdLabel n InfoTbl) = IdLabel n Entry
+infoLblToEntryLbl (IdLabel n ConInfoTbl) = IdLabel n ConEntry
+infoLblToEntryLbl (IdLabel n StaticInfoTbl) = IdLabel n StaticConEntry
+infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
+infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
+infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
+infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s)
+infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s)
+infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl"
+
+entryLblToInfoLbl :: CLabel -> CLabel
+entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTbl
+entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTbl
+entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTbl
+entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
+entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
+entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
+entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s)
+entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
+entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need declaring before use or not?
+
+needsCDecl :: CLabel -> Bool
+ -- False <=> it's pre-declared; don't bother
+ -- don't bother declaring SRT & Bitmap labels, we always make sure
+ -- they are defined before use.
+needsCDecl (IdLabel _ SRT) = False
+needsCDecl (IdLabel _ SRTDesc) = False
+needsCDecl (IdLabel _ Bitmap) = False
+needsCDecl (IdLabel _ _) = True
+needsCDecl (CaseLabel _ CaseReturnPt) = True
+needsCDecl (CaseLabel _ CaseReturnInfo) = True
+needsCDecl (ModuleInitLabel _ _) = True
+needsCDecl (PlainModuleInitLabel _) = True
+needsCDecl ModuleRegdLabel = False
+
+needsCDecl (CaseLabel _ _) = False
+needsCDecl (AsmTempLabel _) = False
+needsCDecl (RtsLabel _) = False
+needsCDecl (ForeignLabel _ _ _) = False
+needsCDecl (CC_Label _) = True
+needsCDecl (CCS_Label _) = True
+
+-- Whether the label is an assembler temporary:
+
+isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation
+isAsmTemp (AsmTempLabel _) = True
+isAsmTemp _ = False
+
+-- -----------------------------------------------------------------------------
+-- Is a CLabel visible outside this object file or not?
+
+-- From the point of view of the code generator, a name is
+-- externally visible if it has to be declared as exported
+-- in the .o file's symbol table; that is, made non-static.
+
+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
+externallyVisibleCLabel (CaseLabel _ _) = False
+externallyVisibleCLabel (AsmTempLabel _) = False
+externallyVisibleCLabel (ModuleInitLabel _ _)= True
+externallyVisibleCLabel (PlainModuleInitLabel _)= True
+externallyVisibleCLabel ModuleRegdLabel = False
+externallyVisibleCLabel (RtsLabel _) = True
+externallyVisibleCLabel (ForeignLabel _ _ _) = True
+externallyVisibleCLabel (IdLabel id _) = isExternalName id
+externallyVisibleCLabel (CC_Label _) = True
+externallyVisibleCLabel (CCS_Label _) = True
+
+
+-- -----------------------------------------------------------------------------
+-- Finding the "type" of a CLabel
+
+-- For generating correct types in label declarations:
+
+data CLabelType
+ = CodeLabel
+ | DataLabel
+
+labelType :: CLabel -> CLabelType
+labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = DataLabel
+labelType (RtsLabel (RtsApInfoTbl _ _)) = DataLabel
+labelType (RtsLabel (RtsData _)) = DataLabel
+labelType (RtsLabel (RtsCode _)) = CodeLabel
+labelType (RtsLabel (RtsInfo _)) = DataLabel
+labelType (RtsLabel (RtsEntry _)) = CodeLabel
+labelType (RtsLabel (RtsRetInfo _)) = DataLabel
+labelType (RtsLabel (RtsRet _)) = CodeLabel
+labelType (RtsLabel (RtsDataFS _)) = DataLabel
+labelType (RtsLabel (RtsCodeFS _)) = CodeLabel
+labelType (RtsLabel (RtsInfoFS _)) = DataLabel
+labelType (RtsLabel (RtsEntryFS _)) = CodeLabel
+labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel
+labelType (RtsLabel (RtsRetFS _)) = CodeLabel
+labelType (CaseLabel _ CaseReturnInfo) = DataLabel
+labelType (CaseLabel _ CaseReturnPt) = CodeLabel
+labelType (ModuleInitLabel _ _) = CodeLabel
+labelType (PlainModuleInitLabel _) = CodeLabel
+
+labelType (IdLabel _ info) =
+ case info of
+ InfoTbl -> DataLabel
+ Closure -> DataLabel
+ Bitmap -> DataLabel
+ ConInfoTbl -> DataLabel
+ StaticInfoTbl -> DataLabel
+ ClosureTable -> DataLabel
+ _ -> CodeLabel
+
+labelType _ = DataLabel
+
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need dynamic linkage?
+
+-- When referring to data in code, we need to know whether
+-- that data resides in a DLL or not. [Win32 only.]
+-- @labelDynamic@ returns @True@ if the label is located
+-- in a DLL, be it a data reference or not.
+
+labelDynamic :: CLabel -> Bool
+labelDynamic lbl =
+ case lbl of
+ -- The special case for RtsShouldNeverHappenCode is because the associated address is
+ -- NULL, i.e. not a DLL entry point
+ RtsLabel RtsShouldNeverHappenCode -> False
+ RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not?
+ IdLabel n k -> isDllName n
+ ForeignLabel _ _ d -> d
+ ModuleInitLabel m _ -> (not opt_Static) && (not (isHomeModule m))
+ PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
+ _ -> False
+
+-- Basically the same as above, but this time for Darwin only.
+-- The things that GHC does when labelDynamic returns true are not quite right
+-- for Darwin. Also, every ForeignLabel might possibly be from a dynamic library,
+-- and a 'false positive' doesn't really hurt on Darwin, so this just returns
+-- True for every ForeignLabel.
+--
+-- ToDo: Clean up DLL-related code so we can do away with the distinction
+-- between this and labelDynamic above.
+
+labelCouldBeDynamic (ForeignLabel _ _ _) = True
+labelCouldBeDynamic lbl = labelDynamic lbl
+
+{-
+OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
+right places. It is used to detect when the abstractC statement of an
+CCodeBlock actually contains the code for a slow entry point. -- HWL
+
+We need at least @Eq@ for @CLabels@, because we want to avoid
+duplicate declarations in generating C (see @labelSeenTE@ in
+@PprAbsC@).
+-}
+
+-----------------------------------------------------------------------------
+-- Printing out CLabels.
+
+{-
+Convention:
+
+ <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+ info Info table
+ srt Static reference table
+ srtd Static reference table descriptor
+ entry Entry code (function, closure)
+ slow Slow entry code (if any)
+ ret Direct return address
+ vtbl Vector table
+ <n>_alt Case alternative (tag n)
+ dflt Default case alternative
+ btm Large bitmap vector
+ closure Static closure
+ con_entry Dynamic Constructor entry code
+ con_info Dynamic Constructor info table
+ static_entry Static Constructor entry code
+ static_info Static Constructor info table
+ sel_info Selector info table
+ sel_entry Selector entry code
+ cc Cost centre
+ ccs Cost centre stack
+
+Many of these distinctions are only for documentation reasons. For
+example, _ret is only distinguished from _entry to make it easy to
+tell whether a code fragment is a return point or a closure/function
+entry.
+-}
+
+pprCLabel :: CLabel -> SDoc
+
+#if ! OMIT_NATIVE_CODEGEN
+pprCLabel (AsmTempLabel u)
+ = getPprStyle $ \ sty ->
+ if asmStyle sty then
+ ptext asmTempLabelPrefix <> pprUnique u
+ else
+ char '_' <> pprUnique u
+#endif
+
+pprCLabel lbl =
+#if ! OMIT_NATIVE_CODEGEN
+ getPprStyle $ \ sty ->
+ if asmStyle sty then
+ maybe_underscore (pprAsmCLbl lbl)
+ else
+#endif
+ pprCLbl lbl
+
+maybe_underscore doc
+ | underscorePrefix = pp_cSEP <> doc
+ | otherwise = doc
+
+-- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
+-- (The C compiler does this itself).
+pprAsmCLbl (ForeignLabel fs (Just sz) _)
+ = ftext fs <> char '@' <> int sz
+pprAsmCLbl lbl
+ = pprCLbl lbl
+
+pprCLbl (CaseLabel u CaseReturnPt)
+ = hcat [pprUnique u, ptext SLIT("_ret")]
+pprCLbl (CaseLabel u CaseReturnInfo)
+ = hcat [pprUnique u, ptext SLIT("_info")]
+pprCLbl (CaseLabel u (CaseAlt tag))
+ = hcat [pprUnique u, pp_cSEP, int tag, ptext SLIT("_alt")]
+pprCLbl (CaseLabel u CaseDefault)
+ = hcat [pprUnique u, ptext SLIT("_dflt")]
+
+pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("0")
+-- used to be stg_error_entry but Windows can't have DLL entry points as static
+-- initialisers, and besides, this ShouldNeverHappen, right?
+
+pprCLbl (RtsLabel (RtsCode str)) = ptext str
+pprCLbl (RtsLabel (RtsData str)) = ptext str
+pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
+pprCLbl (RtsLabel (RtsDataFS str)) = ftext str
+
+pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
+ = hcat [ptext SLIT("stg_sel_"), text (show offset),
+ ptext (if upd_reqd
+ then SLIT("_upd_info")
+ else SLIT("_noupd_info"))
+ ]
+
+pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
+ = hcat [ptext SLIT("stg_sel_"), text (show offset),
+ ptext (if upd_reqd
+ then SLIT("_upd_entry")
+ else SLIT("_noupd_entry"))
+ ]
+
+pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity))
+ = hcat [ptext SLIT("stg_ap_"), text (show arity),
+ ptext (if upd_reqd
+ then SLIT("_upd_info")
+ else SLIT("_noupd_info"))
+ ]
+
+pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
+ = hcat [ptext SLIT("stg_ap_"), text (show arity),
+ ptext (if upd_reqd
+ then SLIT("_upd_entry")
+ else SLIT("_noupd_entry"))
+ ]
+
+pprCLbl (RtsLabel (RtsInfo fs))
+ = ptext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsEntry fs))
+ = ptext fs <> ptext SLIT("_entry")
+
+pprCLbl (RtsLabel (RtsRetInfo fs))
+ = ptext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsRet fs))
+ = ptext fs <> ptext SLIT("_ret")
+
+pprCLbl (RtsLabel (RtsInfoFS fs))
+ = ftext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsEntryFS fs))
+ = ftext fs <> ptext SLIT("_entry")
+
+pprCLbl (RtsLabel (RtsRetInfoFS fs))
+ = ftext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsRetFS fs))
+ = ftext fs <> ptext SLIT("_ret")
+
+pprCLbl (RtsLabel (RtsPrimOp primop))
+ = ppr primop <> ptext SLIT("_fast")
+
+pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
+ = ptext SLIT("SLOW_CALL_") <> text pat <> ptext SLIT("_ctr")
+
+pprCLbl ModuleRegdLabel
+ = ptext SLIT("_module_registered")
+
+pprCLbl (ForeignLabel str _ _)
+ = ftext str
+
+pprCLbl (IdLabel id flavor) = ppr id <> ppIdFlavor flavor
+
+pprCLbl (CC_Label cc) = ppr cc
+pprCLbl (CCS_Label ccs) = ppr ccs
+
+pprCLbl (ModuleInitLabel mod way)
+ = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
+ <> char '_' <> text way
+pprCLbl (PlainModuleInitLabel mod)
+ = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod))
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <>
+ (case x of
+ Closure -> ptext SLIT("closure")
+ SRT -> ptext SLIT("srt")
+ SRTDesc -> ptext SLIT("srtd")
+ InfoTbl -> ptext SLIT("info")
+ Entry -> ptext SLIT("entry")
+ Slow -> ptext SLIT("slow")
+ RednCounts -> ptext SLIT("ct")
+ Bitmap -> ptext SLIT("btm")
+ ConEntry -> ptext SLIT("con_entry")
+ ConInfoTbl -> ptext SLIT("con_info")
+ StaticConEntry -> ptext SLIT("static_entry")
+ StaticInfoTbl -> ptext SLIT("static_info")
+ ClosureTable -> ptext SLIT("closure_tbl")
+ )
+
+
+pp_cSEP = char '_'
+
+-- -----------------------------------------------------------------------------
+-- Machine-dependent knowledge about labels.
+
+underscorePrefix :: Bool -- leading underscore on assembler labels?
+underscorePrefix = (cLeadingUnderscore == "YES")
+
+asmTempLabelPrefix :: LitString -- for formatting labels
+asmTempLabelPrefix =
+#if alpha_TARGET_OS
+ {- The alpha assembler likes temporary labels to look like $L123
+ instead of L123. (Don't toss the L, because then Lf28
+ turns into $f28.)
+ -}
+ SLIT("$")
+#elif darwin_TARGET_OS
+ SLIT("L")
+#else
+ SLIT(".L")
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Cmm data types
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module Cmm (
+ GenCmm(..), Cmm,
+ GenCmmTop(..), CmmTop,
+ GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
+ CmmStmt(..),
+ CmmCallTarget(..),
+ CmmStatic(..), Section(..),
+ CmmExpr(..), cmmExprRep,
+ CmmReg(..), cmmRegRep,
+ CmmLit(..), cmmLitRep,
+ LocalReg(..), localRegRep,
+ BlockId(..),
+ GlobalReg(..), globalRegRep,
+
+ node, nodeReg, spReg, hpReg,
+ ) where
+
+#include "HsVersions.h"
+
+import MachOp
+import CLabel ( CLabel )
+import ForeignCall ( CCallConv )
+import Unique ( Unique, Uniquable(..) )
+import FastString ( FastString )
+
+-----------------------------------------------------------------------------
+-- Cmm, CmmTop, CmmBasicBlock
+-----------------------------------------------------------------------------
+
+-- A file is a list of top-level chunks. These may be arbitrarily
+-- re-orderd during code generation.
+
+-- GenCmm is abstracted over
+-- (a) the type of static data elements
+-- (b) the contents of a basic block.
+-- We expect there to be two main instances of this type:
+-- (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively,
+-- (b) Native code, populated with instructions
+--
+newtype GenCmm d i = Cmm [GenCmmTop d i]
+
+type Cmm = GenCmm CmmStatic CmmStmt
+
+-- A top-level chunk, abstracted over the type of the contents of
+-- the basic blocks (Cmm or instructions are the likely instantiations).
+data GenCmmTop d i
+ = CmmProc
+ [d] -- Info table, may be empty
+ CLabel -- Used to generate both info & entry labels
+ [LocalReg] -- Argument locals live on entry (C-- procedure params)
+ [GenBasicBlock i] -- Code, may be empty. The first block is
+ -- the entry point. The order is otherwise initially
+ -- unimportant, but at some point the code gen will
+ -- fix the order.
+
+ -- the BlockId of the first block does not give rise
+ -- to a label. To jump to the first block in a Proc,
+ -- use the appropriate CLabel.
+
+ -- some static data.
+ | CmmData Section [d] -- constant values only
+
+type CmmTop = GenCmmTop CmmStatic CmmStmt
+
+-- A basic block containing a single label, at the beginning.
+-- The list of basic blocks in a top-level code block may be re-ordered.
+-- Fall-through is not allowed: there must be an explicit jump at the
+-- end of each basic block, but the code generator might rearrange basic
+-- blocks in order to turn some jumps into fallthroughs.
+
+data GenBasicBlock i = BasicBlock BlockId [i]
+ -- ToDo: Julian suggests that we might need to annotate this type
+ -- with the out & in edges in the graph, i.e. two * [BlockId]. This
+ -- information can be derived from the contents, but it might be
+ -- helpful to cache it here.
+
+type CmmBasicBlock = GenBasicBlock CmmStmt
+
+blockId :: GenBasicBlock i -> BlockId
+-- The branch block id is that of the first block in
+-- the branch, which is that branch's entry point
+blockId (BasicBlock blk_id _ ) = blk_id
+
+blockStmts :: GenBasicBlock i -> [i]
+blockStmts (BasicBlock _ stmts) = stmts
+
+
+-----------------------------------------------------------------------------
+-- CmmStmt
+-- A "statement". Note that all branches are explicit: there are no
+-- control transfers to computed addresses, except when transfering
+-- control to a new function.
+-----------------------------------------------------------------------------
+
+data CmmStmt
+ = CmmNop
+ | CmmComment FastString
+
+ | CmmAssign CmmReg CmmExpr -- Assign to register
+
+ | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
+ -- given by cmmExprRep of the rhs.
+
+ | CmmCall -- A foreign call, with
+ CmmCallTarget
+ [(CmmReg,MachHint)] -- zero or more results
+ [(CmmExpr,MachHint)] -- zero or more arguments
+ (Maybe [GlobalReg]) -- Global regs that may need to be saved
+ -- if they will be clobbered by the call.
+ -- Nothing <=> save *all* globals that
+ -- might be clobbered.
+
+ | CmmBranch BlockId -- branch to another BB in this fn
+
+ | CmmCondBranch CmmExpr BlockId -- conditional branch
+
+ | CmmSwitch CmmExpr [Maybe BlockId] -- Table branch
+ -- The scrutinee is zero-based;
+ -- zero -> first block
+ -- one -> second block etc
+ -- Undefined outside range, and when there's a Nothing
+
+ | CmmJump CmmExpr [LocalReg] -- Jump to another function, with these
+ -- parameters.
+
+-----------------------------------------------------------------------------
+-- CmmCallTarget
+--
+-- The target of a CmmCall.
+-----------------------------------------------------------------------------
+
+data CmmCallTarget
+ = CmmForeignCall -- Call to a foreign function
+ CmmExpr -- literal label <=> static call
+ -- other expression <=> dynamic call
+ CCallConv -- The calling convention
+
+ | CmmPrim -- Call to a "primitive" (eg. sin, cos)
+ CallishMachOp -- These might be implemented as inline
+ -- code by the backend.
+
+-----------------------------------------------------------------------------
+-- CmmExpr
+-- An expression. Expressions have no side effects.
+-----------------------------------------------------------------------------
+
+data CmmExpr
+ = CmmLit CmmLit -- Literal
+ | CmmLoad CmmExpr MachRep -- Read memory location
+ | CmmReg CmmReg -- Contents of register
+ | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.)
+ | CmmRegOff CmmReg Int
+ -- CmmRegOff reg i
+ -- ** is shorthand only, meaning **
+ -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
+ -- where rep = cmmRegRep reg
+
+cmmExprRep :: CmmExpr -> MachRep
+cmmExprRep (CmmLit lit) = cmmLitRep lit
+cmmExprRep (CmmLoad _ rep) = rep
+cmmExprRep (CmmReg reg) = cmmRegRep reg
+cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op
+cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
+
+data CmmReg
+ = CmmLocal LocalReg
+ | CmmGlobal GlobalReg
+ deriving( Eq )
+
+cmmRegRep :: CmmReg -> MachRep
+cmmRegRep (CmmLocal reg) = localRegRep reg
+cmmRegRep (CmmGlobal reg) = globalRegRep reg
+
+data LocalReg
+ = LocalReg !Unique MachRep
+
+instance Eq LocalReg where
+ (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+
+instance Uniquable LocalReg where
+ getUnique (LocalReg uniq _) = uniq
+
+localRegRep :: LocalReg -> MachRep
+localRegRep (LocalReg _ rep) = rep
+
+data CmmLit
+ = CmmInt Integer MachRep
+ -- Interpretation: the 2's complement representation of the value
+ -- is truncated to the specified size. This is easier than trying
+ -- to keep the value within range, because we don't know whether
+ -- it will be used as a signed or unsigned value (the MachRep doesn't
+ -- distinguish between signed & unsigned).
+ | CmmFloat Rational MachRep
+ | CmmLabel CLabel -- Address of label
+ | CmmLabelOff CLabel Int -- Address of label + byte offset
+
+cmmLitRep :: CmmLit -> MachRep
+cmmLitRep (CmmInt _ rep) = rep
+cmmLitRep (CmmFloat _ rep) = rep
+cmmLitRep (CmmLabel _) = wordRep
+cmmLitRep (CmmLabelOff _ _) = wordRep
+
+-----------------------------------------------------------------------------
+-- A local label.
+
+-- Local labels must be unique within a single compilation unit.
+
+newtype BlockId = BlockId Unique
+ deriving (Eq,Ord)
+
+instance Uniquable BlockId where
+ getUnique (BlockId u) = u
+
+-----------------------------------------------------------------------------
+-- Static Data
+-----------------------------------------------------------------------------
+
+data Section
+ = Text
+ | Data
+ | ReadOnlyData
+ | UninitialisedData
+ | OtherSection String
+
+data CmmStatic
+ = CmmStaticLit CmmLit
+ -- a literal value, size given by cmmLitRep of the literal.
+ | CmmUninitialised Int
+ -- uninitialised data, N bytes long
+ | CmmAlign Int
+ -- align to next N-byte boundary (N must be a power of 2).
+ | CmmDataLabel CLabel
+ -- label the current position in this section.
+ | CmmString String
+ -- string of 8-bit values only, not zero terminated.
+ -- ToDo: might be more honest to use [Word8] here?
+
+-----------------------------------------------------------------------------
+-- Global STG registers
+-----------------------------------------------------------------------------
+
+data GlobalReg
+ -- Argument and return registers
+ = VanillaReg -- pointers, unboxed ints and chars
+ {-# UNPACK #-} !Int -- its number
+
+ | FloatReg -- single-precision floating-point registers
+ {-# UNPACK #-} !Int -- its number
+
+ | DoubleReg -- double-precision floating-point registers
+ {-# UNPACK #-} !Int -- its number
+
+ | LongReg -- long int registers (64-bit, really)
+ {-# UNPACK #-} !Int -- its number
+
+ -- STG registers
+ | Sp -- Stack ptr; points to last occupied stack location.
+ | SpLim -- Stack limit
+ | Hp -- Heap ptr; points to last occupied heap location.
+ | HpLim -- Heap limit register
+ | CurrentTSO -- pointer to current thread's TSO
+ | CurrentNursery -- pointer to allocation area
+ | HpAlloc -- allocation count for heap check failure
+
+ -- We keep the address of some commonly-called
+ -- functions in the register table, to keep code
+ -- size down:
+ | GCEnter1 -- stg_gc_enter_1
+ | GCFun -- stg_gc_fun
+
+ -- Base offset for the register table, used for accessing registers
+ -- which do not have real registers assigned to them. This register
+ -- will only appear after we have expanded GlobalReg into memory accesses
+ -- (where necessary) in the native code generator.
+ | BaseReg
+
+ deriving( Eq
+#ifdef DEBUG
+ , Show
+#endif
+ )
+
+-- convenient aliases
+spReg, hpReg, nodeReg :: CmmReg
+spReg = CmmGlobal Sp
+hpReg = CmmGlobal Hp
+nodeReg = CmmGlobal node
+
+node :: GlobalReg
+node = VanillaReg 1
+
+globalRegRep :: GlobalReg -> MachRep
+globalRegRep (VanillaReg _) = wordRep
+globalRegRep (FloatReg _) = F32
+globalRegRep (DoubleReg _) = F64
+globalRegRep (LongReg _) = I64
+globalRegRep _ = wordRep
--- /dev/null
+-----------------------------------------------------------------------------
+-- (c) The University of Glasgow, 2004
+--
+-- Lexer for concrete Cmm. We try to stay close to the C-- spec, but there
+-- are a few minor differences:
+--
+-- * extra keywords for our macros, and float32/float64 types
+-- * global registers (Sp,Hp, etc.)
+--
+-----------------------------------------------------------------------------
+
+{
+module CmmLex (
+ CmmToken(..), cmmlex,
+ ) where
+
+#include "HsVersions.h"
+
+import Cmm
+import Lexer
+
+import SrcLoc
+import UniqFM
+import StringBuffer
+import FastString
+import Ctype
+import Util ( readRational )
+--import TRACE
+}
+
+$whitechar = [\ \t\n\r\f\v\xa0]
+$white_no_nl = $whitechar # \n
+
+$ascdigit = 0-9
+$unidigit = \x01
+$digit = [$ascdigit $unidigit]
+$octit = 0-7
+$hexit = [$digit A-F a-f]
+
+$unilarge = \x03
+$asclarge = [A-Z \xc0-\xd6 \xd8-\xde]
+$large = [$asclarge $unilarge]
+
+$unismall = \x04
+$ascsmall = [a-z \xdf-\xf6 \xf8-\xff]
+$small = [$ascsmall $unismall \_]
+
+$namebegin = [$large $small \_ \. \$ \@]
+$namechar = [$namebegin $digit]
+
+@decimal = $digit+
+@octal = $octit+
+@hexadecimal = $hexit+
+@exponent = [eE] [\-\+]? @decimal
+
+@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
+
+@escape = \\ ([abfnrt\\\'\"\?] | x @hexadecimal | @octal)
+@strchar = ($printable # [\"\\]) | @escape
+
+cmm :-
+
+$white_no_nl+ ;
+
+^\# (line)? { begin line_prag }
+
+-- single-line line pragmas, of the form
+-- # <line> "<file>" <extra-stuff> \n
+<line_prag> $digit+ { setLine line_prag1 }
+<line_prag1> \" ($printable # \")* \" { setFile line_prag2 }
+<line_prag2> .* { pop }
+
+<0> {
+ \n ;
+
+ [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char }
+
+ ".." { kw CmmT_DotDot }
+ "::" { kw CmmT_DoubleColon }
+ ">>" { kw CmmT_Shr }
+ "<<" { kw CmmT_Shl }
+ ">=" { kw CmmT_Ge }
+ "<=" { kw CmmT_Le }
+ "==" { kw CmmT_Eq }
+ "!=" { kw CmmT_Ne }
+ "&&" { kw CmmT_BoolAnd }
+ "||" { kw CmmT_BoolOr }
+
+ R@decimal { global_regN VanillaReg }
+ F@decimal { global_regN FloatReg }
+ D@decimal { global_regN DoubleReg }
+ L@decimal { global_regN LongReg }
+ Sp { global_reg Sp }
+ SpLim { global_reg SpLim }
+ Hp { global_reg Hp }
+ HpLim { global_reg HpLim }
+ CurrentTSO { global_reg CurrentTSO }
+ CurrentNursery { global_reg CurrentNursery }
+ HpAlloc { global_reg HpAlloc }
+
+ $namebegin $namechar* { name }
+
+ 0 @octal { tok_octal }
+ @decimal { tok_decimal }
+ 0[xX] @hexadecimal { tok_hexadecimal }
+ @floating_point { strtoken tok_float }
+
+ \" @strchar* \" { strtoken tok_string }
+}
+
+{
+data CmmToken
+ = CmmT_SpecChar Char
+ | CmmT_DotDot
+ | CmmT_DoubleColon
+ | CmmT_Shr
+ | CmmT_Shl
+ | CmmT_Ge
+ | CmmT_Le
+ | CmmT_Eq
+ | CmmT_Ne
+ | CmmT_BoolAnd
+ | CmmT_BoolOr
+ | CmmT_CLOSURE
+ | CmmT_INFO_TABLE
+ | CmmT_INFO_TABLE_RET
+ | CmmT_INFO_TABLE_FUN
+ | CmmT_INFO_TABLE_CONSTR
+ | CmmT_INFO_TABLE_SELECTOR
+ | CmmT_else
+ | CmmT_export
+ | CmmT_section
+ | CmmT_align
+ | CmmT_goto
+ | CmmT_if
+ | CmmT_jump
+ | CmmT_foreign
+ | CmmT_import
+ | CmmT_switch
+ | CmmT_case
+ | CmmT_default
+ | CmmT_bits8
+ | CmmT_bits16
+ | CmmT_bits32
+ | CmmT_bits64
+ | CmmT_float32
+ | CmmT_float64
+ | CmmT_GlobalReg GlobalReg
+ | CmmT_Name FastString
+ | CmmT_String String
+ | CmmT_Int Integer
+ | CmmT_Float Rational
+ | CmmT_EOF
+#ifdef DEBUG
+ deriving (Show)
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Lexer actions
+
+type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken)
+
+begin :: Int -> Action
+begin code _span _str _len = do pushLexState code; lexToken
+
+pop :: Action
+pop _span _buf _len = do popLexState; lexToken
+
+special_char :: Action
+special_char span buf len = return (L span (CmmT_SpecChar (currentChar buf)))
+
+kw :: CmmToken -> Action
+kw tok span buf len = return (L span tok)
+
+global_regN :: (Int -> GlobalReg) -> Action
+global_regN con span buf len
+ = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
+ where buf' = stepOn buf
+ n = parseInteger buf' (len-1) 10 octDecDigit
+
+global_reg :: GlobalReg -> Action
+global_reg r span buf len = return (L span (CmmT_GlobalReg r))
+
+strtoken :: (String -> CmmToken) -> Action
+strtoken f span buf len =
+ return (L span $! (f $! lexemeToString buf len))
+
+name :: Action
+name span buf len =
+ case lookupUFM reservedWordsFM fs of
+ Just tok -> return (L span tok)
+ Nothing -> return (L span (CmmT_Name fs))
+ where
+ fs = lexemeToFastString buf len
+
+reservedWordsFM = listToUFM $
+ map (\(x, y) -> (mkFastString x, y)) [
+ ( "CLOSURE", CmmT_CLOSURE ),
+ ( "INFO_TABLE", CmmT_INFO_TABLE ),
+ ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ),
+ ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ),
+ ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ),
+ ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
+ ( "else", CmmT_else ),
+ ( "export", CmmT_export ),
+ ( "section", CmmT_section ),
+ ( "align", CmmT_align ),
+ ( "goto", CmmT_goto ),
+ ( "if", CmmT_if ),
+ ( "jump", CmmT_jump ),
+ ( "foreign", CmmT_foreign ),
+ ( "import", CmmT_import ),
+ ( "switch", CmmT_switch ),
+ ( "case", CmmT_case ),
+ ( "default", CmmT_default ),
+ ( "bits8", CmmT_bits8 ),
+ ( "bits16", CmmT_bits16 ),
+ ( "bits32", CmmT_bits32 ),
+ ( "bits64", CmmT_bits64 ),
+ ( "float32", CmmT_float32 ),
+ ( "float64", CmmT_float64 )
+ ]
+
+tok_decimal span buf len
+ = return (L span (CmmT_Int $! parseInteger buf len 10 octDecDigit))
+
+tok_octal span buf len
+ = return (L span (CmmT_Int $! parseInteger (stepOn buf) (len-1) 8 octDecDigit))
+
+tok_hexadecimal span buf len
+ = return (L span (CmmT_Int $! parseInteger (stepOnBy 2 buf) (len-2) 16 hexDigit))
+
+tok_float str = CmmT_Float $! readRational str
+
+tok_string str = CmmT_String (read str)
+ -- urk, not quite right, but it'll do for now
+
+-- -----------------------------------------------------------------------------
+-- Line pragmas
+
+setLine :: Int -> Action
+setLine code span buf len = do
+ let line = parseInteger buf len 10 octDecDigit
+ setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
+ -- subtract one: the line number refers to the *following* line
+ -- trace ("setLine " ++ show line) $ do
+ popLexState
+ pushLexState code
+ lexToken
+
+setFile :: Int -> Action
+setFile code span buf len = do
+ let file = lexemeToFastString (stepOn buf) (len-2)
+ setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ popLexState
+ pushLexState code
+ lexToken
+
+-- -----------------------------------------------------------------------------
+-- This is the top-level function: called from the parser each time a
+-- new token is to be read from the input.
+
+cmmlex :: (Located CmmToken -> P a) -> P a
+cmmlex cont = do
+ tok@(L _ tok__) <- lexToken
+ --trace ("token: " ++ show tok__) $ do
+ cont tok
+
+lexToken :: P (Located CmmToken)
+lexToken = do
+ inp@(loc1,buf) <- getInput
+ sc <- getLexState
+ case alexScan inp sc of
+ AlexEOF -> do let span = mkSrcSpan loc1 loc1
+ setLastToken span 0
+ return (L span CmmT_EOF)
+ AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
+ AlexSkip inp2 _ -> do
+ setInput inp2
+ lexToken
+ AlexToken inp2@(end,buf2) len t -> do
+ setInput inp2
+ let span = mkSrcSpan loc1 end
+ span `seq` setLastToken span len
+ t span buf len
+
+-- -----------------------------------------------------------------------------
+-- Monad stuff
+
+-- Stuff that Alex needs to know about our input type:
+type AlexInput = (SrcLoc,StringBuffer)
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (_,s) = prevChar s '\n'
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (loc,s)
+ | atEnd s = Nothing
+ | otherwise = c `seq` loc' `seq` s' `seq` Just (c, (loc', s'))
+ where c = currentChar s
+ loc' = advanceSrcLoc loc c
+ s' = stepOn s
+
+getInput :: P AlexInput
+getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b)
+
+setInput :: AlexInput -> P ()
+setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } ()
+}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- CmmLint: checking the correctness of Cmm statements and expressions
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CmmLint (
+ cmmLint, cmmLintTop
+ ) where
+
+#include "HsVersions.h"
+
+import Cmm
+import CLabel ( pprCLabel )
+import MachOp
+import Outputable
+import PprCmm
+import Unique ( getUnique )
+import Constants ( wORD_SIZE )
+
+import Monad ( when )
+
+-- -----------------------------------------------------------------------------
+-- Exported entry points:
+
+cmmLint :: Cmm -> Maybe SDoc
+cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
+
+cmmLintTop :: CmmTop -> Maybe SDoc
+cmmLintTop top = runCmmLint $ lintCmmTop top
+
+runCmmLint :: CmmLint a -> Maybe SDoc
+runCmmLint l =
+ case unCL l of
+ Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
+ Right _ -> Nothing
+
+lintCmmTop (CmmProc _info lbl _args blocks)
+ = addLintInfo (text "in proc " <> pprCLabel lbl) $
+ mapM_ lintCmmBlock blocks
+lintCmmTop _other
+ = return ()
+
+lintCmmBlock (BasicBlock id stmts)
+ = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
+ mapM_ lintCmmStmt stmts
+
+-- -----------------------------------------------------------------------------
+-- lintCmmExpr
+
+-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
+-- byte/word mismatches.
+
+lintCmmExpr :: CmmExpr -> CmmLint MachRep
+lintCmmExpr (CmmLoad expr rep) = do
+ lintCmmExpr expr
+ when (machRepByteWidth rep >= wORD_SIZE) $
+ cmmCheckWordAddress expr
+ return rep
+lintCmmExpr expr@(CmmMachOp op args) = do
+ mapM_ lintCmmExpr args
+ if map cmmExprRep args == machOpArgReps op
+ then cmmCheckMachOp op args
+ else cmmLintMachOpErr expr
+lintCmmExpr (CmmRegOff reg offset)
+ = lintCmmExpr (CmmMachOp (MO_Add rep)
+ [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
+ where rep = cmmRegRep reg
+lintCmmExpr expr =
+ return (cmmExprRep expr)
+
+-- Check for some common byte/word mismatches (eg. Sp + 1)
+cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
+ | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+ = cmmLintDubiousWordOffset (CmmMachOp op args)
+cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
+ = cmmCheckMachOp op [reg, lit]
+cmmCheckMachOp op args
+ = return (resultRepOfMachOp op)
+
+isWordOffsetReg (CmmGlobal Sp) = True
+isWordOffsetReg (CmmGlobal Hp) = True
+isWordOffsetReg _ = False
+
+isOffsetOp (MO_Add _) = True
+isOffsetOp (MO_Sub _) = True
+isOffsetOp _ = False
+
+-- This expression should be an address from which a word can be loaded:
+-- check for funny-looking sub-word offsets.
+cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
+ | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+ = cmmLintDubiousWordOffset e
+cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
+ | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+ = cmmLintDubiousWordOffset e
+cmmCheckWordAddress _
+ = return ()
+
+
+lintCmmStmt :: CmmStmt -> CmmLint ()
+lintCmmStmt stmt@(CmmAssign reg expr) = do
+ erep <- lintCmmExpr expr
+ if (erep == cmmRegRep reg)
+ then return ()
+ else cmmLintAssignErr stmt
+lintCmmStmt (CmmStore l r) = do
+ lintCmmExpr l
+ lintCmmExpr r
+ return ()
+lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
+lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> return ()
+lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return ()
+lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return ()
+lintCmmStmt _other = return ()
+
+-- -----------------------------------------------------------------------------
+-- CmmLint monad
+
+-- just a basic error monad:
+
+newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
+
+instance Monad CmmLint where
+ CmmLint m >>= k = CmmLint $ case m of
+ Left e -> Left e
+ Right a -> unCL (k a)
+ return a = CmmLint (Right a)
+
+cmmLintErr :: SDoc -> CmmLint a
+cmmLintErr msg = CmmLint (Left msg)
+
+addLintInfo :: SDoc -> CmmLint a -> CmmLint a
+addLintInfo info thing = CmmLint $
+ case unCL thing of
+ Left err -> Left (hang info 2 err)
+ Right a -> Right a
+
+cmmLintMachOpErr :: CmmExpr -> CmmLint a
+cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$
+ nest 2 (pprExpr expr))
+
+cmmLintAssignErr :: CmmStmt -> CmmLint a
+cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$
+ nest 2 (pprStmt stmt))
+
+cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
+cmmLintDubiousWordOffset expr
+ = cmmLintErr (text "offset is not a multiple of words: " $$
+ nest 2 (pprExpr expr))
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2004
+--
+-- Parser for concrete Cmm.
+--
+-----------------------------------------------------------------------------
+
+{
+module CmmParse ( parseCmmFile ) where
+
+import CgMonad
+import CgHeapery
+import CgUtils
+import CgProf
+import CgTicky
+import CgInfoTbls
+import CgForeignCall
+import CgTailCall ( pushUnboxedTuple )
+import CgStackery ( emitPushUpdateFrame )
+import ClosureInfo ( C_SRT(..) )
+import CgCallConv ( smallLiveness )
+import CgClosure ( emitBlackHoleCode )
+import CostCentre ( dontCareCCS )
+
+import Cmm
+import PprCmm
+import CmmUtils ( mkIntCLit, mkLblExpr )
+import CmmLex
+import CLabel
+import MachOp
+import SMRep ( tablesNextToCode, fixedHdrSize, CgRep(..) )
+import Lexer
+
+import ForeignCall ( CCallConv(..) )
+import Literal ( mkMachInt )
+import Unique
+import UniqFM
+import SrcLoc
+import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn )
+import ErrUtils ( printError, dumpIfSet_dyn, showPass )
+import StringBuffer ( hGetStringBuffer )
+import FastString
+import Panic ( panic )
+import Constants ( wORD_SIZE )
+import Outputable
+
+import Monad ( when )
+
+#include "HsVersions.h"
+}
+
+%token
+ ':' { L _ (CmmT_SpecChar ':') }
+ ';' { L _ (CmmT_SpecChar ';') }
+ '{' { L _ (CmmT_SpecChar '{') }
+ '}' { L _ (CmmT_SpecChar '}') }
+ '[' { L _ (CmmT_SpecChar '[') }
+ ']' { L _ (CmmT_SpecChar ']') }
+ '(' { L _ (CmmT_SpecChar '(') }
+ ')' { L _ (CmmT_SpecChar ')') }
+ '=' { L _ (CmmT_SpecChar '=') }
+ '`' { L _ (CmmT_SpecChar '`') }
+ '~' { L _ (CmmT_SpecChar '~') }
+ '/' { L _ (CmmT_SpecChar '/') }
+ '*' { L _ (CmmT_SpecChar '*') }
+ '%' { L _ (CmmT_SpecChar '%') }
+ '-' { L _ (CmmT_SpecChar '-') }
+ '+' { L _ (CmmT_SpecChar '+') }
+ '&' { L _ (CmmT_SpecChar '&') }
+ '^' { L _ (CmmT_SpecChar '^') }
+ '|' { L _ (CmmT_SpecChar '|') }
+ '>' { L _ (CmmT_SpecChar '>') }
+ '<' { L _ (CmmT_SpecChar '<') }
+ ',' { L _ (CmmT_SpecChar ',') }
+ '!' { L _ (CmmT_SpecChar '!') }
+
+ '..' { L _ (CmmT_DotDot) }
+ '::' { L _ (CmmT_DoubleColon) }
+ '>>' { L _ (CmmT_Shr) }
+ '<<' { L _ (CmmT_Shl) }
+ '>=' { L _ (CmmT_Ge) }
+ '<=' { L _ (CmmT_Le) }
+ '==' { L _ (CmmT_Eq) }
+ '!=' { L _ (CmmT_Ne) }
+ '&&' { L _ (CmmT_BoolAnd) }
+ '||' { L _ (CmmT_BoolOr) }
+
+ 'CLOSURE' { L _ (CmmT_CLOSURE) }
+ 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) }
+ 'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
+ 'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
+ 'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
+ 'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
+ 'else' { L _ (CmmT_else) }
+ 'export' { L _ (CmmT_export) }
+ 'section' { L _ (CmmT_section) }
+ 'align' { L _ (CmmT_align) }
+ 'goto' { L _ (CmmT_goto) }
+ 'if' { L _ (CmmT_if) }
+ 'jump' { L _ (CmmT_jump) }
+ 'foreign' { L _ (CmmT_foreign) }
+ 'import' { L _ (CmmT_import) }
+ 'switch' { L _ (CmmT_switch) }
+ 'case' { L _ (CmmT_case) }
+ 'default' { L _ (CmmT_default) }
+ 'bits8' { L _ (CmmT_bits8) }
+ 'bits16' { L _ (CmmT_bits16) }
+ 'bits32' { L _ (CmmT_bits32) }
+ 'bits64' { L _ (CmmT_bits64) }
+ 'float32' { L _ (CmmT_float32) }
+ 'float64' { L _ (CmmT_float64) }
+
+ GLOBALREG { L _ (CmmT_GlobalReg $$) }
+ NAME { L _ (CmmT_Name $$) }
+ STRING { L _ (CmmT_String $$) }
+ INT { L _ (CmmT_Int $$) }
+ FLOAT { L _ (CmmT_Float $$) }
+
+%monad { P } { >>= } { return }
+%lexer { cmmlex } { L _ CmmT_EOF }
+%name cmmParse cmm
+%tokentype { Located CmmToken }
+
+-- C-- operator precedences, taken from the C-- spec
+%right '||' -- non-std extension, called %disjoin in C--
+%right '&&' -- non-std extension, called %conjoin in C--
+%right '!'
+%nonassoc '>=' '>' '<=' '<' '!=' '=='
+%left '|'
+%left '^'
+%left '&'
+%left '>>' '<<'
+%left '-' '+'
+%left '/' '*' '%'
+%right '~'
+
+%%
+
+cmm :: { ExtCode }
+ : {- empty -} { return () }
+ | cmmtop cmm { do $1; $2 }
+
+cmmtop :: { ExtCode }
+ : cmmproc { $1 }
+ | cmmdata { $1 }
+ | decl { $1 }
+ | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
+ { do lits <- sequence $6;
+ staticClosure $3 $5 (map getLit lits) }
+
+-- The only static closures in the RTS are dummy closures like
+-- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need
+-- to provide the full generality of static closures here.
+-- In particular:
+-- * CCS can always be CCS_DONT_CARE
+-- * closure is always extern
+-- * payload is always empty
+-- * we can derive closure and info table labels from a single NAME
+
+cmmdata :: { ExtCode }
+ : 'section' STRING '{' statics '}'
+ { do ss <- sequence $4;
+ code (emitData (section $2) (concat ss)) }
+
+statics :: { [ExtFCode [CmmStatic]] }
+ : {- empty -} { [] }
+ | static statics { $1 : $2 }
+
+-- Strings aren't used much in the RTS HC code, so it doesn't seem
+-- worth allowing inline strings. C-- doesn't allow them anyway.
+static :: { ExtFCode [CmmStatic] }
+ : NAME ':' { return [CmmDataLabel (mkRtsDataLabelFS $1)] }
+ | type expr ';' { do e <- $2;
+ return [CmmStaticLit (getLit e)] }
+ | type ';' { return [CmmUninitialised
+ (machRepByteWidth $1)] }
+ | 'bits8' '[' ']' STRING ';' { return [CmmString $4] }
+ | 'bits8' '[' INT ']' ';' { return [CmmUninitialised
+ (fromIntegral $3)] }
+ | typenot8 '[' INT ']' ';' { return [CmmUninitialised
+ (machRepByteWidth $1 *
+ fromIntegral $3)] }
+ | 'align' INT ';' { return [CmmAlign (fromIntegral $2)] }
+ | 'CLOSURE' '(' NAME lits ')'
+ { do lits <- sequence $4;
+ return $ map CmmStaticLit $
+ mkStaticClosure (mkRtsInfoLabelFS $3)
+ dontCareCCS (map getLit lits) [] [] }
+ -- arrays of closures required for the CHARLIKE & INTLIKE arrays
+
+lits :: { [ExtFCode CmmExpr] }
+ : {- empty -} { [] }
+ | ',' expr lits { $2 : $3 }
+
+cmmproc :: { ExtCode }
+ : info '{' body '}'
+ { do (info_lbl, info1, info2) <- $1;
+ stmts <- getCgStmtsEC (loopDecls $3)
+ blks <- code (cgStmtsToBlocks stmts)
+ code (emitInfoTableAndCode info_lbl info1 info2 [] blks) }
+
+ | info ';'
+ { do (info_lbl, info1, info2) <- $1;
+ code (emitInfoTableAndCode info_lbl info1 info2 [] []) }
+
+ | NAME '{' body '}'
+ { do stmts <- getCgStmtsEC (loopDecls $3);
+ blks <- code (cgStmtsToBlocks stmts)
+ code (emitProc [] (mkRtsCodeLabelFS $1) [] blks) }
+
+info :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
+ : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+ -- ptrs, nptrs, closure type, description, type
+ { stdInfo $3 $5 $7 0 $9 $11 $13 }
+
+ | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
+ -- ptrs, nptrs, closure type, description, type, fun type
+ { funInfo $3 $5 $7 $9 $11 $13 $15 }
+
+ | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+ -- ptrs, nptrs, tag, closure type, description, type
+ { stdInfo $3 $5 $7 $9 $11 $13 $15 }
+
+ | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
+ -- selector, closure type, description, type
+ { basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
+
+ | 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT maybe_vec ')'
+ { retInfo $3 $5 $7 $9 $10 }
+
+maybe_vec :: { [CLabel] }
+ : {- empty -} { [] }
+ | ',' NAME maybe_vec { mkRtsCodeLabelFS $2 : $3 }
+
+body :: { ExtCode }
+ : {- empty -} { return () }
+ | decl body { do $1; $2 }
+ | stmt body { do $1; $2 }
+
+decl :: { ExtCode }
+ : type names ';' { mapM_ (newLocal $1) $2 }
+ | 'import' names ';' { return () } -- ignore imports
+ | 'export' names ';' { return () } -- ignore exports
+
+names :: { [FastString] }
+ : NAME { [$1] }
+ | NAME ',' names { $1 : $3 }
+
+stmt :: { ExtCode }
+ : ';' { nopEC }
+
+ | block_id ':' { code (labelC $1) }
+
+ | lreg '=' expr ';'
+ { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
+ | type '[' expr ']' '=' expr ';'
+ { doStore $1 $3 $6 }
+ | 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
+ {% foreignCall $2 [] $3 $5 $7 }
+ | lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
+ {% let result = do r <- $1; return (r,NoHint) in
+ foreignCall $4 [result] $5 $7 $9 }
+ | STRING lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
+ {% do h <- parseHint $1;
+ let result = do r <- $2; return (r,h) in
+ foreignCall $5 [result] $6 $8 $10 }
+ -- stmt-level macros, stealing syntax from ordinary C-- function calls.
+ -- Perhaps we ought to use the %%-form?
+ | NAME '(' exprs0 ')' ';'
+ {% stmtMacro $1 $3 }
+ | 'switch' maybe_range expr '{' arms default '}'
+ { doSwitch $2 $3 $5 $6 }
+ | 'goto' block_id ';'
+ { stmtEC (CmmBranch $2) }
+ | 'jump' expr {-maybe_actuals-} ';'
+ { do e <- $2; stmtEC (CmmJump e []) }
+ | 'if' bool_expr '{' body '}' else
+ { ifThenElse $2 $4 $6 }
+
+bool_expr :: { ExtFCode BoolExpr }
+ : bool_op { $1 }
+ | expr { do e <- $1; return (BoolTest e) }
+
+bool_op :: { ExtFCode BoolExpr }
+ : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3;
+ return (BoolAnd e1 e2) }
+ | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3;
+ return (BoolOr e1 e2) }
+ | '!' bool_expr { do e <- $2; return (BoolNot e) }
+ | '(' bool_op ')' { $2 }
+
+-- This is not C-- syntax. What to do?
+vols :: { Maybe [GlobalReg] }
+ : {- empty -} { Nothing }
+ | '[' globals ']' { Just $2 }
+
+globals :: { [GlobalReg] }
+ : GLOBALREG { [$1] }
+ | GLOBALREG ',' globals { $1 : $3 }
+
+maybe_range :: { Maybe (Int,Int) }
+ : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) }
+ | {- empty -} { Nothing }
+
+arms :: { [([Int],ExtCode)] }
+ : {- empty -} { [] }
+ | arm arms { $1 : $2 }
+
+arm :: { ([Int],ExtCode) }
+ : 'case' ints ':' '{' body '}' { ($2, $5) }
+
+ints :: { [Int] }
+ : INT { [ fromIntegral $1 ] }
+ | INT ',' ints { fromIntegral $1 : $3 }
+
+default :: { Maybe ExtCode }
+ : 'default' ':' '{' body '}' { Just $4 }
+ -- taking a few liberties with the C-- syntax here; C-- doesn't have
+ -- 'default' branches
+ | {- empty -} { Nothing }
+
+else :: { ExtCode }
+ : {- empty -} { nopEC }
+ | 'else' '{' body '}' { $3 }
+
+-- we have to write this out longhand so that Happy's precedence rules
+-- can kick in.
+expr :: { ExtFCode CmmExpr }
+ : expr '/' expr { mkMachOp MO_U_Quot [$1,$3] }
+ | expr '*' expr { mkMachOp MO_Mul [$1,$3] }
+ | expr '%' expr { mkMachOp MO_U_Rem [$1,$3] }
+ | expr '-' expr { mkMachOp MO_Sub [$1,$3] }
+ | expr '+' expr { mkMachOp MO_Add [$1,$3] }
+ | expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] }
+ | expr '<<' expr { mkMachOp MO_Shl [$1,$3] }
+ | expr '&' expr { mkMachOp MO_And [$1,$3] }
+ | expr '^' expr { mkMachOp MO_Xor [$1,$3] }
+ | expr '|' expr { mkMachOp MO_Or [$1,$3] }
+ | expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] }
+ | expr '>' expr { mkMachOp MO_U_Gt [$1,$3] }
+ | expr '<=' expr { mkMachOp MO_U_Le [$1,$3] }
+ | expr '<' expr { mkMachOp MO_U_Lt [$1,$3] }
+ | expr '!=' expr { mkMachOp MO_Ne [$1,$3] }
+ | expr '==' expr { mkMachOp MO_Eq [$1,$3] }
+ | '~' expr { mkMachOp MO_Not [$2] }
+ | '-' expr { mkMachOp MO_S_Neg [$2] }
+ | expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ;
+ return (mkMachOp mo [$1,$5]) } }
+ | expr0 { $1 }
+
+expr0 :: { ExtFCode CmmExpr }
+ : INT maybe_ty { return (CmmLit (CmmInt $1 $2)) }
+ | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 $2)) }
+ | STRING { do s <- code (mkStringCLit $1);
+ return (CmmLit s) }
+ | reg { $1 }
+ | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) }
+ | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
+ | '(' expr ')' { $2 }
+
+
+-- leaving out the type of a literal gives you the native word size in C--
+maybe_ty :: { MachRep }
+ : {- empty -} { wordRep }
+ | '::' type { $2 }
+
+hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
+ : {- empty -} { [] }
+ | hint_exprs { $1 }
+
+hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] }
+ : hint_expr { [$1] }
+ | hint_expr ',' hint_exprs { $1 : $3 }
+
+hint_expr :: { ExtFCode (CmmExpr, MachHint) }
+ : expr { do e <- $1; return (e, inferHint e) }
+ | expr STRING {% do h <- parseHint $2;
+ return $ do
+ e <- $1; return (e,h) }
+
+exprs0 :: { [ExtFCode CmmExpr] }
+ : {- empty -} { [] }
+ | exprs { $1 }
+
+exprs :: { [ExtFCode CmmExpr] }
+ : expr { [ $1 ] }
+ | expr ',' exprs { $1 : $3 }
+
+reg :: { ExtFCode CmmExpr }
+ : NAME { lookupName $1 }
+ | GLOBALREG { return (CmmReg (CmmGlobal $1)) }
+
+lreg :: { ExtFCode CmmReg }
+ : NAME { do e <- lookupName $1;
+ return $
+ case e of
+ CmmReg r -> r
+ other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
+ | GLOBALREG { return (CmmGlobal $1) }
+
+block_id :: { BlockId }
+ : NAME { BlockId (newTagUnique (getUnique $1) 'L') }
+ -- TODO: ugh. The unique of a FastString has a null
+ -- tag, so we have to put our own tag on. We should
+ -- really make a new unique for every label, and keep
+ -- them in an environment.
+
+type :: { MachRep }
+ : 'bits8' { I8 }
+ | typenot8 { $1 }
+
+typenot8 :: { MachRep }
+ : 'bits16' { I16 }
+ | 'bits32' { I32 }
+ | 'bits64' { I64 }
+ | 'float32' { F32 }
+ | 'float64' { F64 }
+{
+section :: String -> Section
+section "text" = Text
+section "data" = Data
+section "rodata" = ReadOnlyData
+section "bss" = UninitialisedData
+section s = OtherSection s
+
+-- mkMachOp infers the type of the MachOp from the type of its first
+-- argument. We assume that this is correct: for MachOps that don't have
+-- symmetrical args (e.g. shift ops), the first arg determines the type of
+-- the op.
+mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
+mkMachOp fn args = do
+ arg_exprs <- sequence args
+ return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs)
+
+getLit :: CmmExpr -> CmmLit
+getLit (CmmLit l) = l
+getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r
+getLit _ = panic "invalid literal" -- TODO messy failure
+
+nameToMachOp :: FastString -> P (MachRep -> MachOp)
+nameToMachOp name =
+ case lookupUFM machOps name of
+ Nothing -> fail ("unknown primitive " ++ unpackFS name)
+ Just m -> return m
+
+exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
+exprOp name args_code =
+ case lookupUFM exprMacros name of
+ Just f -> return $ do
+ args <- sequence args_code
+ return (f args)
+ Nothing -> do
+ mo <- nameToMachOp name
+ return $ mkMachOp mo args_code
+
+exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
+exprMacros = listToUFM [
+ ( FSLIT("ENTRY_CODE"), \ [x] -> entryCode x ),
+ ( FSLIT("GET_ENTRY"), \ [x] -> entryCode (closureInfoPtr x) ),
+ ( FSLIT("STD_INFO"), \ [x] -> infoTable x ),
+ ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ),
+ ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
+ ( FSLIT("INFO_TYPE"), \ [x] -> infoTableClosureType x ),
+ ( FSLIT("INFO_PTRS"), \ [x] -> infoTablePtrs x ),
+ ( FSLIT("INFO_NPTRS"), \ [x] -> infoTableNonPtrs x ),
+ ( FSLIT("RET_VEC"), \ [info, conZ] -> CmmLoad (vectorSlot info conZ) wordRep )
+ ]
+
+-- we understand a subset of C-- primitives:
+machOps = listToUFM $
+ map (\(x, y) -> (mkFastString x, y)) [
+ ( "add", MO_Add ),
+ ( "sub", MO_Sub ),
+ ( "eq", MO_Eq ),
+ ( "ne", MO_Ne ),
+ ( "mul", MO_Mul ),
+ ( "neg", MO_S_Neg ),
+ ( "quot", MO_S_Quot ),
+ ( "rem", MO_S_Rem ),
+ ( "divu", MO_U_Quot ),
+ ( "modu", MO_U_Rem ),
+
+ ( "ge", MO_S_Ge ),
+ ( "le", MO_S_Le ),
+ ( "gt", MO_S_Gt ),
+ ( "lt", MO_S_Lt ),
+
+ ( "geu", MO_U_Ge ),
+ ( "leu", MO_U_Le ),
+ ( "gtu", MO_U_Gt ),
+ ( "ltu", MO_U_Lt ),
+
+ ( "flt", MO_S_Lt ),
+ ( "fle", MO_S_Le ),
+ ( "feq", MO_Eq ),
+ ( "fne", MO_Ne ),
+ ( "fgt", MO_S_Gt ),
+ ( "fge", MO_S_Ge ),
+ ( "fneg", MO_S_Neg ),
+
+ ( "and", MO_And ),
+ ( "or", MO_Or ),
+ ( "xor", MO_Xor ),
+ ( "com", MO_Not ),
+ ( "shl", MO_Shl ),
+ ( "shrl", MO_U_Shr ),
+ ( "shra", MO_S_Shr ),
+
+ ( "lobits8", flip MO_U_Conv I8 ),
+ ( "lobits16", flip MO_U_Conv I16 ),
+ ( "lobits32", flip MO_U_Conv I32 ),
+ ( "lobits64", flip MO_U_Conv I64 ),
+ ( "sx16", flip MO_S_Conv I16 ),
+ ( "sx32", flip MO_S_Conv I32 ),
+ ( "sx64", flip MO_S_Conv I64 ),
+ ( "zx16", flip MO_U_Conv I16 ),
+ ( "zx32", flip MO_U_Conv I32 ),
+ ( "zx64", flip MO_U_Conv I64 ),
+ ( "f2f32", flip MO_S_Conv F32 ), -- TODO; rounding mode
+ ( "f2f64", flip MO_S_Conv F64 ), -- TODO; rounding mode
+ ( "f2i8", flip MO_S_Conv I8 ),
+ ( "f2i16", flip MO_S_Conv I8 ),
+ ( "f2i32", flip MO_S_Conv I8 ),
+ ( "f2i64", flip MO_S_Conv I8 ),
+ ( "i2f32", flip MO_S_Conv F32 ),
+ ( "i2f64", flip MO_S_Conv F64 )
+ ]
+
+parseHint :: String -> P MachHint
+parseHint "ptr" = return PtrHint
+parseHint "signed" = return SignedHint
+parseHint "float" = return FloatHint
+parseHint str = fail ("unrecognised hint: " ++ str)
+
+-- labels are always pointers, so we might as well infer the hint
+inferHint :: CmmExpr -> MachHint
+inferHint (CmmLit (CmmLabel _)) = PtrHint
+inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
+inferHint _ = NoHint
+
+isPtrGlobalReg Sp = True
+isPtrGlobalReg SpLim = True
+isPtrGlobalReg Hp = True
+isPtrGlobalReg HpLim = True
+isPtrGlobalReg CurrentTSO = True
+isPtrGlobalReg CurrentNursery = True
+isPtrGlobalReg _ = False
+
+happyError :: P a
+happyError = srcParseFail
+
+-- -----------------------------------------------------------------------------
+-- Statement-level macros
+
+stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
+stmtMacro fun args_code = do
+ case lookupUFM stmtMacros fun of
+ Nothing -> fail ("unknown macro: " ++ unpackFS fun)
+ Just fcode -> return $ do
+ args <- sequence args_code
+ code (fcode args)
+
+stmtMacros :: UniqFM ([CmmExpr] -> Code)
+stmtMacros = listToUFM [
+ ( FSLIT("CCS_ALLOC"), \[words,ccs] -> profAlloc words ccs ),
+ ( FSLIT("CLOSE_NURSERY"), \[] -> emitCloseNursery ),
+ ( FSLIT("ENTER_CCS_PAP_CL"), \[e] -> enterCostCentrePAP e ),
+ ( FSLIT("ENTER_CCS_THUNK"), \[e] -> enterCostCentreThunk e ),
+ ( FSLIT("HP_CHK_GEN"), \[words,liveness,reentry] ->
+ hpChkGen words liveness reentry ),
+ ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ),
+ ( FSLIT("LOAD_THREAD_STATE"), \[] -> emitLoadThreadState ),
+ ( FSLIT("LDV_ENTER"), \[e] -> ldvEnter e ),
+ ( FSLIT("LDV_RECORD_CREATE"), \[e] -> ldvRecordCreate e ),
+ ( FSLIT("OPEN_NURSERY"), \[] -> emitOpenNursery ),
+ ( FSLIT("PUSH_UPD_FRAME"), \[sp,e] -> emitPushUpdateFrame sp e ),
+ ( FSLIT("SAVE_THREAD_STATE"), \[] -> emitSaveThreadState ),
+ ( FSLIT("SET_HDR"), \[ptr,info,ccs] ->
+ emitSetDynHdr ptr info ccs ),
+ ( FSLIT("STK_CHK_GEN"), \[words,liveness,reentry] ->
+ stkChkGen words liveness reentry ),
+ ( FSLIT("STK_CHK_NP"), \[e] -> stkChkNodePoints e ),
+ ( FSLIT("TICK_ALLOC_PRIM"), \[hdr,goods,slop] ->
+ tickyAllocPrim hdr goods slop ),
+ ( FSLIT("TICK_ALLOC_PAP"), \[goods,slop] ->
+ tickyAllocPAP goods slop ),
+ ( FSLIT("TICK_ALLOC_UP_THK"), \[goods,slop] ->
+ tickyAllocThunk goods slop ),
+ ( FSLIT("UPD_BH_UPDATABLE"), \[] -> emitBlackHoleCode False ),
+ ( FSLIT("UPD_BH_SINGLE_ENTRY"), \[] -> emitBlackHoleCode True ),
+
+ ( FSLIT("RET_P"), \[a] -> emitRetUT [(PtrArg,a)]),
+ ( FSLIT("RET_N"), \[a] -> emitRetUT [(NonPtrArg,a)]),
+ ( FSLIT("RET_PP"), \[a,b] -> emitRetUT [(PtrArg,a),(PtrArg,b)]),
+ ( FSLIT("RET_NN"), \[a,b] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
+ ( FSLIT("RET_NP"), \[a,b] -> emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
+ ( FSLIT("RET_PPP"), \[a,b,c] -> emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
+ ( FSLIT("RET_NNP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
+ ( FSLIT("RET_NNNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
+ ( FSLIT("RET_NPNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
+
+ ]
+
+-- -----------------------------------------------------------------------------
+-- Our extended FCode monad.
+
+-- We add a mapping from names to CmmExpr, to support local variable names in
+-- the concrete C-- code. The unique supply of the underlying FCode monad
+-- is used to grab a new unique for each local variable.
+
+-- In C--, a local variable can be declared anywhere within a proc,
+-- and it scopes from the beginning of the proc to the end. Hence, we have
+-- to collect declarations as we parse the proc, and feed the environment
+-- back in circularly (to avoid a two-pass algorithm).
+
+type Decls = [(FastString,CmmExpr)]
+type Env = UniqFM CmmExpr
+
+newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
+
+type ExtCode = ExtFCode ()
+
+returnExtFC a = EC $ \e s -> return (s, a)
+thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
+
+instance Monad ExtFCode where
+ (>>=) = thenExtFC
+ return = returnExtFC
+
+-- This function takes the variable decarations and imports and makes
+-- an environment, which is looped back into the computation. In this
+-- way, we can have embedded declarations that scope over the whole
+-- procedure, and imports that scope over the entire module.
+loopDecls :: ExtFCode a -> ExtFCode a
+loopDecls (EC fcode) =
+ EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
+
+getEnv :: ExtFCode Env
+getEnv = EC $ \e s -> return (s, e)
+
+addVarDecl :: FastString -> CmmExpr -> ExtCode
+addVarDecl var expr = EC $ \e s -> return ((var,expr):s, ())
+
+newLocal :: MachRep -> FastString -> ExtCode
+newLocal ty name = do
+ u <- code newUnique
+ addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
+
+-- Unknown names are treated as if they had been 'import'ed.
+-- This saves us a lot of bother in the RTS sources, at the expense of
+-- deferring some errors to link time.
+lookupName :: FastString -> ExtFCode CmmExpr
+lookupName name = do
+ env <- getEnv
+ return $
+ case lookupUFM env name of
+ Nothing -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
+ Just e -> e
+
+-- Lifting FCode computations into the ExtFCode monad:
+code :: FCode a -> ExtFCode a
+code fc = EC $ \e s -> do r <- fc; return (s, r)
+
+code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
+ -> ExtFCode b -> ExtFCode c
+code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
+
+nopEC = code nopC
+stmtEC stmt = code (stmtC stmt)
+stmtsEC stmts = code (stmtsC stmts)
+getCgStmtsEC = code2 getCgStmts'
+
+forkLabelledCodeEC ec = do
+ stmts <- getCgStmtsEC ec
+ code (forkCgStmts stmts)
+
+retInfo name size live_bits cl_type vector = do
+ let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
+ (info1,info2) = mkRetInfoTable liveness NoC_SRT
+ (fromIntegral cl_type) vector
+ return (mkRtsRetInfoLabelFS name, info1, info2)
+
+stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
+ basicInfo name (packHalfWordsCLit ptrs nptrs)
+ srt_bitmap cl_type desc_str ty_str
+
+basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
+ lit1 <- if opt_SccProfilingOn
+ then code $ mkStringCLit desc_str
+ else return (mkIntCLit 0)
+ lit2 <- if opt_SccProfilingOn
+ then code $ mkStringCLit ty_str
+ else return (mkIntCLit 0)
+ let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
+ (fromIntegral srt_bitmap)
+ layout
+ return (mkRtsInfoLabelFS name, info1, [])
+
+funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
+ (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
+ cl_type desc_str ty_str
+ let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
+ -- we leave most of the fields zero here. This is only used
+ -- to generate the BCO info table in the RTS at the moment.
+ return (label,info1,info2)
+ where
+ zero = mkIntCLit 0
+
+
+staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
+staticClosure cl_label info payload
+ = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
+ where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] []
+
+foreignCall
+ :: String
+ -> [ExtFCode (CmmReg,MachHint)]
+ -> ExtFCode CmmExpr
+ -> [ExtFCode (CmmExpr,MachHint)]
+ -> Maybe [GlobalReg] -> P ExtCode
+foreignCall "C" results_code expr_code args_code vols
+ = return $ do
+ results <- sequence results_code
+ expr <- expr_code
+ args <- sequence args_code
+ stmtEC (CmmCall (CmmForeignCall expr CCallConv) results args vols)
+foreignCall conv _ _ _ _
+ = fail ("unknown calling convention: " ++ conv)
+
+doStore :: MachRep -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
+doStore rep addr_code val_code
+ = do addr <- addr_code
+ val <- val_code
+ -- if the specified store type does not match the type of the expr
+ -- on the rhs, then we insert a coercion that will cause the type
+ -- mismatch to be flagged by cmm-lint. If we don't do this, then
+ -- the store will happen at the wrong type, and the error will not
+ -- be noticed.
+ let coerce_val
+ | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
+ | otherwise = val
+ stmtEC (CmmStore addr coerce_val)
+
+-- Return an unboxed tuple.
+emitRetUT :: [(CgRep,CmmExpr)] -> Code
+emitRetUT args = do
+ tickyUnboxedTupleReturn (length args) -- TICK
+ (sp, stmts) <- pushUnboxedTuple 0 args
+ emitStmts stmts
+ when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
+ stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
+
+-- -----------------------------------------------------------------------------
+-- If-then-else and boolean expressions
+
+data BoolExpr
+ = BoolExpr `BoolAnd` BoolExpr
+ | BoolExpr `BoolOr` BoolExpr
+ | BoolNot BoolExpr
+ | BoolTest CmmExpr
+
+-- ToDo: smart constructors which simplify the boolean expression.
+
+ifThenElse cond then_part else_part = do
+ then_id <- code newLabelC
+ join_id <- code newLabelC
+ c <- cond
+ emitCond c then_id
+ else_part
+ stmtEC (CmmBranch join_id)
+ code (labelC then_id)
+ then_part
+ -- fall through to join
+ code (labelC join_id)
+
+-- 'emitCond cond true_id' emits code to test whether the cond is true,
+-- branching to true_id if so, and falling through otherwise.
+emitCond (BoolTest e) then_id = do
+ stmtEC (CmmCondBranch e then_id)
+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
+ | Just op' <- maybeInvertComparison op
+ = emitCond (BoolTest (CmmMachOp op' args)) then_id
+emitCond (BoolNot e) then_id = do
+ else_id <- code newLabelC
+ emitCond e else_id
+ stmtEC (CmmBranch then_id)
+ code (labelC else_id)
+emitCond (e1 `BoolOr` e2) then_id = do
+ emitCond e1 then_id
+ emitCond e2 then_id
+emitCond (e1 `BoolAnd` e2) then_id = do
+ -- we'd like to invert one of the conditionals here to avoid an
+ -- extra branch instruction, but we can't use maybeInvertComparison
+ -- here because we can't look too closely at the expression since
+ -- we're in a loop.
+ and_id <- code newLabelC
+ else_id <- code newLabelC
+ emitCond e1 and_id
+ stmtEC (CmmBranch else_id)
+ code (labelC and_id)
+ emitCond e2 then_id
+ code (labelC else_id)
+
+
+-- -----------------------------------------------------------------------------
+-- Table jumps
+
+-- We use a simplified form of C-- switch statements for now. A
+-- switch statement always compiles to a table jump. Each arm can
+-- specify a list of values (not ranges), and there can be a single
+-- default branch. The range of the table is given either by the
+-- optional range on the switch (eg. switch [0..7] {...}), or by
+-- the minimum/maximum values from the branches.
+
+doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
+ -> Maybe ExtCode -> ExtCode
+doSwitch mb_range scrut arms deflt
+ = do
+ -- Compile code for the default branch
+ dflt_entry <-
+ case deflt of
+ Nothing -> return Nothing
+ Just e -> do b <- forkLabelledCodeEC e; return (Just b)
+
+ -- Compile each case branch
+ table_entries <- mapM emitArm arms
+
+ -- Construct the table
+ let
+ all_entries = concat table_entries
+ ixs = map fst all_entries
+ (min,max)
+ | Just (l,u) <- mb_range = (l,u)
+ | otherwise = (minimum ixs, maximum ixs)
+
+ entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
+ all_entries)
+ expr <- scrut
+ -- ToDo: check for out of range and jump to default if necessary
+ stmtEC (CmmSwitch expr entries)
+ where
+ emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
+ emitArm (ints,code) = do
+ blockid <- forkLabelledCodeEC code
+ return [ (i,blockid) | i <- ints ]
+
+
+-- -----------------------------------------------------------------------------
+-- Putting it all together
+
+-- The initial environment: we define some constants that the compiler
+-- knows about here.
+initEnv :: Env
+initEnv = listToUFM [
+ ( FSLIT("SIZEOF_StgHeader"),
+ CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )
+ ]
+
+parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags filename = do
+ showPass dflags "ParseCmm"
+ buf <- hGetStringBuffer filename
+ let
+ init_loc = mkSrcLoc (mkFastString filename) 1 0
+ init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
+ -- reset the lex_state: the Lexer monad leaves some stuff
+ -- in there we don't want.
+ case unP cmmParse init_state of
+ PFailed span err -> do printError span err; return Nothing
+ POk _ code -> do
+ cmm <- initC no_module (getCmm (unEC code initEnv [] >> return ()))
+ dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
+ return (Just cmm)
+ where
+ no_module = panic "parseCmmFile: no module"
+
+}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Cmm utilities.
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CmmUtils(
+ CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
+ isNopStmt,
+
+ isTrivialCmmExpr,
+
+ cmmRegOff, cmmLabelOff, cmmOffset, cmmOffsetLit, cmmIndex,
+ cmmOffsetExpr, cmmIndexExpr, cmmLoadIndex,
+
+ mkIntCLit, zeroCLit,
+
+ mkLblExpr,
+ ) where
+
+#include "HsVersions.h"
+
+import CLabel ( CLabel )
+import Cmm
+import MachOp
+import OrdList
+import Outputable
+
+---------------------------------------------------
+--
+-- CmmStmts
+--
+---------------------------------------------------
+
+type CmmStmts = OrdList CmmStmt
+
+noStmts :: CmmStmts
+noStmts = nilOL
+
+oneStmt :: CmmStmt -> CmmStmts
+oneStmt = unitOL
+
+mkStmts :: [CmmStmt] -> CmmStmts
+mkStmts = toOL
+
+plusStmts :: CmmStmts -> CmmStmts -> CmmStmts
+plusStmts = appOL
+
+stmtList :: CmmStmts -> [CmmStmt]
+stmtList = fromOL
+
+
+---------------------------------------------------
+--
+-- CmmStmt
+--
+---------------------------------------------------
+
+isNopStmt :: CmmStmt -> Bool
+-- If isNopStmt returns True, the stmt is definitely a no-op;
+-- but it might be a no-op even if isNopStmt returns False
+isNopStmt CmmNop = True
+isNopStmt (CmmAssign r e) = cheapEqReg r e
+isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2
+isNopStmt s = False
+
+cheapEqExpr :: CmmExpr -> CmmExpr -> Bool
+cheapEqExpr (CmmReg r) e = cheapEqReg r e
+cheapEqExpr (CmmRegOff r 0) e = cheapEqReg r e
+cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n'
+cheapEqExpr e1 e2 = False
+
+cheapEqReg :: CmmReg -> CmmExpr -> Bool
+cheapEqReg r (CmmReg r') = r==r'
+cheapEqReg r (CmmRegOff r' 0) = r==r'
+cheapEqReg r e = False
+
+---------------------------------------------------
+--
+-- CmmExpr
+--
+---------------------------------------------------
+
+isTrivialCmmExpr :: CmmExpr -> Bool
+isTrivialCmmExpr (CmmLoad _ _) = False
+isTrivialCmmExpr (CmmMachOp _ _) = False
+isTrivialCmmExpr (CmmLit _) = True
+isTrivialCmmExpr (CmmReg _) = True
+isTrivialCmmExpr (CmmRegOff _ _) = True
+
+---------------------------------------------------
+--
+-- Expr Construction helpers
+--
+---------------------------------------------------
+
+cmmOffsetExpr :: CmmExpr -> CmmExpr -> CmmExpr
+-- assumes base and offset have the same MachRep
+cmmOffsetExpr e (CmmLit (CmmInt n _)) = cmmOffset e (fromInteger n)
+cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprRep e)) [e, byte_off]
+
+-- NB. Do *not* inspect the value of the offset in these smart constructors!!!
+--
+-- because the offset is sometimes involved in a loop in the code generator
+-- (we don't know the real Hp offset until we've generated code for the entire
+-- basic block, for example). So we cannot eliminate zero offsets at this
+-- stage; they're eliminated later instead (either during printing or
+-- a later optimisation step on Cmm).
+--
+cmmOffset :: CmmExpr -> Int -> CmmExpr
+cmmOffset (CmmReg reg) byte_off = cmmRegOff reg byte_off
+cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
+cmmOffset (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
+cmmOffset (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
+ = CmmMachOp (MO_Add rep)
+ [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
+cmmOffset expr byte_off
+ = CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (toInteger byte_off) rep)]
+ where
+ rep = cmmExprRep expr
+
+-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above.
+cmmRegOff :: CmmReg -> Int -> CmmExpr
+cmmRegOff reg byte_off = CmmRegOff reg byte_off
+
+cmmOffsetLit :: CmmLit -> Int -> CmmLit
+cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off
+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
+cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep
+cmmOffsetLit other byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
+
+cmmLabelOff :: CLabel -> Int -> CmmLit
+-- Smart constructor for CmmLabelOff
+cmmLabelOff lbl 0 = CmmLabel lbl
+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
+
+-- | Useful for creating an index into an array, with a staticaly known offset.
+cmmIndex :: MachRep -> CmmExpr -> Int -> CmmExpr
+cmmIndex rep base idx = cmmOffset base (idx * machRepByteWidth rep)
+
+-- | Useful for creating an index into an array, with an unknown offset.
+cmmIndexExpr :: MachRep -> CmmExpr -> CmmExpr -> CmmExpr
+cmmIndexExpr rep base (CmmLit (CmmInt n _)) = cmmIndex rep base (fromInteger n)
+cmmIndexExpr rep base idx =
+ cmmOffsetExpr base byte_off
+ where
+ idx_rep = cmmExprRep idx
+ byte_off = CmmMachOp (MO_Shl idx_rep) [
+ idx, CmmLit (mkIntCLit (machRepLogWidth rep))]
+
+cmmLoadIndex :: MachRep -> CmmExpr -> Int -> CmmExpr
+cmmLoadIndex rep expr ix = CmmLoad (cmmIndex rep expr ix) rep
+
+---------------------------------------------------
+--
+-- Literal construction functions
+--
+---------------------------------------------------
+
+mkIntCLit :: Int -> CmmLit
+mkIntCLit i = CmmInt (toInteger i) wordRep
+
+zeroCLit :: CmmLit
+zeroCLit = CmmInt 0 wordRep
+
+mkLblExpr :: CLabel -> CmmExpr
+mkLblExpr lbl = CmmLit (CmmLabel lbl)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2002-2004
+--
+-- Low-level machine operations, used in the Cmm datatype.
+--
+-----------------------------------------------------------------------------
+
+module MachOp (
+ MachRep(..),
+ machRepBitWidth,
+ machRepByteWidth,
+ machRepLogWidth,
+ isFloatingRep,
+
+ MachHint(..),
+
+ MachOp(..),
+ pprMachOp,
+ isCommutableMachOp,
+ isComparisonMachOp,
+ resultRepOfMachOp,
+ machOpArgReps,
+ maybeInvertComparison,
+
+ CallishMachOp(..),
+ pprCallishMachOp,
+
+ wordRep,
+ halfWordRep,
+ cIntRep, cLongRep,
+
+ mo_wordAdd,
+ mo_wordSub,
+ mo_wordEq,
+ mo_wordNe,
+ mo_wordMul,
+ mo_wordSQuot,
+ mo_wordSRem,
+ mo_wordSNeg,
+ mo_wordUQuot,
+ mo_wordURem,
+
+ mo_wordSGe,
+ mo_wordSLe,
+ mo_wordSGt,
+ mo_wordSLt,
+
+ mo_wordUGe,
+ mo_wordULe,
+ mo_wordUGt,
+ mo_wordULt,
+
+ mo_wordAnd,
+ mo_wordOr,
+ mo_wordXor,
+ mo_wordNot,
+ mo_wordShl,
+ mo_wordSShr,
+ mo_wordUShr,
+
+ mo_u_8To32,
+ mo_s_8To32,
+ mo_u_16To32,
+ mo_s_16To32,
+
+ mo_u_8ToWord,
+ mo_s_8ToWord,
+ mo_u_16ToWord,
+ mo_s_16ToWord,
+ mo_u_32ToWord,
+ mo_s_32ToWord,
+
+ mo_32To8,
+ mo_32To16,
+ mo_WordTo8,
+ mo_WordTo16,
+ mo_WordTo32,
+ ) where
+
+#include "HsVersions.h"
+#include "../includes/ghcconfig.h"
+
+import Constants
+import Outputable
+
+-- -----------------------------------------------------------------------------
+-- MachRep
+
+{- |
+A MachRep is the "representation" of a value in Cmm. It is used for
+resource allocation: eg. which kind of register a value should be
+stored in.
+
+The primary requirement is that there exists a function
+
+ cmmExprRep :: CmmExpr -> MachRep
+
+This means that:
+
+ - a register has an implicit MachRep
+ - a literal has an implicit MachRep
+ - an operation (MachOp) has an implicit result MachRep
+
+It also means that we can check that the arguments to a MachOp have
+the correct MachRep, i.e. we can do a kind of lint-style type checking
+on Cmm.
+-}
+
+data MachRep
+ = I8
+ | I16
+ | I32
+ | I64
+ | I128
+ | F32
+ | F64
+ | F80 -- extended double-precision, used in x86 native codegen only.
+ deriving (Eq, Ord, Show)
+
+mrStr I8 = SLIT("I8")
+mrStr I16 = SLIT("I16")
+mrStr I32 = SLIT("I32")
+mrStr I64 = SLIT("I64")
+mrStr I128 = SLIT("I128")
+mrStr F32 = SLIT("F32")
+mrStr F64 = SLIT("F64")
+mrStr F80 = SLIT("F80")
+
+instance Outputable MachRep where
+ ppr rep = ptext (mrStr rep)
+
+{-
+Implementation notes:
+
+It might suffice to keep just a width, without distinguishing between
+floating and integer types. However, keeping the distinction will
+help the native code generator to assign registers more easily.
+-}
+
+{-
+Should a MachRep include a signed vs. unsigned distinction?
+
+This is very much like a "hint" in C-- terminology: it isn't necessary
+in order to generate correct code, but it might be useful in that the
+compiler can generate better code if it has access to higher-level
+hints about data. This is important at call boundaries, because the
+definition of a function is not visible at all of its call sites, so
+the compiler cannot infer the hints.
+
+Here in Cmm, we're taking a slightly different approach. We include
+the int vs. float hint in the MachRep, because (a) the majority of
+platforms have a strong distinction between float and int registers,
+and (b) we don't want to do any heavyweight hint-inference in the
+native code backend in order to get good code. We're treating the
+hint more like a type: our Cmm is always completely consistent with
+respect to hints. All coercions between float and int are explicit.
+
+What about the signed vs. unsigned hint? This information might be
+useful if we want to keep sub-word-sized values in word-size
+registers, which we must do if we only have word-sized registers.
+
+On such a system, there are two straightforward conventions for
+representing sub-word-sized values:
+
+(a) Leave the upper bits undefined. Comparison operations must
+ sign- or zero-extend both operands before comparing them,
+ depending on whether the comparison is signed or unsigned.
+
+(b) Always keep the values sign- or zero-extended as appropriate.
+ Arithmetic operations must narrow the result to the appropriate
+ size.
+
+A clever compiler might not use either (a) or (b) exclusively, instead
+it would attempt to minimize the coercions by analysis: the same kind
+of analysis that propagates hints around. In Cmm we don't want to
+have to do this, so we plump for having richer types and keeping the
+type information consistent.
+
+If signed/unsigned hints are missing from MachRep, then the only
+choice we have is (a), because we don't know whether the result of an
+operation should be sign- or zero-extended.
+
+Many architectures have extending load operations, which work well
+with (b). To make use of them with (a), you need to know whether the
+value is going to be sign- or zero-extended by an enclosing comparison
+(for example), which involves knowing above the context. This is
+doable but more complex.
+
+Further complicating the issue is foreign calls: a foreign calling
+convention can specify that signed 8-bit quantities are passed as
+sign-extended 32 bit quantities, for example (this is the case on the
+PowerPC). So we *do* need sign information on foreign call arguments.
+
+Pros for adding signed vs. unsigned to MachRep:
+
+ - It would let us use convention (b) above, and get easier
+ code generation for extending loads.
+
+ - Less information required on foreign calls.
+
+ - MachOp type would be simpler
+
+Cons:
+
+ - More complexity
+
+ - What is the MachRep for a VanillaReg? Currently it is
+ always wordRep, but now we have to decide whether it is
+ signed or unsigned. The same VanillaReg can thus have
+ different MachReps in different parts of the program.
+
+ - Extra coercions cluttering up expressions.
+
+Currently for GHC, the foreign call point is moot, because we do our
+own promotion of sub-word-sized values to word-sized values. The Int8
+type is represnted by an Int# which is kept sign-extended at all times
+(this is slightly naughty, because we're making assumptions about the
+C calling convention rather early on in the compiler). However, given
+this, the cons outweigh the pros.
+
+-}
+
+
+machRepBitWidth :: MachRep -> Int
+machRepBitWidth I8 = 8
+machRepBitWidth I16 = 16
+machRepBitWidth I32 = 32
+machRepBitWidth I64 = 64
+machRepBitWidth I128 = 128
+machRepBitWidth F32 = 32
+machRepBitWidth F64 = 64
+machRepBitWidth F80 = 80
+
+machRepByteWidth :: MachRep -> Int
+machRepByteWidth I8 = 1
+machRepByteWidth I16 = 2
+machRepByteWidth I32 = 4
+machRepByteWidth I64 = 8
+machRepByteWidth I128 = 16
+machRepByteWidth F32 = 4
+machRepByteWidth F64 = 8
+machRepByteWidth F80 = 10
+
+-- log_2 of the width in bytes, useful for generating shifts.
+machRepLogWidth :: MachRep -> Int
+machRepLogWidth I8 = 0
+machRepLogWidth I16 = 1
+machRepLogWidth I32 = 2
+machRepLogWidth I64 = 3
+machRepLogWidth I128 = 4
+machRepLogWidth F32 = 2
+machRepLogWidth F64 = 3
+machRepLogWidth F80 = panic "machRepLogWidth: F80"
+
+isFloatingRep :: MachRep -> Bool
+isFloatingRep F32 = True
+isFloatingRep F64 = True
+isFloatingRep F80 = True
+isFloatingRep _ = False
+
+-- -----------------------------------------------------------------------------
+-- Hints
+
+{-
+A hint gives a little more information about a data value. Hints are
+used on the arguments to a foreign call, where the code generator needs
+to know some extra information on top of the MachRep of each argument in
+order to generate a correct call.
+-}
+
+data MachHint
+ = NoHint
+ | PtrHint
+ | SignedHint
+ | FloatHint
+ deriving Eq
+
+mhStr NoHint = SLIT("NoHint")
+mhStr PtrHint = SLIT("PtrHint")
+mhStr SignedHint = SLIT("SignedHint")
+mhStr FloatHint = SLIT("FloatHint")
+
+instance Outputable MachHint where
+ ppr hint = ptext (mhStr hint)
+
+-- -----------------------------------------------------------------------------
+-- MachOp
+
+{- |
+Machine-level primops; ones which we can reasonably delegate to the
+native code generators to handle. Basically contains C's primops
+and no others.
+
+Nomenclature: all ops indicate width and signedness, where
+appropriate. Widths: 8\/16\/32\/64 means the given size, obviously.
+Nat means the operation works on STG word sized objects.
+Signedness: S means signed, U means unsigned. For operations where
+signedness is irrelevant or makes no difference (for example
+integer add), the signedness component is omitted.
+
+An exception: NatP is a ptr-typed native word. From the point of
+view of the native code generators this distinction is irrelevant,
+but the C code generator sometimes needs this info to emit the
+right casts.
+-}
+
+data MachOp
+
+ -- Integer operations
+ = MO_Add MachRep
+ | MO_Sub MachRep
+ | MO_Eq MachRep
+ | MO_Ne MachRep
+ | MO_Mul MachRep -- low word of multiply
+ | MO_S_MulMayOflo MachRep -- nonzero if signed multiply overflows
+ | MO_S_Quot MachRep -- signed / (same semantics as IntQuotOp)
+ | MO_S_Rem MachRep -- signed % (same semantics as IntRemOp)
+ | MO_S_Neg MachRep -- unary -
+ | MO_U_MulMayOflo MachRep -- nonzero if unsigned multiply overflows
+ | MO_U_Quot MachRep -- unsigned / (same semantics as WordQuotOp)
+ | MO_U_Rem MachRep -- unsigned % (same semantics as WordRemOp)
+
+ -- Signed comparisons (floating-point comparisons also use these)
+ | MO_S_Ge MachRep
+ | MO_S_Le MachRep
+ | MO_S_Gt MachRep
+ | MO_S_Lt MachRep
+
+ -- Unsigned comparisons
+ | MO_U_Ge MachRep
+ | MO_U_Le MachRep
+ | MO_U_Gt MachRep
+ | MO_U_Lt MachRep
+
+ -- Bitwise operations. Not all of these may be supported at all sizes,
+ -- and only integral MachReps are valid.
+ | MO_And MachRep
+ | MO_Or MachRep
+ | MO_Xor MachRep
+ | MO_Not MachRep
+ | MO_Shl MachRep
+ | MO_U_Shr MachRep -- unsigned shift right
+ | MO_S_Shr MachRep -- signed shift right
+
+ -- Conversions. Some of these will be NOPs.
+ -- Floating-point conversions use the signed variant.
+ | MO_S_Conv MachRep{-from-} MachRep{-to-} -- signed conversion
+ | MO_U_Conv MachRep{-from-} MachRep{-to-} -- unsigned conversion
+
+ deriving (Eq, Show)
+
+pprMachOp :: MachOp -> SDoc
+pprMachOp mo = text (show mo)
+
+
+-- These MachOps tend to be implemented by foreign calls in some backends,
+-- so we separate them out. In Cmm, these can only occur in a
+-- statement position, in contrast to an ordinary MachOp which can occur
+-- anywhere in an expression.
+data CallishMachOp
+ = MO_F64_Pwr
+ | MO_F64_Sin
+ | MO_F64_Cos
+ | MO_F64_Tan
+ | MO_F64_Sinh
+ | MO_F64_Cosh
+ | MO_F64_Tanh
+ | MO_F64_Asin
+ | MO_F64_Acos
+ | MO_F64_Atan
+ | MO_F64_Log
+ | MO_F64_Exp
+ | MO_F64_Sqrt
+ | MO_F32_Pwr
+ | MO_F32_Sin
+ | MO_F32_Cos
+ | MO_F32_Tan
+ | MO_F32_Sinh
+ | MO_F32_Cosh
+ | MO_F32_Tanh
+ | MO_F32_Asin
+ | MO_F32_Acos
+ | MO_F32_Atan
+ | MO_F32_Log
+ | MO_F32_Exp
+ | MO_F32_Sqrt
+ deriving (Eq, Show)
+
+pprCallishMachOp :: CallishMachOp -> SDoc
+pprCallishMachOp mo = text (show mo)
+
+-- -----------------------------------------------------------------------------
+-- Some common MachReps
+
+-- A 'wordRep' is a machine word on the target architecture
+-- Specifically, it is the size of an Int#, Word#, Addr#
+-- and the unit of allocation on the stack and the heap
+-- Any pointer is also guaranteed to be a wordRep.
+
+wordRep | wORD_SIZE == 4 = I32
+ | wORD_SIZE == 8 = I64
+ | otherwise = panic "MachOp.wordRep: Unknown word size"
+
+halfWordRep | wORD_SIZE == 4 = I16
+ | wORD_SIZE == 8 = I32
+ | otherwise = panic "MachOp.halfWordRep: Unknown word size"
+
+mo_wordAdd = MO_Add wordRep
+mo_wordSub = MO_Sub wordRep
+mo_wordEq = MO_Eq wordRep
+mo_wordNe = MO_Ne wordRep
+mo_wordMul = MO_Mul wordRep
+mo_wordSQuot = MO_S_Quot wordRep
+mo_wordSRem = MO_S_Rem wordRep
+mo_wordSNeg = MO_S_Neg wordRep
+mo_wordUQuot = MO_U_Quot wordRep
+mo_wordURem = MO_U_Rem wordRep
+
+mo_wordSGe = MO_S_Ge wordRep
+mo_wordSLe = MO_S_Le wordRep
+mo_wordSGt = MO_S_Gt wordRep
+mo_wordSLt = MO_S_Lt wordRep
+
+mo_wordUGe = MO_U_Ge wordRep
+mo_wordULe = MO_U_Le wordRep
+mo_wordUGt = MO_U_Gt wordRep
+mo_wordULt = MO_U_Lt wordRep
+
+mo_wordAnd = MO_And wordRep
+mo_wordOr = MO_Or wordRep
+mo_wordXor = MO_Xor wordRep
+mo_wordNot = MO_Not wordRep
+mo_wordShl = MO_Shl wordRep
+mo_wordSShr = MO_S_Shr wordRep
+mo_wordUShr = MO_U_Shr wordRep
+
+mo_u_8To32 = MO_U_Conv I8 I32
+mo_s_8To32 = MO_S_Conv I8 I32
+mo_u_16To32 = MO_U_Conv I16 I32
+mo_s_16To32 = MO_S_Conv I16 I32
+
+mo_u_8ToWord = MO_U_Conv I8 wordRep
+mo_s_8ToWord = MO_S_Conv I8 wordRep
+mo_u_16ToWord = MO_U_Conv I16 wordRep
+mo_s_16ToWord = MO_S_Conv I16 wordRep
+mo_s_32ToWord = MO_S_Conv I32 wordRep
+mo_u_32ToWord = MO_U_Conv I32 wordRep
+
+mo_WordTo8 = MO_U_Conv wordRep I8
+mo_WordTo16 = MO_U_Conv wordRep I16
+mo_WordTo32 = MO_U_Conv wordRep I32
+
+mo_32To8 = MO_U_Conv I32 I8
+mo_32To16 = MO_U_Conv I32 I16
+
+-- cIntRep is the MachRep for a C-language 'int'
+#if SIZEOF_INT == 4
+cIntRep = I32
+#elif SIZEOF_INT == 8
+cIntRep = I64
+#endif
+
+#if SIZEOF_LONG == 4
+cLongRep = I32
+#elif SIZEOF_LONG == 8
+cLongRep = I64
+#endif
+
+-- ----------------------------------------------------------------------------
+-- isCommutableMachOp
+
+{- |
+Returns 'True' if the MachOp has commutable arguments. This is used
+in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'. This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isCommutableMachOp :: MachOp -> Bool
+isCommutableMachOp mop =
+ case mop of
+ MO_Add _ -> True
+ MO_Eq _ -> True
+ MO_Ne _ -> True
+ MO_Mul _ -> True
+ MO_S_MulMayOflo _ -> True
+ MO_U_MulMayOflo _ -> True
+ MO_And _ -> True
+ MO_Or _ -> True
+ MO_Xor _ -> True
+ _other -> False
+
+-- ----------------------------------------------------------------------------
+-- isComparisonMachOp
+
+{- |
+Returns 'True' if the MachOp is a comparison.
+
+If in doubt, return False. This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isComparisonMachOp :: MachOp -> Bool
+isComparisonMachOp mop =
+ case mop of
+ MO_Eq _ -> True
+ MO_Ne _ -> True
+ MO_S_Ge _ -> True
+ MO_S_Le _ -> True
+ MO_S_Gt _ -> True
+ MO_S_Lt _ -> True
+ MO_U_Ge _ -> True
+ MO_U_Le _ -> True
+ MO_U_Gt _ -> True
+ MO_U_Lt _ -> True
+ _other -> False
+
+-- -----------------------------------------------------------------------------
+-- Inverting conditions
+
+-- Sometimes it's useful to be able to invert the sense of a
+-- condition. Not all conditional tests are invertible: in
+-- particular, floating point conditionals cannot be inverted, because
+-- there exist floating-point values which return False for both senses
+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
+
+maybeInvertComparison :: MachOp -> Maybe MachOp
+maybeInvertComparison op
+ = case op of
+ MO_Eq r | not (isFloatingRep r) -> Just (MO_Ne r)
+ MO_Ne r | not (isFloatingRep r) -> Just (MO_Eq r)
+ MO_U_Lt r | not (isFloatingRep r) -> Just (MO_U_Ge r)
+ MO_U_Gt r | not (isFloatingRep r) -> Just (MO_U_Le r)
+ MO_U_Le r | not (isFloatingRep r) -> Just (MO_U_Gt r)
+ MO_U_Ge r | not (isFloatingRep r) -> Just (MO_U_Lt r)
+ MO_S_Lt r | not (isFloatingRep r) -> Just (MO_S_Ge r)
+ MO_S_Gt r | not (isFloatingRep r) -> Just (MO_S_Le r)
+ MO_S_Le r | not (isFloatingRep r) -> Just (MO_S_Gt r)
+ MO_S_Ge r | not (isFloatingRep r) -> Just (MO_S_Lt r)
+ _other -> Nothing
+
+-- ----------------------------------------------------------------------------
+-- resultRepOfMachOp
+
+{- |
+Returns the MachRep of the result of a MachOp.
+-}
+resultRepOfMachOp :: MachOp -> MachRep
+resultRepOfMachOp mop =
+ case mop of
+ MO_Add r -> r
+ MO_Sub r -> r
+ MO_Eq r -> comparisonResultRep
+ MO_Ne r -> comparisonResultRep
+ MO_Mul r -> r
+ MO_S_MulMayOflo r -> r
+ MO_S_Quot r -> r
+ MO_S_Rem r -> r
+ MO_S_Neg r -> r
+ MO_U_MulMayOflo r -> r
+ MO_U_Quot r -> r
+ MO_U_Rem r -> r
+
+ MO_S_Ge r -> comparisonResultRep
+ MO_S_Le r -> comparisonResultRep
+ MO_S_Gt r -> comparisonResultRep
+ MO_S_Lt r -> comparisonResultRep
+
+ MO_U_Ge r -> comparisonResultRep
+ MO_U_Le r -> comparisonResultRep
+ MO_U_Gt r -> comparisonResultRep
+ MO_U_Lt r -> comparisonResultRep
+
+ MO_And r -> r
+ MO_Or r -> r
+ MO_Xor r -> r
+ MO_Not r -> r
+ MO_Shl r -> r
+ MO_U_Shr r -> r
+ MO_S_Shr r -> r
+
+ MO_S_Conv from to -> to
+ MO_U_Conv from to -> to
+
+
+comparisonResultRep = wordRep -- is it?
+
+
+-- -----------------------------------------------------------------------------
+-- machOpArgReps
+
+-- | This function is used for debugging only: we can check whether an
+-- application of a MachOp is "type-correct" by checking that the MachReps of
+-- its arguments are the same as the MachOp expects. This is used when
+-- linting a CmmExpr.
+
+machOpArgReps :: MachOp -> [MachRep]
+machOpArgReps op =
+ case op of
+ MO_Add r -> [r,r]
+ MO_Sub r -> [r,r]
+ MO_Eq r -> [r,r]
+ MO_Ne r -> [r,r]
+ MO_Mul r -> [r,r]
+ MO_S_MulMayOflo r -> [r,r]
+ MO_S_Quot r -> [r,r]
+ MO_S_Rem r -> [r,r]
+ MO_S_Neg r -> [r]
+ MO_U_MulMayOflo r -> [r,r]
+ MO_U_Quot r -> [r,r]
+ MO_U_Rem r -> [r,r]
+
+ MO_S_Ge r -> [r,r]
+ MO_S_Le r -> [r,r]
+ MO_S_Gt r -> [r,r]
+ MO_S_Lt r -> [r,r]
+
+ MO_U_Ge r -> [r,r]
+ MO_U_Le r -> [r,r]
+ MO_U_Gt r -> [r,r]
+ MO_U_Lt r -> [r,r]
+
+ MO_And r -> [r,r]
+ MO_Or r -> [r,r]
+ MO_Xor r -> [r,r]
+ MO_Not r -> [r]
+ MO_Shl r -> [r,wordRep]
+ MO_U_Shr r -> [r,wordRep]
+ MO_S_Shr r -> [r,wordRep]
+
+ MO_S_Conv from to -> [from]
+ MO_U_Conv from to -> [from]
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as C, suitable for feeding gcc
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+--
+-- Print Cmm as real C, for -fvia-C
+--
+-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
+-- relative to the old AbstractC, and many oddities/decorations have
+-- disappeared from the data type.
+--
+
+-- ToDo: save/restore volatile registers around calls.
+
+module PprC (
+ writeCs,
+ pprStringInCStyle
+ ) where
+
+#include "HsVersions.h"
+
+-- Cmm stuff
+import Cmm
+import CLabel
+import MachOp
+import ForeignCall
+
+-- Utils
+import Unique ( getUnique )
+import UniqSet
+import FiniteMap
+import UniqFM ( eltsUFM )
+import FastString
+import Outputable
+import Constants
+import CmdLineOpts ( opt_EnsureSplittableC )
+
+-- The rest
+import Data.List ( intersperse, group )
+import Data.Bits ( shiftR )
+import Char ( ord, chr )
+import IO ( Handle )
+import DATA_BITS
+
+#ifdef DEBUG
+import PprCmm () -- instances only
+-- import Debug.Trace
+#endif
+
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+#endif
+import MONAD_ST
+
+-- --------------------------------------------------------------------------
+-- Top level
+
+pprCs :: [Cmm] -> SDoc
+pprCs cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
+
+writeCs :: Handle -> [Cmm] -> IO ()
+writeCs handle cmms = printForUser handle alwaysQualify (pprCs cmms)
+ -- ToDo: should be printForC
+
+split_marker
+ | opt_EnsureSplittableC = ptext SLIT("__STG_SPLIT_MARKER")
+ | otherwise = empty
+
+-- --------------------------------------------------------------------------
+-- Now do some real work
+--
+-- for fun, we could call cmmToCmm over the tops...
+--
+
+pprC :: Cmm -> SDoc
+pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
+
+--
+-- top level procs
+--
+pprTop :: CmmTop -> SDoc
+pprTop (CmmProc info clbl _params blocks) =
+ (if not (null info)
+ then pprWordArray (entryLblToInfoLbl clbl) info
+ else empty) $$
+ (case blocks of
+ [] -> empty
+ -- the first block doesn't get a label:
+ (BasicBlock _ stmts : rest) -> vcat [
+ text "",
+ extern_decls,
+ (if (externallyVisibleCLabel clbl)
+ then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
+ nest 8 temp_decls,
+ nest 8 mkFB_,
+ nest 8 (vcat (map pprStmt stmts)) $$
+ vcat (map pprBBlock rest),
+ nest 8 mkFE_,
+ rbrace ]
+ )
+ where
+ (temp_decls, extern_decls) = pprTempAndExternDecls blocks
+
+
+-- Chunks of static data.
+
+-- We only handle (a) arrays of word-sized things and (b) strings.
+
+pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) =
+ hcat [
+ pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl,
+ ptext SLIT("[] = "), pprStringInCStyle str, semi
+ ]
+
+pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) =
+ hcat [
+ pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl,
+ brackets (int size), semi
+ ]
+
+pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) =
+ pprDataExterns lits $$
+ pprWordArray lbl lits
+
+-- these shouldn't appear?
+pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
+
+
+-- --------------------------------------------------------------------------
+-- BasicBlocks are self-contained entities: they always end in a jump.
+--
+-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
+-- as many jumps as possible into fall throughs.
+--
+
+pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock (BasicBlock lbl stmts) =
+ if null stmts then
+ pprTrace "pprC.pprBBlock: curious empty code block for"
+ (pprBlockId lbl) empty
+ else
+ nest 4 (pprBlockId lbl <> colon) $$
+ nest 8 (vcat (map pprStmt stmts))
+
+-- --------------------------------------------------------------------------
+-- Info tables. Just arrays of words.
+-- See codeGen/ClosureInfo, and nativeGen/PprMach
+
+pprWordArray :: CLabel -> [CmmStatic] -> SDoc
+pprWordArray lbl ds
+ = hcat [ pprLocalness lbl, ptext SLIT("StgWord")
+ , space, pprCLabel lbl, ptext SLIT("[] = {") ]
+ $$ nest 8 (commafy (pprStatics ds))
+ $$ ptext SLIT("};")
+
+--
+-- has to be static, if it isn't globally visible
+--
+pprLocalness :: CLabel -> SDoc
+pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext SLIT("static ")
+ | otherwise = empty
+
+-- --------------------------------------------------------------------------
+-- Statements.
+--
+
+pprStmt :: CmmStmt -> SDoc
+
+pprStmt stmt = case stmt of
+ CmmNop -> empty
+ CmmComment s -> (hang (ptext SLIT("/*")) 3 (ftext s)) $$ ptext SLIT("*/")
+
+ CmmAssign dest src -> pprAssign dest src
+
+ CmmStore dest src
+ | rep == I64
+ -> ptext SLIT("ASSIGN_Word64") <>
+ parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+
+ | otherwise
+ -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
+ where
+ rep = cmmExprRep src
+
+ CmmCall (CmmForeignCall fn cconv) results args volatile ->
+ -- Controversial: leave this out for now.
+ -- pprUndef fn $$
+
+ pprCall ppr_fn cconv results args volatile
+ where
+ ppr_fn = case fn of
+ CmmLit (CmmLabel lbl) -> pprCLabel lbl
+ _other -> parens (cCast (pprCFunType results args) fn)
+ -- for a dynamic call, cast the expression to
+ -- a function of the right type (we hope).
+
+ -- we #undef a function before calling it: the FFI is supposed to be
+ -- an interface specifically to C, not to C+CPP. For one thing, this
+ -- makes the via-C route more compatible with the NCG. If macros
+ -- are being used for optimisation, then inline functions are probably
+ -- better anyway.
+ pprUndef (CmmLit (CmmLabel lbl)) =
+ ptext SLIT("#undef") <+> pprCLabel lbl
+ pprUndef _ = empty
+
+ CmmCall (CmmPrim op) results args volatile ->
+ pprCall ppr_fn CCallConv results args volatile
+ where
+ ppr_fn = pprCallishMachOp_for_C op
+
+ CmmBranch ident -> pprBranch ident
+ CmmCondBranch expr ident -> pprCondBranch expr ident
+ CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
+ CmmSwitch arg ids -> pprSwitch arg ids
+
+pprCFunType :: [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
+pprCFunType ress args =
+ res_type ress <> parens (char '*') <> parens (commafy (map arg_type args))
+ where
+ res_type [] = ptext SLIT("void")
+ res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
+
+ arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
+
+-- ---------------------------------------------------------------------
+-- unconditional branches
+pprBranch :: BlockId -> SDoc
+pprBranch ident = ptext SLIT("goto") <+> pprBlockId ident <> semi
+
+
+-- ---------------------------------------------------------------------
+-- conditional branches to local labels
+pprCondBranch :: CmmExpr -> BlockId -> SDoc
+pprCondBranch expr ident
+ = hsep [ ptext SLIT("if") , parens(pprExpr expr) ,
+ ptext SLIT("goto") , (pprBlockId ident) <> semi ]
+
+
+-- ---------------------------------------------------------------------
+-- a local table branch
+--
+-- we find the fall-through cases
+--
+-- N.B. we remove Nothing's from the list of branches, as they are
+-- 'undefined'. However, they may be defined one day, so we better
+-- document this behaviour.
+--
+pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
+pprSwitch e maybe_ids
+ = let ids = [ i | Just i <- maybe_ids ]
+ pairs = zip [ 0 .. ] (concatMap markfalls (group ids))
+ in
+ (hang (ptext SLIT("switch") <+> parens ( pprExpr e ) <+> lbrace)
+ 4 (vcat ( map caseify pairs )))
+ $$ rbrace
+
+ where
+ -- fall through case
+ caseify (i,Left ident) =
+ hsep [ ptext SLIT("case") , pprHexVal i <> colon ,
+ ptext SLIT("/* fall through for"),
+ pprBlockId ident,
+ ptext SLIT("*/") ]
+
+ caseify (i,Right ident) =
+ hsep [ ptext SLIT("case") , pprHexVal i <> colon ,
+ ptext SLIT("goto") , (pprBlockId ident) <> semi ]
+
+ -- mark the bottom of a fallthough sequence of cases as `Right'
+ markfalls [a] = [Right a]
+ markfalls as = map (\a -> Left a) (init as) ++ [Right (last as)]
+
+
+-- ---------------------------------------------------------------------
+-- Expressions.
+--
+
+-- C Types: the invariant is that the C expression generated by
+--
+-- pprExpr e
+--
+-- has a type in C which is also given by
+--
+-- machRepCType (cmmExprRep e)
+--
+-- (similar invariants apply to the rest of the pretty printer).
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e = case e of
+ CmmLit lit -> pprLit lit
+
+ CmmLoad e I64
+ -> ptext SLIT("PK_Word64") <> parens (mkP_ <> pprExpr1 e)
+
+ CmmLoad (CmmReg r) rep
+ | isPtrReg r && rep == wordRep
+ -> char '*' <> pprAsPtrReg r
+
+ CmmLoad (CmmRegOff r 0) rep
+ | isPtrReg r && rep == wordRep
+ -> char '*' <> pprAsPtrReg r
+
+ CmmLoad (CmmRegOff r off) rep
+ | isPtrReg r && rep == wordRep
+ -- ToDo: check that the offset is a word multiple?
+ -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))
+
+ CmmLoad expr rep ->
+ -- the general case:
+ char '*' <> parens (cCast (machRepPtrCType rep) expr)
+
+ CmmReg reg -> pprCastReg reg
+ CmmRegOff reg 0 -> pprCastReg reg
+
+ CmmRegOff reg i
+ | i > 0 -> pprRegOff (char '+') i
+ | otherwise -> pprRegOff (char '-') (-i)
+ where
+ pprRegOff op i' = pprCastReg reg <> op <> int i'
+
+ CmmMachOp mop args -> pprMachOpApp mop args
+
+pprExpr1 :: CmmExpr -> SDoc
+pprExpr1 (CmmLit lit) = pprLit1 lit
+pprExpr1 e@(CmmReg _reg) = pprExpr e
+pprExpr1 other = parens (pprExpr other)
+
+-- --------------------------------------------------------------------------
+-- MachOp applications
+
+pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
+
+pprMachOpApp op args
+ | isMulMayOfloOp op
+ = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args)) <> semi
+ where isMulMayOfloOp (MO_U_MulMayOflo _) = True
+ isMulMayOfloOp (MO_S_MulMayOflo _) = True
+ isMulMayOfloOp _ = False
+
+pprMachOpApp mop args
+ = case args of
+ -- dyadic
+ [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
+
+ -- unary
+ [x] -> pprMachOp_for_C mop <> parens (pprArg x)
+
+ _ -> panic "PprC.pprMachOp : machop with wrong number of args"
+
+ where
+ pprArg e | signedOp mop = cCast (machRepSignedCType (cmmExprRep e)) e
+ | otherwise = pprExpr1 e
+
+-- --------------------------------------------------------------------------
+-- Literals
+
+pprLit :: CmmLit -> SDoc
+pprLit lit = case lit of
+ CmmInt i _rep -> pprHexVal i
+ CmmFloat f rep -> parens (machRepCType rep) <> (rational f)
+ CmmLabel clbl -> mkW_ <> pprCLabel clbl
+ CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit)
+pprLit1 other = pprLit other
+
+-- ---------------------------------------------------------------------------
+-- Static data
+
+pprStatics :: [CmmStatic] -> [SDoc]
+pprStatics [] = []
+pprStatics (CmmStaticLit (CmmFloat f F32) : rest)
+ = pprLit1 (floatToWord f) : pprStatics rest
+pprStatics (CmmStaticLit (CmmFloat f F64) : rest)
+ = map pprLit1 (doubleToWords f) ++ pprStatics rest
+pprStatics (CmmStaticLit (CmmInt i I64) : rest)
+ | machRepByteWidth I32 == wORD_SIZE
+#ifdef WORDS_BIGENDIAN
+ = pprStatics (CmmStaticLit (CmmInt q I32) :
+ CmmStaticLit (CmmInt r I32) : rest)
+#else
+ = pprStatics (CmmStaticLit (CmmInt r I32) :
+ CmmStaticLit (CmmInt q I32) : rest)
+#endif
+ where r = i .&. 0xffffffff
+ q = i `shiftR` 32
+pprStatics (CmmStaticLit lit : rest)
+ = pprLit1 lit : pprStatics rest
+pprStatics (other : rest)
+ = pprPanic "pprWord" (pprStatic other)
+
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+
+ CmmStaticLit lit -> nest 4 (pprLit lit)
+ CmmAlign i -> nest 4 (ptext SLIT("/* align */") <+> int i)
+ CmmDataLabel clbl -> pprCLabel clbl <> colon
+ CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
+
+ -- these should be inlined, like the old .hc
+ CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
+
+
+-- ---------------------------------------------------------------------------
+-- Block Ids
+
+pprBlockId :: BlockId -> SDoc
+pprBlockId b = char '_' <> ppr (getUnique b)
+
+-- --------------------------------------------------------------------------
+-- Print a MachOp in a way suitable for emitting via C.
+--
+
+pprMachOp_for_C :: MachOp -> SDoc
+
+pprMachOp_for_C mop = case mop of
+
+ -- Integer operations
+ MO_Add _ -> char '+'
+ MO_Sub _ -> char '-'
+ MO_Eq _ -> ptext SLIT("==")
+ MO_Ne _ -> ptext SLIT("!=")
+ MO_Mul _ -> char '*'
+
+ MO_S_Quot _ -> char '/'
+ MO_S_Rem _ -> char '%'
+ MO_S_Neg _ -> char '-'
+
+ MO_U_Quot _ -> char '/'
+ MO_U_Rem _ -> char '%'
+
+ -- Signed comparisons (floating-point comparisons also use these)
+ -- & Unsigned comparisons
+ MO_S_Ge _ -> ptext SLIT(">=")
+ MO_S_Le _ -> ptext SLIT("<=")
+ MO_S_Gt _ -> char '>'
+ MO_S_Lt _ -> char '<'
+
+ MO_U_Ge _ -> ptext SLIT(">=")
+ MO_U_Le _ -> ptext SLIT("<=")
+ MO_U_Gt _ -> char '>'
+ MO_U_Lt _ -> char '<'
+
+ -- Bitwise operations. Not all of these may be supported at all
+ -- sizes, and only integral MachReps are valid.
+ MO_And _ -> char '&'
+ MO_Or _ -> char '|'
+ MO_Xor _ -> char '^'
+ MO_Not _ -> char '~'
+ MO_Shl _ -> ptext SLIT("<<")
+ MO_U_Shr _ -> ptext SLIT(">>") -- unsigned shift right
+ MO_S_Shr _ -> ptext SLIT(">>") -- signed shift right
+
+-- Conversions. Some of these will be NOPs.
+-- Floating-point conversions use the signed variant.
+-- We won't know to generate (void*) casts here, but maybe from
+-- context elsewhere
+
+-- noop casts
+ MO_U_Conv I8 I8 -> empty
+ MO_U_Conv I16 I16 -> empty
+ MO_U_Conv I32 I32 -> empty
+ MO_U_Conv I64 I64 -> empty
+ MO_U_Conv I128 I128 -> empty
+ MO_S_Conv I8 I8 -> empty
+ MO_S_Conv I16 I16 -> empty
+ MO_S_Conv I32 I32 -> empty
+ MO_S_Conv I64 I64 -> empty
+ MO_S_Conv I128 I128 -> empty
+
+ MO_U_Conv _from to -> parens (machRepCType to)
+ MO_S_Conv _from to -> parens (machRepSignedCType to)
+
+ _ -> panic "PprC.pprMachOp_for_C: unknown machop"
+
+signedOp :: MachOp -> Bool
+signedOp (MO_S_Quot _) = True
+signedOp (MO_S_Rem _) = True
+signedOp (MO_S_Neg _) = True
+signedOp (MO_S_Ge _) = True
+signedOp (MO_S_Le _) = True
+signedOp (MO_S_Gt _) = True
+signedOp (MO_S_Lt _) = True
+signedOp (MO_S_Shr _) = True
+signedOp (MO_S_Conv _ _) = True
+signedOp _ = False
+
+-- ---------------------------------------------------------------------
+-- tend to be implemented by foreign calls
+
+pprCallishMachOp_for_C :: CallishMachOp -> SDoc
+
+pprCallishMachOp_for_C mop
+ = case mop of
+ MO_F64_Pwr -> ptext SLIT("pow")
+ MO_F64_Sin -> ptext SLIT("sin")
+ MO_F64_Cos -> ptext SLIT("cos")
+ MO_F64_Tan -> ptext SLIT("tan")
+ MO_F64_Sinh -> ptext SLIT("sinh")
+ MO_F64_Cosh -> ptext SLIT("cosh")
+ MO_F64_Tanh -> ptext SLIT("tanh")
+ MO_F64_Asin -> ptext SLIT("asin")
+ MO_F64_Acos -> ptext SLIT("asin")
+ MO_F64_Atan -> ptext SLIT("atan")
+ MO_F64_Log -> ptext SLIT("log")
+ MO_F64_Exp -> ptext SLIT("exp")
+ MO_F64_Sqrt -> ptext SLIT("sqrt")
+ MO_F32_Pwr -> ptext SLIT("pow")
+ MO_F32_Sin -> ptext SLIT("sin")
+ MO_F32_Cos -> ptext SLIT("cos")
+ MO_F32_Tan -> ptext SLIT("tan")
+ MO_F32_Sinh -> ptext SLIT("sinh")
+ MO_F32_Cosh -> ptext SLIT("cosh")
+ MO_F32_Tanh -> ptext SLIT("tanh")
+ MO_F32_Asin -> ptext SLIT("asin")
+ MO_F32_Acos -> ptext SLIT("acos")
+ MO_F32_Atan -> ptext SLIT("atan")
+ MO_F32_Log -> ptext SLIT("log")
+ MO_F32_Exp -> ptext SLIT("exp")
+ MO_F32_Sqrt -> ptext SLIT("sqrt")
+
+-- ---------------------------------------------------------------------
+-- Useful #defines
+--
+
+mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
+
+mkJMP_ i = ptext SLIT("JMP_") <> parens i
+mkFN_ i = ptext SLIT("FN_") <> parens i -- externally visible function
+mkIF_ i = ptext SLIT("IF_") <> parens i -- locally visible
+
+
+mkFB_, mkFE_ :: SDoc
+mkFB_ = ptext SLIT("FB_") -- function code begin
+mkFE_ = ptext SLIT("FE_") -- function code end
+
+-- from includes/Stg.h
+--
+mkC_,mkW_,mkP_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc
+
+mkC_ = ptext SLIT("(C_)") -- StgChar
+mkW_ = ptext SLIT("(W_)") -- StgWord
+mkP_ = ptext SLIT("(P_)") -- StgWord*
+mkPP_ = ptext SLIT("(PP_)") -- P_*
+mkI_ = ptext SLIT("(I_)") -- StgInt
+mkA_ = ptext SLIT("(A_)") -- StgAddr
+mkD_ = ptext SLIT("(D_)") -- const StgWord*
+mkF_ = ptext SLIT("(F_)") -- StgFunPtr
+mkB_ = ptext SLIT("(B_)") -- StgByteArray
+mkL_ = ptext SLIT("(L_)") -- StgClosurePtr
+
+mkLI_ = ptext SLIT("(LI_)") -- StgInt64
+mkLW_ = ptext SLIT("(LW_)") -- StgWord64
+
+
+-- ---------------------------------------------------------------------
+--
+-- Assignments
+--
+-- Generating assignments is what we're all about, here
+--
+pprAssign :: CmmReg -> CmmExpr -> SDoc
+
+-- dest is a reg, rhs is a reg
+pprAssign r1 (CmmReg r2)
+ | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2)
+ || isPtrReg r1 && isPtrReg r2
+ = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
+
+-- dest is a reg, rhs is a CmmRegOff
+pprAssign r1 (CmmRegOff r2 off)
+ | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2)
+ || isPtrReg r1 && isPtrReg r2
+ = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
+ where
+ off1 | isPtrReg r2 = off `shiftR` wordShift
+ | otherwise = off
+
+ (op,off') | off >= 0 = (char '+', off1)
+ | otherwise = (char '-', -off1)
+
+-- dest is a reg, rhs is anything
+pprAssign r1 r2
+ = pprCastReg r1 <+> equals <+> pprExpr r2 <> semi
+
+-- ---------------------------------------------------------------------
+-- Registers
+
+pprCastReg reg
+ | isStrangeTypeReg reg = mkW_ <> pprReg reg
+ | otherwise = pprReg reg
+
+-- True if the register has type StgPtr in C, otherwise it has an
+-- integer type. We need to take care with pointer arithmetic on registers
+-- with type StgPtr.
+isPtrReg :: CmmReg -> Bool
+isPtrReg (CmmLocal _) = False
+isPtrReg (CmmGlobal r) = isPtrGlobalReg r
+
+isPtrGlobalReg :: GlobalReg -> Bool
+isPtrGlobalReg (VanillaReg n) = True
+isPtrGlobalReg Sp = True
+isPtrGlobalReg Hp = True
+isPtrGlobalReg HpLim = True
+isPtrGlobalReg SpLim = True
+isPtrGlobalReg _ = False
+
+-- True if in C this register doesn't have the type given by
+-- (machRepCType (cmmRegRep reg)), so it has to be cast.
+isStrangeTypeReg :: CmmReg -> Bool
+isStrangeTypeReg (CmmLocal _) = False
+isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g
+
+isStrangeTypeGlobal :: GlobalReg -> Bool
+isStrangeTypeGlobal CurrentTSO = True
+isStrangeTypeGlobal CurrentNursery = True
+isStrangeTypeGlobal r = isPtrGlobalReg r
+
+
+-- pprReg just prints the register name.
+--
+pprReg :: CmmReg -> SDoc
+pprReg r = case r of
+ CmmLocal local -> pprLocalReg local
+ CmmGlobal global -> pprGlobalReg global
+
+pprAsPtrReg :: CmmReg -> SDoc
+pprAsPtrReg (CmmGlobal (VanillaReg n)) = char 'R' <> int n <> ptext SLIT(".p")
+pprAsPtrReg other_reg = pprReg other_reg
+
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr = case gr of
+ VanillaReg n -> char 'R' <> int n <> ptext SLIT(".w")
+ FloatReg n -> char 'F' <> int n
+ DoubleReg n -> char 'D' <> int n
+ LongReg n -> char 'L' <> int n
+ Sp -> ptext SLIT("Sp")
+ SpLim -> ptext SLIT("SpLim")
+ Hp -> ptext SLIT("Hp")
+ HpLim -> ptext SLIT("HpLim")
+ CurrentTSO -> ptext SLIT("CurrentTSO")
+ CurrentNursery -> ptext SLIT("CurrentNursery")
+ HpAlloc -> ptext SLIT("HpAlloc")
+ BaseReg -> ptext SLIT("BaseReg")
+ GCEnter1 -> ptext SLIT("stg_gc_enter_1")
+ GCFun -> ptext SLIT("stg_gc_fun")
+
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq
+
+-- -----------------------------------------------------------------------------
+-- Foreign Calls
+
+pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
+ -> Maybe [GlobalReg] -> SDoc
+
+pprCall ppr_fn cconv results args vols
+ | not (is_cish cconv)
+ = panic "pprForeignCall: unknown calling convention"
+
+ | otherwise
+ = save vols $$
+ ptext SLIT("CALLER_SAVE_SYSTEM") $$
+ hcat [ ppr_results results, ppr_fn,
+ parens (commafy (map pprArg args)), semi ] $$
+ ptext SLIT("CALLER_RESTORE_SYSTEM") $$
+ restore vols
+ where
+ ppr_results [] = empty
+ ppr_results [(one,hint)] = pprArg (CmmReg one,hint) <> ptext SLIT(" = ")
+ ppr_results _other = panic "pprCall: multiple results"
+
+ pprArg (expr, PtrHint)
+ = cCast (ptext SLIT("void *")) expr
+ -- see comment by machRepHintCType below
+ pprArg (expr, SignedHint)
+ = cCast (machRepSignedCType (cmmExprRep expr)) expr
+ pprArg (expr, _other)
+ = pprExpr expr
+
+ save = save_restore SLIT("CALLER_SAVE")
+ restore = save_restore SLIT("CALLER_RESTORE")
+
+ -- Nothing says "I don't know what's live; save everything"
+ -- CALLER_SAVE_USER is defined in ghc/includes/Regs.h
+ save_restore txt Nothing = ptext txt <> ptext SLIT("_USER")
+ save_restore txt (Just these) = vcat (map saveRestoreGlobal these)
+ where saveRestoreGlobal r = ptext txt <> char '_' <> pprGlobalRegName r
+
+pprGlobalRegName :: GlobalReg -> SDoc
+pprGlobalRegName gr = case gr of
+ VanillaReg n -> char 'R' <> int n -- without the .w suffix
+ _ -> pprGlobalReg gr
+
+is_cish CCallConv = True
+is_cish StdCallConv = True
+is_cish _ = False
+
+-- ---------------------------------------------------------------------
+-- Find and print local and external declarations for a list of
+-- Cmm statements.
+--
+pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls stmts
+ = (vcat (map pprTempDecl (eltsUFM temps)),
+ vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)))
+ where (temps, lbls) = runTE (mapM_ te_BB stmts)
+
+pprDataExterns :: [CmmStatic] -> SDoc
+pprDataExterns statics
+ = vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls))
+ where (_, lbls) = runTE (mapM_ te_Static statics)
+
+pprTempDecl :: LocalReg -> SDoc
+pprTempDecl l@(LocalReg _uniq rep)
+ = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
+
+pprExternDecl :: Bool -> CLabel -> SDoc
+pprExternDecl in_srt lbl
+ -- do not print anything for "known external" things
+ | not (needsCDecl lbl) = empty
+ | otherwise =
+ hcat [ visibility, label_type (labelType lbl),
+ lparen, dyn_wrapper (pprCLabel lbl), text ");" ]
+ where
+ dyn_wrapper d
+ | in_srt && labelDynamic lbl = text "DLL_IMPORT_DATA_VAR" <> parens d
+ | otherwise = d
+
+ label_type CodeLabel = ptext SLIT("F_")
+ label_type DataLabel = ptext SLIT("I_")
+
+ visibility
+ | externallyVisibleCLabel lbl = char 'E'
+ | otherwise = char 'I'
+
+
+type TEState = (UniqSet LocalReg, FiniteMap CLabel ())
+newtype TE a = TE { unTE :: TEState -> (a, TEState) }
+
+instance Monad TE where
+ TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
+ return a = TE $ \s -> (a, s)
+
+te_lbl :: CLabel -> TE ()
+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, addToFM lbls lbl ()))
+
+te_temp :: LocalReg -> TE ()
+te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
+
+runTE :: TE () -> TEState
+runTE (TE m) = snd (m (emptyUniqSet, emptyFM))
+
+te_Static :: CmmStatic -> TE ()
+te_Static (CmmStaticLit lit) = te_Lit lit
+te_Static _ = return ()
+
+te_BB :: CmmBasicBlock -> TE ()
+te_BB (BasicBlock _ ss) = mapM_ te_Stmt ss
+
+te_Lit :: CmmLit -> TE ()
+te_Lit (CmmLabel l) = te_lbl l
+te_Lit _ = return ()
+
+te_Stmt :: CmmStmt -> TE ()
+te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
+te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
+te_Stmt (CmmCall _ rs es _) = mapM_ (te_Reg.fst) rs >>
+ mapM_ (te_Expr.fst) es
+te_Stmt (CmmCondBranch e _) = te_Expr e
+te_Stmt (CmmSwitch e _) = te_Expr e
+te_Stmt (CmmJump e _) = te_Expr e
+te_Stmt _ = return ()
+
+te_Expr :: CmmExpr -> TE ()
+te_Expr (CmmLit lit) = te_Lit lit
+te_Expr (CmmReg r) = te_Reg r
+te_Expr (CmmLoad e _) = te_Expr e
+te_Expr (CmmMachOp _ es) = mapM_ te_Expr es
+te_Expr (CmmRegOff r _) = te_Reg r
+te_Expr _ = return ()
+
+te_Reg :: CmmReg -> TE ()
+te_Reg (CmmLocal l) = te_temp l
+te_Reg _ = return ()
+
+
+-- ---------------------------------------------------------------------
+-- C types for MachReps
+
+cCast :: SDoc -> CmmExpr -> SDoc
+cCast ty expr = parens ty <> pprExpr1 expr
+
+-- This is for finding the types of foreign call arguments. For a pointer
+-- argument, we always cast the argument to (void *), to avoid warnings from
+-- the C compiler.
+machRepHintCType :: MachRep -> MachHint -> SDoc
+machRepHintCType rep PtrHint = ptext SLIT("void *")
+machRepHintCType rep SignedHint = machRepSignedCType rep
+machRepHintCType rep _other = machRepCType rep
+
+machRepPtrCType :: MachRep -> SDoc
+machRepPtrCType r | r == wordRep = ptext SLIT("P_")
+ | otherwise = machRepCType r <> char '*'
+
+machRepCType :: MachRep -> SDoc
+machRepCType r | r == wordRep = ptext SLIT("W_")
+ | otherwise = sized_type
+ where sized_type = case r of
+ I8 -> ptext SLIT("StgWord8")
+ I16 -> ptext SLIT("StgWord16")
+ I32 -> ptext SLIT("StgWord32")
+ I64 -> ptext SLIT("StgWord64")
+ F32 -> ptext SLIT("StgFloat") -- ToDo: correct?
+ F64 -> ptext SLIT("StgDouble")
+ _ -> panic "machRepCType"
+
+machRepSignedCType :: MachRep -> SDoc
+machRepSignedCType r | r == wordRep = ptext SLIT("I_")
+ | otherwise = sized_type
+ where sized_type = case r of
+ I8 -> ptext SLIT("StgInt8")
+ I16 -> ptext SLIT("StgInt16")
+ I32 -> ptext SLIT("StgInt32")
+ I64 -> ptext SLIT("StgInt64")
+ F32 -> ptext SLIT("StgFloat") -- ToDo: correct?
+ F64 -> ptext SLIT("StgDouble")
+ _ -> panic "machRepCType"
+
+-- ---------------------------------------------------------------------
+-- print strings as valid C strings
+
+-- Assumes it contains only characters '\0'..'\xFF'!
+pprFSInCStyle :: FastString -> SDoc
+pprFSInCStyle fs = pprStringInCStyle (unpackFS fs)
+
+pprStringInCStyle :: String -> SDoc
+pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
+
+charToC :: Char -> String
+charToC '\"' = "\\\""
+charToC '\'' = "\\\'"
+charToC '\\' = "\\\\"
+charToC c | c >= ' ' && c <= '~' = [c]
+ | c > '\xFF' = panic ("charToC "++show c)
+ | otherwise = ['\\',
+ chr (ord '0' + ord c `div` 64),
+ chr (ord '0' + ord c `div` 8 `mod` 8),
+ chr (ord '0' + ord c `mod` 8)]
+
+
+-- ---------------------------------------------------------------------------
+-- Initialising static objects with floating-point numbers. We can't
+-- just emit the floating point number, because C will cast it to an int
+-- by rounding it. We want the actual bit-representation of the float.
+
+-- This is a hack to turn the floating point numbers into ints that we
+-- can safely initialise to static locations.
+
+big_doubles
+ | machRepByteWidth F64 == 2 * wORD_SIZE = True
+ | machRepByteWidth F64 == wORD_SIZE = False
+ | otherwise = panic "big_doubles"
+
+#if __GLASGOW_HASKELL__ >= 504
+newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
+newFloatArray = newArray_
+
+newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
+newDoubleArray = newArray_
+
+castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
+castFloatToIntArray = castSTUArray
+
+castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
+castDoubleToIntArray = castSTUArray
+
+writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
+writeFloatArray = writeArray
+
+writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
+writeDoubleArray = writeArray
+
+readIntArray :: STUArray s Int Int -> Int -> ST s Int
+readIntArray = readArray
+
+#else
+
+castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castFloatToIntArray = return
+
+castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castDoubleToIntArray = return
+
+#endif
+
+-- floats are always 1 word
+floatToWord :: Rational -> CmmLit
+floatToWord r
+ = runST (do
+ arr <- newFloatArray ((0::Int),0)
+ writeFloatArray arr 0 (fromRational r)
+ arr' <- castFloatToIntArray arr
+ i <- readIntArray arr' 0
+ return (CmmInt (toInteger i) wordRep)
+ )
+
+doubleToWords :: Rational -> [CmmLit]
+doubleToWords r
+ | big_doubles -- doubles are 2 words
+ = runST (do
+ arr <- newDoubleArray ((0::Int),1)
+ writeDoubleArray arr 0 (fromRational r)
+ arr' <- castDoubleToIntArray arr
+ i1 <- readIntArray arr' 0
+ i2 <- readIntArray arr' 1
+ return [ CmmInt (toInteger i1) wordRep
+ , CmmInt (toInteger i2) wordRep
+ ]
+ )
+ | otherwise -- doubles are 1 word
+ = runST (do
+ arr <- newDoubleArray ((0::Int),0)
+ writeDoubleArray arr 0 (fromRational r)
+ arr' <- castDoubleToIntArray arr
+ i <- readIntArray arr' 0
+ return [ CmmInt (toInteger i) wordRep ]
+ )
+
+-- ---------------------------------------------------------------------------
+-- Utils
+
+wordShift :: Int
+wordShift = machRepLogWidth wordRep
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
+
+-- Print in C hex format: 0x13fa
+pprHexVal :: Integer -> SDoc
+pprHexVal 0 = ptext SLIT("0x0")
+pprHexVal w
+ | w < 0 = parens (char '-' <> ptext SLIT("0x") <> go (-w))
+ | otherwise = ptext SLIT("0x") <> go w
+ where
+ go 0 = empty
+ go w' = go q <> dig
+ where
+ (q,r) = w' `quotRem` 16
+ dig | r < 10 = char (chr (fromInteger r + ord '0'))
+ | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
+
--- /dev/null
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as (a superset of) C--
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
+-- slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+-- 1) if a value has wordRep type, the type is not appended in the
+-- output.
+-- 2) MachOps that operate over wordRep type are printed in a
+-- C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+--
+
+module PprCmm (
+ writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
+ ) where
+
+#include "HsVersions.h"
+
+import Cmm
+import CmmUtils ( isTrivialCmmExpr )
+import MachOp ( MachOp(..), pprMachOp, MachRep(..), wordRep )
+import CLabel ( pprCLabel, mkForeignLabel, entryLblToInfoLbl )
+
+import ForeignCall ( CCallConv(..) )
+import Unique ( getUnique )
+import Outputable
+import FastString ( mkFastString )
+
+import Data.List ( intersperse, groupBy )
+import IO ( Handle )
+import Maybe ( isJust )
+
+pprCmms :: [Cmm] -> SDoc
+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+ where
+ separator = space $$ ptext SLIT("-------------------") $$ space
+
+writeCmms :: Handle -> [Cmm] -> IO ()
+writeCmms handle cmms = printForC handle (pprCmms cmms)
+
+-----------------------------------------------------------------------------
+
+instance Outputable Cmm where
+ ppr c = pprCmm c
+
+instance Outputable CmmTop where
+ ppr t = pprTop t
+
+instance Outputable CmmBasicBlock where
+ ppr b = pprBBlock b
+
+instance Outputable CmmStmt where
+ ppr s = pprStmt s
+
+instance Outputable CmmExpr where
+ ppr e = pprExpr e
+
+instance Outputable CmmReg where
+ ppr e = pprReg e
+
+instance Outputable GlobalReg where
+ ppr e = pprGlobalReg e
+
+-----------------------------------------------------------------------------
+
+pprCmm :: Cmm -> SDoc
+pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks. The info tables, if not null, are
+-- printed in the style of C--'s 'stackdata' declaration, just inside
+-- the proc body, and are labelled with the procedure name ++ "_info".
+--
+pprTop :: CmmTop -> SDoc
+pprTop (CmmProc info lbl params blocks )
+
+ = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace
+ , nest 8 $ pprInfo info lbl
+ , nest 4 $ vcat (map ppr blocks)
+ , rbrace ]
+
+ where
+ pprInfo [] _ = empty
+ pprInfo i label =
+ (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
+ 4 $ vcat (map pprStatic i))
+ $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+-- section "data" { ... }
+--
+pprTop (CmmData section ds) =
+ (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
+ $$ rbrace
+
+
+-- --------------------------------------------------------------------------
+-- Basic blocks look like assembly blocks.
+-- lbl: stmt ; stmt ; ..
+pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+ hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
+
+-- --------------------------------------------------------------------------
+-- Statements. C-- usually, exceptions to this should be obvious.
+--
+pprStmt :: CmmStmt -> SDoc
+pprStmt stmt = case stmt of
+
+ -- ;
+ CmmNop -> semi
+
+ -- // text
+ CmmComment s -> text "//" <+> ftext s
+
+ -- reg = expr;
+ CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+ -- rep[lv] = expr;
+ CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+ where
+ rep = ppr ( cmmExprRep expr )
+
+ -- call "ccall" foo(x, y)[r1, r2];
+ -- ToDo ppr volatile
+ CmmCall (CmmForeignCall fn cconv) results args _volatile ->
+ hcat [ ptext SLIT("call"), space,
+ doubleQuotes(ppr cconv), space,
+ target fn, parens ( commafy $ map ppr args ),
+ (if null results
+ then empty
+ else brackets( commafy $ map ppr results)), semi ]
+ where
+ target (CmmLit lit) = pprLit lit
+ target fn' = parens (ppr fn')
+
+ CmmCall (CmmPrim op) results args volatile ->
+ pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
+ results args volatile)
+ where
+ lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
+
+ CmmBranch ident -> genBranch ident
+ CmmCondBranch expr ident -> genCondBranch expr ident
+ CmmJump expr params -> genJump expr params
+ CmmSwitch arg ids -> genSwitch arg ids
+
+-- --------------------------------------------------------------------------
+-- goto local label. [1], section 6.6
+--
+-- goto lbl;
+--
+genBranch :: BlockId -> SDoc
+genBranch ident =
+ ptext SLIT("goto") <+> pprBlockId ident <> semi
+
+-- --------------------------------------------------------------------------
+-- Conditional. [1], section 6.4
+--
+-- if (expr) { goto lbl; }
+--
+genCondBranch :: CmmExpr -> BlockId -> SDoc
+genCondBranch expr ident =
+ hsep [ ptext SLIT("if")
+ , parens(ppr expr)
+ , ptext SLIT("goto")
+ , pprBlockId ident <> semi ]
+
+-- --------------------------------------------------------------------------
+-- A tail call. [1], Section 6.9
+--
+-- jump foo(a, b, c);
+--
+genJump :: CmmExpr -> [LocalReg] -> SDoc
+genJump expr actuals =
+
+ hcat [ ptext SLIT("jump")
+ , space
+ , if isTrivialCmmExpr expr
+ then pprExpr expr
+ else case expr of
+ CmmLoad (CmmReg _) _ -> pprExpr expr
+ _ -> parens (pprExpr expr)
+ , pprActuals actuals
+ , semi ]
+
+ where
+ pprActuals [] = empty
+ pprActuals as = parens ( commafy $ map pprLocalReg as )
+
+-- --------------------------------------------------------------------------
+-- Tabled jump to local label
+--
+-- The syntax is from [1], section 6.5
+--
+-- switch [0 .. n] (expr) { case ... ; }
+--
+-- N.B. we remove 'Nothing's from the list of branches, as they don't
+-- seem to make sense currently. This may change, if they are defined in
+-- some way.
+--
+genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
+genSwitch expr maybe_ids
+
+ = let ids = [ i | Just i <- maybe_ids ]
+ pairs = groupBy snds (zip [0 .. ] ids )
+
+ in hang (hcat [ ptext SLIT("switch [0 .. ")
+ , int (length ids - 1)
+ , ptext SLIT("] ")
+ , if isTrivialCmmExpr expr
+ then pprExpr expr
+ else parens (pprExpr expr)
+ , ptext SLIT(" {")
+ ])
+ 4 (vcat ( map caseify pairs )) $$ rbrace
+
+ where
+ snds a b = (snd a) == (snd b)
+
+ caseify :: [(Int,BlockId)] -> SDoc
+ caseify as
+ = let (is,ids) = unzip as
+ in hsep [ ptext SLIT("case")
+ , hcat (punctuate comma (map int is))
+ , ptext SLIT(": goto")
+ , pprBlockId (head ids) <> semi ]
+
+-- --------------------------------------------------------------------------
+-- Expressions
+--
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e
+ = case e of
+ CmmRegOff reg i ->
+ pprExpr (CmmMachOp (MO_Add rep)
+ [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
+ where rep = cmmRegRep reg
+ CmmLit lit -> pprLit lit
+ _other -> pprExpr1 e
+
+-- Here's the precedence table from CmmParse.y:
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+-- %left '|'
+-- %left '^'
+-- %left '&'
+-- %left '>>' '<<'
+-- %left '-' '+'
+-- %left '/' '*' '%'
+-- %right '~'
+
+-- We just cope with the common operators for now, the rest will get
+-- a default conservative behaviour.
+
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
+ = pprExpr7 x <+> doc <+> pprExpr7 y
+pprExpr1 e = pprExpr7 e
+
+infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
+infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
+infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
+infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
+infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
+infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
+infixMachOp1 (MO_U_Gt _) = Just (char '>')
+infixMachOp1 (MO_U_Lt _) = Just (char '<')
+infixMachOp1 _ = Nothing
+
+-- %left '-' '+'
+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
+ = pprExpr7 x <+> doc <+> pprExpr8 y
+pprExpr7 e = pprExpr8 e
+
+infixMachOp7 (MO_Add _) = Just (char '+')
+infixMachOp7 (MO_Sub _) = Just (char '-')
+infixMachOp7 _ = Nothing
+
+-- %left '/' '*' '%'
+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
+ = pprExpr8 x <+> doc <+> pprExpr9 y
+pprExpr8 e = pprExpr9 e
+
+infixMachOp8 (MO_U_Quot _) = Just (char '/')
+infixMachOp8 (MO_Mul _) = Just (char '*')
+infixMachOp8 (MO_U_Rem _) = Just (char '%')
+infixMachOp8 _ = Nothing
+
+pprExpr9 :: CmmExpr -> SDoc
+pprExpr9 e =
+ case e of
+ CmmLit lit -> pprLit1 lit
+ CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
+ CmmReg reg -> ppr reg
+ CmmMachOp mop args -> genMachOp mop args
+ e -> parens (pprExpr e)
+
+genMachOp :: MachOp -> [CmmExpr] -> SDoc
+genMachOp mop args
+ | Just doc <- infixMachOp mop = case args of
+ -- dyadic
+ [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+
+ -- unary
+ [x] -> doc <> pprExpr9 x
+
+ _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
+ (pprMachOp mop <+>
+ parens (hcat $ punctuate comma (map pprExpr args)))
+ empty
+
+ | isJust (infixMachOp1 mop)
+ || isJust (infixMachOp7 mop)
+ || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
+
+ | otherwise = char '%' <> pprMachOp mop <> parens (commafy (map pprExpr args))
+
+--
+-- Unsigned ops on the word size of the machine get nice symbols.
+-- All else get dumped in their ugly format.
+--
+infixMachOp :: MachOp -> Maybe SDoc
+infixMachOp mop
+ = case mop of
+ MO_And _ -> Just $ char '&'
+ MO_Or _ -> Just $ char '|'
+ MO_Xor _ -> Just $ char '^'
+ MO_Not _ -> Just $ char '~'
+ MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
+ MO_Not _ -> Just $ char '~'
+ _ -> Nothing
+
+-- --------------------------------------------------------------------------
+-- Literals.
+-- To minimise line noise we adopt the convention that if the literal
+-- has the natural machine word size, we do not append the type
+--
+pprLit :: CmmLit -> SDoc
+pprLit lit = case lit of
+ CmmInt i rep ->
+ hcat [ (if i < 0 then parens else id)(integer i)
+ , (if rep == wordRep
+ then empty
+ else space <> dcolon <+> ppr rep) ]
+
+ CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
+ CmmLabel clbl -> pprCLabel clbl
+ CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
+
+pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
+pprLit1 lit = pprLit lit
+
+ppr_offset :: Int -> SDoc
+ppr_offset i
+ | i==0 = empty
+ | i>=0 = char '+' <> int i
+ | otherwise = char '-' <> int (-i)
+
+-- --------------------------------------------------------------------------
+-- Static data.
+-- Strings are printed as C strings, and we print them as I8[],
+-- following C--
+--
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+ CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
+ CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+ CmmAlign i -> nest 4 $ text "align" <+> int i
+ CmmDataLabel clbl -> pprCLabel clbl <> colon
+ CmmString s' -> nest 4 $ text "I8[]" <+> doubleQuotes (text s')
+
+-- --------------------------------------------------------------------------
+-- Registers, whether local (temps) or global
+--
+pprReg :: CmmReg -> SDoc
+pprReg r
+ = case r of
+ CmmLocal local -> pprLocalReg local
+ CmmGlobal global -> pprGlobalReg global
+
+--
+-- We only print the type of the local reg if it isn't wordRep
+--
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq rep)
+ = hcat [ char '_', ppr uniq,
+ (if rep == wordRep
+ then empty else dcolon <> ppr rep) ]
+
+-- needs to be kept in syn with Cmm.hs.GlobalReg
+--
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr
+ = case gr of
+ VanillaReg n -> char 'R' <> int n
+ FloatReg n -> char 'F' <> int n
+ DoubleReg n -> char 'D' <> int n
+ LongReg n -> char 'L' <> int n
+ Sp -> ptext SLIT("Sp")
+ SpLim -> ptext SLIT("SpLim")
+ Hp -> ptext SLIT("Hp")
+ HpLim -> ptext SLIT("HpLim")
+ CurrentTSO -> ptext SLIT("CurrentTSO")
+ CurrentNursery -> ptext SLIT("CurrentNursery")
+ HpAlloc -> ptext SLIT("HpAlloc")
+ GCEnter1 -> ptext SLIT("stg_gc_enter_1")
+ GCFun -> ptext SLIT("stg_gc_fun")
+ BaseReg -> ptext SLIT("BaseReg")
+
+ _ -> panic $ "PprCmm.pprGlobalReg: unknown global reg"
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Section -> SDoc
+pprSection s = case s of
+ Text -> section <+> doubleQuotes (ptext SLIT("text"))
+ Data -> section <+> doubleQuotes (ptext SLIT("data"))
+ ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
+ UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
+ OtherSection s' -> section <+> doubleQuotes (text s')
+ where
+ section = ptext SLIT("section")
+
+-- --------------------------------------------------------------------------
+-- Basic block ids
+--
+pprBlockId :: BlockId -> SDoc
+pprBlockId b = ppr $ getUnique b
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
+
CgBindings, CgIdInfo,
StableLoc, VolatileLoc,
- stableAmodeIdInfo, heapIdInfo,
+ cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
+
+ stableIdInfo, heapIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
addBindC, addBindsC,
nukeVolatileBinds,
nukeDeadBindings,
+ getLiveStackSlots,
- bindNewToStack, rebindToStack,
+ bindArgsToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp,
- getArgAmode, getArgAmodes,
- getCAddrModeAndInfo, getCAddrMode,
+ getArgAmode, getArgAmodes,
+ getCgIdInfo,
getCAddrModeIfVolatile, getVolatileRegs,
-
- buildContLivenessMask
+ maybeLetNoEscape,
) where
#include "HsVersions.h"
-import AbsCSyn
import CgMonad
-
-import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
-import CgStackery ( freeStackSlots, getStackFrame )
-import CLabel ( mkClosureLabel,
- mkBitmapLabel, pprCLabel )
+import CgHeapery ( getHpRelOffset )
+import CgStackery ( freeStackSlots, getSpRelOffset )
+import CgUtils ( cgLit, cmmOffsetW )
+import CLabel ( mkClosureLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
-import Bitmap
-import PrimRep ( isFollowableRep, getPrimRepSize )
-import Id ( Id, idPrimRep, idType )
-import Type ( typePrimRep )
+
+import Cmm
+import PprCmm ( {- instance Outputable -} )
+import SMRep ( CgRep(..), WordOff, isFollowableArg,
+ isVoidArg, cgRepSizeW, argMachRep,
+ idCgRep, typeCgRep )
+import Id ( Id, idName )
import VarEnv
import VarSet ( varSetElems )
-import Literal ( Literal )
-import Maybes ( catMaybes, maybeToBool, seqMaybe )
-import Name ( isInternalName, NamedThing(..) )
-import PprAbsC ( pprAmode, pprMagicId )
-import PrimRep ( PrimRep(..) )
+import Literal ( literalType )
+import Maybes ( catMaybes )
+import Name ( isExternalName )
import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
-import Unique ( Unique, Uniquable(..) )
+import Unique ( Uniquable(..) )
import UniqSet ( elementOfUniqSet )
-import Util ( zipWithEqual, sortLt )
import Outputable
\end{code}
type CgBindings = IdEnv CgIdInfo
data CgIdInfo
- = MkCgIdInfo Id -- Id that this is the info for
- VolatileLoc
- StableLoc
- LambdaFormInfo
+ = CgIdInfo
+ { cg_id :: Id -- Id that this is the info for
+ -- Can differ from the Id at occurrence sites by
+ -- virtue of being externalised, for splittable C
+ , cg_rep :: CgRep
+ , cg_vol :: VolatileLoc
+ , cg_stb :: StableLoc
+ , cg_lf :: LambdaFormInfo }
+
+mkCgIdInfo id vol stb lf
+ = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
+ cg_lf = lf, cg_rep = idCgRep id }
+
+voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
+ , cg_stb = VoidLoc, cg_lf = mkLFArgument id
+ , cg_rep = VoidArg }
+ -- Used just for VoidRep things
data VolatileLoc
= NoVolatileLoc
- | TempVarLoc Unique
-
- | RegLoc MagicId -- in one of the magic registers
- -- (probably {Int,Float,Char,etc}Reg)
-
- | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure)
-
- | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node
- -- ie *(Node+offset)
+ | RegLoc CmmReg -- In one of the registers (global or local)
+ | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure)
+ | VirNodeLoc VirtualHpOffset -- Cts of offset indirect from Node
+ -- ie *(Node+offset)
\end{code}
@StableLoc@ encodes where an Id can be found, used by
\begin{code}
data StableLoc
= NoStableLoc
- | VirStkLoc VirtualSpOffset
- | LitLoc Literal
- | StableAmodeLoc CAddrMode
--- these are so StableLoc can be abstract:
+ | VirStkLoc VirtualSpOffset -- The thing is held in this
+ -- stack slot
-maybeStkLoc (VirStkLoc offset) = Just offset
-maybeStkLoc _ = Nothing
+ | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the
+ -- value is this stack pointer
+ -- (as opposed to the contents of the slot)
+
+ | StableLoc CmmExpr
+ | VoidLoc -- Used only for VoidRep variables. They never need to
+ -- be saved, so it makes sense to treat treat them as
+ -- having a stable location
\end{code}
\begin{code}
instance Outputable CgIdInfo where
- ppr (MkCgIdInfo id vol stb lf)
+ ppr (CgIdInfo id rep vol stb lf)
= ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
instance Outputable VolatileLoc where
ppr NoVolatileLoc = empty
- ppr (TempVarLoc u) = ptext SLIT("tmp") <+> ppr u
- ppr (RegLoc r) = ptext SLIT("reg") <+> pprMagicId r
- ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v
- ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
+ ppr (RegLoc r) = ptext SLIT("reg") <+> ppr r
+ ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v
+ ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
instance Outputable StableLoc where
- ppr NoStableLoc = empty
- ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v
- ppr (LitLoc l) = ptext SLIT("lit") <+> ppr l
- ppr (StableAmodeLoc a) = ptext SLIT("amode") <+> pprAmode a
+ ppr NoStableLoc = empty
+ ppr VoidLoc = ptext SLIT("void")
+ ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v
+ ppr (VirStkLNE v) = ptext SLIT("lne") <+> ppr v
+ ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
-heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
-tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
-
-letNoEscapeIdInfo i sp lf_info
- = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
-
-idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
-idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
-
-idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
-
-idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind)
-idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id)
-
-idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit)
-idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
+stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
+heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
+letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
+stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
+nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info
+regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
+
+idInfoToAmode :: CgIdInfo -> FCode CmmExpr
+idInfoToAmode info
+ = case cg_vol info of {
+ RegLoc reg -> returnFC (CmmReg reg) ;
+ VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ;
+ VirHpLoc hp_off -> getHpRelOffset hp_off ;
+ NoVolatileLoc ->
+
+ case cg_stb info of
+ StableLoc amode -> returnFC amode
+ VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
+ ; return (CmmLoad sp_rel mach_rep) }
+
+ VirStkLNE sp_off -> getSpRelOffset sp_off ;
+
+ VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
+ -- We return a 'bottom' amode, rather than panicing now
+ -- In this way getArgAmode returns a pair of (VoidArg, bottom)
+ -- and that's exactly what we want
+
+ NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
+ }
+ where
+ mach_rep = argMachRep (cg_rep info)
-idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
- = returnFC (CVal (nodeRel nd_off) kind)
- -- Virtual offsets from Node increase into the closures,
- -- and so do Node-relative offsets (which we want in the CVal),
- -- so there is no mucking about to do to the offset.
+cgIdInfoId :: CgIdInfo -> Id
+cgIdInfoId = cg_id
-idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
- = getHpRelOffset hp_off `thenFC` \ rel_hp ->
- returnFC (CAddr rel_hp)
+cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
+cgIdInfoLF = cg_lf
-idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i)
- = getSpRelOffset i `thenFC` \ rel_sp ->
- returnFC (CVal rel_sp kind)
+cgIdInfoArgRep :: CgIdInfo -> CgRep
+cgIdInfoArgRep = cg_rep
-#ifdef DEBUG
-idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
-#endif
+maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
+maybeLetNoEscape other = Nothing
\end{code}
%************************************************************************
%* *
%************************************************************************
-There are three basic routines, for adding (@addBindC@), modifying
-(@modifyBindC@) and looking up (@lookupBindC@) bindings.
+.There are three basic routines, for adding (@addBindC@), modifying
+(@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
The name should not already be bound. (nice ASSERT, eh?)
addBindsC new_bindings = do
binds <- getBinds
let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
- binds
- new_bindings
+ binds
+ new_bindings
setBinds new_binds
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
binds <- getBinds
setBinds $ modifyVarEnv mangle_fn binds name
-lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC id = do maybe_info <- lookupBindC_maybe id
- case maybe_info of
- Just info -> return info
- Nothing -> cgLookupPanic id
-
-lookupBindC_maybe :: Id -> FCode (Maybe CgIdInfo)
-lookupBindC_maybe id
- = do static_binds <- getStaticBinds
- local_binds <- getBinds
- return (lookupVarEnv local_binds id
- `seqMaybe`
- lookupVarEnv static_binds id)
+getCgIdInfo :: Id -> FCode CgIdInfo
+getCgIdInfo id
+ = do { -- Try local bindings first
+ ; local_binds <- getBinds
+ ; case lookupVarEnv local_binds id of {
+ Just info -> return info ;
+ Nothing -> do
+
+ { -- Try top-level bindings
+ static_binds <- getStaticBinds
+ ; case lookupVarEnv static_binds id of {
+ Just info -> return info ;
+ Nothing ->
+
+ -- Should be imported; make up a CgIdInfo for it
+ if isExternalName name then
+ return (stableIdInfo id ext_lbl (mkLFImported id))
+ else
+ if isVoidArg (idCgRep id) then
+ -- Void things are never in the environment
+ return (voidIdInfo id)
+ else
+ -- Bug
+ cgLookupPanic id
+ }}}}
+ where
+ name = idName id
+ ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
pprPanic "cgPanic"
(vcat [ppr id,
ptext SLIT("static binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
+ vcat [ ppr (cg_id info) | info <- rngVarEnv static_binds ],
ptext SLIT("local binds for:"),
- vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
+ vcat [ ppr (cg_id info) | info <- rngVarEnv local_binds ],
ptext SLIT("SRT label") <+> pprCLabel srt
])
\end{code}
nukeVolatileBinds binds
= mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
where
- keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
- keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc
- = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
+ keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
+ keep_if_stable info acc
+ = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
\end{code}
%* *
%************************************************************************
-I {\em think} all looking-up is done through @getCAddrMode(s)@.
-
\begin{code}
-getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
-
-getCAddrModeAndInfo id
- = do
- maybe_cg_id_info <- lookupBindC_maybe id
- case maybe_cg_id_info of
-
- -- Nothing => not in the environment, so should be imported
- Nothing | isInternalName name -> cgLookupPanic id
- | otherwise -> returnFC (id, global_amode, mkLFImported id)
-
- Just (MkCgIdInfo id' volatile_loc stable_loc lf_info)
- -> do amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
- return (id', amode, lf_info)
- where
- name = getName id
- global_amode = CLbl (mkClosureLabel name) kind
- kind = idPrimRep id
-
-getCAddrMode :: Id -> FCode CAddrMode
-getCAddrMode name = do
- (_, amode, _) <- getCAddrModeAndInfo name
- return amode
-\end{code}
-
-\begin{code}
-getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
-getCAddrModeIfVolatile name
--- | toplevelishId name = returnFC Nothing
--- | otherwise
- = do
- (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name
- case stable_loc of
+getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
+getCAddrModeIfVolatile id
+ = do { info <- getCgIdInfo id
+ ; case cg_stb info of
NoStableLoc -> do -- Aha! So it is volatile!
- amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc
+ amode <- idInfoToAmode info
return $ Just amode
- a_stable_loc -> return Nothing
+ a_stable_loc -> return Nothing }
\end{code}
@getVolatileRegs@ gets a set of live variables, and returns a list of
forget the volatile one.
\begin{code}
-getVolatileRegs :: StgLiveVars -> FCode [MagicId]
+getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
getVolatileRegs vars = do
- stuff <- mapFCs snaffle_it (varSetElems vars)
- returnFC $ catMaybes stuff
- where
- snaffle_it var = do
- (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var
- let
+ do { stuff <- mapFCs snaffle_it (varSetElems vars)
+ ; returnFC $ catMaybes stuff }
+ where
+ snaffle_it var = do
+ { info <- getCgIdInfo var
+ ; let
-- commoned-up code...
- consider_reg reg =
- if not (isVolatileReg reg) then
- -- Potentially dies across C calls
- -- For now, that's everything; we leave
- -- it to the save-macros to decide which
- -- regs *really* need to be saved.
- returnFC Nothing
- else
- case stable_loc of
- NoStableLoc -> returnFC (Just reg) -- got one!
- is_a_stable_loc -> do
- -- has both volatile & stable locations;
- -- force it to rely on the stable location
- modifyBindC var nuke_vol_bind
- return Nothing
- in
- case volatile_loc of
- RegLoc reg -> consider_reg reg
- VirNodeLoc _ -> consider_reg node
- non_reg_loc -> returnFC Nothing
-
- nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
- = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
+ consider_reg reg
+ = -- We assume that all regs can die across C calls
+ -- We leave it to the save-macros to decide which
+ -- regs *really* need to be saved.
+ case cg_stb info of
+ NoStableLoc -> returnFC (Just reg) -- got one!
+ is_a_stable_loc -> do
+ { -- has both volatile & stable locations;
+ -- force it to rely on the stable location
+ modifyBindC var nuke_vol_bind
+ ; return Nothing }
+
+ ; case cg_vol info of
+ RegLoc (CmmGlobal reg) -> consider_reg reg
+ VirNodeLoc _ -> consider_reg node
+ other_loc -> returnFC Nothing -- Local registers
+ }
+
+ nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
\end{code}
\begin{code}
-getArgAmodes :: [StgArg] -> FCode [CAddrMode]
-getArgAmodes [] = returnFC []
-getArgAmodes (atom:atoms)
- | isStgTypeArg atom
- = getArgAmodes atoms
- | otherwise = do
- amode <- getArgAmode atom
- amodes <- getArgAmodes atoms
- return ( amode : amodes )
+getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
+getArgAmode (StgVarArg var)
+ = do { info <- getCgIdInfo var
+ ; amode <- idInfoToAmode info
+ ; return (cgIdInfoArgRep info, amode ) }
-getArgAmode :: StgArg -> FCode CAddrMode
+getArgAmode (StgLitArg lit)
+ = do { cmm_lit <- cgLit lit
+ ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
-getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
-getArgAmode (StgLitArg lit) = returnFC (CLit lit)
+getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
+
+getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
+getArgAmodes [] = returnFC []
+getArgAmodes (atom:atoms)
+ | isStgTypeArg atom = getArgAmodes atoms
+ | otherwise = do { amode <- getArgAmode atom
+ ; amodes <- getArgAmodes atoms
+ ; return ( amode : amodes ) }
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-bindNewToStack :: (Id, VirtualSpOffset) -> Code
-bindNewToStack (name, offset)
- = addBindC name info
+bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
+bindArgsToStack args
+ = mapCs bind args
where
- info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) (mkLFArgument name)
+ bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
-bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
-bindNewToNode name offset lf_info
- = addBindC name info
+bindArgsToRegs :: [(Id, GlobalReg)] -> Code
+bindArgsToRegs args
+ = mapCs bind args
where
- info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
+ bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
+
+bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
+bindNewToNode id offset lf_info
+ = addBindC id (nodeIdInfo id offset lf_info)
-- Create a new temporary whose unique is that in the id,
-- bind the id to it, and return the addressing mode for the
-- temporary.
-bindNewToTemp :: Id -> FCode CAddrMode
+bindNewToTemp :: Id -> FCode CmmReg
bindNewToTemp id
- = do addBindC id id_info
- return temp_amode
- where
- uniq = getUnique id
- temp_amode = CTemp uniq (idPrimRep id)
- id_info = tempIdInfo id uniq lf_info
- lf_info = mkLFArgument id -- Always used of things we
- -- know nothing about
-
-bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
-bindNewToReg name magic_id lf_info
- = addBindC name info
+ = do addBindC id (regIdInfo id temp_reg lf_info)
+ return temp_reg
where
- info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
+ uniq = getUnique id
+ temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id)))
+ lf_info = mkLFArgument id -- Always used of things we
+ -- know nothing about
-bindArgsToRegs :: [Id] -> [MagicId] -> Code
-bindArgsToRegs args regs
- = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
+bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
+bindNewToReg name reg lf_info
+ = addBindC name info
where
- arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg)
+ info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
\end{code}
\begin{code}
rebindToStack name offset
= modifyBindC name replace_stable_fn
where
- replace_stable_fn (MkCgIdInfo i vol stab einfo)
- = MkCgIdInfo i vol (VirStkLoc offset) einfo
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
-%* *
-%************************************************************************
-
-There are four kinds of things on the stack:
-
- - pointer variables (bound in the environment)
- - non-pointer variables (boudn in the environment)
- - free slots (recorded in the stack free list)
- - non-pointer data slots (recorded in the stack free list)
-
-We build up a bitmap of non-pointer slots by searching the environment
-for all the pointer variables, and subtracting these from a bitmap
-with initially all bits set (up to the size of the stack frame).
-
-\begin{code}
-buildLivenessMask
- :: VirtualSpOffset -- size of the stack frame
- -> VirtualSpOffset -- offset from which the bitmap should start
- -> FCode Bitmap -- mask for free/unlifted slots
-
-buildLivenessMask size sp = do {
- -- find all live stack-resident pointers
- binds <- getBinds;
- ((vsp, _, free, _, _), heap_usage) <- getUsage;
-
- let {
- rel_slots = sortLt (<)
- [ sp - ofs -- get slots relative to top of frame
- | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
- isFollowableRep (idPrimRep id)
- ];
- };
-
- WARN( not (all (>=0) rel_slots), ppr size $$ ppr sp $$ ppr rel_slots $$ ppr binds )
- return (intsToReverseBitmap size rel_slots)
- }
-
--- In a continuation, we want a liveness mask that starts from just after
--- the return address, which is on the stack at realSp.
-
-buildContLivenessMask :: Id -> FCode Liveness
- -- The Id is used just for its unique to make a label
-buildContLivenessMask id = do
- realSp <- getRealSp
-
- frame_sp <- getStackFrame
- -- realSp points to the frame-header for the current stack frame,
- -- and the end of this frame is frame_sp. The size is therefore
- -- realSp - frame_sp - 1 (subtract one for the frame-header).
- let frame_size = realSp - frame_sp - 1
-
- mask <- buildLivenessMask frame_size (realSp-1)
-
- let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask
- absC (maybeLargeBitmap liveness)
- return liveness
+ replace_stable_fn info = info { cg_stb = VirStkLoc offset }
\end{code}
%************************************************************************
let (dead_stk_slots, bs') =
dead_slots live_vars
[] []
- [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
+ [ (cg_id b, b) | b <- rngVarEnv binds ]
setBinds $ mkVarEnv bs'
freeStackSlots dead_stk_slots
\end{code}
-- Instead keep it in the filtered bindings
| otherwise
- = case i of
- MkCgIdInfo _ _ stable_loc _
- | is_stk_loc && size > 0 ->
- dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
- where
- maybe_stk_loc = maybeStkLoc stable_loc
- is_stk_loc = maybeToBool maybe_stk_loc
- (Just offset) = maybe_stk_loc
+ = case cg_stb i of
+ VirStkLoc offset
+ | size > 0
+ -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
_ -> dead_slots live_vars fbs ds bs
where
+ size :: WordOff
+ size = cgRepSizeW (cg_rep i)
+\end{code}
- size :: Int
- size = (getPrimRepSize . typePrimRep . idType) v
-
+\begin{code}
+getLiveStackSlots :: FCode [VirtualSpOffset]
+-- Return the offsets of slots in stack containig live pointers
+getLiveStackSlots
+ = do { binds <- getBinds
+ ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
+ cg_rep = rep } <- rngVarEnv binds,
+ isFollowableArg rep] }
\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- CgCallConv
+--
+-- The datatypes and functions here encapsulate the
+-- calling and return conventions used by the code generator.
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+
+module CgCallConv (
+ -- Argument descriptors
+ mkArgDescr, argDescrType,
+
+ -- Liveness
+ isBigLiveness, buildContLiveness, mkRegLiveness,
+ smallLiveness, mkLivenessCLit,
+
+ -- Register assignment
+ assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
+
+ -- Calls
+ constructSlowCall, slowArgs, slowCallPattern,
+
+ -- Returns
+ CtrlReturnConvention(..),
+ ctrlReturnConvAlg,
+ dataReturnConvPrim,
+ getSequelAmode
+ ) where
+
+#include "HsVersions.h"
+
+import CgUtils ( emitRODataLits, mkWordCLit )
+import CgMonad
+
+import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
+ mAX_Vanilla_REG, mAX_Float_REG,
+ mAX_Double_REG, mAX_Long_REG,
+ mAX_Real_Vanilla_REG, mAX_Real_Float_REG,
+ mAX_Real_Double_REG, mAX_Real_Long_REG,
+ bITMAP_BITS_SHIFT
+ )
+
+import ClosureInfo ( ArgDescr(..), Liveness(..) )
+import CgStackery ( getSpRelOffset )
+import SMRep
+import MachOp ( wordRep )
+import Cmm ( CmmExpr(..), GlobalReg(..), CmmLit(..), CmmReg(..), node )
+import CmmUtils ( mkLblExpr )
+import CLabel
+import Maybes ( mapCatMaybes )
+import Id ( Id )
+import Name ( Name )
+import TyCon ( TyCon, tyConFamilySize )
+import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE,
+ mkBitmap, intsToReverseBitmap )
+import Util ( isn'tIn, sortLt )
+import CmdLineOpts ( opt_Unregisterised )
+import FastString ( LitString )
+import Outputable
+import DATA_BITS
+
+
+-------------------------------------------------------------------------
+--
+-- Making argument descriptors
+--
+-- An argument descriptor describes the layout of args on the stack,
+-- both for * GC (stack-layout) purposes, and
+-- * saving/restoring registers when a heap-check fails
+--
+-- Void arguments aren't important, therefore (contrast constructSlowCall)
+--
+-------------------------------------------------------------------------
+
+-- bring in ARG_P, ARG_N, etc.
+#include "../includes/StgFun.h"
+
+-------------------------
+argDescrType :: ArgDescr -> Int
+-- The "argument type" RTS field type
+argDescrType (ArgSpec n) = n
+argDescrType (ArgGen liveness)
+ | isBigLiveness liveness = ARG_GEN_BIG
+ | otherwise = ARG_GEN
+
+
+mkArgDescr :: Name -> [Id] -> FCode ArgDescr
+mkArgDescr nm args
+ = case stdPattern arg_reps of
+ Just spec_id -> return (ArgSpec spec_id)
+ Nothing -> do { liveness <- mkLiveness nm size bitmap
+ ; return (ArgGen liveness) }
+ where
+ arg_reps = filter nonVoidArg (map idCgRep args)
+ -- Getting rid of voids eases matching of standard patterns
+
+ bitmap = mkBitmap arg_bits
+ arg_bits = argBits arg_reps
+ size = length arg_bits
+
+argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr
+argBits [] = []
+argBits (PtrArg : args) = False : argBits args
+argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args
+
+stdPattern :: [CgRep] -> Maybe Int
+stdPattern [PtrArg] = Just ARG_P
+stdPattern [FloatArg] = Just ARG_F
+stdPattern [DoubleArg] = Just ARG_D
+stdPattern [LongArg] = Just ARG_L
+stdPattern [NonPtrArg] = Just ARG_N
+
+stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
+stdPattern [NonPtrArg,PtrArg] = Just ARG_NP
+stdPattern [PtrArg,NonPtrArg] = Just ARG_PN
+stdPattern [PtrArg,PtrArg] = Just ARG_PP
+
+stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
+stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP
+stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN
+stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP
+stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN
+stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP
+stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN
+stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP
+
+stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP
+stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP
+stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
+stdPattern other = Nothing
+
+
+-------------------------------------------------------------------------
+--
+-- Liveness info
+--
+-------------------------------------------------------------------------
+
+mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
+mkLiveness name size bits
+ | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
+ = do { let lbl = mkBitmapLabel name
+ ; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
+ : map mkWordCLit bits)
+ ; return (BigLiveness lbl) }
+
+ | otherwise -- Bitmap fits in one word
+ = let
+ small_bits = case bits of
+ [] -> 0
+ [b] -> fromIntegral b
+ _ -> panic "livenessToAddrMode"
+ in
+ return (smallLiveness size small_bits)
+
+smallLiveness :: Int -> StgWord -> Liveness
+smallLiveness size small_bits = SmallLiveness bits
+ where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
+
+-------------------
+isBigLiveness :: Liveness -> Bool
+isBigLiveness (BigLiveness _) = True
+isBigLiveness (SmallLiveness _) = False
+
+-------------------
+mkLivenessCLit :: Liveness -> CmmLit
+mkLivenessCLit (BigLiveness lbl) = CmmLabel lbl
+mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits
+
+
+-------------------------------------------------------------------------
+--
+-- Bitmap describing register liveness
+-- across GC when doing a "generic" heap check
+-- (a RET_DYN stack frame).
+--
+-- NB. Must agree with these macros (currently in StgMacros.h):
+-- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
+-------------------------------------------------------------------------
+
+mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
+mkRegLiveness regs ptrs nptrs
+ = (fromIntegral nptrs `shiftL` 16) .|.
+ (fromIntegral ptrs `shiftL` 24) .|.
+ all_non_ptrs `xor` reg_bits regs
+ where
+ all_non_ptrs = 0xff
+
+ reg_bits [] = 0
+ reg_bits ((id, VanillaReg i) : regs) | isFollowableArg (idCgRep id)
+ = (1 `shiftL` (i - 1)) .|. reg_bits regs
+ reg_bits (_ : regs)
+ = reg_bits regs
+
+-------------------------------------------------------------------------
+--
+-- Pushing the arguments for a slow call
+--
+-------------------------------------------------------------------------
+
+-- For a slow call, we must take a bunch of arguments and intersperse
+-- some stg_ap_<pattern>_ret_info return addresses.
+constructSlowCall :: [(CgRep,CmmExpr)] -> (CLabel, [(CgRep,CmmExpr)])
+ -- don't forget the zero case
+constructSlowCall []
+ = (stg_ap_0, [])
+ where
+ stg_ap_0 = enterRtsRetLabel SLIT("stg_ap_0")
+
+constructSlowCall amodes
+ = (stg_ap_pat, these ++ slowArgs rest)
+ where
+ stg_ap_pat = enterRtsRetLabel arg_pat
+ (arg_pat, these, rest) = matchSlowPattern amodes
+
+enterRtsRetLabel arg_pat
+ | tablesNextToCode = mkRtsRetInfoLabel arg_pat
+ | otherwise = mkRtsRetLabel arg_pat
+
+-- | 'slowArgs' takes a list of function arguments and prepares them for
+-- pushing on the stack for "extra" arguments to a function which requires
+-- fewer arguments than we currently have.
+slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
+slowArgs [] = []
+slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
+ where (arg_pat, args, rest) = matchSlowPattern amodes
+ stg_ap_pat = mkRtsRetInfoLabel arg_pat
+
+matchSlowPattern :: [(CgRep,CmmExpr)]
+ -> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
+matchSlowPattern amodes = (arg_pat, these, rest)
+ where (arg_pat, n) = slowCallPattern (map fst amodes)
+ (these, rest) = splitAt n amodes
+
+-- These cases were found to cover about 99% of all slow calls:
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppppp"), 5)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppp"), 4)
+slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_pppv"), 4)
+slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppp"), 3)
+slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_ppv"), 3)
+slowCallPattern (PtrArg: PtrArg: _) = (SLIT("stg_ap_pp"), 2)
+slowCallPattern (PtrArg: VoidArg: _) = (SLIT("stg_ap_pv"), 2)
+slowCallPattern (PtrArg: _) = (SLIT("stg_ap_p"), 1)
+slowCallPattern (VoidArg: _) = (SLIT("stg_ap_v"), 1)
+slowCallPattern (NonPtrArg: _) = (SLIT("stg_ap_n"), 1)
+slowCallPattern (FloatArg: _) = (SLIT("stg_ap_f"), 1)
+slowCallPattern (DoubleArg: _) = (SLIT("stg_ap_d"), 1)
+slowCallPattern (LongArg: _) = (SLIT("stg_ap_l"), 1)
+slowCallPattern _ = panic "CgStackery.slowCallPattern"
+
+-------------------------------------------------------------------------
+--
+-- Return conventions
+--
+-------------------------------------------------------------------------
+
+-- A @CtrlReturnConvention@ says how {\em control} is returned.
+
+data CtrlReturnConvention
+ = VectoredReturn Int -- size of the vector table (family size)
+ | UnvectoredReturn Int -- family size
+
+ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
+ctrlReturnConvAlg tycon
+ = case (tyConFamilySize tycon) of
+ size -> -- we're supposed to know...
+ if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
+ VectoredReturn size
+ else
+ UnvectoredReturn size
+ -- NB: unvectored returns Include size 0 (no constructors), so that
+ -- the following perverse code compiles (it crashed GHC in 5.02)
+ -- data T1
+ -- data T2 = T2 !T1 Int
+ -- The only value of type T1 is bottom, which never returns anyway.
+
+dataReturnConvPrim :: CgRep -> CmmReg
+dataReturnConvPrim PtrArg = CmmGlobal (VanillaReg 1)
+dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1)
+dataReturnConvPrim LongArg = CmmGlobal (LongReg 1)
+dataReturnConvPrim FloatArg = CmmGlobal (FloatReg 1)
+dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
+dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void"
+
+
+-- getSequelAmode returns an amode which refers to an info table. The info
+-- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
+-- not to handle real code pointers, just in case we're compiling for
+-- an unregisterised/untailcallish architecture, where info pointers and
+-- code pointers aren't the same.
+-- DIRE WARNING.
+-- The OnStack case of sequelToAmode delivers an Amode which is only
+-- valid just before the final control transfer, because it assumes
+-- that Sp is pointing to the top word of the return address. This
+-- seems unclean but there you go.
+
+getSequelAmode :: FCode CmmExpr
+getSequelAmode
+ = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
+ ; case sequel of
+ OnStack -> do { sp_rel <- getSpRelOffset virt_sp
+ ; returnFC (CmmLoad sp_rel wordRep) }
+
+ UpdateCode -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel))
+ CaseAlts lbl _ _ True -> returnFC (CmmLit (CmmLabel mkSeqInfoLabel))
+ CaseAlts lbl _ _ False -> returnFC (CmmLit (CmmLabel lbl))
+ }
+
+-------------------------------------------------------------------------
+--
+-- Build a liveness mask for the current stack
+--
+-------------------------------------------------------------------------
+
+-- There are four kinds of things on the stack:
+--
+-- - pointer variables (bound in the environment)
+-- - non-pointer variables (boudn in the environment)
+-- - free slots (recorded in the stack free list)
+-- - non-pointer data slots (recorded in the stack free list)
+--
+-- We build up a bitmap of non-pointer slots by searching the environment
+-- for all the pointer variables, and subtracting these from a bitmap
+-- with initially all bits set (up to the size of the stack frame).
+
+buildContLiveness :: Name -- Basis for label (only)
+ -> [VirtualSpOffset] -- Live stack slots
+ -> FCode Liveness
+buildContLiveness name live_slots
+ = do { stk_usg <- getStkUsage
+ ; let StackUsage { realSp = real_sp,
+ frameSp = frame_sp } = stk_usg
+
+ start_sp :: VirtualSpOffset
+ start_sp = real_sp - retAddrSizeW
+ -- In a continuation, we want a liveness mask that
+ -- starts from just after the return address, which is
+ -- on the stack at real_sp.
+
+ frame_size :: WordOff
+ frame_size = start_sp - frame_sp
+ -- real_sp points to the frame-header for the current
+ -- stack frame, and the end of this frame is frame_sp.
+ -- The size is therefore real_sp - frame_sp - retAddrSizeW
+ -- (subtract one for the frame-header = return address).
+
+ rel_slots :: [WordOff]
+ rel_slots = sortLt (<)
+ [ start_sp - ofs -- Get slots relative to top of frame
+ | ofs <- live_slots ]
+
+ bitmap = intsToReverseBitmap frame_size rel_slots
+
+ ; WARN( not (all (>=0) rel_slots),
+ ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
+ mkLiveness name frame_size bitmap }
+
+
+-------------------------------------------------------------------------
+--
+-- Register assignment
+--
+-------------------------------------------------------------------------
+
+-- How to assign registers for
+--
+-- 1) Calling a fast entry point.
+-- 2) Returning an unboxed tuple.
+-- 3) Invoking an out-of-line PrimOp.
+--
+-- Registers are assigned in order.
+--
+-- If we run out, we don't attempt to assign any further registers (even
+-- though we might have run out of only one kind of register); we just
+-- return immediately with the left-overs specified.
+--
+-- The alternative version @assignAllRegs@ uses the complete set of
+-- registers, including those that aren't mapped to real machine
+-- registers. This is used for calling special RTS functions and PrimOps
+-- which expect their arguments to always be in the same registers.
+
+assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
+ :: [(CgRep,a)] -- Arg or result values to assign
+ -> ([(a, GlobalReg)], -- Register assignment in same order
+ -- for *initial segment of* input list
+ -- (but reversed; doesn't matter)
+ -- VoidRep args do not appear here
+ [(CgRep,a)]) -- Leftover arg or result values
+
+assignCallRegs args
+ = assign_regs args (mkRegTbl [node])
+ -- The entry convention for a function closure
+ -- never uses Node for argument passing; instead
+ -- Node points to the function closure itself
+
+assignPrimOpCallRegs args
+ = assign_regs args (mkRegTbl_allRegs [])
+ -- For primops, *all* arguments must be passed in registers
+
+assignReturnRegs args
+ = assign_regs args (mkRegTbl [])
+ -- For returning unboxed tuples etc,
+ -- we use all regs
+
+assign_regs :: [(CgRep,a)] -- Arg or result values to assign
+ -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs
+ -> ([(a, GlobalReg)], [(CgRep, a)])
+assign_regs args supply
+ = go args [] supply
+ where
+ go [] acc supply = (acc, []) -- Return the results reversed (doesn't matter)
+ go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and
+ = go args acc supply -- there's nothign to bind them to
+ go ((rep,arg) : args) acc supply
+ = case assign_reg rep supply of
+ Just (reg, supply') -> go args ((arg,reg):acc) supply'
+ Nothing -> (acc, (rep,arg):args) -- No more regs
+
+assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
+assign_reg FloatArg (vs, f:fs, ds, ls) = Just (FloatReg f, (vs, fs, ds, ls))
+assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d, (vs, fs, ds, ls))
+assign_reg LongArg (vs, fs, ds, l:ls) = Just (LongReg l, (vs, fs, ds, ls))
+assign_reg PtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
+assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
+ -- PtrArg and NonPtrArg both go in a vanilla register
+assign_reg other not_enough_regs = Nothing
+
+
+-------------------------------------------------------------------------
+--
+-- Register supplies
+--
+-------------------------------------------------------------------------
+
+-- Vanilla registers can contain pointers, Ints, Chars.
+-- Floats and doubles have separate register supplies.
+--
+-- We take these register supplies from the *real* registers, i.e. those
+-- that are guaranteed to map to machine registers.
+
+useVanillaRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Vanilla_REG
+useFloatRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Float_REG
+useDoubleRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Double_REG
+useLongRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Long_REG
+
+vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
+vanillaRegNos = regList useVanillaRegs
+floatRegNos = regList useFloatRegs
+doubleRegNos = regList useDoubleRegs
+longRegNos = regList useLongRegs
+
+allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
+allVanillaRegNos = regList mAX_Vanilla_REG
+allFloatRegNos = regList mAX_Float_REG
+allDoubleRegNos = regList mAX_Double_REG
+allLongRegNos = regList mAX_Long_REG
+
+regList 0 = []
+regList n = [1 .. n]
+
+type AvailRegs = ( [Int] -- available vanilla regs.
+ , [Int] -- floats
+ , [Int] -- doubles
+ , [Int] -- longs (int64 and word64)
+ )
+
+mkRegTbl :: [GlobalReg] -> AvailRegs
+mkRegTbl regs_in_use
+ = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
+
+mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
+mkRegTbl_allRegs regs_in_use
+ = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
+
+mkRegTbl' regs_in_use vanillas floats doubles longs
+ = (ok_vanilla, ok_float, ok_double, ok_long)
+ where
+ ok_vanilla = mapCatMaybes (select VanillaReg) vanillas
+ ok_float = mapCatMaybes (select FloatReg) floats
+ ok_double = mapCatMaybes (select DoubleReg) doubles
+ ok_long = mapCatMaybes (select LongReg) longs
+ -- rep isn't looked at, hence we can use any old rep.
+
+ select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
+ -- one we've unboxed the Int, we make a GlobalReg
+ -- and see if it is already in use; if not, return its number.
+
+ select mk_reg_fun cand
+ = let
+ reg = mk_reg_fun cand
+ in
+ if reg `not_elem` regs_in_use
+ then Just cand
+ else Nothing
+ where
+ not_elem = isn'tIn "mkRegTbl"
+
+
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.68 2004/08/10 09:02:38 simonmar Exp $
+% $Id: CgCase.lhs,v 1.69 2004/08/13 13:05:51 simonmar Exp $
%
%********************************************************
%* *
\begin{code}
module CgCase ( cgCase, saveVolatileVarsAndRegs,
- mkRetDirectTarget, restoreCurrentCostCentre
+ restoreCurrentCostCentre
) where
#include "HsVersions.h"
import CgMonad
import StgSyn
-import AbsCSyn
-
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- getAmodeRep, shimFCallArg )
-import CgBindery ( getVolatileRegs, getArgAmodes,
+import CgBindery ( getArgAmodes,
bindNewToReg, bindNewToTemp,
- getCAddrModeAndInfo,
- rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
- buildContLivenessMask, nukeDeadBindings,
+ getCgIdInfo, getArgAmode,
+ rebindToStack, getCAddrModeIfVolatile,
+ nukeDeadBindings, idInfoToAmode
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
import CgHeapery ( altHeapCheck, unbxTupleHeapCheck )
-import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
+import CgCallConv ( dataReturnConvPrim, ctrlReturnConvAlg,
CtrlReturnConvention(..)
)
-import CgStackery ( allocPrimStack, allocStackTop,
- deAllocStackTop, freeStackSlots, dataStackSlots
+import CgStackery ( allocPrimStack, allocStackTop, getSpRelOffset,
+ deAllocStackTop, freeStackSlots
)
import CgTailCall ( performTailCall )
-import CgUsages ( getSpRelOffset )
-import CLabel ( mkVecTblLabel, mkClosureTblLabel,
- mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
- )
+import CgPrimOp ( cgPrimOp )
+import CgForeignCall ( cgForeignCall )
+import CgUtils ( newTemp, cgLit, emitLitSwitch, emitSwitch,
+ tagToClosure )
+import CgProf ( curCCS, curCCSAddr )
+import CgInfoTbls ( emitDirectReturnTarget, emitAlgReturnTarget,
+ dataConTagZ )
+import SMRep ( CgRep(..), retAddrSizeW, nonVoidArg, isVoidArg,
+ idCgRep, tyConCgRep, typeHint )
+import CmmUtils ( CmmStmts, noStmts, oneStmt, plusStmts )
+import Cmm
+import MachOp ( wordRep )
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn )
-import Id ( Id, idName, isDeadBinder )
-import DataCon ( dataConTag, fIRST_TAG, ConTag )
+import Id ( Id, idName, isDeadBinder, idType )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), playSafe )
import VarSet ( varSetElems )
import CoreSyn ( AltCon(..) )
-import PrimOp ( primOpOutOfLine, PrimOp(..) )
-import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
- )
-import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep )
-import Unique ( Unique, Uniquable(..), newTagUnique )
-import ForeignCall
-import Util ( only )
-import List ( sortBy )
+import PrimOp ( PrimOp(..), primOpOutOfLine )
+import TyCon ( isEnumerationTyCon, tyConFamilySize )
+import Util ( isSingleton )
import Outputable
\end{code}
\begin{code}
cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
- alt_type@(PrimAlt tycon) alts
- = bindNewToTemp bndr `thenFC` \ tmp_amode ->
- absC (CAssign tmp_amode (CLit lit)) `thenC`
- cgPrimAlts NoGC tmp_amode alts alt_type
+ alt_type@(PrimAlt tycon) alts
+ = do { tmp_reg <- bindNewToTemp bndr
+ ; cm_lit <- cgLit lit
+ ; stmtC (CmmAssign tmp_reg (CmmLit cm_lit))
+ ; cgPrimAlts NoGC alt_type tmp_reg alts }
\end{code}
Special case #2: scrutinising a primitive-typed variable. No
\begin{code}
cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
alt_type@(PrimAlt tycon) alts
-
- = -- Careful! we can't just bind the default binder to the same thing
- -- as the scrutinee, since it might be a stack location, and having
- -- two bindings pointing at the same stack locn doesn't work (it
- -- confuses nukeDeadBindings). Hence, use a new temp.
- getCAddrMode v `thenFC` \ amode ->
- bindNewToTemp bndr `thenFC` \ tmp_amode ->
- absC (CAssign tmp_amode amode) `thenC`
- cgPrimAlts NoGC tmp_amode alts alt_type
+ = do { -- Careful! we can't just bind the default binder to the same thing
+ -- as the scrutinee, since it might be a stack location, and having
+ -- two bindings pointing at the same stack locn doesn't work (it
+ -- confuses nukeDeadBindings). Hence, use a new temp.
+ v_info <- getCgIdInfo v
+ ; amode <- idInfoToAmode v_info
+ ; tmp_reg <- bindNewToTemp bndr
+ ; stmtC (CmmAssign tmp_reg amode)
+ ; cgPrimAlts NoGC alt_type tmp_reg alts }
\end{code}
Special case #3: inline PrimOps and foreign calls.
\begin{code}
cgCase (StgOpApp op args _)
live_in_whole_case live_in_alts bndr srt alt_type alts
- | inline_primop
- = -- Get amodes for the arguments and results
- getArgAmodes args `thenFC` \ arg_amodes1 ->
- let
- arg_amodes
- | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
- | otherwise = arg_amodes1
- in
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-
- case alt_type of
- PrimAlt tycon -- PRIMITIVE ALTS
- -> bindNewToTemp bndr `thenFC` \ tmp_amode ->
- absC (COpStmt [tmp_amode] op arg_amodes vol_regs) `thenC`
- -- Note: no liveness arg
- cgPrimAlts NoGC tmp_amode alts alt_type
-
- UbxTupAlt tycon -- UNBOXED TUPLE ALTS
- -> -- No heap check, no yield, just get in there and do it.
- -- NB: the case binder isn't bound to anything;
- -- it has a unboxed tuple type
- mapFCs bindNewToTemp res_ids `thenFC` \ res_tmps ->
- absC (COpStmt res_tmps op arg_amodes vol_regs) `thenC`
- cgExpr rhs
- where
- [(_, res_ids, _, rhs)] = alts
-
- AlgAlt tycon -- ENUMERATION TYPE RETURN
- | StgPrimOp primop <- op
- -> ASSERT( isEnumerationTyCon tycon )
- let
- do_enum_primop :: PrimOp -> FCode CAddrMode -- Returns amode for result
- do_enum_primop TagToEnumOp -- No code!
- = returnFC (only arg_amodes)
-
- do_enum_primop primop
- = absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
- returnFC tag_amode
- where
- tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
- -- Being a bit short of uniques for temporary
- -- variables here, we use newTagUnique to
- -- generate a new unique from the case binder.
- -- The case binder's unique will presumably
- -- have the 'c' tag (generated by CoreToStg),
- -- so we just change its tag to 'C' (for
- -- 'case') to ensure it doesn't clash with
- -- anything else. We can't use the unique
- -- from the case binder, becaus e this is used
- -- to hold the actual result closure (via the
- -- call to bindNewToTemp)
- in
- do_enum_primop primop `thenFC` \ tag_amode ->
-
- -- Bind the default binder if necessary
- -- (avoiding it avoids the assignment)
- -- The deadness info is set by StgVarInfo
- (if (isDeadBinder bndr)
- then nopC
- else bindNewToTemp bndr `thenFC` \ tmp_amode ->
- absC (CAssign tmp_amode (tagToClosure tycon tag_amode))
- ) `thenC`
-
- -- Compile the alts
- cgAlgAlts NoGC (getUnique bndr)
- Nothing{-cc_slot-} False{-no semi-tagging-}
- (AlgAlt tycon) alts `thenFC` \ tagged_alts ->
-
- -- Do the switch
- absC (mkAlgAltsCSwitch tag_amode tagged_alts)
-
- other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
- where
- inline_primop = case op of
- StgPrimOp primop -> not (primOpOutOfLine primop)
- --StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True
- -- unsafe foreign calls are "inline"
- _otherwise -> False
-
+ | not (primOpOutOfLine primop)
+ = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
\end{code}
TODO: Case-of-case of primop can probably be done inline too (but
ghc/lib/misc/PackedString.lhs for examples where this crops up (with
4.02).
+Special case #4: inline foreign calls: an unsafe foreign call can be done
+right here, just like an inline primop.
+
+\begin{code}
+cgCase (StgOpApp op@(StgFCallOp fcall _) args _)
+ live_in_whole_case live_in_alts bndr srt alt_type alts
+ | unsafe_foreign_call
+ = ASSERT( isSingleton alts )
+ do -- *must* be an unboxed tuple alt.
+ -- exactly like the cgInlinePrimOp case for unboxed tuple alts..
+ { res_tmps <- mapFCs bindNewToTemp non_void_res_ids
+ ; let res_hints = map (typeHint.idType) non_void_res_ids
+ ; cgForeignCall (zip res_tmps res_hints) fcall args live_in_alts
+ ; cgExpr rhs }
+ where
+ (_, res_ids, _, rhs) = head alts
+ non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
+
+ unsafe_foreign_call
+ = case fcall of
+ CCall (CCallSpec _ _ s) -> not (playSafe s)
+ _other -> False
+\end{code}
+
Special case: scrutinising a non-primitive variable.
This can be done a little better than the general case, because
we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
cgCase (StgApp fun args)
live_in_whole_case live_in_alts bndr srt alt_type alts
- = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
- getArgAmodes args `thenFC` \ arg_amodes ->
+ = do { fun_info <- getCgIdInfo fun
+ ; arg_amodes <- getArgAmodes args
-- Nuking dead bindings *before* calculating the saves is the
-- value-add here. We might end up freeing up some slots currently
-- NOTE: we need to look up the variables used in the call before
-- doing this, because some of them may not be in the environment
-- afterward.
- nukeDeadBindings live_in_alts `thenC`
- saveVolatileVarsAndRegs live_in_alts
- `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
-
- forkEval alts_eob_info
- ( allocStackTop retPrimRepSize
- `thenFC` \_ -> nopC )
- ( deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alt_type alts )
- `thenFC` \ scrut_eob_info ->
-
- setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
- performTailCall fun' fun_amode lf_info arg_amodes save_assts
+ ; nukeDeadBindings live_in_alts
+ ; (save_assts, alts_eob_info, maybe_cc_slot)
+ <- saveVolatileVarsAndRegs live_in_alts
+
+ ; scrut_eob_info
+ <- forkEval alts_eob_info
+ (allocStackTop retAddrSizeW >> nopC)
+ (do { deAllocStackTop retAddrSizeW
+ ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+
+ ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)
+ (performTailCall fun_info arg_amodes save_assts) }
\end{code}
Note about return addresses: we *always* push a return address, even
\begin{code}
cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
- = -- Figure out what volatile variables to save
- nukeDeadBindings live_in_whole_case `thenC`
+ = do { -- Figure out what volatile variables to save
+ nukeDeadBindings live_in_whole_case
- saveVolatileVarsAndRegs live_in_alts
- `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
-
- -- Save those variables right now!
- absC save_assts `thenC`
-
- -- generate code for the alts
- forkEval alts_eob_info
- (nukeDeadBindings live_in_alts `thenC`
- allocStackTop retPrimRepSize -- space for retn address
- `thenFC` \_ -> nopC
- )
- (deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info ->
-
- setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
- cgExpr expr
+ ; (save_assts, alts_eob_info, maybe_cc_slot)
+ <- saveVolatileVarsAndRegs live_in_alts
+
+ -- Save those variables right now!
+ ; emitStmts save_assts
+
+ -- generate code for the alts
+ ; scrut_eob_info
+ <- forkEval alts_eob_info
+ (do { nukeDeadBindings live_in_alts
+ ; allocStackTop retAddrSizeW -- space for retn address
+ ; nopC })
+ (do { deAllocStackTop retAddrSizeW
+ ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+
+ ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)
+ (cgExpr expr)
+ }
\end{code}
There's a lot of machinery going on behind the scenes to manage the
TODO!! Problem: however, we have to save the current cost centre
stack somewhere, because at the eval point the current CCS might be
-different. So we pick a free stack slot and save CCCS in it. The
-problem with this is that this slot isn't recorded as free/unboxed in
-the environment, so a case expression in the scrutinee will have the
-wrong bitmap attached. Fortunately we don't ever seem to see
-case-of-case at the back end. One solution might be to shift the
-saved CCS to the correct place in the activation record just before
-the jump.
- --SDM
-
-(one consequence of the above is that activation records on the stack
-don't follow the layout of closures when we're profiling. The CCS
-could be anywhere within the record).
+different. So we pick a free stack slot and save CCCS in it. One
+consequence of this is that activation records on the stack don't
+follow the layout of closures when we're profiling. The CCS could be
+anywhere within the record).
\begin{code}
-maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
- = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
+maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff bndr _))
+ = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True)
maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\end{code}
+
+%************************************************************************
+%* *
+ Inline primops
+%* *
+%************************************************************************
+
+\begin{code}
+cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
+ | isVoidArg (idCgRep bndr)
+ = ASSERT( con == DEFAULT && isSingleton alts && null bs )
+ do { -- VOID RESULT; just sequencing,
+ -- so get in there and do it
+ cgPrimOp [] primop args live_in_alts
+ ; cgExpr rhs }
+ where
+ (con,bs,_,rhs) = head alts
+
+cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
+ = do { -- PRIMITIVE ALTS, with non-void result
+ tmp_reg <- bindNewToTemp bndr
+ ; cgPrimOp [tmp_reg] primop args live_in_alts
+ ; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts }
+
+cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts
+ = ASSERT( isSingleton alts )
+ do { -- UNBOXED TUPLE ALTS
+ -- No heap check, no yield, just get in there and do it.
+ -- NB: the case binder isn't bound to anything;
+ -- it has a unboxed tuple type
+
+ res_tmps <- mapFCs bindNewToTemp non_void_res_ids
+ ; cgPrimOp res_tmps primop args live_in_alts
+ ; cgExpr rhs }
+ where
+ (_, res_ids, _, rhs) = head alts
+ non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
+
+cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
+ = do { -- ENUMERATION TYPE RETURN
+ -- Typical: case a ># b of { True -> ..; False -> .. }
+ -- The primop itself returns an index into the table of
+ -- closures for the enumeration type.
+ tag_amode <- ASSERT( isEnumerationTyCon tycon )
+ do_enum_primop primop
+
+ -- Bind the default binder if necessary
+ -- (avoiding it avoids the assignment)
+ -- The deadness info is set by StgVarInfo
+ ; whenC (not (isDeadBinder bndr))
+ (do { tmp_reg <- bindNewToTemp bndr
+ ; stmtC (CmmAssign tmp_reg (tagToClosure tycon tag_amode)) })
+
+ -- Compile the alts
+ ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
+ (AlgAlt tycon) alts
+
+ -- Do the switch
+ ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1)
+ }
+ where
+
+ do_enum_primop :: PrimOp -> FCode CmmExpr -- Returns amode for result
+ do_enum_primop TagToEnumOp -- No code!
+ | [arg] <- args = do
+ (_,e) <- getArgAmode arg
+ return e
+ do_enum_primop primop
+ = do tmp <- newTemp wordRep
+ cgPrimOp [tmp] primop args live_in_alts
+ returnFC (CmmReg tmp)
+
+cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
+ = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
+\end{code}
+
%************************************************************************
%* *
\subsection[CgCase-alts]{Alternatives}
-- to be a label so that we can duplicate it
-- without risk of duplicating code
+cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
+ = do { let rep = tyConCgRep tycon
+ reg = dataReturnConvPrim rep -- Bottom for voidRep
+
+ ; abs_c <- forkProc $ do
+ { -- Bind the case binder, except if it's void
+ -- (reg is bottom in that case)
+ whenC (nonVoidArg rep) $
+ bindNewToReg bndr reg (mkLFArgument bndr)
+ ; restoreCurrentCostCentre cc_slot True
+ ; cgPrimAlts GCMayHappen alt_type reg alts }
+
+ ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt
+ ; returnFC (CaseAlts lbl Nothing bndr False) }
+
cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
= -- Unboxed tuple case
-- By now, the simplifier should have have turned it
-- case e of DEFAULT -> e
ASSERT2( case con of { DataAlt _ -> True; other -> False },
text "cgEvalAlts: dodgy case of unboxed tuple type" )
-
- forkAbsC ( -- forkAbsC for the RHS, so that the envt is
- -- not changed for the mkRetDirect call
- bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) ->
- -- restore the CC *after* binding the tuple components, so that we
- -- get the stack offset of the saved CC right.
- restoreCurrentCostCentre cc_slot True `thenC`
- -- Generate a heap check if necessary
- unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop (
- -- And finally the code for the alternative
- cgExpr rhs
- )) `thenFC` \ abs_c ->
- mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
- returnFC (CaseAlts lbl Nothing False)
-
-cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
- = forkAbsC ( -- forkAbsC for the RHS, so that the envt is
- -- not changed for the mkRetDirect call
- restoreCurrentCostCentre cc_slot True `thenC`
- bindNewToReg bndr reg (mkLFArgument bndr) `thenC`
- cgPrimAlts GCMayHappen (CReg reg) alts alt_type
- ) `thenFC` \ abs_c ->
- mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
- returnFC (CaseAlts lbl Nothing False)
- where
- reg = dataReturnConvPrim kind
- kind = tyConPrimRep tycon
+ do { -- forkAbsC for the RHS, so that the envt is
+ -- not changed for the emitDirectReturn call
+ abs_c <- forkProc $ do
+ { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args
+ -- Restore the CC *after* binding the tuple components,
+ -- so that we get the stack offset of the saved CC right.
+ ; restoreCurrentCostCentre cc_slot True
+ -- Generate a heap check if necessary
+ -- and finally the code for the alternative
+ ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts
+ (cgExpr rhs) }
+ ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt
+ ; returnFC (CaseAlts lbl Nothing bndr False) }
cgEvalAlts cc_slot bndr srt alt_type alts
= -- Algebraic and polymorphic case
- -- Bind the default binder
- bindNewToReg bndr node (mkLFArgument bndr) `thenC`
+ do { -- Bind the default binder
+ bindNewToReg bndr nodeReg (mkLFArgument bndr)
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
--
-- which is worse than having the alt code in the switch statement
- let ret_conv = case alt_type of
- AlgAlt tc -> ctrlReturnConvAlg tc
- PolyAlt -> UnvectoredReturn 0
-
- use_labelled_alts = case ret_conv of
- VectoredReturn _ -> True
- _ -> False
-
- semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts
-
- in
- cgAlgAlts GCMayHappen (getUnique bndr)
- cc_slot use_labelled_alts
- alt_type alts `thenFC` \ tagged_alt_absCs ->
+ ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
- mkRetVecTarget bndr tagged_alt_absCs
- srt ret_conv `thenFC` \ return_vec ->
+ ; (lbl, branches) <- emitAlgReturnTarget (idName bndr)
+ alts mb_deflt srt ret_conv
- returnFC (CaseAlts return_vec semi_tagged_stuff False)
+ ; returnFC (CaseAlts lbl branches bndr False) }
+ where
+ ret_conv = case alt_type of
+ AlgAlt tc -> ctrlReturnConvAlg tc
+ PolyAlt -> UnvectoredReturn 0
\end{code}
\begin{code}
cgAlgAlts :: GCFlag
- -> Unique
-> Maybe VirtualSpOffset
- -> Bool -- True <=> branches must be labelled
- -- (used for semi-tagging)
- -> AltType -- ** AlgAlt or PolyAlt only **
- -> [StgAlt] -- The alternatives
- -> FCode [(AltCon, AbstractC)] -- The branches
+ -> AltType -- ** AlgAlt or PolyAlt only **
+ -> [StgAlt] -- The alternatives
+ -> FCode ( [(ConTagZ, CgStmts)], -- The branches
+ Maybe CgStmts ) -- The default case
+
+cgAlgAlts gc_flag cc_slot alt_type alts
+ = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts]
+ let
+ mb_deflt = case alts of -- DEFAULT is always first, if present
+ ((DEFAULT,blks) : _) -> Just blks
+ other -> Nothing
+
+ branches = [(dataConTagZ con, blks)
+ | (DataAlt con, blks) <- alts]
+ -- in
+ return (branches, mb_deflt)
-cgAlgAlts gc_flag uniq restore_cc must_label_branches alt_type alts
- = forkAlts [ cgAlgAlt gc_flag uniq restore_cc must_label_branches alt_type alt
- | alt <- alts]
cgAlgAlt :: GCFlag
- -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
- -> AltType -- ** AlgAlt or PolyAlt only **
+ -> Maybe VirtualSpOffset -- Turgid state
+ -> AltType -- ** AlgAlt or PolyAlt only **
-> StgAlt
- -> FCode (AltCon, AbstractC)
-
-cgAlgAlt gc_flag uniq cc_slot must_label_branch
- alt_type (con, args, use_mask, rhs)
- = getAbsC (bind_con_args con args `thenFC` \ _ ->
- restoreCurrentCostCentre cc_slot True `thenC`
- maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)
- ) `thenFC` \ abs_c ->
- let
- final_abs_c | must_label_branch = CCodeBlock lbl abs_c
- | otherwise = abs_c
- in
- returnFC (con, final_abs_c)
+ -> FCode (AltCon, CgStmts)
+
+cgAlgAlt gc_flag cc_slot alt_type (con, args, use_mask, rhs)
+ = do { abs_c <- getCgStmts $ do
+ { bind_con_args con args
+ ; restoreCurrentCostCentre cc_slot True
+ ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) }
+ ; return (con, abs_c) }
where
- lbl = case con of
- DataAlt dc -> mkAltLabel uniq (dataConTag dc)
- DEFAULT -> mkDefaultLabel uniq
- other -> pprPanic "cgAlgAlt" (ppr con)
-
bind_con_args DEFAULT args = nopC
bind_con_args (DataAlt dc) args = bindConArgs dc args
\end{code}
-%************************************************************************
-%* *
-\subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
-%* *
-%************************************************************************
-
-Turgid-but-non-monadic code to conjure up the required info from
-algebraic case alternatives for semi-tagging.
-
-\begin{code}
-cgSemiTaggedAlts :: Bool -- True <=> use semitagging: each alt will be labelled
- -> Id
- -> [StgAlt]
- -> SemiTaggingStuff
-
-cgSemiTaggedAlts False binder alts
- = Nothing
-cgSemiTaggedAlts True binder alts
- = Just ([st_alt con args | (DataAlt con, args, _, _) <- alts],
- case head alts of
- (DEFAULT, _, _, _) -> Just st_deflt
- other -> Nothing)
- where
- uniq = getUnique binder
-
- st_deflt = (binder,
- (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
- mkDefaultLabel uniq))
-
- st_alt con args -- Ha! Nothing to do; Node already points to the thing
- = (con_tag,
- (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
- [mkIntCLit (length args)], -- how big the thing in the heap is
- join_label)
- )
- where
- con_tag = dataConTag con
- join_label = mkAltLabel uniq con_tag
-
-
-tagToClosure :: TyCon -> CAddrMode -> CAddrMode
--- Primops returning an enumeration type (notably Bool)
--- actually return an index into
--- the table of closures for the enumeration type
-tagToClosure tycon tag_amode
- = CVal (CIndex closure_tbl tag_amode PtrRep) PtrRep
- where
- closure_tbl = CLbl (mkClosureTblLabel tycon) PtrRep
-\end{code}
%************************************************************************
%* *
\begin{code}
cgPrimAlts :: GCFlag
- -> CAddrMode -- Scrutinee
+ -> AltType -- Always PrimAlt, but passed to maybeAltHeapCheck
+ -> CmmReg -- Scrutinee
-> [StgAlt] -- Alternatives
- -> AltType
-> Code
+-- NB: cgPrimAlts emits code that does the case analysis.
+-- It's often used in inline situations, rather than to genearte
+-- a labelled return point. That's why its interface is a little
+-- different to cgAlgAlts
+--
-- INVARIANT: the default binder is already bound
-cgPrimAlts gc_flag scrutinee alts alt_type
- = forkAlts (map (cgPrimAlt gc_flag alt_type) alts) `thenFC` \ tagged_absCs ->
- let
- ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default
- alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
- in
- absC (CSwitch scrutinee alt_absCs deflt_absC)
- -- CSwitch does sensible things with one or zero alternatives
+cgPrimAlts gc_flag alt_type scrutinee alts
+ = do { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts)
+ ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default
+ alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
+ ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC }
cgPrimAlt :: GCFlag
-> AltType
- -> StgAlt -- The alternative
- -> FCode (AltCon, AbstractC) -- Its compiled form
+ -> StgAlt -- The alternative
+ -> FCode (AltCon, CgStmts) -- Its compiled form
cgPrimAlt gc_flag alt_type (con, [], [], rhs)
= ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } )
- getAbsC (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) `thenFC` \ abs_c ->
- returnFC (con, abs_c)
+ do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs))
+ ; returnFC (con, abs_c) }
\end{code}
-> Code -- Continuation
-> Code
maybeAltHeapCheck NoGC _ code = code
-maybeAltHeapCheck GCMayHappen alt_type code
- = -- HWL: maybe need yield here
- -- yield [node] True -- XXX live regs wrong
- altHeapCheck alt_type code
+maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code
saveVolatileVarsAndRegs
:: StgLiveVars -- Vars which should be made safe
- -> FCode (AbstractC, -- Assignments to do the saves
+ -> FCode (CmmStmts, -- Assignments to do the saves
EndOfBlockInfo, -- sequel for the alts
Maybe VirtualSpOffset) -- Slot for current cost centre
saveVolatileVarsAndRegs vars
- = saveVolatileVars vars `thenFC` \ var_saves ->
- saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
- getEndOfBlockInfo `thenFC` \ eob_info ->
- returnFC (mkAbstractCs [var_saves, cc_save],
- eob_info,
- maybe_cc_slot)
+ = do { var_saves <- saveVolatileVars vars
+ ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre
+ ; eob_info <- getEndOfBlockInfo
+ ; returnFC (var_saves `plusStmts` cc_save,
+ eob_info,
+ maybe_cc_slot) }
saveVolatileVars :: StgLiveVars -- Vars which should be made safe
- -> FCode AbstractC -- Assignments to to the saves
+ -> FCode CmmStmts -- Assignments to to the saves
saveVolatileVars vars
- = save_em (varSetElems vars)
+ = do { stmts_s <- mapFCs save_it (varSetElems vars)
+ ; return (foldr plusStmts noStmts stmts_s) }
where
- save_em [] = returnFC AbsCNop
-
- save_em (var:vars)
- = getCAddrModeIfVolatile var `thenFC` \ v ->
- case v of
- Nothing -> save_em vars -- Non-volatile, so carry on
-
-
- Just vol_amode -> -- Aha! It's volatile
- save_var var vol_amode `thenFC` \ abs_c ->
- save_em vars `thenFC` \ abs_cs ->
- returnFC (abs_c `mkAbsCStmts` abs_cs)
+ save_it var
+ = do { v <- getCAddrModeIfVolatile var
+ ; case v of
+ Nothing -> return noStmts -- Non-volatile
+ Just vol_amode -> save_var var vol_amode -- Aha! It's volatile
+ }
save_var var vol_amode
- = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
- rebindToStack var slot `thenC`
- getSpRelOffset slot `thenFC` \ sp_rel ->
- returnFC (CAssign (CVal sp_rel kind) vol_amode)
- where
- kind = getAmodeRep vol_amode
+ = do { slot <- allocPrimStack (idCgRep var)
+ ; rebindToStack var slot
+ ; sp_rel <- getSpRelOffset slot
+ ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) }
\end{code}
---------------------------------------------------------------------------
\begin{code}
saveCurrentCostCentre ::
FCode (Maybe VirtualSpOffset, -- Where we decide to store it
- AbstractC) -- Assignment to save it
+ CmmStmts) -- Assignment to save it
saveCurrentCostCentre
- = if not opt_SccProfilingOn then
- returnFC (Nothing, AbsCNop)
- else
- allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
- dataStackSlots [slot] `thenC`
- getSpRelOffset slot `thenFC` \ sp_rel ->
- returnFC (Just slot,
- CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
+ | not opt_SccProfilingOn
+ = returnFC (Nothing, noStmts)
+ | otherwise
+ = do { slot <- allocPrimStack PtrArg
+ ; sp_rel <- getSpRelOffset slot
+ ; returnFC (Just slot,
+ oneStmt (CmmStore sp_rel curCCS)) }
-- Sometimes we don't free the slot containing the cost centre after restoring it
-- (see CgLetNoEscape.cgLetNoEscapeBody).
restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code
restoreCurrentCostCentre Nothing _freeit = nopC
restoreCurrentCostCentre (Just slot) freeit
- = getSpRelOffset slot `thenFC` \ sp_rel ->
- (if freeit then freeStackSlots [slot] else nopC) `thenC`
- absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
- -- we use the RESTORE_CCCS macro, rather than just
- -- assigning into CurCostCentre, in case RESTORE_CCCS
- -- has some sanity-checking in it.
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgCase-return-vec]{Building a return vector}
-%* *
-%************************************************************************
-
-Build a return vector, and return a suitable label addressing
-mode for it.
-
-\begin{code}
-mkRetDirectTarget :: Id -- Used for labelling only
- -> AbstractC -- Return code
- -> SRT -- Live CAFs in return code
- -> FCode CAddrMode -- Emit the labelled return block,
- -- and return its label
-mkRetDirectTarget bndr abs_c srt
- = buildContLivenessMask bndr `thenFC` \ liveness ->
- getSRTInfo name srt `thenFC` \ srt_info ->
- absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
- return lbl
- where
- name = idName bndr
- uniq = getUnique name
- lbl = CLbl (mkReturnInfoLabel uniq) RetRep
+ = do { sp_rel <- getSpRelOffset slot
+ ; whenC freeit (freeStackSlots [slot])
+ ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel wordRep)) }
\end{code}
-\begin{code}
-mkRetVecTarget :: Id -- Just for its unique
- -> [(AltCon, AbstractC)] -- Branch codes
- -> SRT -- Continuation's SRT
- -> CtrlReturnConvention
- -> FCode CAddrMode
-
-mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn 0)
- = ASSERT( null other_alts )
- mkRetDirectTarget bndr deflt_absC srt
- where
- ((DEFAULT, deflt_absC) : other_alts) = tagged_alt_absCs
-
-mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn n)
- = mkRetDirectTarget bndr switch_absC srt
- where
- -- Find the tag explicitly rather than using tag_reg for now.
- -- on architectures with lots of regs the tag will be loaded
- -- into tag_reg by the code doing the returning.
- tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
- switch_absC = mkAlgAltsCSwitch tag tagged_alt_absCs
-
-
-mkRetVecTarget bndr tagged_alt_absCs srt (VectoredReturn table_size)
- = buildContLivenessMask bndr `thenFC` \ liveness ->
- getSRTInfo name srt `thenFC` \ srt_info ->
- let
- ret_vector = CRetVector vtbl_lbl vector_table srt_info liveness
- in
- absC (mkAbstractCs alts_absCs `mkAbsCStmts` ret_vector) `thenC`
- -- Alts come first, because we don't want to declare all the symbols
-
- return (CLbl vtbl_lbl DataPtrRep)
- where
- tags = [fIRST_TAG .. (table_size+fIRST_TAG-1)]
- vector_table = map mk_vector_entry tags
- alts_absCs = map snd (sortBy cmp tagged_alt_absCs)
- -- The sort is unnecessary; just there for now
- -- to make the new order the same as the old
- (DEFAULT,_) `cmp` (DEFAULT,_) = EQ
- (DEFAULT,_) `cmp` _ = GT
- (DataAlt d1,_) `cmp` (DataAlt d2,_) = dataConTag d1 `compare` dataConTag d2
- (DataAlt d1,_) `cmp` (DEFAULT, _) = LT
- -- Others impossible
-
- name = idName bndr
- uniq = getUnique name
- vtbl_lbl = mkVecTblLabel uniq
-
- deflt_lbl :: CAddrMode
- deflt_lbl = case tagged_alt_absCs of
- (DEFAULT, abs_c) : _ -> get_block_label abs_c
- other -> mkIntCLit 0
- -- 'other' case: the simplifier might have eliminated a case
- -- so we may have e.g. case xs of
- -- [] -> e
- -- In that situation the default should never be taken,
- -- so we just use '0' (=> seg fault if used)
-
- mk_vector_entry :: ConTag -> CAddrMode
- mk_vector_entry tag
- = case [ absC | (DataAlt d, absC) <- tagged_alt_absCs, dataConTag d == tag ] of
- -- The comprehension neatly, and correctly, ignores the DEFAULT
- [] -> deflt_lbl
- [abs_c] -> get_block_label abs_c
- _ -> panic "mkReturnVector: too many"
-
- get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep
-\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.63 2004/08/13 13:05:54 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
module CgClosure ( cgTopRhsClosure,
cgStdRhsClosure,
cgRhsClosure,
+ emitBlackHoleCode,
) where
#include "HsVersions.h"
import CgMonad
import CgBindery
-import CgUpdate ( pushUpdateFrame )
import CgHeapery
-import CgStackery
-import CgUsages
+import CgStackery ( mkVirtStkOffsets, pushUpdateFrame, getVirtSp,
+ setRealAndVirtualSp )
+import CgProf ( chooseDynCostCentres, ldvEnter, enterCostCentre,
+ costCentreFrom )
+import CgTicky
+import CgParallel ( granYield, granFetchAndReschedule )
+import CgInfoTbls ( emitClosureCodeAndInfoTable, getSRTInfo )
+import CgCallConv ( assignCallRegs, mkArgDescr )
+import CgUtils ( emitDataLits, addIdReps, cmmRegOffW,
+ emitRtsCallWithVols )
import ClosureInfo -- lots and lots of stuff
-
-import AbsCUtils ( getAmodeRep, mkAbstractCs )
-import AbsCSyn
-import CLabel
-
+import SMRep ( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff,
+ idCgRep )
+import MachOp ( MachHint(..) )
+import Cmm
+import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts,
+ mkLblExpr )
+import CLabel ( mkRtsDataLabel, mkClosureLabel, mkRednCountsLabel,
+ mkSlowEntryLabel, mkIndStaticInfoLabel )
import StgSyn
-import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
+import CmdLineOpts ( opt_DoTickyProfiling )
import CostCentre
-import Id ( Id, idName, idType, idPrimRep )
-import Name ( Name, isInternalName )
+import Id ( Id, idName, idType )
+import Name ( Name )
import Module ( Module, pprModule )
import ListSetOps ( minusList )
-import PrimRep ( PrimRep(..), getPrimRepSize )
-import Util ( isIn, splitAtList )
-import CmdLineOpts ( opt_SccProfilingOn )
+import Util ( isIn, mapAccumL, zipWithEqual )
+import BasicTypes ( TopLevelFlag(..) )
+import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE )
import Outputable
import FastString
-
-import Name ( nameOccName )
-import OccName ( occNameFS )
-
--- Turgid imports for showTypeCategory
-import PrelNames
-import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
-import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
-import Maybe
\end{code}
%********************************************************
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> SRT
+ -> UpdateFlag
-> [Id] -- Args
-> StgExpr
- -> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure id ccs binder_info srt args body lf_info
- =
- let
- name = idName id
- in
- -- LAY OUT THE OBJECT
- getSRTInfo name srt `thenFC` \ srt_info ->
- moduleName `thenFC` \ mod_name ->
- let
- name = idName id
- descr = closureDescription mod_name name
- closure_info = layOutStaticNoFVClosure id lf_info srt_info descr
+cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
+ { -- LAY OUT THE OBJECT
+ let name = idName id
+ ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
+ ; srt_info <- getSRTInfo name srt
+ ; mod_name <- moduleName
+ ; let descr = closureDescription mod_name name
+ closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
- in
-
- -- BUILD THE OBJECT (IF NECESSARY)
- (
- ({- if staticClosureRequired name binder_info lf_info
- then -}
- absC (mkStaticClosure closure_label closure_info ccs [] True)
- {- else
- nopC -}
- )
- `thenC`
-
- -- GENERATE THE INFO TABLE (IF NECESSARY)
- forkClosureBody (closureCodeBody binder_info closure_info
- ccs args body)
+ cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
+ closure_rep = mkStaticClosureFields closure_info ccs True []
- ) `thenC`
-
- returnFC (id, cg_id_info)
+ -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
+ ; emitDataLits closure_label closure_rep
+ ; forkClosureBody (closureCodeBody binder_info closure_info
+ ccs args body)
+ ; returnFC (id, cg_id_info) }
\end{code}
%********************************************************
-> [StgArg] -- payload
-> FCode (Id, CgIdInfo)
-cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
- -- AHA! A STANDARD-FORM THUNK
- = (
- -- LAY OUT THE OBJECT
- getArgAmodes payload `thenFC` \ amodes ->
- moduleName `thenFC` \ mod_name ->
- let
- descr = closureDescription mod_name (idName binder)
-
- (closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
- -- No SRT for a standard-form closure
-
- (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
- in
+cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
+ = do -- AHA! A STANDARD-FORM THUNK
+ { -- LAY OUT THE OBJECT
+ amodes <- getArgAmodes payload
+ ; mod_name <- moduleName
+ ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets amodes
+
+ descr = closureDescription mod_name (idName bndr)
+ closure_info = mkClosureInfo False -- Not static
+ bndr lf_info tot_wds ptr_wds
+ NoC_SRT -- No SRT for a std-form closure
+ descr
+
+ ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
-- BUILD THE OBJECT
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- )
- `thenFC` \ heap_offset ->
+ ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
-- RETURN
- returnFC (binder, heapIdInfo binder heap_offset lf_info)
+ ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
\end{code}
Here's the general case.
-> StgBinderInfo
-> SRT
-> [Id] -- Free vars
+ -> UpdateFlag
-> [Id] -- Args
-> StgExpr
- -> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgRhsClosure binder cc binder_info srt fvs args body lf_info
- = (
- -- LAY OUT THE OBJECT
- --
+cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
+ { -- LAY OUT THE OBJECT
-- If the binder is itself a free variable, then don't store
-- it in the closure. Instead, just bind it to Node on entry.
-- NB we can be sure that Node will point to it, because we
-- stored in the closure itself, so it will make sure that
-- Node points to it...
let
- is_elem = isIn "cgRhsClosure"
-
- binder_is_a_fv = binder `is_elem` fvs
- reduced_fvs = if binder_is_a_fv
- then fvs `minusList` [binder]
- else fvs
-
- name = idName binder
- in
-
- mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
- getSRTInfo name srt `thenFC` \ srt_info ->
- moduleName `thenFC` \ mod_name ->
- let
- descr = closureDescription mod_name (idName binder)
-
- closure_info :: ClosureInfo
- bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
-
- (closure_info, bind_details)
- = layOutDynClosure binder get_kind
- fvs_w_amodes_and_info lf_info srt_info descr
-
- bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
-
- amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
-
- get_kind (id, _, _) = idPrimRep id
- in
+ name = idName bndr
+ is_elem = isIn "cgRhsClosure"
+ bndr_is_a_fv = bndr `is_elem` fvs
+ reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
+ | otherwise = fvs
+
+ ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
+ ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
+ ; srt_info <- getSRTInfo name srt
+ ; mod_name <- moduleName
+ ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
+ (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (map add_rep fv_infos)
+ add_rep info = (cgIdInfoArgRep info, info)
+
+ descr = closureDescription mod_name name
+ closure_info = mkClosureInfo False -- Not static
+ bndr lf_info tot_wds ptr_wds
+ srt_info descr
-- BUILD ITS INFO TABLE AND CODE
- forkClosureBody (
- -- Bind the fvs
- mapCs bind_fv bind_details `thenC`
+ ; forkClosureBody (do
+ { -- Bind the fvs
+ let bind_fv (info, offset)
+ = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
+ ; mapCs bind_fv bind_details
-- Bind the binder itself, if it is a free var
- (if binder_is_a_fv then
- bindNewToReg binder node lf_info
- else
- nopC) `thenC`
-
+ ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
+
-- Compile the body
- closureCodeBody binder_info closure_info cc args body
- ) `thenC`
+ ; closureCodeBody bndr_info closure_info cc args body })
-- BUILD THE OBJECT
- let
- (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
- in
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- ) `thenFC` \ heap_offset ->
+ ; let
+ to_amode (info, offset) = do { amode <- idInfoToAmode info
+ ; return (amode, offset) }
+ ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
+ ; amodes_w_offsets <- mapFCs to_amode bind_details
+ ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
-- RETURN
- returnFC (binder, heapIdInfo binder heap_offset lf_info)
+ ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
+
+
+mkClosureLFInfo :: Id -- The binder
+ -> TopLevelFlag -- True of top level
+ -> [Id] -- Free vars
+ -> UpdateFlag -- Update flag
+ -> [Id] -- Args
+ -> FCode LambdaFormInfo
+mkClosureLFInfo bndr top fvs upd_flag args
+ | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
+ | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
+ ; return (mkLFReEntrant top fvs args arg_descr) }
\end{code}
+
%************************************************************************
%* *
\subsection[code-for-closures]{The code for closures}
There are two main cases for the code for closures. If there are {\em
no arguments}, then the closure is a thunk, and not in normal form.
So it should set up an update frame (if it is shared).
+NB: Thunks cannot have a primitive type!
\begin{code}
-closureCodeBody binder_info closure_info cc [] body
- = -- thunks cannot have a primitive type!
- getAbsC body_code `thenFC` \ body_absC ->
-
- absC (CClosureInfoAndCode closure_info body_absC)
- where
- is_box = case body of { StgApp fun [] -> True; _ -> False }
-
- ticky_ent_lit = if (isStaticClosure closure_info)
- then FSLIT("TICK_ENT_STATIC_THK")
- else FSLIT("TICK_ENT_DYN_THK")
-
- body_code = profCtrC ticky_ent_lit [] `thenC`
- -- node always points when profiling, so this is ok:
- ldvEnter `thenC`
- thunkWrapper closure_info (
- -- We only enter cc after setting up update so
- -- that cc of enclosing scope will be recorded
- -- in update frame CAF/DICT functions will be
- -- subsumed by this enclosing cc
- enterCostCentreCode closure_info cc IsThunk is_box `thenC`
- cgExpr body
- )
-
+closureCodeBody binder_info cl_info cc [] body = do
+ { body_absC <- getCgStmts $ do
+ { tickyEnterThunk cl_info
+ ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling
+ ; thunkWrapper cl_info $ do
+ -- We only enter cc after setting up update so
+ -- that cc of enclosing scope will be recorded
+ -- in update frame CAF/DICT functions will be
+ -- subsumed by this enclosing cc
+ { enterCostCentre cl_info cc body
+ ; cgExpr body }
+ }
+
+ ; emitClosureCodeAndInfoTable cl_info [] body_absC }
\end{code}
If there is /at least one argument/, then this closure is in
Node points to closure is available. -- HWL
\begin{code}
-closureCodeBody binder_info closure_info cc all_args body
- = let arg_reps = map idPrimRep all_args in
-
- getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv ->
-
- let
- -- Arg mapping for the entry point; as many args as poss in
- -- registers; the rest on the stack
- -- arg_regs are the registers used for arg passing
- -- stk_args are the args which are passed on the stack
- --
- -- Args passed on the stack are not tagged.
- --
- arg_regs = case entry_conv of
- DirectEntry lbl arity regs -> regs
- _ -> panic "closureCodeBody"
- in
-
- -- If this function doesn't have a specialised ArgDescr, we need
- -- to generate the function's arg bitmap, slow-entry code, and
- -- register-save code for the heap-check failure
- --
- (case closureFunInfo closure_info of
- Just (_, ArgGen slow_lbl liveness) ->
- absC (maybeLargeBitmap liveness) `thenC`
- absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
- returnFC (mkRegSaveCode arg_regs arg_reps)
-
- other -> returnFC AbsCNop
- )
- `thenFC` \ reg_save_code ->
-
- -- get the current virtual Sp (it might not be zero, eg. if we're
- -- compiling a let-no-escape).
- getVirtSp `thenFC` \vSp ->
-
- let
- (reg_args, stk_args) = splitAtList arg_regs all_args
-
- (sp_stk_args, stk_offsets)
- = mkVirtStkOffsets vSp idPrimRep stk_args
-
- entry_code = do
- mod_name <- moduleName
- profCtrC FSLIT("TICK_CTR") [
- CLbl ticky_ctr_label DataPtrRep,
- mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
- mkIntCLit stg_arity, -- total # of args
- mkIntCLit sp_stk_args, -- # passed on stk
- mkCString (mkFastString (map (showTypeCategory . idType) all_args))
- ]
- let prof =
- profCtrC ticky_ent_lit [
- CLbl ticky_ctr_label DataPtrRep
- ]
-
- -- Bind args to regs/stack as appropriate, and
- -- record expected position of sps.
- bindArgsToRegs reg_args arg_regs
- mapCs bindNewToStack stk_offsets
- setRealAndVirtualSp sp_stk_args
-
- -- Enter the closures cc, if required
- enterCostCentreCode closure_info cc IsFunction False
-
- -- Do the business
- funWrapper closure_info arg_regs reg_save_code
- (prof >> cgExpr body)
- in
-
- setTickyCtrLabel ticky_ctr_label (
-
- forkAbsC entry_code `thenFC` \ entry_abs_c ->
- moduleName `thenFC` \ mod_name ->
-
- -- Now construct the info table
- absC (CClosureInfoAndCode closure_info entry_abs_c)
- )
- where
- ticky_ctr_label = mkRednCountsLabel name
-
- ticky_ent_lit =
- if (isStaticClosure closure_info)
- then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
- else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
-
- stg_arity = length all_args
- lf_info = closureLFInfo closure_info
-
- -- Manufacture labels
- name = closureName closure_info
-
-
--- When printing the name of a thing in a ticky file, we want to
--- give the module name even for *local* things. We print
--- just "x (M)" rather that "M.x" to distinguish them from the global kind.
-ppr_for_ticky_name mod_name name
- | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
- | otherwise = showSDocDebug (ppr name)
+closureCodeBody binder_info cl_info cc args body = do
+ { -- Get the current virtual Sp (it might not be zero,
+ -- eg. if we're compiling a let-no-escape).
+ vSp <- getVirtSp
+ ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
+ (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
+
+ -- Allocate the global ticky counter
+ ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
+ ; emitTickyCounter cl_info args sp_top
+
+ -- ...and establish the ticky-counter
+ -- label for this block
+ ; setTickyCtrLabel ticky_ctr_lbl $ do
+
+ -- Emit the slow-entry code
+ { reg_save_code <- mkSlowEntryCode cl_info reg_args
+
+ -- Emit the main entry code
+ ; blks <- forkProc $
+ mkFunEntryCode cl_info cc reg_args stk_args
+ sp_top reg_save_code body
+ ; emitClosureCodeAndInfoTable cl_info [] blks
+ }}
+
+
+
+mkFunEntryCode :: ClosureInfo
+ -> CostCentreStack
+ -> [(Id,GlobalReg)] -- Args in regs
+ -> [(Id,VirtualSpOffset)] -- Args on stack
+ -> VirtualSpOffset -- Last allocated word on stack
+ -> CmmStmts -- Register-save code in case of GC
+ -> StgExpr
+ -> Code
+-- The main entry code for the closure
+mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
+ { -- Bind args to regs/stack as appropriate,
+ -- and record expected position of sps
+ ; bindArgsToRegs reg_args
+ ; bindArgsToStack stk_args
+ ; setRealAndVirtualSp sp_top
+
+ -- Enter the cost-centre, if required
+ -- ToDo: It's not clear why this is outside the funWrapper,
+ -- but the tickyEnterFun is inside. Perhaps we can put
+ -- them together?
+ ; enterCostCentre cl_info cc body
+
+ -- Do the business
+ ; funWrapper cl_info reg_args reg_save_code $ do
+ { tickyEnterFun cl_info
+ ; cgExpr body }
+ }
\end{code}
The "slow entry" code for a function. This entry point takes its
(b) returning from a heap-check failure
\begin{code}
-mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
-mkSlowEntryCode name lbl regs reps
- = CCodeBlock lbl (
- mkAbstractCs [assts, stk_adj, jump]
- )
+mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
+-- If this function doesn't have a specialised ArgDescr, we need
+-- to generate the function's arg bitmap, slow-entry code, and
+-- register-save code for the heap-check failure
+-- Here, we emit the slow-entry code, and
+-- return the register-save assignments
+mkSlowEntryCode cl_info reg_args
+ | Just (_, ArgGen _) <- closureFunInfo cl_info
+ = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
+ ; return save_stmts }
+ | otherwise = return noStmts
where
- stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
-
- assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
- mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
-
- stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
- stk_final_offset = head (drop (length regs) stk_offsets)
-
- jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
-
-mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
-mkRegSaveCode regs reps
- = mkAbstractCs [stk_adj, assts]
- where
- stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
-
- stk_final_offset = head (drop (length regs) stk_offsets)
- stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
-
- assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
- mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
+ name = closureName cl_info
+ slow_lbl = mkSlowEntryLabel name
+
+ load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
+ save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
+
+ reps_w_regs :: [(CgRep,GlobalReg)]
+ reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
+ (final_stk_offset, stk_offsets)
+ = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
+ 0 reps_w_regs
+
+ load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
+ mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
+ (CmmLoad (cmmRegOffW spReg offset)
+ (argMachRep rep))
+
+ save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
+ mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
+ CmmStore (cmmRegOffW spReg offset)
+ (CmmReg (CmmGlobal reg))
+
+ stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
+ stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
+ jump_to_entry = CmmJump (mkLblExpr (enterIdLabel name)) []
\end{code}
-For lexically scoped profiling we have to load the cost centre from
-the closure entered, if the costs are not supposed to be inherited.
-This is done immediately on entering the fast entry point.
-
-Load current cost centre from closure, if not inherited.
-Node is guaranteed to point to it, if profiling and not inherited.
-
-\begin{code}
-data IsThunk = IsThunk | IsFunction -- Bool-like, local
--- #ifdef DEBUG
- deriving Eq
--- #endif
-
-enterCostCentreCode
- :: ClosureInfo -> CostCentreStack
- -> IsThunk
- -> Bool -- is_box: this closure is a special box introduced by SCCfinal
- -> Code
-
-enterCostCentreCode closure_info ccs is_thunk is_box
- = if not opt_SccProfilingOn then
- nopC
- else
- ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
-
- if isSubsumedCCS ccs then
- ASSERT(isToplevClosure closure_info)
- ASSERT(is_thunk == IsFunction)
- costCentresC FSLIT("ENTER_CCS_FSUB") []
-
- else if isDerivedFromCurrentCCS ccs then
- if re_entrant && not is_box
- then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
- else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
-
- else if isCafCCS ccs then
- ASSERT(isToplevClosure closure_info)
- ASSERT(is_thunk == IsThunk)
- -- might be a PAP, in which case we want to subsume costs
- if re_entrant
- then costCentresC FSLIT("ENTER_CCS_FSUB") []
- else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
-
- else panic "enterCostCentreCode"
-
- where
- c_ccs = [mkCCostCentreStack ccs]
- re_entrant = closureReEntrant closure_info
-\end{code}
%************************************************************************
%* *
\begin{code}
thunkWrapper:: ClosureInfo -> Code -> Code
-thunkWrapper closure_info thunk_code
- = -- Stack and heap overflow checks
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
+thunkWrapper closure_info thunk_code = do
+ { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
-- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-- (we prefer fetchAndReschedule-style context switches to yield ones)
- (if opt_GranMacros
- then if node_points
- then fetchAndReschedule [] node_points
- else yield [] node_points
- else absC AbsCNop) `thenC`
-
- let closure_lbl
- | node_points = Nothing
- | otherwise = Just (closureLabelFromCI closure_info)
- in
-
- -- stack and/or heap checks
- thunkChecks closure_lbl (
-
- -- Overwrite with black hole if necessary
- blackHoleIt closure_info node_points `thenC`
-
- setupUpdate closure_info ( -- setupUpdate *encloses* the rest
-
- -- Finally, do the business
- thunk_code
- ))
+ ; if node_points
+ then granFetchAndReschedule [] node_points
+ else granYield [] node_points
+
+ -- Stack and/or heap checks
+ ; thunkEntryChecks closure_info $ do
+ { -- Overwrite with black hole if necessary
+ whenC (blackHoleOnEntry closure_info && node_points)
+ (blackHoleIt closure_info)
+ ; setupUpdate closure_info thunk_code }
+ -- setupUpdate *encloses* the thunk_code
+ }
funWrapper :: ClosureInfo -- Closure whose code body this is
- -> [MagicId] -- List of argument registers (if any)
- -> AbstractC -- reg saves for the heap check failure
+ -> [(Id,GlobalReg)] -- List of argument registers (if any)
+ -> CmmStmts -- reg saves for the heap check failure
-> Code -- Body of function being compiled
-> Code
-funWrapper closure_info arg_regs reg_save_code fun_body
- = -- Stack overflow check
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-
- -- enter for Ldv profiling
- (if node_points then ldvEnter else nopC) `thenC`
+funWrapper closure_info arg_regs reg_save_code fun_body = do
+ { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
- (if opt_GranMacros
- then yield arg_regs node_points
- else absC AbsCNop) `thenC`
+ -- Enter for Ldv profiling
+ ; whenC node_points (ldvEnter (CmmReg nodeReg))
- let closure_lbl
- | node_points = Nothing
- | otherwise = Just (closureLabelFromCI closure_info)
- in
+ -- GranSim yeild poin
+ ; granYield arg_regs node_points
- -- heap and/or stack checks
- funEntryChecks closure_lbl reg_save_code (
-
- -- Finally, do the business
- fun_body
- )
+ -- Heap and/or stack checks wrap the function body
+ ; funEntryChecks closure_info reg_save_code
+ fun_body
+ }
\end{code}
\begin{code}
-blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
-
-blackHoleIt closure_info node_points
- = if blackHoleOnEntry closure_info && node_points
- then
- let
- info_label = infoTableLabelFromCI closure_info
- args = [ CLbl info_label DataPtrRep ]
- in
- absC (if closureSingleEntry(closure_info) then
- CMacroStmt UPD_BH_SINGLE_ENTRY args
- else
- CMacroStmt UPD_BH_UPDATABLE args)
- else
+blackHoleIt :: ClosureInfo -> Code
+-- Only called for closures with no args
+-- Node points to the closure
+blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
+
+emitBlackHoleCode :: Bool -> Code
+emitBlackHoleCode is_single_entry
+ | eager_blackholing = do
+ tickyBlackHole (not is_single_entry)
+ stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
+ | otherwise =
nopC
+ where
+ bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info")
+ | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info")
+
+ -- If we wanted to do eager blackholing with slop filling,
+ -- we'd need to do it at the *end* of a basic block, otherwise
+ -- we overwrite the free variables in the thunk that we still
+ -- need. We have a patch for this from Andy Cheadle, but not
+ -- incorporated yet. --SDM [6/2004]
+ --
+ -- Profiling needs slop filling (to support LDV profiling), so
+ -- currently eager blackholing doesn't work with profiling.
+ --
+ -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
+ -- single-entry thunks.
+ eager_blackholing
+ | opt_DoTickyProfiling = True
+ | otherwise = False
+
\end{code}
\begin{code}
setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
- -- extracted by a subsequent ENTER_CC_TCL
-
--- I've tidied up the code for this function, but it should still do the same as
--- it did before (modulo ticky stuff). KSW 1999-04.
+ -- extracted by a subsequent enterCostCentre
setupUpdate closure_info code
- = if closureReEntrant closure_info
- then
- code
- else
- case (closureUpdReqd closure_info, isStaticClosure closure_info) of
- (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
- code
- (False,True ) -> (if opt_DoTickyProfiling
- then
- -- blackhole the SE CAF
- link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
- else
- nopC) `thenC`
- profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
- profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
- code
- (True ,False) -> pushUpdateFrame (CReg node) code
- (True ,True ) -> -- blackhole the (updatable) CAF:
- link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
- profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
- pushUpdateFrame update_closure code
- where
- cl_name :: FastString
- cl_name = (occNameFS . nameOccName . closureName) closure_info
-
- link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
- -> FCode CAddrMode -- Returns amode for closure to be updated
- link_caf bhCI
- = -- To update a CAF we must allocate a black hole, link the CAF onto the
- -- CAF list, then update the CAF to point to the fresh black hole.
- -- This function returns the address of the black hole, so it can be
- -- updated with the new value when available.
-
- -- Alloc black hole specifying CC_HDR(Node) as the cost centre
- let
- use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
- blame_cc = use_cc
- in
- allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
- getHpRelOffset heap_offset `thenFC` \ hp_rel ->
- let amode = CAddr hp_rel
- in
- absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
- returnFC amode
+ | closureReEntrant closure_info
+ = code
+
+ | not (isStaticClosure closure_info)
+ = if closureUpdReqd closure_info
+ then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
+ else do { tickyUpdateFrameOmitted; code }
+
+ | otherwise -- A static closure
+ = do { tickyUpdateBhCaf closure_info
+
+ ; if closureUpdReqd closure_info
+ then do -- Blackhole the (updatable) CAF:
+ { upd_closure <- link_caf closure_info True
+ ; pushUpdateFrame upd_closure code }
+ else do
+ { -- No update reqd, you'd think we don't need to
+ -- black-hole it. But when ticky-ticky is on, we
+ -- black-hole it regardless, to catch errors in which
+ -- an allegedly single-entry closure is entered twice
+ --
+ -- We discard the pointer returned by link_caf, because
+ -- we don't push an update frame
+ whenC opt_DoTickyProfiling -- Blackhole even a SE CAF
+ (link_caf closure_info False >> nopC)
+ ; tickyUpdateFrameOmitted
+ ; code }
+ }
+
+
+-----------------------------------------------------------------------------
+-- Entering a CAF
+--
+-- When a CAF is first entered, it creates a black hole in the heap,
+-- and updates itself with an indirection to this new black hole.
+--
+-- We update the CAF with an indirection to a newly-allocated black
+-- hole in the heap. We also set the blocking queue on the newly
+-- allocated black hole to be empty.
+--
+-- Why do we make a black hole in the heap when we enter a CAF?
+--
+-- - for a generational garbage collector, which needs a fast
+-- test for whether an updatee is in an old generation or not
+--
+-- - for the parallel system, which can implement updates more
+-- easily if the updatee is always in the heap. (allegedly).
+--
+-- When debugging, we maintain a separate CAF list so we can tell when
+-- a CAF has been garbage collected.
+
+-- newCAF must be called before the itbl ptr is overwritten, since
+-- newCAF records the old itbl ptr in order to do CAF reverting
+-- (which Hugs needs to do in order that combined mode works right.)
+--
+
+-- ToDo [Feb 04] This entire link_caf nonsense could all be moved
+-- into the "newCAF" RTS procedure, which we call anyway, including
+-- the allocation of the black-hole indirection closure.
+-- That way, code size would fall, the CAF-handling code would
+-- be closer together, and the compiler wouldn't need to know
+-- about off_indirectee etc.
+
+link_caf :: ClosureInfo
+ -> Bool -- True <=> updatable, False <=> single-entry
+ -> FCode CmmExpr -- Returns amode for closure to be updated
+-- To update a CAF we must allocate a black hole, link the CAF onto the
+-- CAF list, then update the CAF to point to the fresh black hole.
+-- This function returns the address of the black hole, so it can be
+-- updated with the new value when available. The reason for all of this
+-- is that we only want to update dynamic heap objects, not static ones,
+-- so that generational GC is easier.
+link_caf cl_info is_upd = do
+ { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
+ ; let use_cc = costCentreFrom (CmmReg nodeReg)
+ blame_cc = use_cc
+ ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
+ ; hp_rel <- getHpRelOffset hp_offset
+
+ -- Call the RTS function newCAF to add the CAF to the CafList
+ -- so that the garbage collector can find them
+ -- This must be done *before* the info table pointer is overwritten,
+ -- because the old info table ptr is needed for reversion
+ ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
+ -- node is live, so save it.
+
+ -- Overwrite the closure with a (static) indirection
+ -- to the newly-allocated black hole
+ ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
+ , CmmStore (CmmReg nodeReg) ind_static_info ]
+
+ ; returnFC hp_rel }
+ where
+ bh_cl_info :: ClosureInfo
+ bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info
+ | otherwise = seCafBlackHoleClosureInfo cl_info
+
+ ind_static_info :: CmmExpr
+ ind_static_info = mkLblExpr mkIndStaticInfoLabel
+
+ off_indirectee :: WordOff
+ off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
\end{code}
+
%************************************************************************
%* *
\subsection[CgClosure-Description]{Profiling Closure Description.}
%************************************************************************
For "global" data constructors the description is simply occurrence
-name of the data constructor itself (see \ref{CgConTbls-info-tables}).
-
-Otherwise it is determind by @closureDescription@ from the let
-binding information.
+name of the data constructor itself. Otherwise it is determined by
+@closureDescription@ from the let binding information.
\begin{code}
closureDescription :: Module -- Module
-> Name -- Id of closure binding
-> String
-
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.lhs with a description generated from the data constructor
-
closureDescription mod_name name
- = showSDoc (
- hcat [char '<',
- pprModule mod_name,
- char '.',
- ppr name,
- char '>'])
+ = showSDoc (hcat [char '<', pprModule mod_name,
+ char '.', ppr name, char '>'])
\end{code}
-\begin{code}
-chooseDynCostCentres ccs args fvs body
- = let
- use_cc -- cost-centre we record in the object
- = if currentOrSubsumedCCS ccs
- then CReg CurCostCentre
- else mkCCostCentreStack ccs
-
- blame_cc -- cost-centre on whom we blame the allocation
- = case (args, fvs, body) of
- ([], _, StgApp fun [{-no args-}])
- -> mkCCostCentreStack overheadCCS
- _ -> use_cc
-
- -- if it's an utterly trivial RHS, then it must be
- -- one introduced by boxHigherOrderArgs for profiling,
- -- so we charge it to "OVERHEAD".
-
- -- This looks like a HACK to me --SDM
- in
- (use_cc, blame_cc)
-\end{code}
-
-
-\begin{code}
-showTypeCategory :: Type -> Char
- {-
- {C,I,F,D} char, int, float, double
- T tuple
- S other single-constructor type
- {c,i,f,d} unboxed ditto
- t *unpacked* tuple
- s *unpacked" single-cons...
-
- v void#
- a primitive array
-
- E enumeration type
- + dictionary, unless it's a ...
- L List
- > function
- M other (multi-constructor) data-con type
- . other type
- - reserved for others to mark as "uninteresting"
- -}
-showTypeCategory ty
- = if isDictTy ty
- then '+'
- else
- case tcSplitTyConApp_maybe ty of
- Nothing -> if isJust (tcSplitFunTy_maybe ty)
- then '>'
- else '.'
-
- Just (tycon, _) ->
- let utc = getUnique tycon in
- if utc == charDataConKey then 'C'
- else if utc == intDataConKey then 'I'
- else if utc == floatDataConKey then 'F'
- else if utc == doubleDataConKey then 'D'
- else if utc == smallIntegerDataConKey ||
- utc == largeIntegerDataConKey then 'J'
- else if utc == charPrimTyConKey then 'c'
- else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
- || utc == addrPrimTyConKey) then 'i'
- else if utc == floatPrimTyConKey then 'f'
- else if utc == doublePrimTyConKey then 'd'
- else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
- else if isEnumerationTyCon tycon then 'E'
- else if isTupleTyCon tycon then 'T'
- else if isJust (maybeTyConSingleCon tycon) then 'S'
- else if utc == listTyConKey then 'L'
- else 'M' -- oh, well...
-\end{code}
module CgCon (
cgTopRhsCon, buildDynCon,
bindConArgs, bindUnboxedTupleComponents,
- cgReturnDataCon
+ cgReturnDataCon,
+ cgTyCon
) where
#include "HsVersions.h"
import CgMonad
-import AbsCSyn
import StgSyn
-import AbsCUtils ( getAmodeRep )
import CgBindery ( getArgAmodes, bindNewToNode,
- bindArgsToRegs,
- idInfoToAmode, stableAmodeIdInfo,
- heapIdInfo, CgIdInfo, bindNewToStack
+ bindArgsToRegs, idInfoToAmode, stableIdInfo,
+ heapIdInfo, CgIdInfo, bindArgsToStack
)
-import CgStackery ( mkVirtStkOffsets, freeStackSlots )
-import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp )
-import CgRetConv ( assignRegs )
+import CgStackery ( mkVirtStkOffsets, freeStackSlots,
+ getRealSp, getVirtSp, setRealAndVirtualSp )
+import CgUtils ( addIdReps, cmmLabelOffW, emitRODataLits, emitDataLits )
+import CgCallConv ( assignReturnRegs )
import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE )
-import CgHeapery ( allocDynClosure )
-import CgTailCall ( performReturn, mkStaticAlgReturnCode,
- returnUnboxedTuple )
-import CLabel ( mkClosureLabel )
-import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynConstr,
- layOutStaticConstr, mkStaticClosure
- )
+import CgHeapery ( allocDynClosure, layOutDynConstr,
+ layOutStaticConstr, mkStaticClosureFields )
+import CgTailCall ( performReturn, emitKnownConReturnCode, returnUnboxedTuple )
+import CgProf ( mkCCostCentreStack, ldvEnter, curCCS )
+import CgTicky
+import CgInfoTbls ( emitClosureCodeAndInfoTable, dataConTagZ )
+import CLabel ( mkClosureLabel, mkRtsDataLabel, mkClosureTblLabel )
+import ClosureInfo ( mkConLFInfo, mkLFArgument )
+import CmmUtils ( mkLblExpr )
+import Cmm
+import SMRep ( WordOff, CgRep, separateByPtrFollowness,
+ fixedHdrSize, typeCgRep )
import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
currentCCS )
-import DataCon ( DataCon, dataConTag,
+import Constants ( mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE )
+import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, tyConName )
+import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon,
isUnboxedTupleCon, dataConWorkId,
dataConName, dataConRepArity
)
-import Id ( Id, idName, idPrimRep, isDeadBinder )
-import Literal ( Literal(..) )
+import Id ( Id, idName, isDeadBinder )
+import Type ( Type )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
-import PrimRep ( PrimRep(..), isFollowableRep )
-import Util
import Outputable
-
-import List ( partition )
-import Char ( ord )
+import Util ( lengthIs )
+import ListSetOps ( assocMaybe )
\end{code}
+
%************************************************************************
%* *
\subsection[toplevel-constructors]{Top-level constructors}
cgTopRhsCon id con args
= ASSERT( not (isDllConApp con args) )
ASSERT( args `lengthIs` dataConRepArity con )
+ do { -- LAY IT OUT
+ ; amodes <- getArgAmodes args
+
+ ; let
+ name = idName id
+ lf_info = mkConLFInfo con
+ closure_label = mkClosureLabel name
+ caffy = any stgArgHasCafRefs args
+ (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
+ closure_rep = mkStaticClosureFields
+ closure_info
+ dontCareCCS -- Because it's static data
+ caffy -- Has CAF refs
+ payload
+
+ payload = map get_lit amodes_w_offsets
+ get_lit (CmmLit lit, _offset) = lit
+ get_lit other = pprPanic "CgCon.get_lit" (ppr other)
+ -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs
+ -- NB2: all the amodes should be Lits!
+
+ -- BUILD THE OBJECT
+ ; emitDataLits closure_label closure_rep
- -- LAY IT OUT
- getArgAmodes args `thenFC` \ amodes ->
-
- let
- name = idName id
- lf_info = mkConLFInfo con
- closure_label = mkClosureLabel name
- (closure_info, amodes_w_offsets)
- = layOutStaticConstr con getAmodeRep amodes
- caffy = any stgArgHasCafRefs args
- in
-
- -- BUILD THE OBJECT
- absC (mkStaticClosure
- closure_label
- closure_info
- dontCareCCS -- because it's static data
- (map fst amodes_w_offsets) -- Sorted into ptrs first, then nonptrs
- caffy -- has CAF refs
- ) `thenC`
- -- NOTE: can't use idCafInfo instead of nonEmptySRT above,
- -- because top-level constructors that were floated by
- -- CorePrep don't have CafInfo attached. The SRT is more
- -- reliable.
-
- -- RETURN
- returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
+ -- RETURN
+ ; returnFC (id, stableIdInfo id (mkLblExpr closure_label) lf_info) }
\end{code}
%************************************************************************
\subsection[code-for-constructors]{The code for constructors}
\begin{code}
-buildDynCon :: Id -- Name of the thing to which this constr will
- -- be bound
- -> CostCentreStack -- Where to grab cost centre from;
- -- current CCS if currentOrSubsumedCCS
- -> DataCon -- The data constructor
- -> [CAddrMode] -- Its args
- -> FCode CgIdInfo -- Return details about how to find it
+buildDynCon :: Id -- Name of the thing to which this constr will
+ -- be bound
+ -> CostCentreStack -- Where to grab cost centre from;
+ -- current CCS if currentOrSubsumedCCS
+ -> DataCon -- The data constructor
+ -> [(CgRep,CmmExpr)] -- Its args
+ -> FCode CgIdInfo -- Return details about how to find it
-- We used to pass a boolean indicating whether all the
-- args were of size zero, so we could use a static
\begin{code}
buildDynCon binder cc con []
- = returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel (dataConName con)) PtrRep)
- (mkConLFInfo con))
+ = returnFC (stableIdInfo binder
+ (mkLblExpr (mkClosureLabel (dataConName con)))
+ (mkConLFInfo con))
\end{code}
The following three paragraphs about @Char@-like and @Int@-like
\begin{code}
buildDynCon binder cc con [arg_amode]
- | maybeIntLikeCon con && in_range_int_lit arg_amode
- = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
- where
- in_range_int_lit (CLit (MachInt val)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
- in_range_int_lit _other_amode = False
+ | maybeIntLikeCon con
+ , (_, CmmLit (CmmInt val _)) <- arg_amode
+ , let val_int = (fromIntegral val) :: Int
+ , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE
+ = do { let intlike_lbl = mkRtsDataLabel SLIT("stg_INTLIKE_closure")
+ offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
+ -- INTLIKE closures consist of a header and one word payload
+ intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW)
+ ; returnFC (stableIdInfo binder intlike_amode (mkConLFInfo con)) }
buildDynCon binder cc con [arg_amode]
- | maybeCharLikeCon con && in_range_char_lit arg_amode
- = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con))
- where
- in_range_char_lit (CLit (MachChar val)) =
- ord val <= mAX_CHARLIKE && ord val >= mIN_CHARLIKE
- in_range_char_lit _other_amode = False
+ | maybeCharLikeCon con
+ , (_, CmmLit (CmmInt val _)) <- arg_amode
+ , let val_int = (fromIntegral val) :: Int
+ , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE
+ = do { let charlike_lbl = mkRtsDataLabel SLIT("stg_CHARLIKE_closure")
+ offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
+ -- CHARLIKE closures consist of a header and one word payload
+ charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW)
+ ; returnFC (stableIdInfo binder charlike_amode (mkConLFInfo con)) }
\end{code}
Now the general case.
\begin{code}
buildDynCon binder ccs con args
- = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
- returnFC (heapIdInfo binder hp_off lf_info)
+ = do { hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
+ ; returnFC (heapIdInfo binder hp_off lf_info) }
where
lf_info = mkConLFInfo con
-
- (closure_info, amodes_w_offsets) = layOutDynConstr con getAmodeRep args
+ (closure_info, amodes_w_offsets) = layOutDynConstr con args
use_cc -- cost-centre to stick in the object
- = if currentOrSubsumedCCS ccs
- then CReg CurCostCentre
- else mkCCostCentreStack ccs
+ | currentOrSubsumedCCS ccs = curCCS
+ | otherwise = CmmLit (mkCCostCentreStack ccs)
blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
\end{code}
found a $con$.
\begin{code}
-bindConArgs
- :: DataCon -> [Id] -- Constructor and args
- -> Code
-
+bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
= ASSERT(not (isUnboxedTupleCon con))
mapCs bind_arg args_w_offsets
where
bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
- (_, args_w_offsets) = layOutDynConstr con idPrimRep args
+ (_, args_w_offsets) = layOutDynConstr con (addIdReps args)
\end{code}
Unboxed tuples are handled slightly differently - the object is
\begin{code}
bindUnboxedTupleComponents
- :: [Id] -- Aargs
- -> FCode ([MagicId], -- Regs assigned
- Int, -- Number of pointer stack slots
- Int, -- Number of non-pointer stack slots
+ :: [Id] -- Args
+ -> FCode ([(Id,GlobalReg)], -- Regs assigned
+ WordOff, -- Number of pointer stack slots
+ WordOff, -- Number of non-pointer stack slots
VirtualSpOffset) -- Offset of return address slot
-- (= realSP on entry)
bindUnboxedTupleComponents args
- = -- Assign as many components as possible to registers
- let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
- (reg_args, stk_args) = splitAtList arg_regs args
-
- -- separate the rest of the args into pointers and non-pointers
- (ptr_args, nptr_args) =
- partition (isFollowableRep . idPrimRep) stk_args
- in
+ = do {
+ vsp <- getVirtSp
+ ; rsp <- getRealSp
+
+ -- Assign as many components as possible to registers
+ ; let (reg_args, stk_args) = assignReturnRegs (addIdReps args)
+
+ -- Separate the rest of the args into pointers and non-pointers
+ (ptr_args, nptr_args) = separateByPtrFollowness stk_args
- -- Allocate the rest on the stack
- -- The real SP points to the return address, above which any
- -- leftover unboxed-tuple components will be allocated
- getVirtSp `thenFC` \ vsp ->
- getRealSp `thenFC` \ rsp ->
- let
- (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp idPrimRep ptr_args
- (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
- ptrs = ptr_sp - rsp
- nptrs = nptr_sp - ptr_sp
- in
-
- -- The stack pointer points to the last stack-allocated component
- setRealAndVirtualSp nptr_sp `thenC`
-
- -- We have just allocated slots starting at real SP + 1, and set the new
- -- virtual SP to the topmost allocated slot.
- -- If the virtual SP started *below* the real SP, we've just jumped over
- -- some slots that won't be in the free-list, so put them there
- -- This commonly happens because we've freed the return-address slot
- -- (trimming back the virtual SP), but the real SP still points to that slot
- freeStackSlots [vsp+1,vsp+2 .. rsp] `thenC`
-
- bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToStack ptr_offsets `thenC`
- mapCs bindNewToStack nptr_offsets `thenC`
-
- returnFC (arg_regs, ptrs, nptrs, rsp)
+ -- Allocate the rest on the stack
+ -- The real SP points to the return address, above which any
+ -- leftover unboxed-tuple components will be allocated
+ (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp ptr_args
+ (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args
+ ptrs = ptr_sp - rsp
+ nptrs = nptr_sp - ptr_sp
+
+ -- The stack pointer points to the last stack-allocated component
+ ; setRealAndVirtualSp nptr_sp
+
+ -- We have just allocated slots starting at real SP + 1, and set the new
+ -- virtual SP to the topmost allocated slot.
+ -- If the virtual SP started *below* the real SP, we've just jumped over
+ -- some slots that won't be in the free-list, so put them there
+ -- This commonly happens because we've freed the return-address slot
+ -- (trimming back the virtual SP), but the real SP still points to that slot
+ ; freeStackSlots [vsp+1,vsp+2 .. rsp]
+
+ ; bindArgsToRegs reg_args
+ ; bindArgsToStack ptr_offsets
+ ; bindArgsToStack nptr_offsets
+
+ ; returnFC (reg_args, ptrs, nptrs, rsp) }
\end{code}
%************************************************************************
%* *
-\subsubsection[CgRetConv-cgReturnDataCon]{Actually generate code for a constructor return}
+ Actually generate code for a constructor return
%* *
%************************************************************************
Note: it's the responsibility of the @cgReturnDataCon@ caller to be
sure the @amodes@ passed don't conflict with each other.
\begin{code}
-cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
+cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code
cgReturnDataCon con amodes
= ASSERT( amodes `lengthIs` dataConRepArity con )
- getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
-
- case sequel of
-
- CaseAlts _ (Just (alts, Just (deflt_bndr, (_,deflt_lbl)))) False
- | not (dataConTag con `is_elem` map fst alts)
- ->
- -- Special case! We're returning a constructor to the default case
- -- of an enclosing case. For example:
- --
- -- case (case e of (a,b) -> C a b) of
- -- D x -> ...
- -- y -> ...<returning here!>...
- --
- -- In this case,
- -- if the default is a non-bind-default (ie does not use y),
- -- then we should simply jump to the default join point;
-
- if isDeadBinder deflt_bndr
- then performReturn AbsCNop {- No reg assts -} jump_to_join_point
- else build_it_then jump_to_join_point
- where
- is_elem = isIn "cgReturnDataCon"
- jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
- -- Ignore the sequel: we've already looked at it above
-
- other_sequel -- The usual case
- | isUnboxedTupleCon con -> returnUnboxedTuple amodes
- | otherwise -> build_it_then (mkStaticAlgReturnCode con)
-
+ do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
+ ; case sequel of
+ CaseAlts _ (Just (alts, deflt_lbl)) bndr _
+ -> -- Ho! We know the constructor so we can
+ -- go straight to the right alternative
+ case assocMaybe alts (dataConTagZ con) of {
+ Just join_lbl -> build_it_then (jump_to join_lbl) ;
+ Nothing
+ -- Special case! We're returning a constructor to the default case
+ -- of an enclosing case. For example:
+ --
+ -- case (case e of (a,b) -> C a b) of
+ -- D x -> ...
+ -- y -> ...<returning here!>...
+ --
+ -- In this case,
+ -- if the default is a non-bind-default (ie does not use y),
+ -- then we should simply jump to the default join point;
+
+ | isDeadBinder bndr -> performReturn (jump_to deflt_lbl)
+ | otherwise -> build_it_then (jump_to deflt_lbl) }
+
+ other_sequel -- The usual case
+ | isUnboxedTupleCon con -> returnUnboxedTuple amodes
+ | otherwise -> build_it_then (emitKnownConReturnCode con)
+ }
where
- move_to_reg :: CAddrMode -> MagicId -> AbstractC
- move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
-
- build_it_then return =
- -- BUILD THE OBJECT IN THE HEAP
- -- The first "con" says that the name bound to this
+ jump_to lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl)) [])
+ build_it_then return_code
+ = do { -- BUILD THE OBJECT IN THE HEAP
+ -- The first "con" says that the name bound to this
-- closure is "con", which is a bit of a fudge, but it only
-- affects profiling
-- temporary variable, if the closure is a CHARLIKE.
-- funnily enough, this makes the unique always come
-- out as '54' :-)
- buildDynCon (dataConWorkId con) currentCCS con amodes `thenFC` \ idinfo ->
- idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
+ tickyReturnNewCon (length amodes)
+ ; idinfo <- buildDynCon (dataConWorkId con) currentCCS con amodes
+ ; amode <- idInfoToAmode idinfo
+ ; checkedAbsC (CmmAssign nodeReg amode)
+ ; performReturn return_code }
+\end{code}
- -- RETURN
- profCtrC FSLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
- -- could use doTailCall here.
- performReturn (move_to_reg amode node) return
+%************************************************************************
+%* *
+ Generating static stuff for algebraic data types
+%* *
+%************************************************************************
+
+ [These comments are rather out of date]
+
+\begin{tabular}{lll}
+Info tbls & Macro & Kind of constructor \\
+\hline
+info & @CONST_INFO_TABLE@& Zero arity (no info -- compiler uses static closure)\\
+info & @CHARLIKE_INFO_TABLE@& Charlike (no info -- compiler indexes fixed array)\\
+info & @INTLIKE_INFO_TABLE@& Intlike; the one macro generates both info tbls\\
+info & @SPEC_INFO_TABLE@& SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\
+info & @GEN_INFO_TABLE@& GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\
+\end{tabular}
+
+Possible info tables for constructor con:
+
+\begin{description}
+\item[@_con_info@:]
+Used for dynamically let(rec)-bound occurrences of
+the constructor, and for updates. For constructors
+which are int-like, char-like or nullary, when GC occurs,
+the closure tries to get rid of itself.
+
+\item[@_static_info@:]
+Static occurrences of the constructor
+macro: @STATIC_INFO_TABLE@.
+\end{description}
+
+For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
+it's place is taken by the top level defn of the constructor.
+
+For charlike and intlike closures there is a fixed array of static
+closures predeclared.
+
+\begin{code}
+cgTyCon :: TyCon -> FCode [Cmm] -- each constructor gets a separate Cmm
+cgTyCon tycon
+ = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
+
+ -- Generate a table of static closures for an enumeration type
+ -- Put the table after the data constructor decls, because the
+ -- datatype closure table (for enumeration types)
+ -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
+ ; extra <-
+ if isEnumerationTyCon tycon then do
+ tbl <- getCmm (emitRODataLits (mkClosureTblLabel
+ (tyConName tycon))
+ [ CmmLabel (mkClosureLabel (dataConName con))
+ | con <- tyConDataCons tycon])
+ return [tbl]
+ else
+ return []
+
+ ; return (extra ++ constrs)
+ }
+\end{code}
+
+Generate the entry code, info tables, and (for niladic constructor) the
+static closure, for a constructor.
+
+\begin{code}
+cgDataCon :: DataCon -> Code
+cgDataCon data_con
+ = do { -- Don't need any dynamic closure code for zero-arity constructors
+ whenC (not (isNullaryDataCon data_con))
+ (emit_info dyn_cl_info tickyEnterDynCon)
+
+ -- Dynamic-Closure first, to reduce forward references
+ ; emit_info static_cl_info tickyEnterStaticCon }
+
+ where
+ emit_info cl_info ticky_code
+ = do { code_blks <- getCgStmts the_code
+ ; emitClosureCodeAndInfoTable cl_info [] code_blks }
+ where
+ the_code = do { ticky_code
+ ; ldvEnter (CmmReg nodeReg)
+ ; body_code }
+
+ arg_reps :: [(CgRep, Type)]
+ arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
+
+ -- To allow the debuggers, interpreters, etc to cope with static
+ -- data structures (ie those built at compile time), we take care that
+ -- info-table contains the information we need.
+ (static_cl_info, _) = layOutStaticConstr data_con arg_reps
+ (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
+
+ body_code = do { -- NB: We don't set CC when entering data (WDP 94/06)
+ tickyReturnOldCon (length arg_things)
+ ; performReturn (emitKnownConReturnCode data_con) }
+ -- noStmts: Ptr to thing already in Node
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgConTbls]{Info tables and update bits for constructors}
-
-\begin{code}
-module CgConTbls ( genStaticConBits ) where
-
-#include "HsVersions.h"
-
-import AbsCSyn
-import CgMonad
-
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
-import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo )
-import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon )
-import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon )
-import Type ( typePrimRep )
-import CmdLineOpts
-\end{code}
-
-For every constructor we generate the following info tables:
- A static info table, for static instances of the constructor,
-
- Plus:
-
-\begin{tabular}{lll}
-Info tbls & Macro & Kind of constructor \\
-\hline
-info & @CONST_INFO_TABLE@& Zero arity (no info -- compiler uses static closure)\\
-info & @CHARLIKE_INFO_TABLE@& Charlike (no info -- compiler indexes fixed array)\\
-info & @INTLIKE_INFO_TABLE@& Intlike; the one macro generates both info tbls\\
-info & @SPEC_INFO_TABLE@& SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\
-info & @GEN_INFO_TABLE@& GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\
-\end{tabular}
-
-Possible info tables for constructor con:
-
-\begin{description}
-\item[@_con_info@:]
-Used for dynamically let(rec)-bound occurrences of
-the constructor, and for updates. For constructors
-which are int-like, char-like or nullary, when GC occurs,
-the closure tries to get rid of itself.
-
-\item[@_static_info@:]
-Static occurrences of the constructor
-macro: @STATIC_INFO_TABLE@.
-\end{description}
-
-
-For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
-it's place is taken by the top level defn of the constructor.
-
-For charlike and intlike closures there is a fixed array of static
-closures predeclared.
-
-\begin{code}
-genStaticConBits :: CompilationInfo -- global info about the compilation
- -> [TyCon] -- tycons to generate
- -> AbstractC -- output
-
-genStaticConBits comp_info gen_tycons
- = -- for each type constructor:
- -- grab all its data constructors;
- -- for each one, generate an info table
- -- for each specialised type constructor
- -- for each specialisation of the type constructor
- -- grab data constructors, and generate info tables
-
- -- ToDo: for tycons and specialisations which are not
- -- declared in this module we must ensure that the
- -- C labels are local to this module i.e. static
- -- since they may be duplicated in other modules
-
- mkAbstractCs [ gen_for_tycon tc `mkAbsCStmts` enum_closure_table tc
- | tc <- gen_tycons ]
- where
- gen_for_tycon :: TyCon -> AbstractC
- gen_for_tycon tycon = mkAbstractCs [ genConInfo comp_info data_con
- | data_con <- tyConDataCons tycon ]
-
- enum_closure_table tycon
- | isEnumerationTyCon tycon = CClosureTbl tycon
- | otherwise = AbsCNop
- -- Put the table after the data constructor decls, because the
- -- datatype closure table (for enumeration types)
- -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[CgConTbls-info-tables]{Generating info tables for constructors}
-%* *
-%************************************************************************
-
-Generate the entry code, info tables, and (for niladic constructor) the
-static closure, for a constructor.
-
-\begin{code}
-genConInfo :: CompilationInfo -> DataCon -> AbstractC
-
-genConInfo comp_info data_con
- = -- Order of things is to reduce forward references
- mkAbstractCs [if opt_EnsureSplittableC then CSplitMarker else AbsCNop,
- closure_code,
- static_code]
- where
- (closure_info, body_code) = mkConCodeAndInfo data_con
-
- -- To allow the debuggers, interpreters, etc to cope with static
- -- data structures (ie those built at compile time), we take care that
- -- info-table contains the information we need.
- (static_ci,_) = layOutStaticConstr data_con typePrimRep arg_tys
-
- static_body = initC comp_info (
- profCtrC FSLIT("TICK_ENT_STATIC_CON") [CReg node] `thenC`
- ldv_enter_and_body_code)
-
- closure_body = initC comp_info (
- profCtrC FSLIT("TICK_ENT_DYN_CON") [CReg node] `thenC`
- ldv_enter_and_body_code)
-
- ldv_enter_and_body_code = ldvEnter `thenC` body_code
-
- -- Don't need any dynamic closure code for zero-arity constructors
- closure_code = if zero_arity_con then
- AbsCNop
- else
- CClosureInfoAndCode closure_info closure_body
-
- static_code = CClosureInfoAndCode static_ci static_body
-
- zero_arity_con = isNullaryDataCon data_con
- -- We used to check that all the arg-sizes were zero, but we don't
- -- really have any constructors with only zero-size args, and it's
- -- just one more thing to go wrong.
-
- arg_tys = dataConRepArgTys data_con
-\end{code}
-
-\begin{code}
-mkConCodeAndInfo :: DataCon -- Data constructor
- -> (ClosureInfo, Code) -- The info table
-
-mkConCodeAndInfo con
- = let
- arg_tys = dataConRepArgTys con
-
- (closure_info, arg_things) = layOutDynConstr con typePrimRep arg_tys
-
- body_code
- = -- NB: We don't set CC when entering data (WDP 94/06)
- profCtrC FSLIT("TICK_RET_OLD")
- [mkIntCLit (length arg_things)] `thenC`
-
- performReturn AbsCNop -- Ptr to thing already in Node
- (mkStaticAlgReturnCode con)
- in
- (closure_info, body_code)
-\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.58 2004/08/10 09:02:41 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.59 2004/08/13 13:05:58 simonmar Exp $
%
%********************************************************
%* *
import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
import StgSyn
import CgMonad
-import AbsCSyn
-import AbsCUtils ( mkAbstractCs, getAmodeRep, shimFCallArg )
-import CLabel ( mkClosureTblLabel )
-import SMRep ( fixedHdrSize )
+import SMRep ( fixedHdrSize, isFollowableArg, CgRep(..), argMachRep,
+ nonVoidArg, idCgRep, typeCgRep, typeHint,
+ primRepToCgRep )
import CoreSyn ( AltCon(..) )
+import CgProf ( emitSetCCC )
+import CgHeapery ( layOutDynConstr )
import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo,
nukeDeadBindings, addBindC, addBindsC )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure, cgStdRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgLetNoEscape ( cgLetNoEscapeClosure )
-import CgRetConv ( dataReturnConvPrim )
-import CgTailCall ( cgTailCall, performReturn, performPrimReturn,
- mkDynamicAlgReturnCode, mkPrimReturnCode,
- tailCallPrimOp, ccallReturnUnboxedTuple
- )
-import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
- mkApLFInfo, layOutDynConstr )
-import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
-import Id ( idPrimRep, Id )
+import CgCallConv ( dataReturnConvPrim )
+import CgTailCall
+import CgInfoTbls ( emitDirectReturnInstr )
+import CgForeignCall ( emitForeignCall, shimForeignCallArg )
+import CgPrimOp ( cgPrimOp )
+import CgUtils ( addIdReps, newTemp, assignTemp, cgLit, tagToClosure )
+import ClosureInfo ( mkSelectorLFInfo, mkApLFInfo )
+import Cmm ( CmmExpr(..), CmmStmt(..), CmmReg, nodeReg )
+import MachOp ( wordRep, MachHint )
import VarSet
+import Literal ( literalType )
import PrimOp ( primOpOutOfLine, getPrimOpResultInfo,
PrimOp(..), PrimOpResultInfo(..) )
-import PrimRep ( PrimRep(..), isFollowableRep )
+import Id ( Id )
import TyCon ( isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type ( Type, typePrimRep, tyConAppArgs,
- tyConAppTyCon, repType )
+import Type ( Type, tyConAppArgs, tyConAppTyCon, repType,
+ PrimRep(VoidRep) )
import Maybes ( maybeToBool )
import ListSetOps ( assocMaybe )
-import Unique ( mkBuiltinUnique )
-import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
+import BasicTypes ( RecFlag(..) )
import Util ( lengthIs )
import Outputable
\end{code}
\begin{code}
cgExpr (StgConApp con args)
- = getArgAmodes args `thenFC` \ amodes ->
- cgReturnDataCon con amodes
+ = do { amodes <- getArgAmodes args
+ ; cgReturnDataCon con amodes }
\end{code}
Literals are similar to constructors; they return by putting
\begin{code}
cgExpr (StgLit lit)
- = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
+ = do { cmm_lit <- cgLit lit
+ ; performPrimReturn rep (CmmLit cmm_lit) }
+ where
+ rep = typeCgRep (literalType lit)
\end{code}
%********************************************************
%* *
-%* STG PrimApps (unboxed primitive ops) *
+%* PrimOps and foreign calls.
%* *
%********************************************************
-Here is where we insert real live machine instructions.
-
-NOTE about _ccall_GC_:
+NOTE about "safe" foreign calls: a safe foreign call is never compiled
+inline in a case expression. When we see
-A _ccall_GC_ is treated as an out-of-line primop (returns True
-for primOpOutOfLine) so that when we see the call in case context
case (ccall ...) of { ... }
-we get a proper stack frame on the stack when we perform it. When we
-get in a tail-call position, however, we need to actually perform the
-call, so we treat it as an inline primop.
+
+We generate a proper return address for the alternatives and push the
+stack frame before doing the call, so that in the event that the call
+re-enters the RTS the stack is in a sane state.
\begin{code}
-cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
- = primRetUnboxedTuple op args res_ty
+cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
+ {-
+ First, copy the args into temporaries. We're going to push
+ a return address right before doing the call, so the args
+ must be out of the way.
+ -}
+ reps_n_amodes <- getArgAmodes stg_args
+ let
+ -- Get the *non-void* args, and jiggle them with shimForeignCall
+ arg_exprs = [ shimForeignCallArg stg_arg expr
+ | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
+ nonVoidArg rep]
+ -- in
+ arg_tmps <- mapM assignTemp arg_exprs
+ let
+ arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args)
+ -- in
+ {-
+ Now, allocate some result regs.
+ -}
+ (res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty
+ ccallReturnUnboxedTuple (zip res_reps (map CmmReg res_regs)) $
+ emitForeignCall (zip res_regs res_hints) fcall
+ arg_hints emptyVarSet{-no live vars-}
+
-- tagToEnum# is special: we need to pull the constructor out of the table,
-- and perform an appropriate return.
cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
= ASSERT(isEnumerationTyCon tycon)
- getArgAmode arg `thenFC` \amode ->
- -- save the tag in a temporary in case amode overlaps
- -- with node.
- absC (CAssign dyn_tag amode) `thenC`
- performReturn (
- CAssign (CReg node)
- (CVal (CIndex
- (CLbl (mkClosureTblLabel tycon) PtrRep)
- dyn_tag PtrRep) PtrRep))
- (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
+ do { (_,amode) <- getArgAmode arg
+ ; amode' <- assignTemp amode -- We're going to use it twice,
+ -- so save in a temp if non-trivial
+ ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode'))
+ ; performReturn (emitAlgReturnCode tycon amode') }
where
- dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
- -- The '0' is just to get a random spare temp
- --
- -- if you're reading this code in the attempt to figure
+ -- If you're reading this code in the attempt to figure
-- out why the compiler panic'ed here, it is probably because
-- you used tagToEnum# in a non-monomorphic setting, e.g.,
-- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
- --
-- That won't work.
- --
tycon = tyConAppTyCon res_ty
cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
- | primOpOutOfLine primop
- = tailCallPrimOp primop args
-
- | otherwise
- = getArgAmodes args `thenFC` \ arg_amodes ->
-
- case (getPrimOpResultInfo primop) of
-
- ReturnsPrim kind ->
- let result_amode = CReg (dataReturnConvPrim kind) in
- performReturn
- (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
- (mkPrimReturnCode (text "primapp)" <+> ppr x))
-
- -- otherwise, must be returning an enumerated type (eg. Bool).
- -- we've only got the tag in R2, so we have to load the constructor
- -- itself into R1.
-
- ReturnsAlg tycon
- | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
-
- | isEnumerationTyCon tycon ->
- performReturn
- (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
- (\ sequel ->
- absC (CAssign (CReg node) closure_lbl) `thenC`
- mkDynamicAlgReturnCode tycon dyn_tag sequel)
-
- where
- -- Pull a unique out of thin air to put the tag in.
- -- It shouldn't matter if this overlaps with anything - we're
- -- about to return anyway.
- dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
-
- closure_lbl = CVal (CIndex
- (CLbl (mkClosureTblLabel tycon) PtrRep)
- dyn_tag PtrRep) PtrRep
-
+ | primOpOutOfLine primop
+ = tailCallPrimOp primop args
+
+ | ReturnsPrim VoidRep <- result_info
+ = do cgPrimOp [] primop args emptyVarSet
+ performReturn emitDirectReturnInstr
+
+ | ReturnsPrim rep <- result_info
+ = do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)]
+ primop args emptyVarSet
+ performReturn emitDirectReturnInstr
+
+ | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
+ = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
+ cgPrimOp regs primop args emptyVarSet{-no live vars-}
+ returnUnboxedTuple (zip reps (map CmmReg regs))
+
+ | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
+ -- c.f. cgExpr (...TagToEnumOp...)
+ = do tag_reg <- newTemp wordRep
+ cgPrimOp [tag_reg] primop args emptyVarSet
+ stmtC (CmmAssign nodeReg (tagToClosure tycon (CmmReg tag_reg)))
+ performReturn (emitAlgReturnCode tycon (CmmReg tag_reg))
+ where
+ result_info = getPrimOpResultInfo primop
\end{code}
%********************************************************
\begin{code}
cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
- = -- Figure out what volatile variables to save
- nukeDeadBindings live_in_whole_let `thenC`
- saveVolatileVarsAndRegs live_in_rhss
- `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
+ = do { -- Figure out what volatile variables to save
+ ; nukeDeadBindings live_in_whole_let
+ ; (save_assts, rhs_eob_info, maybe_cc_slot)
+ <- saveVolatileVarsAndRegs live_in_rhss
-- Save those variables right now!
- absC save_assts `thenC`
+ ; emitStmts save_assts
-- Produce code for the rhss
-- and add suitable bindings to the environment
- cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
+ ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info
+ maybe_cc_slot bindings
-- Do the body
- setEndOfBlockInfo rhs_eob_info (cgExpr body)
+ ; setEndOfBlockInfo rhs_eob_info (cgExpr body) }
\end{code}
SCC expressions are treated specially. They set the current cost
centre.
+
\begin{code}
-cgExpr (StgSCC cc expr)
- = ASSERT(sccAbleCostCentre cc)
- costCentresC
- FSLIT("SET_CCC")
- [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
- `thenC`
- cgExpr expr
+cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr
\end{code}
-ToDo: counting of dict sccs ...
-
%********************************************************
%* *
%* Non-top-level bindings *
-- the Id is passed along so a binding can be set up
cgRhs name (StgRhsCon maybe_cc con args)
- = getArgAmodes args `thenFC` \ amodes ->
- buildDynCon name maybe_cc con amodes `thenFC` \ idinfo ->
- returnFC (name, idinfo)
+ = do { amodes <- getArgAmodes args
+ ; idinfo <- buildDynCon name maybe_cc con amodes
+ ; returnFC (name, idinfo) }
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
= mkRhsClosure name cc bi srt fvs upd_flag args body
cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
- (_, params_w_offsets) = layOutDynConstr con idPrimRep params
+ (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
-- Just want the layout
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
body@(StgApp fun_id args)
| args `lengthIs` (arity-1)
- && all isFollowableRep (map idPrimRep fvs)
+ && all isFollowableArg (map idCgRep fvs)
&& isUpdatable upd_flag
&& arity <= mAX_SPEC_AP_SIZE
lf_info = mkApLFInfo bndr upd_flag arity
-- the payload has to be in the correct order, hence we can't
-- just use the fvs.
- payload = StgVarArg fun_id : args
- arity = length fvs
+ payload = StgVarArg fun_id : args
+ arity = length fvs
\end{code}
The default case
~~~~~~~~~~~~~~~~
\begin{code}
mkRhsClosure bndr cc bi srt fvs upd_flag args body
- = cgRhsClosure bndr cc bi srt fvs args body lf_info
- where
- lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
+ = cgRhsClosure bndr cc bi srt fvs upd_flag args body
\end{code}
\begin{code}
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
(StgNonRec binder rhs)
- = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
- NonRecursive binder rhs
- `thenFC` \ (binder, info) ->
- addBindC binder info
+ = do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info
+ maybe_cc_slot
+ NonRecursive binder rhs
+ ; addBindC binder info }
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
- = fixC (\ new_bindings ->
- addBindsC new_bindings `thenC`
- listFCs [ cgLetNoEscapeRhs full_live_in_rhss
+ = do { new_bindings <- fixC (\ new_bindings -> do
+ { addBindsC new_bindings
+ ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss
rhs_eob_info maybe_cc_slot Recursive b e
- | (b,e) <- pairs ]
- ) `thenFC` \ new_bindings ->
+ | (b,e) <- pairs ] })
- addBindsC new_bindings
+ ; addBindsC new_bindings }
where
-- We add the binders to the live-in-rhss set so that we don't
-- delete the bindings for the binder from the environment!
Little helper for primitives that return unboxed tuples.
-
\begin{code}
-primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
-primRetUnboxedTuple op args res_ty
- = getArgAmodes args `thenFC` \ arg_amodes1 ->
- {-
- For a foreign call, we might need to fiddle with some of the args:
- for example, when passing a ByteArray#, we pass a ptr to the goods
- rather than the heap object.
- -}
- let
- arg_amodes
- | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
- | otherwise = arg_amodes1
- in
- {-
- put all the arguments in temporaries so they don't get stomped when
- we push the return address.
- -}
- let
- n_args = length args
- arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
- arg_reps = map getAmodeRep arg_amodes
- arg_temps = zipWith CTemp arg_uniqs arg_reps
- in
- absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
- {-
- allocate some temporaries for the return values.
- -}
- let
- ty_args = tyConAppArgs (repType res_ty)
- prim_reps = map typePrimRep ty_args
- temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
- temp_amodes = zipWith CTemp temp_uniqs prim_reps
- in
- ccallReturnUnboxedTuple temp_amodes
- (absC (COpStmt temp_amodes op arg_temps []))
+newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint])
+newUnboxedTupleRegs res_ty =
+ let
+ ty_args = tyConAppArgs (repType res_ty)
+ (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args,
+ let rep = typeCgRep ty,
+ nonVoidArg rep ]
+ in do
+ regs <- mapM (newTemp . argMachRep) reps
+ return (reps,regs,hints)
\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Code generation for foreign calls.
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CgForeignCall (
+ emitForeignCall,
+ cgForeignCall,
+ shimForeignCallArg,
+ emitSaveThreadState, -- will be needed by the Cmm parser
+ emitLoadThreadState, -- ditto
+ emitCloseNursery,
+ emitOpenNursery,
+ ) where
+
+#include "HsVersions.h"
+
+import StgSyn ( StgLiveVars, StgArg, stgArgType )
+import CgProf ( curCCS, curCCSAddr )
+import CgBindery ( getVolatileRegs, getArgAmodes )
+import CgMonad
+import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp )
+import Type ( tyConAppTyCon, repType )
+import TysPrim
+import CLabel ( mkForeignLabel, mkRtsCodeLabel )
+import Cmm
+import CmmUtils
+import MachOp
+import SMRep
+import ForeignCall
+import Constants
+import CmdLineOpts ( opt_SccProfilingOn )
+import Outputable
+
+import Monad ( when )
+
+-- -----------------------------------------------------------------------------
+-- Code generation for Foreign Calls
+
+cgForeignCall
+ :: [(CmmReg,MachHint)] -- where to put the results
+ -> ForeignCall -- the op
+ -> [StgArg] -- arguments
+ -> StgLiveVars -- live vars, in case we need to save them
+ -> Code
+cgForeignCall results fcall stg_args live
+ = do
+ reps_n_amodes <- getArgAmodes stg_args
+ let
+ -- Get the *non-void* args, and jiggle them with shimForeignCall
+ arg_exprs = [ shimForeignCallArg stg_arg expr
+ | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
+ nonVoidArg rep]
+
+ arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args)
+ -- in
+ emitForeignCall results fcall arg_hints live
+
+
+emitForeignCall
+ :: [(CmmReg,MachHint)] -- where to put the results
+ -> ForeignCall -- the op
+ -> [(CmmExpr,MachHint)] -- arguments
+ -> StgLiveVars -- live vars, in case we need to save them
+ -> Code
+
+emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
+ | not (playSafe safety)
+ = do
+ vols <- getVolatileRegs live
+ stmtC (the_call vols)
+
+ | otherwise -- it's a safe foreign call
+ = do
+ vols <- getVolatileRegs live
+ id <- newTemp wordRep
+ emitSaveThreadState
+ stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) [(id,NoHint)]
+ [ (CmmReg (CmmGlobal BaseReg), NoHint) ]
+ Nothing{-save all; ToDo-}
+ )
+ stmtC (the_call vols)
+ stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) []
+ [ (CmmReg id, NoHint) ] (Just vols)
+ )
+ emitLoadThreadState
+
+ where
+ (call_args, cmm_target)
+ = case target of
+ StaticTarget lbl -> (args, CmmLit (CmmLabel
+ (mkForeignLabel lbl Nothing False)))
+ -- ToDo: what about the size here?
+ -- it is currently tacked on by the NCG.
+ DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
+
+ the_call vols = CmmCall (CmmForeignCall cmm_target cconv)
+ results call_args (Just vols)
+
+
+emitForeignCall results (DNCall _) args live
+ = panic "emitForeignCall: DNCall"
+
+suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
+resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
+
+-- -----------------------------------------------------------------------------
+-- Save/restore the thread state in the TSO
+
+-- This stuff can't be done in suspendThread/resumeThread, because it
+-- refers to global registers which aren't available in the C world.
+
+emitSaveThreadState = do
+ -- CurrentTSO->sp = Sp;
+ stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
+ emitCloseNursery
+ -- and save the current cost centre stack in the TSO when profiling:
+ when opt_SccProfilingOn $
+ stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
+
+ -- CurrentNursery->free = Hp+1;
+emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
+
+emitLoadThreadState = do
+ tso <- newTemp wordRep
+ stmtsC [
+ -- tso = CurrentTSO;
+ CmmAssign tso stgCurrentTSO,
+ -- Sp = tso->sp;
+ CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
+ wordRep),
+ -- SpLim = tso->stack + RESERVED_STACK_WORDS;
+ CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
+ rESERVED_STACK_WORDS)
+ ]
+ emitOpenNursery
+ -- and load the current cost centre stack from the TSO when profiling:
+ when opt_SccProfilingOn $
+ stmtC (CmmStore curCCSAddr
+ (CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
+
+emitOpenNursery = stmtsC [
+ -- Hp = CurrentNursery->free - 1;
+ CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
+
+ -- HpLim = CurrentNursery->start +
+ -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+ CmmAssign hpLim
+ (cmmOffsetExpr
+ (CmmLoad nursery_bdescr_start wordRep)
+ (cmmOffset
+ (CmmMachOp mo_wordMul [
+ CmmMachOp (MO_S_Conv I32 wordRep)
+ [CmmLoad nursery_bdescr_blocks I32],
+ CmmLit (mkIntCLit bLOCK_SIZE)
+ ])
+ (-1)
+ )
+ )
+ ]
+
+
+nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
+nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
+nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
+
+tso_SP = tsoFieldB oFFSET_StgTSO_sp
+tso_STACK = tsoFieldB oFFSET_StgTSO_stack
+tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
+
+-- The TSO struct has a variable header, and an optional StgTSOProfInfo in
+-- the middle. The fields we're interested in are after the StgTSOProfInfo.
+tsoFieldB :: ByteOff -> ByteOff
+tsoFieldB off
+ | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
+ | otherwise = off + fixedHdrSize * wORD_SIZE
+
+tsoProfFieldB :: ByteOff -> ByteOff
+tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
+
+stgSp = CmmReg sp
+stgHp = CmmReg hp
+stgCurrentTSO = CmmReg currentTSO
+stgCurrentNursery = CmmReg currentNursery
+
+sp = CmmGlobal Sp
+spLim = CmmGlobal SpLim
+hp = CmmGlobal Hp
+hpLim = CmmGlobal HpLim
+currentTSO = CmmGlobal CurrentTSO
+currentNursery = CmmGlobal CurrentNursery
+
+-- -----------------------------------------------------------------------------
+-- For certain types passed to foreign calls, we adjust the actual
+-- value passed to the call. Two main cases: for ForeignObj# we pass
+-- the pointer inside the ForeignObj# closure, and for ByteArray#/Array# we
+-- pass the address of the actual array, not the address of the heap object.
+
+shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
+shimForeignCallArg arg expr
+ | tycon == foreignObjPrimTyCon
+ = cmmLoadIndexW expr fixedHdrSize
+
+ | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+ = cmmOffsetB expr arrPtrsHdrSize
+
+ | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+ = cmmOffsetB expr arrWordsHdrSize
+
+ | otherwise = expr
+ where
+ -- should be a tycon app, since this is a foreign call
+ tycon = tyConAppTyCon (repType (stgArgType arg))
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.39 2003/07/28 16:05:35 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.40 2004/08/13 13:06:00 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
module CgHeapery (
- funEntryChecks, altHeapCheck, unbxTupleHeapCheck, thunkChecks,
- allocDynClosure,
+ initHeapUsage, getVirtHp, setVirtHp, setRealHp,
+ getHpRelOffset, hpRel,
- -- new functions, basically inserting macro calls into Code -- HWL
- ,fetchAndReschedule, yield
+ funEntryChecks, thunkEntryChecks,
+ altHeapCheck, unbxTupleHeapCheck,
+ hpChkGen, hpChkNodePointsAssignSp0,
+ stkChkGen, stkChkNodePoints,
+
+ layOutDynConstr, layOutStaticConstr,
+ mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
+
+ allocDynClosure, emitSetDynHdr
) where
#include "HsVersions.h"
-import AbsCSyn
+import Constants ( mIN_UPD_SIZE )
import StgSyn ( AltType(..) )
-import CLabel
+import CLabel ( CLabel, mkRtsCodeLabel )
+import CgUtils ( mkWordCLit, cmmRegOffW, cmmOffsetW,
+ cmmOffsetExprB )
import CgMonad
-import CgStackery ( getFinalStackHW )
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
- initHeapUsage
- )
-import CgRetConv ( dataReturnConvPrim )
-import ClosureInfo ( closureSize, closureGoodStuffSize,
- slopSize, allocProfilingMsg, ClosureInfo
- )
+import CgProf ( staticProfHdr, profDynAlloc, dynProfHdr )
+import CgTicky ( staticTickyHdr, tickyDynAlloc, tickyAllocHeap )
+import CgParallel ( staticGranHdr, staticParHdr, doGranAllocate )
+import CgStackery ( getFinalStackHW, getRealSp )
+import CgCallConv ( mkRegLiveness )
+import ClosureInfo ( closureSize, closureUpdReqd,
+ staticClosureNeedsLink,
+ mkConInfo,
+ infoTableLabelFromCI, closureLabelFromCI,
+ nodeMustPointToIt, closureLFInfo,
+ ClosureInfo )
+import SMRep ( CgRep(..), cgRepSizeW, separateByPtrFollowness,
+ WordOff, fixedHdrSize, isVoidArg, primRepToCgRep )
+
+import Cmm ( CmmLit(..), CmmStmt(..), CmmExpr(..), GlobalReg(..),
+ CmmReg(..), hpReg, nodeReg, spReg )
+import MachOp ( mo_wordULt, mo_wordUGt, mo_wordSub )
+import CmmUtils ( mkIntCLit, CmmStmts, noStmts, oneStmt, plusStmts,
+ mkStmts )
+import Id ( Id )
+import DataCon ( DataCon )
import TyCon ( tyConPrimRep )
-import PrimRep ( PrimRep(..), isFollowableRep )
-import CmdLineOpts ( opt_GranMacros )
+import CostCentre ( CostCentreStack )
+import Util ( mapAccumL, filterOut )
+import Constants ( wORD_SIZE )
import Outputable
-#ifdef DEBUG
-import PprAbsC ( pprMagicId )
-#endif
import GLAEXTS
+
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
+%* *
+%************************************************************************
+
+The heap always grows upwards, so hpRel is easy
+
+\begin{code}
+hpRel :: VirtualHpOffset -- virtual offset of Hp
+ -> VirtualHpOffset -- virtual offset of The Thing
+ -> WordOff -- integer word offset
+hpRel hp off = off - hp
+\end{code}
+
+@initHeapUsage@ applies a function to the amount of heap that it uses.
+It initialises the heap usage to zeros, and passes on an unchanged
+heap usage.
+
+It is usually a prelude to performing a GC check, so everything must
+be in a tidy and consistent state.
+
+rje: Note the slightly suble fixed point behaviour needed here
+
+\begin{code}
+initHeapUsage :: (VirtualHpOffset -> Code) -> Code
+initHeapUsage fcode
+ = do { orig_hp_usage <- getHpUsage
+ ; setHpUsage initHpUsage
+ ; fixC (\heap_usage2 -> do
+ { fcode (heapHWM heap_usage2)
+ ; getHpUsage })
+ ; setHpUsage orig_hp_usage }
+
+setVirtHp :: VirtualHpOffset -> Code
+setVirtHp new_virtHp
+ = do { hp_usage <- getHpUsage
+ ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
+
+getVirtHp :: FCode VirtualHpOffset
+getVirtHp
+ = do { hp_usage <- getHpUsage
+ ; return (virtHp hp_usage) }
+
+setRealHp :: VirtualHpOffset -> Code
+setRealHp new_realHp
+ = do { hp_usage <- getHpUsage
+ ; setHpUsage (hp_usage {realHp = new_realHp}) }
+
+getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
+getHpRelOffset virtual_offset
+ = do { hp_usg <- getHpUsage
+ ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Layout of heap objects
+%* *
+%************************************************************************
+
+\begin{code}
+layOutDynConstr, layOutStaticConstr
+ :: DataCon
+ -> [(CgRep,a)]
+ -> (ClosureInfo,
+ [(a,VirtualHpOffset)])
+
+layOutDynConstr = layOutConstr False
+layOutStaticConstr = layOutConstr True
+
+layOutConstr is_static data_con args
+ = (mkConInfo is_static data_con tot_wds ptr_wds,
+ things_w_offsets)
+ where
+ (tot_wds, -- #ptr_wds + #nonptr_wds
+ ptr_wds, -- #ptr_wds
+ things_w_offsets) = mkVirtHeapOffsets args
+\end{code}
+
+@mkVirtHeapOffsets@ always returns boxed things with smaller offsets
+than the unboxed things, and furthermore, the offsets in the result
+list
+
+\begin{code}
+mkVirtHeapOffsets
+ :: [(CgRep,a)] -- Things to make offsets for
+ -> (WordOff, -- *Total* number of words allocated
+ WordOff, -- Number of words allocated for *pointers*
+ [(a, VirtualHpOffset)])
+ -- Things with their offsets from start of
+ -- object in order of increasing offset
+
+-- First in list gets lowest offset, which is initial offset + 1.
+
+mkVirtHeapOffsets things
+ = let non_void_things = filterOut (isVoidArg . fst) things
+ (ptrs, non_ptrs) = separateByPtrFollowness non_void_things
+ (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
+ (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
+ in
+ (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
+ where
+ computeOffset wds_so_far (rep, thing)
+ = (wds_so_far + cgRepSizeW rep, (thing, fixedHdrSize + wds_so_far))
+\end{code}
+
+
+%************************************************************************
+%* *
+ Lay out a static closure
+%* *
+%************************************************************************
+
+Make a static closure, adding on any extra padding needed for CAFs,
+and adding a static link field if necessary.
+
+\begin{code}
+mkStaticClosureFields
+ :: ClosureInfo
+ -> CostCentreStack
+ -> Bool -- Has CAF refs
+ -> [CmmLit] -- Payload
+ -> [CmmLit] -- The full closure
+mkStaticClosureFields cl_info ccs caf_refs payload
+ = mkStaticClosure info_lbl ccs payload padding_wds static_link_field
+ where
+ info_lbl = infoTableLabelFromCI cl_info
+
+ upd_reqd = closureUpdReqd cl_info
+
+ -- for the purposes of laying out the static closure, we consider all
+ -- thunks to be "updatable", so that the static link field is always
+ -- in the same place.
+ padding_wds
+ | not upd_reqd = []
+ | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s
+ where n = max 0 (mIN_UPD_SIZE - length payload)
+
+ -- We always have a static link field for a thunk, it's used to
+ -- save the closure's info pointer when we're reverting CAFs
+ -- (see comment in Storage.c)
+ static_link_field
+ | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value]
+ | otherwise = []
+
+ -- for a static constructor which has NoCafRefs, we set the
+ -- static link field to a non-zero value so the garbage
+ -- collector will ignore it.
+ static_link_value
+ | caf_refs = mkIntCLit 0
+ | otherwise = mkIntCLit 1
+
+mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
+ -> [CmmLit] -> [CmmLit] -> [CmmLit]
+mkStaticClosure info_lbl ccs payload padding_wds static_link_field
+ = [CmmLabel info_lbl]
+ ++ variable_header_words
+ ++ payload
+ ++ padding_wds
+ ++ static_link_field
+ where
+ variable_header_words
+ = staticGranHdr
+ ++ staticParHdr
+ ++ staticProfHdr ccs
+ ++ staticTickyHdr
\end{code}
%************************************************************************
closures. If fetching is necessary (i.e. current closure is not local) then
an automatic context switch is done.
------------------------------------------------------------------------------
+--------------------------------------------------------------
A heap/stack check at a function or thunk entry point.
\begin{code}
-funEntryChecks :: Maybe CLabel -> AbstractC -> Code -> Code
-funEntryChecks closure_lbl reg_save_code code
- = hpStkCheck closure_lbl True reg_save_code code
-
-thunkChecks :: Maybe CLabel -> Code -> Code
-thunkChecks closure_lbl code
- = hpStkCheck closure_lbl False AbsCNop code
-
-hpStkCheck
- :: Maybe CLabel -- function closure
- -> Bool -- is a function? (not a thunk)
- -> AbstractC -- register saves
- -> Code
- -> Code
-
-hpStkCheck closure_lbl is_fun reg_save_code code
- = getFinalStackHW (\ spHw ->
- getRealSp `thenFC` \ sp ->
- let stk_words = spHw - sp in
- initHeapUsage (\ hHw ->
-
- getTickyCtrLabel `thenFC` \ ticky_ctr ->
-
- absC (checking_code stk_words hHw ticky_ctr) `thenC`
-
- setRealHp hHw `thenC`
- code))
-
+funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
+funEntryChecks cl_info reg_save_code code
+ = hpStkCheck cl_info True reg_save_code code
+
+thunkEntryChecks :: ClosureInfo -> Code -> Code
+thunkEntryChecks cl_info code
+ = hpStkCheck cl_info False noStmts code
+
+hpStkCheck :: ClosureInfo -- Function closure
+ -> Bool -- Is a function? (not a thunk)
+ -> CmmStmts -- Register saves
+ -> Code
+ -> Code
+
+hpStkCheck cl_info is_fun reg_save_code code
+ = getFinalStackHW $ \ spHw -> do
+ { sp <- getRealSp
+ ; let stk_words = spHw - sp
+ ; initHeapUsage $ \ hpHw -> do
+ { -- Emit heap checks, but be sure to do it lazily so
+ -- that the conditionals on hpHw don't cause a black hole
+ codeOnly $ do
+ { do_checks stk_words hpHw full_save_code rts_label
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
+ }
where
- node_asst
- | Just lbl <- closure_lbl = CAssign nodeReg (CLbl lbl PtrRep)
- | otherwise = AbsCNop
-
- save_code = mkAbstractCs [node_asst, reg_save_code]
-
- checking_code stk hp ctr
- = mkAbstractCs
- [ if is_fun
- then do_checks_fun stk hp save_code
- else do_checks_np stk hp save_code,
- if hp == 0
- then AbsCNop
- else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit hp, CLbl ctr DataPtrRep ]
- ]
-
-
--- For functions:
-
-do_checks_fun
- :: Int -- stack headroom
- -> Int -- heap headroom
- -> AbstractC -- assignments to perform on failure
- -> AbstractC
-do_checks_fun 0 0 _ = AbsCNop
-do_checks_fun 0 hp_words assts =
- CCheck HP_CHK_FUN [ mkIntCLit hp_words ] assts
-do_checks_fun stk_words 0 assts =
- CCheck STK_CHK_FUN [ mkIntCLit stk_words ] assts
-do_checks_fun stk_words hp_words assts =
- CCheck HP_STK_CHK_FUN [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
-
--- For thunks:
-
-do_checks_np
- :: Int -- stack headroom
- -> Int -- heap headroom
- -> AbstractC -- assignments to perform on failure
- -> AbstractC
-do_checks_np 0 0 _ = AbsCNop
-do_checks_np 0 hp_words assts =
- CCheck HP_CHK_NP [ mkIntCLit hp_words ] assts
-do_checks_np stk_words 0 assts =
- CCheck STK_CHK_NP [ mkIntCLit stk_words ] assts
-do_checks_np stk_words hp_words assts =
- CCheck HP_STK_CHK_NP [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
+ node_asst
+ | nodeMustPointToIt (closureLFInfo cl_info)
+ = noStmts
+ | otherwise
+ = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
+ closure_lbl = closureLabelFromCI cl_info
+
+ full_save_code = node_asst `plusStmts` reg_save_code
+
+ rts_label | is_fun = CmmReg (CmmGlobal GCFun)
+ -- Function entry point
+ | otherwise = CmmReg (CmmGlobal GCEnter1)
+ -- Thunk or case return
+ -- In the thunk/case-return case, R1 points to a closure
+ -- which should be (re)-entered after GC
\end{code}
Heap checks in a case alternative are nice and easy, provided this is
(either R1 or FloatReg1 or DblReg1). This means using specialised
heap-check code for these cases.
-For unboxed tuple returns, there are an arbitrary number of possibly
-unboxed return values, some of which will be in registers, and the
-others will be on the stack. We always organise the stack-resident
-fields into pointers & non-pointers, and pass the number of each to
-the heap check code.
-
\begin{code}
altHeapCheck
:: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
-> Code -- Continuation
-> Code
altHeapCheck alt_type code
- = initHeapUsage (\ hHw ->
- do_heap_chk hHw `thenC`
- setRealHp hHw `thenC`
- code)
+ = initHeapUsage $ \ hpHw -> do
+ { codeOnly $ do
+ { do_checks 0 {- no stack chk -} hpHw
+ noStmts {- nothign to save -}
+ (rts_label alt_type)
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
where
- do_heap_chk :: HeapOffset -> Code
- do_heap_chk words_required
- = getTickyCtrLabel `thenFC` \ ctr ->
- absC ( -- NB The conditional is inside the absC,
- -- so the monadic stuff doesn't depend on
- -- the value of words_required!
- if words_required == 0
- then AbsCNop
- else mkAbstractCs
- [ CCheck (checking_code alt_type)
- [mkIntCLit words_required] AbsCNop,
- profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
- ])
-
- checking_code PolyAlt
- = HP_CHK_UNPT_R1 -- Do *not* enter R1 after a heap check in
- -- a polymorphic case. It might be a function
- -- and the entry code for a function (currently)
- -- applies it
- --
- -- However R1 is guaranteed to be a pointer
-
- checking_code (AlgAlt tc)
- = HP_CHK_NP -- Enter R1 after the heap check; it's a pointer
- -- The "NP" is short for "Node (R1) Points to it"
+ rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")))
+ -- Do *not* enter R1 after a heap check in
+ -- a polymorphic case. It might be a function
+ -- and the entry code for a function (currently)
+ -- applies it
+ --
+ -- However R1 is guaranteed to be a pointer
+
+ rts_label (AlgAlt tc) = stg_gc_enter1
+ -- Enter R1 after the heap check; it's a pointer
- checking_code (PrimAlt tc)
- = case dataReturnConvPrim (tyConPrimRep tc) of
- VoidReg -> HP_CHK_NOREGS
- FloatReg 1# -> HP_CHK_F1
- DoubleReg 1# -> HP_CHK_D1
- LongReg _ 1# -> HP_CHK_L1
- VanillaReg rep 1#
- | isFollowableRep rep -> HP_CHK_UNPT_R1 -- R1 is boxed but unlifted:
- | otherwise -> HP_CHK_UNBX_R1 -- R1 is unboxed
-#ifdef DEBUG
- other_reg -> pprPanic "CgHeapery.altHeapCheck" (ppr tc <+> pprMagicId other_reg)
-#endif
-
--- Unboxed tuple alternatives and let-no-escapes (the two most annoying
--- constructs to generate code for!):
+ rts_label (PrimAlt tc)
+ = CmmLit $ CmmLabel $
+ case primRepToCgRep (tyConPrimRep tc) of
+ VoidArg -> mkRtsCodeLabel SLIT( "stg_gc_noregs")
+ FloatArg -> mkRtsCodeLabel SLIT( "stg_gc_f1")
+ DoubleArg -> mkRtsCodeLabel SLIT( "stg_gc_d1")
+ LongArg -> mkRtsCodeLabel SLIT( "stg_gc_l1")
+ -- R1 is boxed but unlifted:
+ PtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")
+ -- R1 is unboxed:
+ NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1")
+
+ rts_label (UbxTupAlt _) = panic "altHeapCheck"
+\end{code}
+
+Unboxed tuple alternatives and let-no-escapes (the two most annoying
+constructs to generate code for!) For unboxed tuple returns, there
+are an arbitrary number of possibly unboxed return values, some of
+which will be in registers, and the others will be on the stack. We
+always organise the stack-resident fields into pointers &
+non-pointers, and pass the number of each to the heap check code.
+
+\begin{code}
unbxTupleHeapCheck
- :: [MagicId] -- live registers
- -> Int -- no. of stack slots containing ptrs
- -> Int -- no. of stack slots containing nonptrs
- -> AbstractC -- code to insert in the failure path
+ :: [(Id, GlobalReg)] -- Live registers
+ -> WordOff -- no. of stack slots containing ptrs
+ -> WordOff -- no. of stack slots containing nonptrs
+ -> CmmStmts -- code to insert in the failure path
-> Code
-> Code
unbxTupleHeapCheck regs ptrs nptrs fail_code code
- -- we can't manage more than 255 pointers/non-pointers in a generic
- -- heap check.
+ -- We can't manage more than 255 pointers/non-pointers
+ -- in a generic heap check.
| ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
- | otherwise = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+ | otherwise
+ = initHeapUsage $ \ hpHw -> do
+ { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
+ full_fail_code rts_label
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
where
- do_heap_chk words_required
- = getTickyCtrLabel `thenFC` \ ctr ->
- absC ( if words_required == 0
- then AbsCNop
- else mkAbstractCs
- [ checking_code words_required,
- profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
- ]
- ) `thenC`
- setRealHp words_required
-
- liveness = I# (word2Int# (mkRegLiveness regs ptrs nptrs))
- checking_code words_required = CCheck HP_CHK_UNBX_TUPLE
- [mkIntCLit words_required,
- mkIntCLit liveness]
- fail_code
-
--- build up a bitmap of the live pointer registers
-
-#if __GLASGOW_HASKELL__ >= 503
-shiftL = uncheckedShiftL#
-#else
-shiftL = shiftL#
-#endif
-
-mkRegLiveness :: [MagicId] -> Int -> Int -> Word#
-mkRegLiveness [] (I# ptrs) (I# nptrs) =
- (int2Word# nptrs `shiftL` 16#) `or#` (int2Word# ptrs `shiftL` 24#)
-mkRegLiveness (VanillaReg rep i : regs) ptrs nptrs | isFollowableRep rep
- = ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs ptrs nptrs
-mkRegLiveness (_ : regs) ptrs nptrs = mkRegLiveness regs ptrs nptrs
-
--- The two functions below are only used in a GranSim setup
--- Emit macro for simulating a fetch and then reschedule
-
-fetchAndReschedule :: [MagicId] -- Live registers
- -> Bool -- Node reqd?
- -> Code
-
-fetchAndReschedule regs node_reqd =
- if (node `elem` regs || node_reqd)
- then fetch_code `thenC` reschedule_code
- else absC AbsCNop
- where
- liveness_mask = mkRegLiveness regs 0 0
- reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
- mkIntCLit (I# (word2Int# liveness_mask)),
- mkIntCLit (if node_reqd then 1 else 0)])
-
- --HWL: generate GRAN_FETCH macro for GrAnSim
- -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
- fetch_code = absC (CMacroStmt GRAN_FETCH [])
+ full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
+ assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho!
+ (CmmLit (mkWordCLit liveness))
+ liveness = mkRegLiveness regs ptrs nptrs
+ rts_label = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_ut")))
+
\end{code}
-The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
-allows to context-switch at places where @node@ is not alive (it uses the
-@Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
-this kind of macro at the beginning of the following kinds of basic bocks:
-\begin{itemize}
- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
- we use @fetchAndReschedule@ at a slow entry code.
- \item Fast entry code (see @CgClosure.lhs@).
- \item Alternatives in case expressions (@CLabelledCode@ structures), provided
- that they are not inlined (see @CgCases.lhs@). These alternatives will
- be turned into separate functions.
-\end{itemize}
+
+%************************************************************************
+%* *
+ Heap/Stack Checks.
+%* *
+%************************************************************************
+
+When failing a check, we save a return address on the stack and
+jump to a pre-compiled code fragment that saves the live registers
+and returns to the scheduler.
+
+The return address in most cases will be the beginning of the basic
+block in which the check resides, since we need to perform the check
+again on re-entry because someone else might have stolen the resource
+in the meantime.
\begin{code}
-yield :: [MagicId] -- Live registers
- -> Bool -- Node reqd?
- -> Code
-
-yield regs node_reqd =
- if opt_GranMacros && node_reqd
- then yield_code
- else absC AbsCNop
- where
- liveness_mask = mkRegLiveness regs 0 0
- yield_code =
- absC (CMacroStmt GRAN_YIELD
- [mkIntCLit (I# (word2Int# liveness_mask))])
+do_checks :: WordOff -- Stack headroom
+ -> WordOff -- Heap headroom
+ -> CmmStmts -- Assignments to perform on failure
+ -> CmmExpr -- Rts address to jump to on failure
+ -> Code
+do_checks 0 0 _ _ = nopC
+do_checks stk hp reg_save_code rts_lbl
+ = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE)))
+ (CmmLit (mkIntCLit (hp*wORD_SIZE)))
+ (stk /= 0) (hp /= 0) reg_save_code rts_lbl
+
+-- The offsets are now in *bytes*
+do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
+ = do { doGranAllocate hp_expr
+
+ -- Emit a block for the heap-check-failure code
+ ; blk_id <- forkLabelledCode $ do
+ { whenC hp_nonzero $
+ stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
+ ; emitStmts reg_save_code
+ ; stmtC (CmmJump rts_lbl []) }
+
+ -- Check for stack overflow *FIRST*; otherwise
+ -- we might bumping Hp and then failing stack oflo
+ ; whenC stk_nonzero
+ (stmtC (CmmCondBranch stk_oflo blk_id))
+
+ ; whenC hp_nonzero
+ (stmtsC [CmmAssign hpReg
+ (cmmOffsetExprB (CmmReg hpReg) hp_expr),
+ CmmCondBranch hp_oflo blk_id])
+ -- Bump heap pointer, and test for heap exhaustion
+ -- Note that we don't move the heap pointer unless the
+ -- stack check succeeds. Otherwise we might end up
+ -- with slop at the end of the current block, which can
+ -- confuse the LDV profiler.
+ }
+ where
+ -- Stk overflow if (Sp - stk_bytes < SpLim)
+ stk_oflo = CmmMachOp mo_wordULt
+ [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr],
+ CmmReg (CmmGlobal SpLim)]
+
+ -- Hp overflow if (Hpp > HpLim)
+ -- (Hp has been incremented by now)
+ -- HpLim points to the LAST WORD of valid allocation space.
+ hp_oflo = CmmMachOp mo_wordUGt
+ [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
+\end{code}
+
+%************************************************************************
+%* *
+ Generic Heap/Stack Checks - used in the RTS
+%* *
+%************************************************************************
+
+\begin{code}
+hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+hpChkGen bytes liveness reentry
+ = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
+ where
+ assigns = mkStmts [
+ CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
+ CmmAssign (CmmGlobal (VanillaReg 10)) reentry
+ ]
+
+-- a heap check where R1 points to the closure to enter on return, and
+-- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
+hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
+hpChkNodePointsAssignSp0 bytes sp0
+ = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
+ where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
+
+stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+stkChkGen bytes liveness reentry
+ = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
+ where
+ assigns = mkStmts [
+ CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
+ CmmAssign (CmmGlobal (VanillaReg 10)) reentry
+ ]
+
+stkChkNodePoints :: CmmExpr -> Code
+stkChkNodePoints bytes
+ = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
+
+stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_gen")))
+stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
\end{code}
%************************************************************************
\begin{code}
allocDynClosure
:: ClosureInfo
- -> CAddrMode -- Cost Centre to stick in the object
- -> CAddrMode -- Cost Centre to blame for this alloc
+ -> CmmExpr -- Cost Centre to stick in the object
+ -> CmmExpr -- Cost Centre to blame for this alloc
-- (usually the same; sometimes "OVERHEAD")
- -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
- -- ie Info ptr has offset zero.
- -> FCode VirtualHeapOffset -- Returns virt offset of object
+ -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object
+ -- ie Info ptr has offset zero.
+ -> FCode VirtualHpOffset -- Returns virt offset of object
-allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
- = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
+allocDynClosure cl_info use_cc blame_cc amodes_with_offsets
+ = do { virt_hp <- getVirtHp
-- FIND THE OFFSET OF THE INFO-PTR WORD
- -- virtHp points to last allocated word, ie 1 *before* the
- -- info-ptr word of new object.
- let info_offset = virtHp + 1
-
- -- do_move IS THE ASSIGNMENT FUNCTION
- do_move (amode, offset_from_start)
- = CAssign (CVal (hpRel realHp
- (info_offset + offset_from_start))
- (getAmodeRep amode))
- amode
- in
+ ; let info_offset = virt_hp + 1
+ -- info_offset is the VirtualHpOffset of the first
+ -- word of the new object
+ -- Remember, virtHp points to last allocated word,
+ -- ie 1 *before* the info-ptr word of new object.
+
+ info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
+ hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..]
+
-- SAY WHAT WE ARE ABOUT TO DO
- profCtrC (allocProfilingMsg closure_info)
- [mkIntCLit (closureGoodStuffSize closure_info),
- mkIntCLit slop_size] `thenC`
+ ; profDynAlloc cl_info use_cc
+ -- ToDo: This is almost certainly wrong
+ -- We're ignoring blame_cc. But until we've
+ -- fixed the boxing hack in chooseDynCostCentres etc,
+ -- we're worried about making things worse by "fixing"
+ -- this part to use blame_cc!
- -- GENERATE THE CODE
- absC ( mkAbstractCs (
- [ CInitHdr closure_info
- (CAddr (hpRel realHp info_offset))
- use_cc closure_size ]
- ++ (map do_move amodes_with_offsets))) `thenC`
+ ; tickyDynAlloc cl_info
- -- BUMP THE VIRTUAL HEAP POINTER
- setVirtHp (virtHp + closure_size) `thenC`
+ -- ALLOCATE THE OBJECT
+ ; base <- getHpRelOffset info_offset
+ ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
+ -- BUMP THE VIRTUAL HEAP POINTER
+ ; setVirtHp (virt_hp + closureSize cl_info)
+
-- RETURN PTR TO START OF OBJECT
- returnFC info_offset
- where
- closure_size = closureSize closure_info
- slop_size = slopSize closure_info
+ ; returnFC info_offset }
+
+
+initDynHdr :: CmmExpr
+ -> CmmExpr -- Cost centre to put in object
+ -> [CmmExpr]
+initDynHdr info_ptr cc
+ = [info_ptr]
+ -- ToDo: Gransim stuff
+ -- ToDo: Parallel stuff
+ ++ dynProfHdr cc
+ -- No ticky header
+
+hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
+-- Store the item (expr,off) in base[off]
+hpStore base es
+ = stmtsC [ CmmStore (cmmOffsetW base off) val
+ | (val, off) <- es ]
+
+emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+emitSetDynHdr base info_ptr ccs
+ = hpStore base (zip (initDynHdr info_ptr ccs) [0..])
\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Building info tables.
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CgInfoTbls (
+ emitClosureCodeAndInfoTable,
+ emitInfoTableAndCode,
+ dataConTagZ,
+ getSRTInfo,
+ emitDirectReturnTarget, emitAlgReturnTarget,
+ emitDirectReturnInstr, emitVectoredReturnInstr,
+ mkRetInfoTable,
+ mkStdInfoTable,
+ mkFunGenInfoExtraBits,
+ entryCode, closureInfoPtr,
+ getConstrTag,
+ infoTable, infoTableClosureType,
+ infoTablePtrs, infoTableNonPtrs,
+ funInfoTable,
+ vectorSlot,
+ ) where
+
+
+#include "HsVersions.h"
+
+import ClosureInfo ( ClosureInfo, closureTypeDescr, closureName,
+ infoTableLabelFromCI, Liveness,
+ closureValDescr, closureSRT, closureSMRep,
+ closurePtrsSize, closureNonHdrSize, closureFunInfo,
+ C_SRT(..), needsSRT, isConstrClosure_maybe,
+ ArgDescr(..) )
+import SMRep ( StgHalfWord, hALF_WORD_SIZE_IN_BITS, hALF_WORD_SIZE,
+ WordOff, ByteOff,
+ smRepClosureTypeInt, tablesNextToCode,
+ rET_BIG, rET_SMALL, rET_VEC_BIG, rET_VEC_SMALL )
+import CgBindery ( getLiveStackSlots )
+import CgCallConv ( isBigLiveness, mkLivenessCLit, buildContLiveness,
+ argDescrType, getSequelAmode,
+ CtrlReturnConvention(..) )
+import CgUtils ( mkStringCLit, packHalfWordsCLit, mkWordCLit,
+ cmmOffsetB, cmmOffsetExprW, cmmLabelOffW, cmmOffsetW,
+ emitDataLits, emitRODataLits, emitSwitch, cmmNegate )
+import CgMonad
+
+import CmmUtils ( mkIntCLit, zeroCLit )
+import Cmm ( CmmStmt(..), CmmExpr(..), CmmLit(..), LocalReg,
+ CmmBasicBlock, nodeReg )
+import MachOp ( MachOp(..), wordRep, halfWordRep )
+import CLabel
+import StgSyn ( SRT(..) )
+import Name ( Name )
+import DataCon ( DataCon, dataConTag, fIRST_TAG )
+import Unique ( Uniquable(..) )
+import CmdLineOpts ( opt_SccProfilingOn )
+import ListSetOps ( assocDefault )
+import Maybes ( isJust )
+import Constants ( wORD_SIZE, sIZEOF_StgFunInfoExtra )
+import Outputable
+
+
+-------------------------------------------------------------------------
+--
+-- Generating the info table and code for a closure
+--
+-------------------------------------------------------------------------
+
+-- Here we make a concrete info table, represented as a list of CmmAddr
+-- (it can't be simply a list of Word, because the SRT field is
+-- represented by a label+offset expression).
+
+-- With tablesNextToCode, the layout is
+-- <reversed variable part>
+-- <normal forward StgInfoTable, but without
+-- an entry point at the front>
+-- <code>
+--
+-- Without tablesNextToCode, the layout of an info table is
+-- <entry label>
+-- <normal forward rest of StgInfoTable>
+-- <forward variable part>
+--
+-- See includes/InfoTables.h
+
+emitClosureCodeAndInfoTable :: ClosureInfo -> [LocalReg] -> CgStmts -> Code
+emitClosureCodeAndInfoTable cl_info args body
+ = do { ty_descr_lit <-
+ if opt_SccProfilingOn
+ then mkStringCLit (closureTypeDescr cl_info)
+ else return (mkIntCLit 0)
+ ; cl_descr_lit <-
+ if opt_SccProfilingOn
+ then mkStringCLit cl_descr_string
+ else return (mkIntCLit 0)
+ ; let std_info = mkStdInfoTable ty_descr_lit cl_descr_lit
+ cl_type srt_len layout_lit
+
+ ; blks <- cgStmtsToBlocks body
+ ; emitInfoTableAndCode info_lbl std_info extra_bits args blks }
+ where
+ info_lbl = infoTableLabelFromCI cl_info
+
+ cl_descr_string = closureValDescr cl_info
+ cl_type = smRepClosureTypeInt (closureSMRep cl_info)
+
+ srt = closureSRT cl_info
+ needs_srt = needsSRT srt
+
+ mb_con = isConstrClosure_maybe cl_info
+ is_con = isJust mb_con
+
+ (srt_label,srt_len)
+ = case mb_con of
+ Just con -> -- Constructors don't have an SRT
+ -- We keep the *zero-indexed* tag in the srt_len
+ -- field of the info table.
+ (mkIntCLit 0, fromIntegral (dataConTagZ con))
+
+ Nothing -> -- Not a constructor
+ srtLabelAndLength srt
+
+ ptrs = closurePtrsSize cl_info
+ nptrs = size - ptrs
+ size = closureNonHdrSize cl_info
+ layout_lit = packHalfWordsCLit ptrs nptrs
+
+ extra_bits
+ | is_fun = fun_extra_bits
+ | is_con = []
+ | needs_srt = [srt_label]
+ | otherwise = []
+
+ maybe_fun_stuff = closureFunInfo cl_info
+ is_fun = isJust maybe_fun_stuff
+ (Just (arity, arg_descr)) = maybe_fun_stuff
+
+ fun_extra_bits
+ | ArgGen liveness <- arg_descr
+ = [ fun_amode,
+ srt_label,
+ mkLivenessCLit liveness,
+ CmmLabel (mkSlowEntryLabel (closureName cl_info)) ]
+ | needs_srt = [fun_amode, srt_label]
+ | otherwise = [fun_amode]
+
+ fun_amode = packHalfWordsCLit fun_type arity
+ fun_type = argDescrType arg_descr
+
+-- We keep the *zero-indexed* tag in the srt_len field of the info
+-- table of a data constructor.
+dataConTagZ :: DataCon -> ConTagZ
+dataConTagZ con = dataConTag con - fIRST_TAG
+
+-- A low-level way to generate the variable part of a fun-style info table.
+-- (must match fun_extra_bits above). Used by the C-- parser.
+mkFunGenInfoExtraBits :: Int -> Int -> CmmLit -> CmmLit -> CmmLit -> [CmmLit]
+mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry
+ = [ packHalfWordsCLit fun_type arity,
+ srt_label,
+ liveness,
+ slow_entry ]
+
+-------------------------------------------------------------------------
+--
+-- Generating the info table and code for a return point
+--
+-------------------------------------------------------------------------
+
+-- Here's the layout of a return-point info table
+--
+-- Tables next to code:
+--
+-- <reversed vector table>
+-- <srt slot>
+-- <standard info table>
+-- ret-addr --> <entry code (if any)>
+--
+-- Not tables-next-to-code:
+--
+-- ret-addr --> <ptr to entry code>
+-- <standard info table>
+-- <srt slot>
+-- <forward vector table>
+--
+-- * The vector table is only present for vectored returns
+--
+-- * The SRT slot is only there if either
+-- (a) there is SRT info to record, OR
+-- (b) if the return is vectored
+-- The latter (b) is necessary so that the vector is in a
+-- predictable place
+
+vectorSlot :: CmmExpr -> CmmExpr -> CmmExpr
+-- Get the vector slot from the info pointer
+vectorSlot info_amode zero_indexed_tag
+ | tablesNextToCode
+ = cmmOffsetExprW (cmmOffsetW info_amode (- (stdInfoTableSizeW + 2)))
+ (cmmNegate zero_indexed_tag)
+ -- The "2" is one for the SRT slot, and one more
+ -- to get to the first word of the vector
+
+ | otherwise
+ = cmmOffsetExprW (cmmOffsetW info_amode (stdInfoTableSizeW + 2))
+ zero_indexed_tag
+ -- The "2" is one for the entry-code slot and one for the SRT slot
+
+
+emitReturnTarget
+ :: Name
+ -> CgStmts -- The direct-return code (if any)
+ -- (empty for vectored returns)
+ -> [CLabel] -- Vector of return points
+ -- (empty for non-vectored returns)
+ -> SRT
+ -> FCode CLabel
+emitReturnTarget name stmts vector srt
+ = do { live_slots <- getLiveStackSlots
+ ; liveness <- buildContLiveness name live_slots
+ ; srt_info <- getSRTInfo name srt
+
+ ; let
+ cl_type = case (null vector, isBigLiveness liveness) of
+ (True, True) -> rET_BIG
+ (True, False) -> rET_SMALL
+ (False, True) -> rET_VEC_BIG
+ (False, False) -> rET_VEC_SMALL
+
+ (std_info, extra_bits) =
+ mkRetInfoTable liveness srt_info cl_type vector
+
+ ; blks <- cgStmtsToBlocks stmts
+ ; emitInfoTableAndCode info_lbl std_info extra_bits args blks
+ ; return info_lbl }
+ where
+ args = trace "emitReturnTarget: missing args" []
+ uniq = getUnique name
+ info_lbl = mkReturnInfoLabel uniq
+
+
+mkRetInfoTable
+ :: Liveness -- liveness
+ -> C_SRT -- SRT Info
+ -> Int -- type (eg. rET_SMALL)
+ -> [CLabel] -- vector
+ -> ([CmmLit],[CmmLit])
+mkRetInfoTable liveness srt_info cl_type vector
+ = (std_info, extra_bits)
+ where
+ (srt_label, srt_len) = srtLabelAndLength srt_info
+
+ srt_slot | need_srt = [srt_label]
+ | otherwise = []
+
+ need_srt = needsSRT srt_info || not (null vector)
+ -- If there's a vector table then we must allocate
+ -- an SRT slot, so that the vector table is at a
+ -- known offset from the info pointer
+
+ liveness_lit = mkLivenessCLit liveness
+ std_info = mkStdInfoTable zeroCLit zeroCLit cl_type srt_len liveness_lit
+ extra_bits = srt_slot ++ map CmmLabel vector
+
+
+emitDirectReturnTarget
+ :: Name
+ -> CgStmts -- The direct-return code
+ -> SRT
+ -> FCode CLabel
+emitDirectReturnTarget name code srt
+ = emitReturnTarget name code [] srt
+
+emitAlgReturnTarget
+ :: Name -- Just for its unique
+ -> [(ConTagZ, CgStmts)] -- Tagged branches
+ -> Maybe CgStmts -- Default branch (if any)
+ -> SRT -- Continuation's SRT
+ -> CtrlReturnConvention
+ -> FCode (CLabel, SemiTaggingStuff)
+
+emitAlgReturnTarget name branches mb_deflt srt ret_conv
+ = case ret_conv of
+ UnvectoredReturn fam_sz -> do
+ { blks <- getCgStmts $
+ emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
+ -- NB: tag_expr is zero-based
+ ; lbl <- emitDirectReturnTarget name blks srt
+ ; return (lbl, Nothing) }
+ -- Nothing: the internal branches in the switch don't have
+ -- global labels, so we can't use them at the 'call site'
+
+ VectoredReturn fam_sz -> do
+ { tagged_lbls <- mapFCs emit_alt branches
+ ; deflt_lbl <- emit_deflt mb_deflt
+ ; let vector = [ assocDefault deflt_lbl tagged_lbls i
+ | i <- [0..fam_sz-1]]
+ ; lbl <- emitReturnTarget name noCgStmts vector srt
+ ; return (lbl, Just (tagged_lbls, deflt_lbl)) }
+ where
+ uniq = getUnique name
+ tag_expr = getConstrTag (CmmReg nodeReg)
+
+ emit_alt :: (Int, CgStmts) -> FCode (Int, CLabel)
+ -- Emit the code for the alternative as a top-level
+ -- code block returning a label for it
+ emit_alt (tag, stmts) = do { let lbl = mkAltLabel uniq tag
+ ; blks <- cgStmtsToBlocks stmts
+ ; emitProc [] lbl [] blks
+ ; return (tag, lbl) }
+
+ emit_deflt (Just stmts) = do { let lbl = mkDefaultLabel uniq
+ ; blks <- cgStmtsToBlocks stmts
+ ; emitProc [] lbl [] blks
+ ; return lbl }
+ emit_deflt Nothing = return mkErrorStdEntryLabel
+ -- Nothing case: the simplifier might have eliminated a case
+ -- so we may have e.g. case xs of
+ -- [] -> e
+ -- In that situation the default should never be taken,
+ -- so we just use mkErrorStdEntryLabel
+
+--------------------------------
+emitDirectReturnInstr :: Code
+emitDirectReturnInstr
+ = do { info_amode <- getSequelAmode
+ ; stmtC (CmmJump (entryCode info_amode) []) }
+
+emitVectoredReturnInstr :: CmmExpr -- *Zero-indexed* constructor tag
+ -> Code
+emitVectoredReturnInstr zero_indexed_tag
+ = do { info_amode <- getSequelAmode
+ ; let slot = vectorSlot info_amode zero_indexed_tag
+ ; stmtC (CmmJump (CmmLoad slot wordRep) []) }
+
+
+
+-------------------------------------------------------------------------
+--
+-- Generating a standard info table
+--
+-------------------------------------------------------------------------
+
+-- The standard bits of an info table. This part of the info table
+-- corresponds to the StgInfoTable type defined in InfoTables.h.
+--
+-- Its shape varies with ticky/profiling/tables next to code etc
+-- so we can't use constant offsets from Constants
+
+mkStdInfoTable
+ :: CmmLit -- closure type descr (profiling)
+ -> CmmLit -- closure descr (profiling)
+ -> Int -- closure type
+ -> StgHalfWord -- SRT length
+ -> CmmLit -- layout field
+ -> [CmmLit]
+
+mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
+ = -- Parallel revertible-black hole field
+ prof_info
+ -- Ticky info (none at present)
+ -- Debug info (none at present)
+ ++ [layout_lit, type_lit]
+
+ where
+ prof_info
+ | opt_SccProfilingOn = [closure_descr, type_descr]
+ | otherwise = []
+
+ type_lit = packHalfWordsCLit cl_type srt_len
+
+stdInfoTableSizeW :: WordOff
+-- The size of a standard info table varies with profiling/ticky etc,
+-- so we can't get it from Constants
+-- It must vary in sync with mkStdInfoTable
+stdInfoTableSizeW
+ = size_fixed + size_prof
+ where
+ size_fixed = 2 -- layout, type
+ size_prof | opt_SccProfilingOn = 2
+ | otherwise = 0
+
+stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
+
+stdSrtBitmapOffset :: ByteOff
+-- Byte offset of the SRT bitmap half-word which is
+-- in the *higher-addressed* part of the type_lit
+stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
+
+stdClosureTypeOffset :: ByteOff
+-- Byte offset of the closure type half-word
+stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
+
+stdPtrsOffset, stdNonPtrsOffset :: ByteOff
+stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE
+stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
+
+-------------------------------------------------------------------------
+--
+-- Accessing fields of an info table
+--
+-------------------------------------------------------------------------
+
+closureInfoPtr :: CmmExpr -> CmmExpr
+-- Takes a closure pointer and returns the info table pointer
+closureInfoPtr e = CmmLoad e wordRep
+
+entryCode :: CmmExpr -> CmmExpr
+-- Takes an info pointer (the first word of a closure)
+-- and returns its entry code
+entryCode e | tablesNextToCode = e
+ | otherwise = CmmLoad e wordRep
+
+getConstrTag :: CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the *zero-indexed*
+-- constructor tag obtained from the info table
+-- This lives in the SRT field of the info table
+-- (constructors don't need SRTs).
+getConstrTag closure_ptr
+ = CmmMachOp (MO_U_Conv halfWordRep wordRep) [infoTableConstrTag info_table]
+ where
+ info_table = infoTable (closureInfoPtr closure_ptr)
+
+infoTable :: CmmExpr -> CmmExpr
+-- Takes an info pointer (the first word of a closure)
+-- and returns a pointer to the first word of the standard-form
+-- info table, excluding the entry-code word (if present)
+infoTable info_ptr
+ | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
+ | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer
+
+infoTableConstrTag :: CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the constr tag
+-- field of the info table (same as the srt_bitmap field)
+infoTableConstrTag = infoTableSrtBitmap
+
+infoTableSrtBitmap :: CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
+-- field of the info table
+infoTableSrtBitmap info_tbl
+ = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) halfWordRep
+
+infoTableClosureType :: CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the closure type
+-- field of the info table.
+infoTableClosureType info_tbl
+ = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) halfWordRep
+
+infoTablePtrs :: CmmExpr -> CmmExpr
+infoTablePtrs info_tbl
+ = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) halfWordRep
+
+infoTableNonPtrs :: CmmExpr -> CmmExpr
+infoTableNonPtrs info_tbl
+ = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) halfWordRep
+
+funInfoTable :: CmmExpr -> CmmExpr
+-- Takes the info pointer of a function,
+-- and returns a pointer to the first word of the StgFunInfoExtra struct
+-- in the info table.
+funInfoTable info_ptr
+ | tablesNextToCode
+ = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtra)
+ | otherwise
+ = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
+ -- Past the entry code pointer
+
+-------------------------------------------------------------------------
+--
+-- Emit the code for a closure (or return address)
+-- and its associated info table
+--
+-------------------------------------------------------------------------
+
+-- The complication here concerns whether or not we can
+-- put the info table next to the code
+
+emitInfoTableAndCode
+ :: CLabel -- Label of info table
+ -> [CmmLit] -- ...its invariant part
+ -> [CmmLit] -- ...and its variant part
+ -> [LocalReg] -- ...args
+ -> [CmmBasicBlock] -- ...and body
+ -> Code
+
+emitInfoTableAndCode info_lbl std_info extra_bits args blocks
+ | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
+ = emitProc (reverse extra_bits ++ std_info)
+ entry_lbl args blocks
+ -- NB: the info_lbl is discarded
+
+ | null blocks -- No actual code; only the info table is significant
+ = -- Use a zero place-holder in place of the
+ -- entry-label in the info table
+ emitRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)
+
+ | otherwise -- Separately emit info table (with the function entry
+ = -- point as first entry) and the entry code
+ do { emitDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)
+ ; emitProc [] entry_lbl args blocks }
+
+ where
+ entry_lbl = infoLblToEntryLbl info_lbl
+
+-------------------------------------------------------------------------
+--
+-- Static reference tables
+--
+-------------------------------------------------------------------------
+
+-- 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.
+
+getSRTInfo :: Name -> SRT -> FCode C_SRT
+getSRTInfo id NoSRT = return NoC_SRT
+getSRTInfo id (SRT off len bmp)
+ | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
+ = do { srt_lbl <- getSRTLabel
+ ; let srt_desc_lbl = mkSRTDescLabel id
+ ; emitRODataLits srt_desc_lbl
+ ( cmmLabelOffW srt_lbl off
+ : mkWordCLit (fromIntegral len)
+ : map mkWordCLit bmp)
+ ; return (C_SRT srt_desc_lbl 0 srt_escape) }
+
+ | otherwise
+ = do { srt_lbl <- getSRTLabel
+ ; return (C_SRT srt_lbl off (fromIntegral (head bmp))) }
+ -- The fromIntegral converts to StgHalfWord
+
+srt_escape = (-1) :: StgHalfWord
+
+srtLabelAndLength :: C_SRT -> (CmmLit, StgHalfWord)
+srtLabelAndLength NoC_SRT = (zeroCLit, 0)
+srtLabelAndLength (C_SRT lbl off bitmap) = (cmmLabelOffW lbl off, bitmap)
+
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.24 2003/07/21 11:01:07 simonmar Exp $
+% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $
%
%********************************************************
%* *
import StgSyn
import CgMonad
-import AbsCSyn
import CgBindery ( CgIdInfo, letNoEscapeIdInfo, nukeDeadBindings )
-import CgCase ( mkRetDirectTarget, restoreCurrentCostCentre )
+import CgCase ( restoreCurrentCostCentre )
import CgCon ( bindUnboxedTupleComponents )
import CgHeapery ( unbxTupleHeapCheck )
-import CgStackery ( allocStackTop, deAllocStackTop )
-import CgUsages ( getSpRelOffset )
+import CgInfoTbls ( emitDirectReturnTarget )
+import CgStackery ( allocStackTop, deAllocStackTop, getSpRelOffset )
+import Cmm ( CmmStmt(..) )
+import CmmUtils ( mkLblExpr, oneStmt )
import CLabel ( mkReturnInfoLabel )
import ClosureInfo ( mkLFLetNoEscape )
import CostCentre ( CostCentreStack )
-import Id ( Id )
+import Id ( Id, idName )
import Var ( idUnique )
-import PrimRep ( PrimRep(..), retPrimRepSize )
+import SMRep ( retAddrSizeW )
import BasicTypes ( RecFlag(..) )
+import Outputable
\end{code}
%************************************************************************
arity = length args
lf_info = mkLFLetNoEscape arity
in
-
-- saveVolatileVarsAndRegs done earlier in cgExpr.
- forkEvalHelp
- rhs_eob_info
+ do { (vSp, _) <- forkEvalHelp rhs_eob_info
+
+ (do { allocStackTop retAddrSizeW
+ ; nukeDeadBindings full_live_in_rhss })
- (allocStackTop retPrimRepSize `thenFC` \_ ->
- nukeDeadBindings full_live_in_rhss)
+ (do { deAllocStackTop retAddrSizeW
+ ; abs_c <- forkProc $ cgLetNoEscapeBody bndr cc
+ cc_slot args body
- (deAllocStackTop retPrimRepSize `thenFC` \_ ->
- forkAbsC (
- cgLetNoEscapeBody bndr cc cc_slot args body
- ) `thenFC` \ abs_c ->
- mkRetDirectTarget bndr abs_c srt
- -- Ignore the label that comes back from
- -- mkRetDirectTarget. It must be conjured up elswhere
- ) `thenFC` \ (vSp, _) ->
+ -- Ignore the label that comes back from
+ -- mkRetDirectTarget. It must be conjured up elswhere
+ ; emitDirectReturnTarget (idName bndr) abs_c srt
+ ; return () })
- returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info)
+ ; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) }
\end{code}
\begin{code}
-> StgExpr -- Body
-> Code
-cgLetNoEscapeBody bndr cc cc_slot all_args body
- = bindUnboxedTupleComponents all_args `thenFC` \ (arg_regs, ptrs, nptrs, ret_slot) ->
+cgLetNoEscapeBody bndr cc cc_slot all_args body = do
+ { (arg_regs, ptrs, nptrs, ret_slot) <- bindUnboxedTupleComponents all_args
-- restore the saved cost centre. BUT: we must not free the stack slot
-- containing the cost centre, because it might be needed for a
-- recursive call to this let-no-escape.
- restoreCurrentCostCentre cc_slot False{-don't free-} `thenC`
+ ; restoreCurrentCostCentre cc_slot False{-don't free-}
-- Enter the closures cc, if required
- --enterCostCentreCode closure_info cc IsFunction `thenC`
+ ; -- enterCostCentreCode closure_info cc IsFunction
-- The "return address" slot doesn't have a return address in it;
-- but the heap-check needs it filled in if the heap-check fails.
-- So we pass code to fill it in to the heap-check macro
- getSpRelOffset ret_slot `thenFC` \ sp_rel ->
- let lbl = mkReturnInfoLabel (idUnique bndr)
- frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep)
- in
+ ; sp_rel <- getSpRelOffset ret_slot
+
+ ; let lbl = mkReturnInfoLabel (idUnique bndr)
+ frame_hdr_asst = oneStmt (CmmStore sp_rel (mkLblExpr lbl))
-- Do heap check [ToDo: omit for non-recursive case by recording in
-- in envt and absorbing at call site]
- unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst (
- cgExpr body
- )
+ ; unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst
+ (cgExpr body)
+ }
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.39 2003/07/02 13:12:38 simonpj Exp $
+% $Id: CgMonad.lhs,v 1.40 2004/08/13 13:06:03 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
FCode, -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
- returnFC, fixC, absC, nopC, getAbsC,
+ returnFC, fixC, checkedAbsC,
+ stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
+ newUnique, newUniqSupply,
+ CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
+ getCgStmts', getCgStmts,
+ noCgStmts, oneCgStmt, consCgStmt,
+
+ getCmm,
+ emitData, emitProc, emitSimpleProc,
+
+ forkLabelledCode,
forkClosureBody, forkStatics, forkAlts, forkEval,
- forkEvalHelp, forkAbsC,
- SemiTaggingStuff,
+ forkEvalHelp, forkProc, codeOnly,
+ SemiTaggingStuff, ConTagZ,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
- setSRTLabel, getSRTLabel, getSRTInfo,
+ setSRTLabel, getSRTLabel,
setTickyCtrLabel, getTickyCtrLabel,
- StackUsage, Slot(..), HeapUsage,
-
- profCtrC, profCtrAbsC, ldvEnter,
+ StackUsage(..), HeapUsage(..),
+ VirtualSpOffset, VirtualHpOffset,
+ initStkUsage, initHpUsage,
+ getHpUsage, setHpUsage,
+ heapHWM,
- costCentresC, moduleName,
+ 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,
+ getStkUsage, setStkUsage,
getBinds, setBinds, getStaticBinds,
-- out of general friendliness, we also export ...
- CgInfoDownwards(..), CgState(..), -- non-abstract
- CompilationInfo(..)
+ CgInfoDownwards(..), CgState(..) -- non-abstract
) where
#include "HsVersions.h"
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
-import {-# SOURCE #-} CgUsages ( getSpRelOffset )
-import AbsCSyn
+import Cmm
+import CmmUtils ( CmmStmts, isNopStmt )
import CLabel
-import StgSyn ( SRT(..) )
-import AbsCUtils ( mkAbsCStmts )
-import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
+import SMRep ( WordOff )
import Module ( Module )
-import DataCon ( ConTag )
import Id ( Id )
-import Name ( Name )
import VarEnv
-import PrimRep ( PrimRep(..) )
-import SMRep ( StgHalfWord, hALF_WORD )
+import OrdList
+import Unique ( Unique )
+import Util ( mapAccumL )
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
import FastString
import Outputable
\begin{code}
data CgInfoDownwards -- information only passed *downwards* by the monad
- = MkCgInfoDown
- CompilationInfo -- COMPLETELY STATIC info about this compilation
- -- (e.g., what flags were passed to the compiler)
-
- CgBindings -- [Id -> info] : static environment
-
- CLabel -- label of the current SRT
-
- CLabel -- current destination for ticky counts
-
- EndOfBlockInfo -- Info for stuff to do at end of basic block:
-
-
-data CompilationInfo
- = MkCompInfo
- Module -- the module name
+ = MkCgInfoDown {
+ cgd_mod :: Module, -- Module being compiled
+ cgd_statics :: CgBindings, -- [Id -> info] : static environment
+ cgd_srt :: CLabel, -- label of the current SRT
+ cgd_ticky :: CLabel, -- current destination for ticky counts
+ cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
+ }
+
+initCgInfoDown :: Module -> CgInfoDownwards
+initCgInfoDown mod
+ = MkCgInfoDown { cgd_mod = mod,
+ cgd_statics = emptyVarEnv,
+ cgd_srt = error "initC: srt",
+ cgd_ticky = mkTopTickyCtrLabel,
+ cgd_eob = initEobInfo }
data CgState
- = MkCgState
- AbstractC -- code accumulated so far
- CgBindings -- [Id -> info] : *local* bindings environment
- -- Bindings for top-level things are given in the info-down part
- CgStksAndHeapUsage
+ = MkCgState {
+ cgs_stmts :: OrdList CgStmt, -- Current proc
+ cgs_tops :: OrdList CmmTop,
+ -- Other procedures and data blocks in this compilation unit
+ -- Both the latter two are ordered only so that we can
+ -- reduce forward references, when it's easy to do so
+
+ cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
+ -- Bindings for top-level things are given in
+ -- the info-down part
+
+ cgs_stk_usg :: StackUsage,
+ cgs_hp_usg :: HeapUsage,
+
+ cgs_uniqs :: UniqSupply }
+
+initCgState :: UniqSupply -> CgState
+initCgState uniqs
+ = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
+ cgs_binds = emptyVarEnv,
+ cgs_stk_usg = initStkUsage,
+ cgs_hp_usg = initHpUsage,
+ cgs_uniqs = uniqs }
\end{code}
@EndOfBlockInfo@ tells what to do at the end of this block of code or,
-- by a case alternative.
Sequel
-initEobInfo = EndOfBlockInfo 0 (OnStack 0)
+initEobInfo = EndOfBlockInfo 0 OnStack
\end{code}
Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
\begin{code}
data Sequel
- = OnStack
- VirtualSpOffset -- Continuation is on the stack, at the
- -- specified location
-
- | UpdateCode
+ = OnStack -- Continuation is on the stack
+ | UpdateCode -- Continuation is update
| 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)
+ CLabel -- Jump to this; if the continuation is for a vectored
+ -- case this might be the label of a return vector
SemiTaggingStuff
-
+ Id -- The case binder, only used to see if it's dead
Bool -- True <=> polymorphic, push a SEQ frame too
-
type SemiTaggingStuff
- = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
- ([(ConTag, JoinDetails)], -- Alternatives
- Maybe (Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
- -- The default branch expects a
- -- it expects a ptr to the thing
- -- in Node, bound to b
- )
-
-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
+ = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
+ ([(ConTagZ, CLabel)], -- Alternatives
+ CLabel) -- Default (will be a can't happen RTS label if can't happen)
+
+type ConTagZ = Int -- A *zero-indexed* contructor tag
+
+-- The case branch 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.
+\end{code}
+
+%************************************************************************
+%* *
+ CgStmt type
+%* *
+%************************************************************************
+
+The CgStmts type is what the code generator outputs: it is a tree of
+statements, including in-line labels. The job of flattenCgStmts is to
+turn this into a list of basic blocks, each of which ends in a jump
+statement (either a local branch or a non-local jump).
+
+\begin{code}
+type CgStmts = OrdList CgStmt
+
+data CgStmt
+ = CgStmt CmmStmt
+ | CgLabel BlockId
+ | CgFork BlockId CgStmts
+
+flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
+flattenCgStmts id stmts =
+ case flatten (fromOL stmts) of
+ ([],blocks) -> blocks
+ (block,blocks) -> BasicBlock id block : blocks
+ where
+ flatten [] = ([],[])
+
+ -- A label at the end of a function or fork: this label must not be reachable,
+ -- but it might be referred to from another BB that also isn't reachable.
+ -- Eliminating these has to be done with a dead-code analysis. For now,
+ -- we just make it into a well-formed block by adding a recursive jump.
+ flatten [CgLabel id]
+ = ( [], [BasicBlock id [CmmBranch id]] )
+
+ -- A jump/branch: throw away all the code up to the next label, because
+ -- it is unreachable. Be careful to keep forks that we find on the way.
+ flatten (CgStmt stmt : stmts)
+ | isJump stmt
+ = case dropWhile isOrdinaryStmt stmts of
+ [] -> ( [stmt], [] )
+ [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
+ (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
+ where (block,blocks) = flatten stmts
+ (CgFork fork_id stmts : ss) ->
+ flatten (CgFork fork_id stmts : CgStmt stmt : ss)
+
+ flatten (s:ss) =
+ case s of
+ CgStmt stmt -> (stmt:block,blocks)
+ CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
+ CgFork fork_id stmts ->
+ (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
+ where (fork_block, fork_blocks) = flatten (fromOL stmts)
+ where (block,blocks) = flatten ss
+
+isJump (CmmJump _ _) = True
+isJump (CmmBranch _) = True
+isJump _ = False
+
+isOrdinaryStmt (CgStmt _) = True
+isOrdinaryStmt _ = False
+\end{code}
+
+%************************************************************************
+%* *
+ Stack and heap models
+%* *
+%************************************************************************
--- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only
--- valid just before the final control transfer, because it assumes
--- that Sp is pointing to the top word of the return address. This
--- seems unclean but there you go.
-
--- sequelToAmode returns an amode which refers to an info table. The info
--- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
--- not to handle real code pointers, just in case we're compiling for
--- an unregisterised/untailcallish architecture, where info pointers and
--- code pointers aren't the same.
-
-sequelToAmode :: Sequel -> FCode CAddrMode
-
-sequelToAmode (OnStack virt_sp_offset)
- = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
- returnFC (CVal sp_rel RetRep)
-
-sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
-
-sequelToAmode (CaseAlts amode _ False) = returnFC amode
-sequelToAmode (CaseAlts amode _ True) = returnFC (CLbl mkSeqInfoLabel RetRep)
-
-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, -- 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
- HeapOffset) -- realHp: Virtual offset of real heap ptr
+\begin{code}
+type VirtualHpOffset = WordOff -- Both are in
+type VirtualSpOffset = WordOff -- units of words
+
+data StackUsage
+ = StackUsage {
+ virtSp :: VirtualSpOffset,
+ -- Virtual offset of topmost allocated slot
+
+ frameSp :: VirtualSpOffset,
+ -- Virtual offset of the return address of the enclosing frame.
+ -- This RA describes the liveness/pointedness of
+ -- all the stack from frameSp downwards
+ -- INVARIANT: less than or equal to virtSp
+
+ freeStk :: [VirtualSpOffset],
+ -- List of free slots, in *increasing* order
+ -- INVARIANT: all <= virtSp
+ -- All slots <= virtSp are taken except these ones
+
+ realSp :: VirtualSpOffset,
+ -- Virtual offset of real stack pointer register
+
+ hwSp :: VirtualSpOffset
+ } -- Highest value ever taken by virtSp
+
+-- INVARAINT: The environment contains no Stable references to
+-- stack slots below (lower offset) frameSp
+-- It can contain volatile references to this area though.
+
+data HeapUsage =
+ HeapUsage {
+ virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
+ realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
+ }
\end{code}
-NB: absolutely every one of the above Ints is really
-a VirtualOffset of some description (the code generator
-works entirely in terms of VirtualOffsets).
+The heap high water mark is the larger of virtHp and hwHp. The latter is
+only records the high water marks of forked-off branches, so to find the
+heap high water mark you have to take the max of virtHp and hwHp. Remember,
+virtHp never retreats!
-Initialisation.
+Note Jan 04: ok, so why do we only look at the virtual Hp??
\begin{code}
-initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
+heapHWM :: HeapUsage -> VirtualHpOffset
+heapHWM = virtHp
+\end{code}
-initUsage :: CgStksAndHeapUsage
-initUsage = ((0,0,[],0,0), (0,0))
+Initialisation.
+
+\begin{code}
+initStkUsage :: StackUsage
+initStkUsage = StackUsage {
+ virtSp = 0,
+ frameSp = 0,
+ freeStk = [],
+ realSp = 0,
+ hwSp = 0
+ }
+
+initHpUsage :: HeapUsage
+initHpUsage = HeapUsage {
+ virtHp = 0,
+ realHp = 0
+ }
\end{code}
@stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
\begin{code}
stateIncUsage :: CgState -> CgState -> CgState
+stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
+ = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
+ cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
+ `addCodeBlocksFrom` s2
+
+stateIncUsageEval :: CgState -> CgState -> CgState
+stateIncUsageEval s1 s2
+ = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
+ `addCodeBlocksFrom` s2
+ -- 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.
-stateIncUsage (MkCgState abs_c bs ((v,t,f,r,h1),(vH1,rH1)))
- (MkCgState _ _ ((_,_,_,_,h2),(vH2, _)))
- = MkCgState abs_c
- bs
- ((v,t,f,r,h1 `max` h2),
- (vH1 `max` vH2, rH1))
+addCodeBlocksFrom :: CgState -> CgState -> CgState
+-- Add code blocks from the latter to the former
+-- (The cgs_stmts will often be empty, but not always; see codeOnly)
+s1 `addCodeBlocksFrom` s2
+ = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
+ cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
+
+maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
+hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
+
+maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
+stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
\end{code}
%************************************************************************
%* *
-\subsection[CgMonad-basics]{Basic code-generation monad magic}
+ The FCode monad
%* *
%************************************************************************
\begin{code}
newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
-type Code = FCode ()
+type Code = FCode ()
instance Monad FCode where
(>>=) = thenFC
The Abstract~C is not in the environment so as to improve strictness.
\begin{code}
-initC :: CompilationInfo -> Code -> AbstractC
-
-initC cg_info (FCode code)
- = case (code (MkCgInfoDown
- cg_info
- emptyVarEnv -- (error "initC: statics")
- (error "initC: srt")
- (mkTopTickyCtrLabel)
- initEobInfo)
- initialStateC) of
- ((),MkCgState abc _ _) -> abc
+initC :: Module -> FCode a -> IO a
+
+initC mod (FCode code)
+ = do { uniqs <- mkSplitUniqSupply 'c'
+ ; case code (initCgInfoDown mod) (initCgState uniqs) of
+ (res, _) -> return res
+ }
returnFC :: a -> FCode a
returnFC val = FCode (\info_down state -> (val, state))
)
\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.
+%************************************************************************
+%* *
+ Operators for getting and setting the state and "info_down".
+
+%* *
+%************************************************************************
\begin{code}
getState :: FCode CgState
setState :: CgState -> FCode ()
setState state = FCode $ \info_down _ -> ((),state)
-getUsage :: FCode CgStksAndHeapUsage
-getUsage = do
- MkCgState absC binds usage <- getState
- return usage
+getStkUsage :: FCode StackUsage
+getStkUsage = do
+ state <- getState
+ return $ cgs_stk_usg state
-setUsage :: CgStksAndHeapUsage -> FCode ()
-setUsage newusage = do
- MkCgState absC binds usage <- getState
- setState $ MkCgState absC binds newusage
+setStkUsage :: StackUsage -> Code
+setStkUsage new_stk_usg = do
+ state <- getState
+ setState $ state {cgs_stk_usg = new_stk_usg}
+
+getHpUsage :: FCode HeapUsage
+getHpUsage = do
+ state <- getState
+ return $ cgs_hp_usg state
+
+setHpUsage :: HeapUsage -> Code
+setHpUsage new_hp_usg = do
+ state <- getState
+ setState $ state {cgs_hp_usg = new_hp_usg}
getBinds :: FCode CgBindings
getBinds = do
- MkCgState absC binds usage <- getState
- return binds
+ state <- getState
+ return $ cgs_binds state
setBinds :: CgBindings -> FCode ()
-setBinds newbinds = do
- MkCgState absC binds usage <- getState
- setState $ MkCgState absC newbinds usage
+setBinds new_binds = do
+ state <- getState
+ setState $ state {cgs_binds = new_binds}
getStaticBinds :: FCode CgBindings
getStaticBinds = do
- (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
- return static_binds
+ info <- getInfoDown
+ return (cgd_statics info)
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)
+newUniqSupply :: FCode UniqSupply
+newUniqSupply = do
+ state <- getState
+ let (us1, us2) = splitUniqSupply (cgs_uniqs state)
+ setState $ state { cgs_uniqs = us1 }
+ return us2
+
+newUnique :: FCode Unique
+newUnique = do
+ us <- newUniqSupply
+ return (uniqFromSupply us)
+
+------------------
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)
\end{code}
+%************************************************************************
+%* *
+ Forking
+%* *
+%************************************************************************
+
@forkClosureBody@ takes a code, $c$, and compiles it in a completely
fresh environment, except that:
- compilation info and statics are passed in unchanged.
The current environment is passed on completely unaltered, except that
abstract C from the fork is incorporated.
-@forkAbsC@ takes a code and compiles it in the current environment,
-returning the abstract C thus constructed. The current environment
-is passed on completely unchanged. It is pretty similar to @getAbsC@,
-except that the latter does affect the environment. ToDo: combine?
+@forkProc@ takes a code and compiles it in the current environment,
+returning the basic blocks thus constructed. The current environment
+is passed on completely unchanged. It is pretty similar to
+@getBlocks@, except that the latter does affect the environment.
@forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
from the current bindings, but which is otherwise freshly initialised.
\begin{code}
forkClosureBody :: Code -> Code
-
-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
+forkClosureBody body_code
+ = do { info <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let body_info_down = info { cgd_eob = initEobInfo }
+ ((),fork_state) = doFCode body_code body_info_down
+ (initCgState us)
+ ; ASSERT( isNilOL (cgs_stmts fork_state) )
+ setState $ state `addCodeBlocksFrom` fork_state }
forkStatics :: FCode a -> FCode a
-
-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 (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
+forkStatics body_code
+ = do { info <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let rhs_info_down = info { cgd_statics = cgs_binds state,
+ cgd_eob = initEobInfo }
+ (result, fork_state_out) = doFCode body_code rhs_info_down
+ (initCgState us)
+ ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
+ setState (state `addCodeBlocksFrom` fork_state_out)
+ ; return result }
+
+forkProc :: Code -> FCode CgStmts
+forkProc body_code
+ = do { info_down <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let fork_state_in = (initCgState us)
+ { cgs_binds = cgs_binds state,
+ cgs_stk_usg = cgs_stk_usg state,
+ cgs_hp_usg = cgs_hp_usg state }
+ -- ToDo: is the hp usage necesary?
+ (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
+ info_down fork_state_in
+ ; setState $ state `stateIncUsageEval` fork_state_out
+ ; return code_blks }
+
+codeOnly :: Code -> Code
+-- Emit any code from the inner thing into the outer thing
+-- Do not affect anything else in the outer state
+-- Used in almost-circular code to prevent false loop dependencies
+codeOnly body_code
+ = do { info_down <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
+ cgs_stk_usg = cgs_stk_usg state,
+ cgs_hp_usg = cgs_hp_usg state }
+ ((), fork_state_out) = doFCode body_code info_down fork_state_in
+ ; setState $ state `addCodeBlocksFrom` fork_state_out }
\end{code}
@forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
forkAlts :: [FCode a] -> FCode [a]
forkAlts branch_fcodes
- = 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)
- setState $ foldl stateIncUsage in_state branch_out_states
- -- NB foldl. in_state is the *left* argument to stateIncUsage
- return branch_results
+ = do { info_down <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let compile us branch
+ = (us2, doFCode branch info_down branch_state)
+ where
+ (us1,us2) = splitUniqSupply us
+ branch_state = (initCgState us1) {
+ cgs_binds = cgs_binds state,
+ cgs_stk_usg = cgs_stk_usg state,
+ cgs_hp_usg = cgs_hp_usg state }
+
+ (_us, results) = mapAccumL compile us branch_fcodes
+ (branch_results, branch_out_states) = unzip results
+ ; setState $ foldl stateIncUsage state branch_out_states
+ -- NB foldl. state is the *left* argument to stateIncUsage
+ ; return branch_results }
\end{code}
@forkEval@ takes two blocks of code.
-> FCode EndOfBlockInfo -- The new end of block info
forkEval body_eob_info env_code body_code
- = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
- returnFC (EndOfBlockInfo v sequel)
+ = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
+ ; returnFC (EndOfBlockInfo v sequel) }
forkEvalHelp :: EndOfBlockInfo -- For the body
-> Code -- Code to set environment
-> FCode a -- The code to do after the eval
- -> FCode (Int, -- Sp
- a) -- Result of the FCode
-
-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,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,t,f,r,h1),heap_usage))
- (MkCgState absC2 _ ((_,_,_,_,h2), _))
- = MkCgState (absC1 `mkAbsCStmts` absC2)
- -- The AbsC coming back should consist only of nested declarations,
+ -> FCode (VirtualSpOffset, -- Sp
+ a) -- Result of the FCode
+ -- A disturbingly complicated function
+forkEvalHelp body_eob_info env_code body_code
+ = do { info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
+ ; us <- newUniqSupply
+ ; state <- getState
+ ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
+ ; (_, env_state) = doFCode env_code info_down_for_body
+ (state {cgs_uniqs = us})
+ ; state_for_body = (initCgState (cgs_uniqs env_state))
+ { cgs_binds = binds_for_body,
+ cgs_stk_usg = stk_usg_for_body }
+ ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
+ ; stk_usg_from_env = cgs_stk_usg env_state
+ ; virtSp_from_env = virtSp stk_usg_from_env
+ ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
+ hwSp = virtSp_from_env}
+ ; (value_returned, state_at_end_return)
+ = doFCode body_code info_down_for_body state_for_body
+ }
+ ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
+ -- The code coming back should consist only of nested declarations,
-- notably of the return vector!
- bs
- ((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.
-\end{code}
+ setState $ state `stateIncUsageEval` state_at_end_return
+ ; return (virtSp_from_env, value_returned) }
-%************************************************************************
-%* *
-\subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
-%* *
-%************************************************************************
-@nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
-environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
-\begin{code}
+-- ----------------------------------------------------------------------------
+-- Combinators for emitting code
+
nopC :: Code
nopC = return ()
-absC :: AbstractC -> Code
-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
-info (whether SCC profiling or profiling-ctrs going) and possibly emit
-nothing.
-
-\begin{code}
-costCentresC :: FastString -> [CAddrMode] -> Code
-costCentresC macro args
- | opt_SccProfilingOn = absC (CCallProfCCMacro macro args)
- | otherwise = nopC
-
-profCtrC :: FastString -> [CAddrMode] -> Code
-profCtrC macro args
- | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args)
- | otherwise = nopC
-
-profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC
-profCtrAbsC macro args
- | opt_DoTickyProfiling = CCallProfCtrMacro macro args
- | otherwise = AbsCNop
-
-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
- targets, so that we can get away with as few variants of .hc files
- as possible.
--}
-\end{code}
-
-@getAbsC@ compiles the code in the current environment, and returns
-the abstract C thus constructed (leaving the abstract C being carried
-around in the state untouched). @getAbsC@ does not generate any
-in-line Abstract~C itself, but the environment it returns is that
-obtained from the compilation.
+whenC :: Bool -> Code -> Code
+whenC True code = code
+whenC False code = nopC
+
+stmtC :: CmmStmt -> Code
+stmtC stmt = emitCgStmt (CgStmt stmt)
+
+labelC :: BlockId -> Code
+labelC id = emitCgStmt (CgLabel id)
+
+newLabelC :: FCode BlockId
+newLabelC = do { id <- newUnique; return (BlockId id) }
+
+checkedAbsC :: CmmStmt -> Code
+-- Emit code, eliminating no-ops
+checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
+ else unitOL stmt)
+
+stmtsC :: [CmmStmt] -> Code
+stmtsC stmts = emitStmts (toOL stmts)
+
+-- Emit code; no no-op checking
+emitStmts :: CmmStmts -> Code
+emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
+
+-- forkLabelledCode is for emitting a chunk of code with a label, outside
+-- of the current instruction stream.
+forkLabelledCode :: Code -> FCode BlockId
+forkLabelledCode code = getCgStmts code >>= forkCgStmts
+
+emitCgStmt :: CgStmt -> Code
+emitCgStmt stmt
+ = do { state <- getState
+ ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
+ }
+
+emitData :: Section -> [CmmStatic] -> Code
+emitData sect lits
+ = do { state <- getState
+ ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
+ where
+ data_block = CmmData sect lits
+
+emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
+emitProc lits lbl args blocks
+ = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
+ ; state <- getState
+ ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+
+emitSimpleProc :: CLabel -> Code -> Code
+-- Emit a procedure whose body is the specified code; no info table
+emitSimpleProc lbl code
+ = do { stmts <- getCgStmts code
+ ; blks <- cgStmtsToBlocks stmts
+ ; emitProc [] lbl [] blks }
+
+getCmm :: Code -> FCode Cmm
+-- Get all the CmmTops (there should be no stmts)
+getCmm code
+ = do { state1 <- getState
+ ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
+ ; setState $ state2 { cgs_tops = cgs_tops state1 }
+ ; return (Cmm (fromOL (cgs_tops state2))) }
+
+-- ----------------------------------------------------------------------------
+-- CgStmts
+
+-- These functions deal in terms of CgStmts, which is an abstract type
+-- representing the code in the current proc.
+
+
+-- emit CgStmts into the current instruction stream
+emitCgStmts :: CgStmts -> Code
+emitCgStmts stmts
+ = do { state <- getState
+ ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
+
+-- emit CgStmts outside the current instruction stream, and return a label
+forkCgStmts :: CgStmts -> FCode BlockId
+forkCgStmts stmts
+ = do { id <- newLabelC
+ ; emitCgStmt (CgFork id stmts)
+ ; return id
+ }
+
+-- turn CgStmts into [CmmBasicBlock], for making a new proc.
+cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
+cgStmtsToBlocks stmts
+ = do { id <- newLabelC
+ ; return (flattenCgStmts id stmts)
+ }
+
+-- collect the code emitted by an FCode computation
+getCgStmts' :: FCode a -> FCode (a, CgStmts)
+getCgStmts' fcode
+ = do { state1 <- getState
+ ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
+ ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
+ ; return (a, cgs_stmts state2) }
+
+getCgStmts :: FCode a -> FCode CgStmts
+getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
+
+-- Simple ways to construct CgStmts:
+noCgStmts :: CgStmts
+noCgStmts = nilOL
+
+oneCgStmt :: CmmStmt -> CgStmts
+oneCgStmt stmt = unitOL (CgStmt stmt)
+
+consCgStmt :: CmmStmt -> CgStmts -> CgStmts
+consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
+
+-- ----------------------------------------------------------------------------
+-- Get the current module name
-\begin{code}
-getAbsC :: Code -> FCode AbstractC
-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 = do
- (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
- return mod_name
-\end{code}
+moduleName = do { info <- getInfoDown; return (cgd_mod info) }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the end-of-block info
-\begin{code}
setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
setEndOfBlockInfo eob_info code = do
- (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
- withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
+ info <- getInfoDown
+ withInfoDown code (info {cgd_eob = eob_info})
getEndOfBlockInfo :: FCode EndOfBlockInfo
getEndOfBlockInfo = do
- (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
- return eob_info
-\end{code}
+ info <- getInfoDown
+ return (cgd_eob info)
-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.
+-- ----------------------------------------------------------------------------
+-- Get/set the current SRT label
-\begin{code}
-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
+-- 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.
getSRTLabel :: FCode CLabel -- Used only by cgPanic
-getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
- return srt_lbl
+getSRTLabel = do info <- getInfoDown
+ return (cgd_srt info)
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}
+ = do info <- getInfoDown
+ withInfoDown code (info { cgd_srt = srt_lbl})
+
+-- ----------------------------------------------------------------------------
+-- Get/set the current ticky counter label
-\begin{code}
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = do
- (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
- return ticky
+ info <- getInfoDown
+ return (cgd_ticky info)
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)
+ info <- getInfoDown
+ withInfoDown code (info {cgd_ticky = ticky})
\end{code}
--- /dev/null
+-- Code generation relaed to GpH
+-- (a) parallel
+-- (b) GranSim
+
+module CgParallel(
+ staticGranHdr,staticParHdr,
+ granFetchAndReschedule, granYield,
+ doGranAllocate
+ ) where
+
+import CgMonad
+import CgCallConv ( mkRegLiveness )
+import Id ( Id )
+import Cmm ( CmmLit, GlobalReg(..), node, CmmExpr )
+import CmdLineOpts ( opt_GranMacros )
+import Outputable
+
+staticParHdr :: [CmmLit]
+-- Parallel header words in a static closure
+staticParHdr = []
+
+--------------------------------------------------------
+-- GranSim stuff
+--------------------------------------------------------
+
+staticGranHdr :: [CmmLit]
+-- Gransim header words in a static closure
+staticGranHdr = []
+
+doGranAllocate :: CmmExpr -> Code
+-- macro DO_GRAN_ALLOCATE
+doGranAllocate hp
+ | not opt_GranMacros = nopC
+ | otherwise = panic "doGranAllocate"
+
+
+
+-------------------------
+granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers
+ -> Bool -- Node reqd?
+ -> Code
+-- Emit code for simulating a fetch and then reschedule.
+granFetchAndReschedule regs node_reqd
+ | opt_GranMacros && (node `elem` map snd regs || node_reqd)
+ = do { fetch
+ ; reschedule liveness node_reqd }
+ | otherwise
+ = nopC
+ where
+ liveness = mkRegLiveness regs 0 0
+
+fetch = panic "granFetch"
+ -- Was: absC (CMacroStmt GRAN_FETCH [])
+ --HWL: generate GRAN_FETCH macro for GrAnSim
+ -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
+
+reschedule liveness node_reqd = panic "granReschedule"
+ -- Was: absC (CMacroStmt GRAN_RESCHEDULE [
+ -- mkIntCLit (I# (word2Int# liveness_mask)),
+ -- mkIntCLit (if node_reqd then 1 else 0)])
+
+
+-------------------------
+-- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
+-- allows to context-switch at places where @node@ is not alive (it uses the
+-- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
+-- this kind of macro at the beginning of the following kinds of basic bocks:
+-- \begin{itemize}
+-- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
+-- we use @fetchAndReschedule@ at a slow entry code.
+-- \item Fast entry code (see @CgClosure.lhs@).
+-- \item Alternatives in case expressions (@CLabelledCode@ structures), provided
+-- that they are not inlined (see @CgCases.lhs@). These alternatives will
+-- be turned into separate functions.
+
+granYield :: [(Id,GlobalReg)] -- Live registers
+ -> Bool -- Node reqd?
+ -> Code
+
+granYield regs node_reqd
+ | opt_GranMacros && node_reqd = yield liveness
+ | otherwise = nopC
+ where
+ liveness = mkRegLiveness regs 0 0
+
+yield liveness = panic "granYield"
+ -- Was : absC (CMacroStmt GRAN_YIELD
+ -- [mkIntCLit (I# (word2Int# liveness_mask))])
+
+
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Code generation for PrimOps.
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CgPrimOp (
+ cgPrimOp
+ ) where
+
+import StgSyn ( StgLiveVars, StgArg )
+import CgBindery ( getVolatileRegs, getArgAmodes )
+import CgMonad
+import CgInfoTbls ( getConstrTag )
+import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW )
+import Cmm
+import CLabel ( mkMAP_FROZEN_infoLabel )
+import CmmUtils
+import MachOp
+import SMRep
+import PrimOp ( PrimOp(..) )
+import SMRep ( tablesNextToCode )
+import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS )
+import Outputable
+
+-- ---------------------------------------------------------------------------
+-- Code generation for PrimOps
+
+cgPrimOp :: [CmmReg] -- where to put the results
+ -> PrimOp -- the op
+ -> [StgArg] -- arguments
+ -> StgLiveVars -- live vars, in case we need to save them
+ -> Code
+
+cgPrimOp results op args live
+ = do arg_exprs <- getArgAmodes args
+ let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ]
+ emitPrimOp results op non_void_args live
+
+
+emitPrimOp :: [CmmReg] -- where to put the results
+ -> PrimOp -- the op
+ -> [CmmExpr] -- arguments
+ -> StgLiveVars -- live vars, in case we need to save them
+ -> Code
+
+-- First we handle various awkward cases specially. The remaining
+-- easy cases are then handled by translateOp, defined below.
+
+emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] live
+{-
+ With some bit-twiddling, we can define int{Add,Sub}Czh portably in
+ C, and without needing any comparisons. This may not be the
+ fastest way to do it - if you have better code, please send it! --SDM
+
+ Return : r = a + b, c = 0 if no overflow, 1 on overflow.
+
+ We currently don't make use of the r value if c is != 0 (i.e.
+ overflow), we just convert to big integers and try again. This
+ could be improved by making r and c the correct values for
+ plugging into a new J#.
+
+ { r = ((I_)(a)) + ((I_)(b)); \
+ c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
+ >> (BITS_IN (I_) - 1); \
+ }
+ Wading through the mass of bracketry, it seems to reduce to:
+ c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
+
+-}
+ = stmtsC [
+ CmmAssign res_r (CmmMachOp mo_wordAdd [aa,bb]),
+ CmmAssign res_c $
+ CmmMachOp mo_wordUShr [
+ CmmMachOp mo_wordAnd [
+ CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]],
+ CmmMachOp mo_wordXor [aa, CmmReg res_r]
+ ],
+ CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
+ ]
+ ]
+
+
+emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] live
+{- Similarly:
+ #define subIntCzh(r,c,a,b) \
+ { r = ((I_)(a)) - ((I_)(b)); \
+ c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
+ >> (BITS_IN (I_) - 1); \
+ }
+
+ c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
+-}
+ = stmtsC [
+ CmmAssign res_r (CmmMachOp mo_wordSub [aa,bb]),
+ CmmAssign res_c $
+ CmmMachOp mo_wordUShr [
+ CmmMachOp mo_wordAnd [
+ CmmMachOp mo_wordXor [aa,bb],
+ CmmMachOp mo_wordXor [aa, CmmReg res_r]
+ ],
+ CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
+ ]
+ ]
+
+
+emitPrimOp [res] ParOp [arg] live
+ = stmtC (CmmAssign res (CmmLit (mkIntCLit 1)))
+
+emitPrimOp [res] ReadMutVarOp [mutv] live
+ = stmtC (CmmAssign res (cmmLoadIndexW mutv fixedHdrSize))
+
+emitPrimOp [] WriteMutVarOp [mutv,var] live
+ = stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
+
+emitPrimOp [res] ForeignObjToAddrOp [fo] live
+ = stmtC (CmmAssign res (cmmLoadIndexW fo fixedHdrSize))
+
+emitPrimOp [] WriteForeignObjOp [fo,addr] live
+ = stmtC (CmmStore (cmmOffsetW fo fixedHdrSize) addr)
+
+-- #define sizzeofByteArrayzh(r,a) \
+-- r = (((StgArrWords *)(a))->words * sizeof(W_))
+emitPrimOp [res] SizeofByteArrayOp [arg] live
+ = stmtC $
+ CmmAssign res (CmmMachOp mo_wordMul [
+ cmmLoadIndexW arg fixedHdrSize,
+ CmmLit (mkIntCLit wORD_SIZE)
+ ])
+
+-- #define sizzeofMutableByteArrayzh(r,a) \
+-- r = (((StgArrWords *)(a))->words * sizeof(W_))
+emitPrimOp [res] SizeofMutableByteArrayOp [arg] live
+ = emitPrimOp [res] SizeofByteArrayOp [arg] live
+
+
+-- #define touchzh(o) /* nothing */
+emitPrimOp [] TouchOp [arg] live
+ = nopC
+
+-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
+emitPrimOp [res] ByteArrayContents_Char [arg] live
+ = stmtC (CmmAssign res (cmmOffsetB arg arrWordsHdrSize))
+
+-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
+emitPrimOp [res] StableNameToIntOp [arg] live
+ = stmtC (CmmAssign res (cmmLoadIndexW arg fixedHdrSize))
+
+-- #define eqStableNamezh(r,sn1,sn2) \
+-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
+emitPrimOp [res] EqStableNameOp [arg1,arg2] live
+ = stmtC (CmmAssign res (CmmMachOp mo_wordEq [
+ cmmLoadIndexW arg1 fixedHdrSize,
+ cmmLoadIndexW arg2 fixedHdrSize
+ ]))
+
+
+emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] live
+ = stmtC (CmmAssign res (CmmMachOp mo_wordEq [arg1,arg2]))
+
+-- #define addrToHValuezh(r,a) r=(P_)a
+emitPrimOp [res] AddrToHValueOp [arg] live
+ = stmtC (CmmAssign res arg)
+
+-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
+emitPrimOp [res] DataToTagOp [arg] live
+ = stmtC (CmmAssign res (getConstrTag arg))
+
+{- Freezing arrays-of-ptrs requires changing an info table, for the
+ benefit of the generational collector. It needs to scavenge mutable
+ objects, even if they are in old space. When they become immutable,
+ they can be removed from this scavenge list. -}
+
+-- #define unsafeFreezzeArrayzh(r,a)
+-- {
+-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info);
+-- r = a;
+-- }
+emitPrimOp [res] UnsafeFreezeArrayOp [arg] live
+ = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
+ CmmAssign res arg ]
+
+-- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
+emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] live
+ = stmtC (CmmAssign res arg)
+
+-- Reading/writing pointer arrays
+
+emitPrimOp [r] ReadArrayOp [obj,ix] live = doReadPtrArrayOp r obj ix
+emitPrimOp [r] IndexArrayOp [obj,ix] live = doReadPtrArrayOp r obj ix
+emitPrimOp [] WriteArrayOp [obj,ix,v] live = doWritePtrArrayOp obj ix v
+
+-- IndexXXXoffForeignObj
+
+emitPrimOp res IndexOffForeignObjOp_Char args live = doIndexOffForeignObjOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res IndexOffForeignObjOp_WideChar args live = doIndexOffForeignObjOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res IndexOffForeignObjOp_Int args live = doIndexOffForeignObjOp Nothing wordRep res args
+emitPrimOp res IndexOffForeignObjOp_Word args live = doIndexOffForeignObjOp Nothing wordRep res args
+emitPrimOp res IndexOffForeignObjOp_Addr args live = doIndexOffForeignObjOp Nothing wordRep res args
+emitPrimOp res IndexOffForeignObjOp_Float args live = doIndexOffForeignObjOp Nothing F32 res args
+emitPrimOp res IndexOffForeignObjOp_Double args live = doIndexOffForeignObjOp Nothing F64 res args
+emitPrimOp res IndexOffForeignObjOp_StablePtr args live = doIndexOffForeignObjOp Nothing wordRep res args
+emitPrimOp res IndexOffForeignObjOp_Int8 args live = doIndexOffForeignObjOp (Just mo_s_8ToWord) I8 res args
+emitPrimOp res IndexOffForeignObjOp_Int16 args live = doIndexOffForeignObjOp (Just mo_s_16ToWord) I16 res args
+emitPrimOp res IndexOffForeignObjOp_Int32 args live = doIndexOffForeignObjOp (Just mo_s_32ToWord) I32 res args
+emitPrimOp res IndexOffForeignObjOp_Int64 args live = doIndexOffForeignObjOp Nothing I64 res args
+emitPrimOp res IndexOffForeignObjOp_Word8 args live = doIndexOffForeignObjOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res IndexOffForeignObjOp_Word16 args live = doIndexOffForeignObjOp (Just mo_u_16ToWord) I16 res args
+emitPrimOp res IndexOffForeignObjOp_Word32 args live = doIndexOffForeignObjOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res IndexOffForeignObjOp_Word64 args live = doIndexOffForeignObjOp Nothing I64 res args
+
+-- IndexXXXoffAddr
+
+emitPrimOp res IndexOffAddrOp_Char args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res IndexOffAddrOp_WideChar args live = doIndexOffAddrOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res IndexOffAddrOp_Int args live = doIndexOffAddrOp Nothing wordRep res args
+emitPrimOp res IndexOffAddrOp_Word args live = doIndexOffAddrOp Nothing wordRep res args
+emitPrimOp res IndexOffAddrOp_Addr args live = doIndexOffAddrOp Nothing wordRep res args
+emitPrimOp res IndexOffAddrOp_Float args live = doIndexOffAddrOp Nothing F32 res args
+emitPrimOp res IndexOffAddrOp_Double args live = doIndexOffAddrOp Nothing F64 res args
+emitPrimOp res IndexOffAddrOp_StablePtr args live = doIndexOffAddrOp Nothing wordRep res args
+emitPrimOp res IndexOffAddrOp_Int8 args live = doIndexOffAddrOp (Just mo_s_8ToWord) I8 res args
+emitPrimOp res IndexOffAddrOp_Int16 args live = doIndexOffAddrOp (Just mo_s_16ToWord) I16 res args
+emitPrimOp res IndexOffAddrOp_Int32 args live = doIndexOffAddrOp (Just mo_s_32ToWord) I32 res args
+emitPrimOp res IndexOffAddrOp_Int64 args live = doIndexOffAddrOp Nothing I64 res args
+emitPrimOp res IndexOffAddrOp_Word8 args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res IndexOffAddrOp_Word16 args live = doIndexOffAddrOp (Just mo_u_16ToWord) I16 res args
+emitPrimOp res IndexOffAddrOp_Word32 args live = doIndexOffAddrOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res IndexOffAddrOp_Word64 args live = doIndexOffAddrOp Nothing I64 res args
+
+-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
+
+emitPrimOp res ReadOffAddrOp_Char args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res ReadOffAddrOp_WideChar args live = doIndexOffAddrOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res ReadOffAddrOp_Int args live = doIndexOffAddrOp Nothing wordRep res args
+emitPrimOp res ReadOffAddrOp_Word args live = doIndexOffAddrOp Nothing wordRep res args
+emitPrimOp res ReadOffAddrOp_Addr args live = doIndexOffAddrOp Nothing wordRep res args
+emitPrimOp res ReadOffAddrOp_Float args live = doIndexOffAddrOp Nothing F32 res args
+emitPrimOp res ReadOffAddrOp_Double args live = doIndexOffAddrOp Nothing F64 res args
+emitPrimOp res ReadOffAddrOp_StablePtr args live = doIndexOffAddrOp Nothing wordRep res args
+emitPrimOp res ReadOffAddrOp_Int8 args live = doIndexOffAddrOp (Just mo_s_8ToWord) I8 res args
+emitPrimOp res ReadOffAddrOp_Int16 args live = doIndexOffAddrOp (Just mo_s_16ToWord) I16 res args
+emitPrimOp res ReadOffAddrOp_Int32 args live = doIndexOffAddrOp (Just mo_s_32ToWord) I32 res args
+emitPrimOp res ReadOffAddrOp_Int64 args live = doIndexOffAddrOp Nothing I64 res args
+emitPrimOp res ReadOffAddrOp_Word8 args live = doIndexOffAddrOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res ReadOffAddrOp_Word16 args live = doIndexOffAddrOp (Just mo_u_16ToWord) I16 res args
+emitPrimOp res ReadOffAddrOp_Word32 args live = doIndexOffAddrOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res ReadOffAddrOp_Word64 args live = doIndexOffAddrOp Nothing I64 res args
+
+-- IndexXXXArray
+
+emitPrimOp res IndexByteArrayOp_Char args live = doIndexByteArrayOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res IndexByteArrayOp_WideChar args live = doIndexByteArrayOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res IndexByteArrayOp_Int args live = doIndexByteArrayOp Nothing wordRep res args
+emitPrimOp res IndexByteArrayOp_Word args live = doIndexByteArrayOp Nothing wordRep res args
+emitPrimOp res IndexByteArrayOp_Addr args live = doIndexByteArrayOp Nothing wordRep res args
+emitPrimOp res IndexByteArrayOp_Float args live = doIndexByteArrayOp Nothing F32 res args
+emitPrimOp res IndexByteArrayOp_Double args live = doIndexByteArrayOp Nothing F64 res args
+emitPrimOp res IndexByteArrayOp_StablePtr args live = doIndexByteArrayOp Nothing wordRep res args
+emitPrimOp res IndexByteArrayOp_Int8 args live = doIndexByteArrayOp (Just mo_s_8ToWord) I8 res args
+emitPrimOp res IndexByteArrayOp_Int16 args live = doIndexByteArrayOp (Just mo_s_16ToWord) I16 res args
+emitPrimOp res IndexByteArrayOp_Int32 args live = doIndexByteArrayOp (Just mo_s_32ToWord) I32 res args
+emitPrimOp res IndexByteArrayOp_Int64 args live = doIndexByteArrayOp Nothing I64 res args
+emitPrimOp res IndexByteArrayOp_Word8 args live = doIndexByteArrayOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res IndexByteArrayOp_Word16 args live = doIndexByteArrayOp (Just mo_u_16ToWord) I16 res args
+emitPrimOp res IndexByteArrayOp_Word32 args live = doIndexByteArrayOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res IndexByteArrayOp_Word64 args live = doIndexByteArrayOp Nothing I64 res args
+
+-- ReadXXXArray, identical to IndexXXXArray.
+
+emitPrimOp res ReadByteArrayOp_Char args live = doIndexByteArrayOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res ReadByteArrayOp_WideChar args live = doIndexByteArrayOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res ReadByteArrayOp_Int args live = doIndexByteArrayOp Nothing wordRep res args
+emitPrimOp res ReadByteArrayOp_Word args live = doIndexByteArrayOp Nothing wordRep res args
+emitPrimOp res ReadByteArrayOp_Addr args live = doIndexByteArrayOp Nothing wordRep res args
+emitPrimOp res ReadByteArrayOp_Float args live = doIndexByteArrayOp Nothing F32 res args
+emitPrimOp res ReadByteArrayOp_Double args live = doIndexByteArrayOp Nothing F64 res args
+emitPrimOp res ReadByteArrayOp_StablePtr args live = doIndexByteArrayOp Nothing wordRep res args
+emitPrimOp res ReadByteArrayOp_Int8 args live = doIndexByteArrayOp (Just mo_s_8ToWord) I8 res args
+emitPrimOp res ReadByteArrayOp_Int16 args live = doIndexByteArrayOp (Just mo_s_16ToWord) I16 res args
+emitPrimOp res ReadByteArrayOp_Int32 args live = doIndexByteArrayOp (Just mo_s_32ToWord) I32 res args
+emitPrimOp res ReadByteArrayOp_Int64 args live = doIndexByteArrayOp Nothing I64 res args
+emitPrimOp res ReadByteArrayOp_Word8 args live = doIndexByteArrayOp (Just mo_u_8ToWord) I8 res args
+emitPrimOp res ReadByteArrayOp_Word16 args live = doIndexByteArrayOp (Just mo_u_16ToWord) I16 res args
+emitPrimOp res ReadByteArrayOp_Word32 args live = doIndexByteArrayOp (Just mo_u_32ToWord) I32 res args
+emitPrimOp res ReadByteArrayOp_Word64 args live = doIndexByteArrayOp Nothing I64 res args
+
+-- WriteXXXoffAddr
+
+emitPrimOp res WriteOffAddrOp_Char args live = doWriteOffAddrOp (Just mo_WordTo8) I8 res args
+emitPrimOp res WriteOffAddrOp_WideChar args live = doWriteOffAddrOp (Just mo_WordTo32) I32 res args
+emitPrimOp res WriteOffAddrOp_Int args live = doWriteOffAddrOp Nothing wordRep res args
+emitPrimOp res WriteOffAddrOp_Word args live = doWriteOffAddrOp Nothing wordRep res args
+emitPrimOp res WriteOffAddrOp_Addr args live = doWriteOffAddrOp Nothing wordRep res args
+emitPrimOp res WriteOffAddrOp_Float args live = doWriteOffAddrOp Nothing F32 res args
+emitPrimOp res WriteOffAddrOp_ForeignObj args live = doWriteOffAddrOp Nothing wordRep res args
+emitPrimOp res WriteOffAddrOp_Double args live = doWriteOffAddrOp Nothing F64 res args
+emitPrimOp res WriteOffAddrOp_StablePtr args live = doWriteOffAddrOp Nothing wordRep res args
+emitPrimOp res WriteOffAddrOp_Int8 args live = doWriteOffAddrOp (Just mo_WordTo8) I8 res args
+emitPrimOp res WriteOffAddrOp_Int16 args live = doWriteOffAddrOp (Just mo_WordTo16) I16 res args
+emitPrimOp res WriteOffAddrOp_Int32 args live = doWriteOffAddrOp (Just mo_WordTo32) I32 res args
+emitPrimOp res WriteOffAddrOp_Int64 args live = doWriteOffAddrOp Nothing I64 res args
+emitPrimOp res WriteOffAddrOp_Word8 args live = doWriteOffAddrOp (Just mo_WordTo8) I8 res args
+emitPrimOp res WriteOffAddrOp_Word16 args live = doWriteOffAddrOp (Just mo_WordTo16) I16 res args
+emitPrimOp res WriteOffAddrOp_Word32 args live = doWriteOffAddrOp (Just mo_WordTo32) I32 res args
+emitPrimOp res WriteOffAddrOp_Word64 args live = doWriteOffAddrOp Nothing I64 res args
+
+-- WriteXXXArray
+
+emitPrimOp res WriteByteArrayOp_Char args live = doWriteByteArrayOp (Just mo_WordTo8) I8 res args
+emitPrimOp res WriteByteArrayOp_WideChar args live = doWriteByteArrayOp (Just mo_WordTo32) I32 res args
+emitPrimOp res WriteByteArrayOp_Int args live = doWriteByteArrayOp Nothing wordRep res args
+emitPrimOp res WriteByteArrayOp_Word args live = doWriteByteArrayOp Nothing wordRep res args
+emitPrimOp res WriteByteArrayOp_Addr args live = doWriteByteArrayOp Nothing wordRep res args
+emitPrimOp res WriteByteArrayOp_Float args live = doWriteByteArrayOp Nothing F32 res args
+emitPrimOp res WriteByteArrayOp_Double args live = doWriteByteArrayOp Nothing F64 res args
+emitPrimOp res WriteByteArrayOp_StablePtr args live = doWriteByteArrayOp Nothing wordRep res args
+emitPrimOp res WriteByteArrayOp_Int8 args live = doWriteByteArrayOp (Just mo_WordTo8) I8 res args
+emitPrimOp res WriteByteArrayOp_Int16 args live = doWriteByteArrayOp (Just mo_WordTo16) I16 res args
+emitPrimOp res WriteByteArrayOp_Int32 args live = doWriteByteArrayOp (Just mo_WordTo32) I32 res args
+emitPrimOp res WriteByteArrayOp_Int64 args live = doWriteByteArrayOp Nothing I64 res args
+emitPrimOp res WriteByteArrayOp_Word8 args live = doWriteByteArrayOp (Just mo_WordTo8) I8 res args
+emitPrimOp res WriteByteArrayOp_Word16 args live = doWriteByteArrayOp (Just mo_WordTo16) I16 res args
+emitPrimOp res WriteByteArrayOp_Word32 args live = doWriteByteArrayOp (Just mo_WordTo32) I32 res args
+emitPrimOp res WriteByteArrayOp_Word64 args live = doWriteByteArrayOp Nothing I64 res args
+
+
+-- The rest just translate straightforwardly
+emitPrimOp [res] op [arg] live
+ | nopOp op
+ = stmtC (CmmAssign res arg)
+
+ | Just (mop,rep) <- narrowOp op
+ = stmtC (CmmAssign res (CmmMachOp (mop rep wordRep) [
+ CmmMachOp (mop wordRep rep) [arg]]))
+
+emitPrimOp [res] op args live
+ | Just prim <- callishOp op
+ = do vols <- getVolatileRegs live
+ stmtC (CmmCall (CmmPrim prim) [(res,NoHint)]
+ [(a,NoHint) | a<-args] (Just vols)) -- ToDo: hints?
+
+ | Just mop <- translateOp op
+ = let stmt = CmmAssign res (CmmMachOp mop args) in
+ stmtC stmt
+
+emitPrimOp _ op _ _
+ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
+
+
+-- These PrimOps are NOPs in Cmm
+
+nopOp Int2WordOp = True
+nopOp Word2IntOp = True
+nopOp Int2AddrOp = True
+nopOp Addr2IntOp = True
+nopOp _ = False
+
+-- These PrimOps turn into double casts
+
+narrowOp Narrow8IntOp = Just (MO_S_Conv, I8)
+narrowOp Narrow16IntOp = Just (MO_S_Conv, I16)
+narrowOp Narrow32IntOp = Just (MO_S_Conv, I32)
+narrowOp Narrow8WordOp = Just (MO_U_Conv, I8)
+narrowOp Narrow16WordOp = Just (MO_U_Conv, I16)
+narrowOp Narrow32WordOp = Just (MO_U_Conv, I32)
+narrowOp _ = Nothing
+
+-- Native word signless ops
+
+translateOp IntAddOp = Just mo_wordAdd
+translateOp IntSubOp = Just mo_wordSub
+translateOp WordAddOp = Just mo_wordAdd
+translateOp WordSubOp = Just mo_wordSub
+translateOp AddrAddOp = Just mo_wordAdd
+translateOp AddrSubOp = Just mo_wordSub
+
+translateOp IntEqOp = Just mo_wordEq
+translateOp IntNeOp = Just mo_wordNe
+translateOp WordEqOp = Just mo_wordEq
+translateOp WordNeOp = Just mo_wordNe
+translateOp AddrEqOp = Just mo_wordEq
+translateOp AddrNeOp = Just mo_wordNe
+
+translateOp AndOp = Just mo_wordAnd
+translateOp OrOp = Just mo_wordOr
+translateOp XorOp = Just mo_wordXor
+translateOp NotOp = Just mo_wordNot
+translateOp SllOp = Just mo_wordShl
+translateOp SrlOp = Just mo_wordUShr
+
+translateOp AddrRemOp = Just mo_wordURem
+
+-- Native word signed ops
+
+translateOp IntMulOp = Just mo_wordMul
+translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordRep)
+translateOp IntQuotOp = Just mo_wordSQuot
+translateOp IntRemOp = Just mo_wordSRem
+translateOp IntNegOp = Just mo_wordSNeg
+
+
+translateOp IntGeOp = Just mo_wordSGe
+translateOp IntLeOp = Just mo_wordSLe
+translateOp IntGtOp = Just mo_wordSGt
+translateOp IntLtOp = Just mo_wordSLt
+
+translateOp ISllOp = Just mo_wordShl
+translateOp ISraOp = Just mo_wordSShr
+translateOp ISrlOp = Just mo_wordUShr
+
+-- Native word unsigned ops
+
+translateOp WordGeOp = Just mo_wordUGe
+translateOp WordLeOp = Just mo_wordULe
+translateOp WordGtOp = Just mo_wordUGt
+translateOp WordLtOp = Just mo_wordULt
+
+translateOp WordMulOp = Just mo_wordMul
+translateOp WordQuotOp = Just mo_wordUQuot
+translateOp WordRemOp = Just mo_wordURem
+
+translateOp AddrGeOp = Just mo_wordUGe
+translateOp AddrLeOp = Just mo_wordULe
+translateOp AddrGtOp = Just mo_wordUGt
+translateOp AddrLtOp = Just mo_wordULt
+
+-- 32-bit unsigned ops
+
+translateOp CharEqOp = Just (MO_Eq I32)
+translateOp CharNeOp = Just (MO_Ne I32)
+translateOp CharGeOp = Just (MO_U_Ge I32)
+translateOp CharLeOp = Just (MO_U_Le I32)
+translateOp CharGtOp = Just (MO_U_Gt I32)
+translateOp CharLtOp = Just (MO_U_Lt I32)
+
+-- Double ops
+
+translateOp DoubleEqOp = Just (MO_Eq F64)
+translateOp DoubleNeOp = Just (MO_Ne F64)
+translateOp DoubleGeOp = Just (MO_S_Ge F64)
+translateOp DoubleLeOp = Just (MO_S_Le F64)
+translateOp DoubleGtOp = Just (MO_S_Gt F64)
+translateOp DoubleLtOp = Just (MO_S_Lt F64)
+
+translateOp DoubleAddOp = Just (MO_Add F64)
+translateOp DoubleSubOp = Just (MO_Sub F64)
+translateOp DoubleMulOp = Just (MO_Mul F64)
+translateOp DoubleDivOp = Just (MO_S_Quot F64)
+translateOp DoubleNegOp = Just (MO_S_Neg F64)
+
+-- Float ops
+
+translateOp FloatEqOp = Just (MO_Eq F32)
+translateOp FloatNeOp = Just (MO_Ne F32)
+translateOp FloatGeOp = Just (MO_S_Ge F32)
+translateOp FloatLeOp = Just (MO_S_Le F32)
+translateOp FloatGtOp = Just (MO_S_Gt F32)
+translateOp FloatLtOp = Just (MO_S_Lt F32)
+
+translateOp FloatAddOp = Just (MO_Add F32)
+translateOp FloatSubOp = Just (MO_Sub F32)
+translateOp FloatMulOp = Just (MO_Mul F32)
+translateOp FloatDivOp = Just (MO_S_Quot F32)
+translateOp FloatNegOp = Just (MO_S_Neg F32)
+
+-- Conversions
+
+translateOp Int2DoubleOp = Just (MO_S_Conv wordRep F64)
+translateOp Double2IntOp = Just (MO_S_Conv F64 wordRep)
+
+translateOp Int2FloatOp = Just (MO_S_Conv wordRep F32)
+translateOp Float2IntOp = Just (MO_S_Conv F32 wordRep)
+
+translateOp Float2DoubleOp = Just (MO_S_Conv F32 F64)
+translateOp Double2FloatOp = Just (MO_S_Conv F64 F32)
+
+translateOp OrdOp = Just (MO_U_Conv I32 wordRep)
+translateOp ChrOp = Just (MO_U_Conv wordRep I32)
+
+-- Word comparisons masquerading as more exotic things.
+
+translateOp SameMutVarOp = Just mo_wordEq
+translateOp SameMVarOp = Just mo_wordEq
+translateOp SameMutableArrayOp = Just mo_wordEq
+translateOp SameMutableByteArrayOp = Just mo_wordEq
+translateOp EqForeignObj = Just mo_wordEq
+translateOp EqStablePtrOp = Just mo_wordEq
+
+translateOp _ = Nothing
+
+-- These primops are implemented by CallishMachOps, because they sometimes
+-- turn into foreign calls depending on the backend.
+
+callishOp DoublePowerOp = Just MO_F64_Pwr
+callishOp DoubleSinOp = Just MO_F64_Sin
+callishOp DoubleCosOp = Just MO_F64_Cos
+callishOp DoubleTanOp = Just MO_F64_Tan
+callishOp DoubleSinhOp = Just MO_F64_Sinh
+callishOp DoubleCoshOp = Just MO_F64_Cosh
+callishOp DoubleTanhOp = Just MO_F64_Tanh
+callishOp DoubleAsinOp = Just MO_F64_Asin
+callishOp DoubleAcosOp = Just MO_F64_Acos
+callishOp DoubleAtanOp = Just MO_F64_Atan
+callishOp DoubleLogOp = Just MO_F64_Log
+callishOp DoubleExpOp = Just MO_F64_Exp
+callishOp DoubleSqrtOp = Just MO_F64_Sqrt
+
+callishOp FloatPowerOp = Just MO_F32_Pwr
+callishOp FloatSinOp = Just MO_F32_Sin
+callishOp FloatCosOp = Just MO_F32_Cos
+callishOp FloatTanOp = Just MO_F32_Tan
+callishOp FloatSinhOp = Just MO_F32_Sinh
+callishOp FloatCoshOp = Just MO_F32_Cosh
+callishOp FloatTanhOp = Just MO_F32_Tanh
+callishOp FloatAsinOp = Just MO_F32_Asin
+callishOp FloatAcosOp = Just MO_F32_Acos
+callishOp FloatAtanOp = Just MO_F32_Atan
+callishOp FloatLogOp = Just MO_F32_Log
+callishOp FloatExpOp = Just MO_F32_Exp
+callishOp FloatSqrtOp = Just MO_F32_Sqrt
+
+callishOp _ = Nothing
+
+------------------------------------------------------------------------------
+-- Helpers for translating various minor variants of array indexing.
+
+doIndexOffForeignObjOp maybe_post_read_cast rep [res] [addr,idx]
+ = mkBasicIndexedRead 0 maybe_post_read_cast rep res
+ (cmmLoadIndexW addr fixedHdrSize) idx
+doIndexOffForeignObjOp _ _ _ _
+ = panic "CgPrimOp: doIndexOffForeignObjOp"
+
+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
+ = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
+doIndexOffAddrOp _ _ _ _
+ = panic "CgPrimOp: doIndexOffAddrOp"
+
+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
+ = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
+doIndexByteArrayOp _ _ _ _
+ = panic "CgPrimOp: doIndexByteArrayOp"
+
+doReadPtrArrayOp res addr idx
+ = mkBasicIndexedRead arrPtrsHdrSize Nothing wordRep res addr idx
+
+
+doWriteOffAddrOp maybe_pre_write_cast rep [] [addr,idx,val]
+ = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
+doWriteOffAddrOp _ _ _ _
+ = panic "CgPrimOp: doWriteOffAddrOp"
+
+doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val]
+ = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
+doWriteByteArrayOp _ _ _ _
+ = panic "CgPrimOp: doWriteByteArrayOp"
+
+doWritePtrArrayOp addr idx val
+ = mkBasicIndexedWrite arrPtrsHdrSize Nothing wordRep addr idx val
+
+
+mkBasicIndexedRead off Nothing read_rep res base idx
+ = stmtC (CmmAssign res (cmmLoadIndexOffExpr off read_rep base idx))
+mkBasicIndexedRead off (Just cast) read_rep res base idx
+ = stmtC (CmmAssign res (CmmMachOp cast [
+ cmmLoadIndexOffExpr off read_rep base idx]))
+
+mkBasicIndexedWrite off Nothing write_rep base idx val
+ = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) val)
+mkBasicIndexedWrite off (Just cast) write_rep base idx val
+ = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) (CmmMachOp cast [val]))
+
+-- ----------------------------------------------------------------------------
+-- Misc utils
+
+cmmIndexOffExpr :: ByteOff -> MachRep -> CmmExpr -> CmmExpr -> CmmExpr
+cmmIndexOffExpr off rep base idx
+ = cmmIndexExpr rep (cmmOffsetB base off) idx
+
+cmmLoadIndexOffExpr :: ByteOff -> MachRep -> CmmExpr -> CmmExpr -> CmmExpr
+cmmLoadIndexOffExpr off rep base idx
+ = CmmLoad (cmmIndexOffExpr off rep base idx) rep
+
+setInfo :: CmmExpr -> CmmExpr -> CmmStmt
+setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
+
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Code generation for profiling
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CgProf (
+ mkCCostCentre, mkCCostCentreStack,
+
+ -- Cost-centre Profiling
+ dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
+ enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
+ chooseDynCostCentres,
+ costCentreFrom,
+ curCCS, curCCSAddr,
+ emitCostCentreDecl, emitCostCentreStackDecl,
+ emitRegisterCC, emitRegisterCCS,
+ emitSetCCC, emitCCS,
+
+ -- Lag/drag/void stuff
+ ldvEnter, ldvRecordCreate
+ ) where
+
+#include "HsVersions.h"
+#include "../includes/ghcconfig.h"
+ -- Needed by Constants.h
+#include "../includes/Constants.h"
+ -- For LDV_CREATE_MASK, LDV_STATE_USE
+ -- which are StgWords
+#include "../includes/DerivedConstants.h"
+ -- For REP_xxx constants, which are MachReps
+
+import ClosureInfo ( ClosureInfo, closureSize,
+ closureName, isToplevClosure, closureReEntrant, )
+import CgUtils
+import CgMonad
+import SMRep ( StgWord, profHdrSize )
+
+import Cmm
+import MachOp
+import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
+import CLabel ( mkCCLabel, mkCCSLabel, mkRtsDataLabel )
+
+import Module ( moduleNameUserString )
+import Id ( Id )
+import CostCentre
+import StgSyn ( GenStgExpr(..), StgExpr )
+import CmdLineOpts ( opt_SccProfilingOn )
+import FastString ( FastString, mkFastString, LitString )
+import Constants -- Lots of field offsets
+import Outputable
+
+import Maybe
+import Char ( ord )
+import Monad ( when )
+
+-----------------------------------------------------------------------------
+--
+-- Cost-centre-stack Profiling
+--
+-----------------------------------------------------------------------------
+
+-- Expression representing the current cost centre stack
+curCCS :: CmmExpr
+curCCS = CmmLoad curCCSAddr wordRep
+
+-- Address of current CCS variable, for storing into
+curCCSAddr :: CmmExpr
+curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCCS")))
+
+mkCCostCentre :: CostCentre -> CmmLit
+mkCCostCentre cc = CmmLabel (mkCCLabel cc)
+
+mkCCostCentreStack :: CostCentreStack -> CmmLit
+mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
+
+costCentreFrom :: CmmExpr -- A closure pointer
+ -> CmmExpr -- The cost centre from that closure
+costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) wordRep
+
+staticProfHdr :: CostCentreStack -> [CmmLit]
+-- The profiling header words in a static closure
+-- Was SET_STATIC_PROF_HDR
+staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
+ staticLdvInit]
+
+dynProfHdr :: CmmExpr -> [CmmExpr]
+-- Profiling header words in a dynamic closure
+dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
+
+initUpdFrameProf :: CmmExpr -> Code
+-- Initialise the profiling field of an update frame
+initUpdFrameProf frame_amode
+ = ifProfiling $ -- frame->header.prof.ccs = CCCS
+ stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
+ -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
+ -- is unnecessary because it is not used anyhow.
+
+-- -----------------------------------------------------------------------------
+-- Recording allocation in a cost centre
+
+-- | Record the allocation of a closure. The CmmExpr is the cost
+-- centre stack to which to attribute the allocation.
+profDynAlloc :: ClosureInfo -> CmmExpr -> Code
+profDynAlloc cl_info ccs
+ = ifProfiling $
+ profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
+
+-- | Record the allocation of a closure (size is given by a CmmExpr)
+-- The size must be in words, because the allocation counter in a CCS counts
+-- in words.
+profAlloc :: CmmExpr -> CmmExpr -> Code
+profAlloc words ccs
+ = ifProfiling $
+ stmtC (addToMemE alloc_rep
+ (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
+ (CmmMachOp (MO_U_Conv wordRep alloc_rep) $
+ [CmmMachOp mo_wordSub [words,
+ CmmLit (mkIntCLit profHdrSize)]]))
+ -- subtract the "profiling overhead", which is the
+ -- profiling header in a closure.
+ where
+ alloc_rep = REP_CostCentreStack_mem_alloc
+
+-- ----------------------------------------------------------------------
+-- Setting the cost centre in a new closure
+
+chooseDynCostCentres :: CostCentreStack
+ -> [Id] -- Args
+ -> StgExpr -- Body
+ -> FCode (CmmExpr, CmmExpr)
+-- Called when alllcating a closure
+-- Tells which cost centre to put in the object, and which
+-- to blame the cost of allocation on
+chooseDynCostCentres ccs args body = do
+ -- Cost-centre we record in the object
+ use_ccs <- emitCCS ccs
+
+ -- Cost-centre on whom we blame the allocation
+ let blame_ccs
+ | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
+ | otherwise = use_ccs
+
+ return (use_ccs, blame_ccs)
+
+
+-- Some CostCentreStacks are a sequence of pushes on top of CCCS.
+-- These pushes must be performed before we can refer to the stack in
+-- an expression.
+emitCCS :: CostCentreStack -> FCode CmmExpr
+emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
+ where
+ (cc's, ccs') = decomposeCCS ccs
+
+ push_em ccs [] = return ccs
+ push_em ccs (cc:rest) = do
+ tmp <- newTemp wordRep
+ pushCostCentre tmp ccs cc
+ push_em (CmmReg tmp) rest
+
+ccsExpr :: CostCentreStack -> CmmExpr
+ccsExpr ccs
+ | isCurrentCCS ccs = curCCS
+ | otherwise = CmmLit (mkCCostCentreStack ccs)
+
+
+isBox :: StgExpr -> Bool
+-- If it's an utterly trivial RHS, then it must be
+-- one introduced by boxHigherOrderArgs for profiling,
+-- so we charge it to "OVERHEAD".
+-- This looks like a GROSS HACK to me --SDM
+isBox (StgApp fun []) = True
+isBox other = False
+
+
+-- -----------------------------------------------------------------------
+-- Setting the current cost centre on entry to a closure
+
+-- For lexically scoped profiling we have to load the cost centre from
+-- the closure entered, if the costs are not supposed to be inherited.
+-- This is done immediately on entering the fast entry point.
+
+-- Load current cost centre from closure, if not inherited.
+-- Node is guaranteed to point to it, if profiling and not inherited.
+
+enterCostCentre
+ :: ClosureInfo
+ -> CostCentreStack
+ -> StgExpr -- The RHS of the closure
+ -> Code
+
+-- We used to have a special case for bindings of form
+-- f = g True
+-- where g has arity 2. The RHS is a thunk, but we don't
+-- need to update it; and we want to subsume costs.
+-- We don't have these sort of PAPs any more, so the special
+-- case has gone away.
+
+enterCostCentre closure_info ccs body
+ = ifProfiling $
+ ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
+ enter_cost_centre closure_info ccs body
+
+enter_cost_centre closure_info ccs body
+ | isSubsumedCCS ccs
+ = ASSERT(isToplevClosure closure_info)
+ ASSERT(re_entrant)
+ enter_ccs_fsub
+
+ | isDerivedFromCurrentCCS ccs
+ = do {
+ if re_entrant && not is_box
+ then
+ enter_ccs_fun node_ccs
+ else
+ stmtC (CmmStore curCCSAddr node_ccs)
+
+ -- don't forget to bump the scc count. This closure might have been
+ -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
+ -- pass has turned into simply let x = e in ...x... and attached
+ -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
+ -- we don't lose the scc counter, bump it in the entry code for x.
+ -- ToDo: for a multi-push we should really bump the counter for
+ -- each of the intervening CCSs, not just the top one.
+ ; when (not (isCurrentCCS ccs)) $
+ stmtC (bumpSccCount curCCS)
+ }
+
+ | isCafCCS ccs
+ = ASSERT(isToplevClosure closure_info)
+ ASSERT(not re_entrant)
+ do { -- This is just a special case of the isDerivedFromCurrentCCS
+ -- case above. We could delete this, but it's a micro
+ -- optimisation and saves a bit of code.
+ stmtC (CmmStore curCCSAddr enc_ccs)
+ ; stmtC (bumpSccCount node_ccs)
+ }
+
+ | otherwise
+ = panic "enterCostCentre"
+ where
+ enc_ccs = CmmLit (mkCCostCentreStack ccs)
+ re_entrant = closureReEntrant closure_info
+ node_ccs = costCentreFrom (CmmReg nodeReg)
+ is_box = isBox body
+
+-- set the current CCS when entering a PAP
+enterCostCentrePAP :: CmmExpr -> Code
+enterCostCentrePAP closure =
+ ifProfiling $ do
+ enter_ccs_fun (costCentreFrom closure)
+ enteringPAP 1
+
+enterCostCentreThunk :: CmmExpr -> Code
+enterCostCentreThunk closure =
+ ifProfiling $ do
+ stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
+
+enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
+
+enter_ccs_fsub = enteringPAP 0
+
+-- When entering a PAP, EnterFunCCS is called by both the PAP entry
+-- code and the function entry code; we don't want the function's
+-- entry code to also update CCCS in the event that it was called via
+-- a PAP, so we set the flag entering_PAP to indicate that we are
+-- entering via a PAP.
+enteringPAP :: Integer -> Code
+enteringPAP n
+ = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
+ (CmmLit (CmmInt n cIntRep)))
+
+ifProfiling :: Code -> Code
+ifProfiling code
+ | opt_SccProfilingOn = code
+ | otherwise = nopC
+
+ifProfilingL :: [a] -> [a]
+ifProfilingL xs
+ | opt_SccProfilingOn = xs
+ | otherwise = []
+
+
+-- ---------------------------------------------------------------------------
+-- Initialising Cost Centres & CCSs
+
+emitCostCentreDecl
+ :: CostCentre
+ -> Code
+emitCostCentreDecl cc = do
+ { label <- mkStringCLit (costCentreUserName cc)
+ ; modl <- mkStringCLit (moduleNameUserString (cc_mod cc))
+ ; let
+ lits = [ zero, -- StgInt ccID,
+ label, -- char *label,
+ modl, -- char *module,
+ zero, -- StgWord time_ticks
+ zero64, -- StgWord64 mem_alloc
+ subsumed, -- StgInt is_caf
+ zero -- struct _CostCentre *link
+ ]
+ ; emitDataLits (mkCCLabel cc) lits
+ }
+ where
+ subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
+ | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
+
+
+emitCostCentreStackDecl
+ :: CostCentreStack
+ -> Code
+emitCostCentreStackDecl ccs
+ | Just cc <- maybeSingletonCCS ccs = do
+ { let
+ lits = [ zero,
+ mkCCostCentre cc,
+ zero, -- struct _CostCentreStack *prevStack;
+ zero, -- struct _IndexTable *indexTable;
+ zero, -- StgWord selected;
+ zero64, -- StgWord64 scc_count;
+ zero, -- StgWord time_ticks;
+ zero64, -- StgWord64 mem_alloc;
+ zero, -- StgWord inherited_ticks;
+ zero64, -- StgWord64 inherited_alloc;
+ zero -- CostCentre *root;
+ ]
+ ; emitDataLits (mkCCSLabel ccs) lits
+ }
+ | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
+
+zero = mkIntCLit 0
+zero64 = CmmInt 0 I64
+
+
+-- ---------------------------------------------------------------------------
+-- Registering CCs and CCSs
+
+-- (cc)->link = CC_LIST;
+-- CC_LIST = (cc);
+-- (cc)->ccID = CC_ID++;
+
+emitRegisterCC :: CostCentre -> Code
+emitRegisterCC cc = do
+ { tmp <- newTemp cIntRep
+ ; stmtsC [
+ CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
+ (CmmLoad cC_LIST wordRep),
+ CmmStore cC_LIST cc_lit,
+ CmmAssign tmp (CmmLoad cC_ID cIntRep),
+ CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
+ CmmStore cC_ID (cmmRegOffB tmp 1)
+ ]
+ }
+ where
+ cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
+
+-- (ccs)->prevStack = CCS_LIST;
+-- CCS_LIST = (ccs);
+-- (ccs)->ccsID = CCS_ID++;
+
+emitRegisterCCS :: CostCentreStack -> Code
+emitRegisterCCS ccs = do
+ { tmp <- newTemp cIntRep
+ ; stmtsC [
+ CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
+ (CmmLoad cCS_LIST wordRep),
+ CmmStore cCS_LIST ccs_lit,
+ CmmAssign tmp (CmmLoad cCS_ID cIntRep),
+ CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
+ CmmStore cCS_ID (cmmRegOffB tmp 1)
+ ]
+ }
+ where
+ ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
+
+
+cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
+cC_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
+
+cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
+cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
+
+-- ---------------------------------------------------------------------------
+-- Set the current cost centre stack
+
+emitSetCCC :: CostCentre -> Code
+emitSetCCC cc
+ | not opt_SccProfilingOn = nopC
+ | otherwise = do
+ ASSERTM(sccAbleCostCentre cc)
+ tmp <- newTemp wordRep
+ pushCostCentre tmp curCCS cc
+ stmtC (CmmStore curCCSAddr (CmmReg tmp))
+ when (isSccCountCostCentre cc) $
+ stmtC (bumpSccCount curCCS)
+
+pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
+pushCostCentre result ccs cc
+ = emitRtsCallWithResult result PtrHint
+ SLIT("PushCostCentre") [(ccs,PtrHint),
+ (CmmLit (mkCCostCentre cc), PtrHint)]
+
+bumpSccCount :: CmmExpr -> CmmStmt
+bumpSccCount ccs
+ = addToMem REP_CostCentreStack_scc_count
+ (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
+
+-----------------------------------------------------------------------------
+--
+-- Lag/drag/void stuff
+--
+-----------------------------------------------------------------------------
+
+--
+-- Initial value for the LDV field in a static closure
+--
+staticLdvInit :: CmmLit
+staticLdvInit = zeroCLit
+
+--
+-- Initial value of the LDV field in a dynamic closure
+--
+dynLdvInit :: CmmExpr
+dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
+ CmmMachOp mo_wordOr [
+ CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
+ CmmLit (mkWordCLit lDV_STATE_CREATE)
+ ]
+
+--
+-- Initialise the LDV word of a new closure
+--
+ldvRecordCreate :: CmmExpr -> Code
+ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
+
+--
+-- Called when a closure is entered, marks the closure as having been "used".
+-- The closure is not an 'inherently used' one.
+-- The closure is not IND or IND_OLDGEN because neither is considered for LDV
+-- profiling.
+--
+ldvEnter :: CmmExpr -> Code
+-- Argument is a closure pointer
+ldvEnter cl_ptr
+ = ifProfiling $
+ -- if (era > 0) {
+ -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
+ -- era | LDV_STATE_USE }
+ emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
+ (stmtC (CmmStore ldv_wd new_ldv_wd))
+ where
+ ldv_wd = ldvWord cl_ptr
+ new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
+ (CmmLit (mkWordCLit lDV_CREATE_MASK)))
+ (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
+
+loadEra :: CmmExpr
+loadEra = CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep
+
+ldvWord :: CmmExpr -> CmmExpr
+-- Takes the address of a closure, and returns
+-- the address of the LDV word in the closure
+ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
+
+-- LDV constants, from ghc/includes/Constants.h
+lDV_SHIFT = (LDV_SHIFT :: Int)
+--lDV_STATE_MASK = (LDV_STATE_MASK :: StgWord)
+lDV_CREATE_MASK = (LDV_CREATE_MASK :: StgWord)
+--lDV_LAST_MASK = (LDV_LAST_MASK :: StgWord)
+lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
+lDV_STATE_USE = (LDV_STATE_USE :: StgWord)
+
+++ /dev/null
-_interface_ CgRetConv 1
-_exports_
-CgRetConv CtrlReturnConvention(VectoredReturn UnvectoredReturn) ctrlReturnConvAlg;
-_declarations_
-1 data CtrlReturnConvention = VectoredReturn PrelBase.Int | UnvectoredReturn PrelBase.Int;
-1 ctrlReturnConvAlg _:_ TyCon.TyCon -> CtrlReturnConvention ;;
-
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992-1998
-%
-% $Id: CgRetConv.lhs,v 1.34 2003/10/09 11:58:46 simonpj Exp $
-%
-\section[CgRetConv]{Return conventions for the code generator}
-
-The datatypes and functions here encapsulate what there is to know
-about return conventions.
-
-\begin{code}
-module CgRetConv (
- CtrlReturnConvention(..),
- ctrlReturnConvAlg,
- dataReturnConvPrim,
- assignRegs, assignAllRegs
- ) where
-
-#include "HsVersions.h"
-
-import AbsCSyn -- quite a few things
-import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
- mAX_Vanilla_REG, mAX_Float_REG,
- mAX_Double_REG, mAX_Long_REG,
- mAX_Real_Vanilla_REG, mAX_Real_Float_REG,
- mAX_Real_Double_REG, mAX_Real_Long_REG
- )
-import CmdLineOpts ( opt_Unregisterised )
-import Maybes ( mapCatMaybes )
-import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
-import TyCon ( TyCon, tyConFamilySize )
-import Util ( isn'tIn )
-import FastTypes
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgRetConv-possibilities]{Data types that encode possible return conventions}
-%* *
-%************************************************************************
-
-A @CtrlReturnConvention@ says how {\em control} is returned.
-\begin{code}
-data CtrlReturnConvention
- = VectoredReturn Int -- size of the vector table (family size)
- | UnvectoredReturn Int -- family size
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
-%* *
-%************************************************************************
-
-\begin{code}
-ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
-
-ctrlReturnConvAlg tycon
- = case (tyConFamilySize tycon) of
- size -> -- we're supposed to know...
- if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
- VectoredReturn size
- else
- UnvectoredReturn size
- -- NB: unvectored returns Include size 0 (no constructors), so that
- -- the following perverse code compiles (it crashed GHC in 5.02)
- -- data T1
- -- data T2 = T2 !T1 Int
- -- The only value of type T1 is bottom, which never returns anyway.
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
-%* *
-%************************************************************************
-
-\begin{code}
-dataReturnConvPrim :: PrimRep -> MagicId
-
-dataReturnConvPrim PtrRep = VanillaReg PtrRep (_ILIT 1)
-dataReturnConvPrim IntRep = VanillaReg IntRep (_ILIT 1)
-dataReturnConvPrim WordRep = VanillaReg WordRep (_ILIT 1)
-dataReturnConvPrim Int32Rep = VanillaReg Int32Rep (_ILIT 1)
-dataReturnConvPrim Word32Rep = VanillaReg Word32Rep (_ILIT 1)
-dataReturnConvPrim Int64Rep = LongReg Int64Rep (_ILIT 1)
-dataReturnConvPrim Word64Rep = LongReg Word64Rep (_ILIT 1)
-dataReturnConvPrim AddrRep = VanillaReg AddrRep (_ILIT 1)
-dataReturnConvPrim CharRep = VanillaReg CharRep (_ILIT 1)
-dataReturnConvPrim Int8Rep = VanillaReg Int8Rep (_ILIT 1)
-dataReturnConvPrim FloatRep = FloatReg (_ILIT 1)
-dataReturnConvPrim DoubleRep = DoubleReg (_ILIT 1)
-dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep (_ILIT 1)
-dataReturnConvPrim VoidRep = VoidReg
-
-#ifdef DEBUG
-dataReturnConvPrim rep = pprPanic "dataReturnConvPrim:" (ppr rep)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[CgRetConv-regs]{Register assignment}
-%* *
-%************************************************************************
-
-How to assign registers for
-
- 1) Calling a fast entry point.
- 2) Returning an unboxed tuple.
- 3) Invoking an out-of-line PrimOp.
-
-Registers are assigned in order.
-
-If we run out, we don't attempt to assign any further registers (even
-though we might have run out of only one kind of register); we just
-return immediately with the left-overs specified.
-
-The alternative version @assignAllRegs@ uses the complete set of
-registers, including those that aren't mapped to real machine
-registers. This is used for calling special RTS functions and PrimOps
-which expect their arguments to always be in the same registers.
-
-\begin{code}
-assignRegs, assignAllRegs
- :: [MagicId] -- Unavailable registers
- -> [PrimRep] -- Arg or result kinds to assign
- -> ([MagicId], -- Register assignment in same order
- -- for *initial segment of* input list
- [PrimRep])-- leftover kinds
-
-assignRegs regs_in_use kinds
- = assign_reg kinds [] (mkRegTbl regs_in_use)
-
-assignAllRegs regs_in_use kinds
- = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
-
-assign_reg
- :: [PrimRep] -- arg kinds being scrutinized
- -> [MagicId] -- accum. regs assigned so far (reversed)
- -> AvailRegs -- regs still avail: Vanilla, Float, Double, longs
- -> ([MagicId], [PrimRep])
-
-assign_reg (VoidRep:ks) acc supply
- = assign_reg ks (VoidReg:acc) supply
- -- one VoidReg is enough for everybody!
-
-assign_reg (FloatRep:ks) acc (vanilla_rs, f:float_rs, double_rs, long_rs)
- = assign_reg ks (FloatReg (iUnbox f):acc)
- (vanilla_rs, float_rs, double_rs, long_rs)
-
-assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, d:double_rs, long_rs)
- = assign_reg ks (DoubleReg (iUnbox d):acc)
- (vanilla_rs, float_rs, double_rs, long_rs)
-
-assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, u:long_rs)
- = assign_reg ks (LongReg Word64Rep (iUnbox u):acc)
- (vanilla_rs, float_rs, double_rs, long_rs)
-
-assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, l:long_rs)
- = assign_reg ks (LongReg Int64Rep (iUnbox l):acc)
- (vanilla_rs, float_rs, double_rs, long_rs)
-
-assign_reg (k:ks) acc (v:vanilla_rs, float_rs, double_rs, long_rs)
- | not (isFloatingRep k || is64BitRep k)
- = assign_reg ks (VanillaReg k (iUnbox v):acc)
- (vanilla_rs, float_rs, double_rs, long_rs)
-
--- The catch-all. It can happen because either
--- (a) we've assigned all the regs so leftover_ks is []
--- (b) we couldn't find a spare register in the appropriate supply
--- or, I suppose,
--- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
-assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
-
-\end{code}
-
-Register supplies. Vanilla registers can contain pointers, Ints, Chars.
-Floats and doubles have separate register supplies.
-
-We take these register supplies from the *real* registers, i.e. those
-that are guaranteed to map to machine registers.
-
-\begin{code}
-useVanillaRegs | opt_Unregisterised = 0
- | otherwise = mAX_Real_Vanilla_REG
-useFloatRegs | opt_Unregisterised = 0
- | otherwise = mAX_Real_Float_REG
-useDoubleRegs | opt_Unregisterised = 0
- | otherwise = mAX_Real_Double_REG
-useLongRegs | opt_Unregisterised = 0
- | otherwise = mAX_Real_Long_REG
-
-vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
-vanillaRegNos = regList useVanillaRegs
-floatRegNos = regList useFloatRegs
-doubleRegNos = regList useDoubleRegs
-longRegNos = regList useLongRegs
-
-allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
-allVanillaRegNos = regList mAX_Vanilla_REG
-allFloatRegNos = regList mAX_Float_REG
-allDoubleRegNos = regList mAX_Double_REG
-allLongRegNos = regList mAX_Long_REG
-
-regList 0 = []
-regList n = [1 .. n]
-
-type AvailRegs = ( [Int] -- available vanilla regs.
- , [Int] -- floats
- , [Int] -- doubles
- , [Int] -- longs (int64 and word64)
- )
-
-mkRegTbl :: [MagicId] -> AvailRegs
-mkRegTbl regs_in_use
- = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
-
-mkRegTbl_allRegs :: [MagicId] -> AvailRegs
-mkRegTbl_allRegs regs_in_use
- = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
-
-mkRegTbl' regs_in_use vanillas floats doubles longs
- = (ok_vanilla, ok_float, ok_double, ok_long)
- where
- ok_vanilla = mapCatMaybes (select (VanillaReg VoidRep)) vanillas
- ok_float = mapCatMaybes (select FloatReg) floats
- ok_double = mapCatMaybes (select DoubleReg) doubles
- ok_long = mapCatMaybes (select (LongReg Int64Rep)) longs
- -- rep isn't looked at, hence we can use any old rep.
-
- select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int
- -- one we've unboxed the Int, we make a MagicId
- -- and see if it is already in use; if not, return its number.
-
- select mk_reg_fun cand
- = let
- reg = mk_reg_fun (iUnbox cand)
- in
- if reg `not_elem` regs_in_use
- then Just cand
- else Nothing
- where
- not_elem = isn'tIn "mkRegTbl"
-\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.24 2003/11/17 14:42:47 simonmar Exp $
+% $Id: CgStackery.lhs,v 1.25 2004/08/13 13:06:12 simonmar Exp $
%
\section[CgStackery]{Stack management functions}
\begin{code}
module CgStackery (
+ spRel, getVirtSp, getRealSp, setRealSp,
+ setRealAndVirtualSp, getSpRelOffset,
+
allocPrimStack, allocStackTop, deAllocStackTop,
adjustStackHW, getFinalStackHW,
setStackFrame, getStackFrame,
mkVirtStkOffsets, mkStkAmodes,
- freeStackSlots, dataStackSlots,
- updateFrameSize,
- constructSlowCall, slowArgs,
+ freeStackSlots,
+ pushUpdateFrame, emitPushUpdateFrame,
) where
#include "HsVersions.h"
import CgMonad
-import AbsCSyn
-import CLabel ( mkRtsApplyInfoLabel, mkRtsApplyEntryLabel )
-
-import CgUsages ( getRealSp )
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import PrimRep
-import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
+import CgUtils ( cmmOffsetB, cmmRegOffW )
+import CgProf ( initUpdFrameProf )
+import SMRep
+import Cmm
+import CmmUtils ( CmmStmts, mkLblExpr )
+import CLabel ( mkUpdInfoLabel )
import Constants
import Util ( sortLt )
import FastString ( LitString )
-import Panic
-
-import TRACE ( trace )
+import OrdList ( toOL )
+import Outputable
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[CgUsages-stackery]{Monad things for fiddling with stack usage}
+%* *
+%************************************************************************
+
+spRel is a little function that abstracts the stack direction. Note that most
+of the code generator is dependent on the stack direction anyway, so
+changing this on its own spells certain doom. ToDo: remove?
+
+ THIS IS DIRECTION SENSITIVE!
+
+Stack grows down, positive virtual offsets correspond to negative
+additions to the stack pointer.
+
+\begin{code}
+spRel :: VirtualSpOffset -- virtual offset of Sp
+ -> VirtualSpOffset -- virtual offset of The Thing
+ -> WordOff -- integer offset
+spRel sp off = sp - off
+\end{code}
+
+@setRealAndVirtualSp@ sets into the environment the offsets of the
+current position of the real and virtual stack pointers in the current
+stack frame. The high-water mark is set too. It generates no code.
+It is used to initialise things at the beginning of a closure body.
+
+\begin{code}
+setRealAndVirtualSp :: VirtualSpOffset -- New real Sp
+ -> Code
+
+setRealAndVirtualSp new_sp
+ = do { stk_usg <- getStkUsage
+ ; setStkUsage (stk_usg {virtSp = new_sp,
+ realSp = new_sp,
+ hwSp = new_sp}) }
+
+getVirtSp :: FCode VirtualSpOffset
+getVirtSp
+ = do { stk_usg <- getStkUsage
+ ; return (virtSp stk_usg) }
+
+getRealSp :: FCode VirtualSpOffset
+getRealSp
+ = do { stk_usg <- getStkUsage
+ ; return (realSp stk_usg) }
+
+setRealSp :: VirtualSpOffset -> Code
+setRealSp new_real_sp
+ = do { stk_usg <- getStkUsage
+ ; setStkUsage (stk_usg {realSp = new_real_sp}) }
+
+getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr
+getSpRelOffset virtual_offset
+ = do { real_sp <- getRealSp
+ ; return (cmmRegOffW spReg (spRel real_sp virtual_offset)) }
\end{code}
+
%************************************************************************
%* *
\subsection[CgStackery-layout]{Laying out a stack frame}
\begin{code}
mkVirtStkOffsets
:: VirtualSpOffset -- Offset of the last allocated thing
- -> (a -> PrimRep) -- to be able to grab kinds
- -> [a] -- things to make offsets for
+ -> [(CgRep,a)] -- things to make offsets for
-> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
- [(a, VirtualSpOffset)]) -- things with offsets
+ [(a, VirtualSpOffset)]) -- things with offsets (voids filtered out)
-mkVirtStkOffsets init_Sp_offset kind_fun things
+mkVirtStkOffsets init_Sp_offset things
= loop init_Sp_offset [] (reverse things)
where
loop offset offs [] = (offset,offs)
- loop offset offs (t:things) =
- let
- size = getPrimRepSize (kind_fun t)
- thing_slot = offset + size
- in
- loop thing_slot ((t,thing_slot):offs) things
- -- offset of thing is offset+size, because we're growing the stack
- -- *downwards* as the offsets increase.
-
+ loop offset offs ((VoidArg,t):things) = loop offset offs things
+ -- ignore Void arguments
+ loop offset offs ((rep,t):things)
+ = loop thing_slot ((t,thing_slot):offs) things
+ where
+ thing_slot = offset + cgRepSizeW rep
+ -- offset of thing is offset+size, because we're
+ -- growing the stack *downwards* as the offsets increase.
-- | 'mkStkAmodes' is a higher-level version of
-- 'mkVirtStkOffsets'. It starts from the tail-call locations.
mkStkAmodes
:: VirtualSpOffset -- Tail call positions
- -> [CAddrMode] -- things to make offsets for
+ -> [(CgRep,CmmExpr)] -- things to make offsets for
-> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
- AbstractC) -- Assignments to appropriate stk slots
+ CmmStmts) -- Assignments to appropriate stk slots
mkStkAmodes tail_Sp things
- = getRealSp `thenFC` \ realSp ->
- let
- (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp getAmodeRep things
-
- abs_cs =
- [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
- | (thing, offset) <- offsets
- ]
- in
- returnFC (last_Sp_offset, mkAbstractCs abs_cs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Pushing the arguments for a slow call}
-%* *
-%************************************************************************
-
-For a slow call, we must take a bunch of arguments and intersperse
-some stg_ap_<pattern>_ret_info return addresses.
-
-\begin{code}
-constructSlowCall :: [CAddrMode] -> (CAddrMode, [CAddrMode])
- -- don't forget the zero case
-constructSlowCall [] = (CLbl stg_ap_0 CodePtrRep , [])
-constructSlowCall amodes =
- -- traceSlowCall amodes $
- (CLbl lbl CodePtrRep, these ++ slowArgs rest)
- where (tag, these, rest) = matchSlowPattern amodes
- lbl = mkRtsApplyEntryLabel tag
-
-stg_ap_0 = mkRtsApplyEntryLabel SLIT("0")
-
--- | 'slowArgs' takes a list of function arguments and prepares them for
--- pushing on the stack for "extra" arguments to a function which requires
--- fewer arguments than we currently have.
-slowArgs :: [CAddrMode] -> [CAddrMode]
-slowArgs [] = []
-slowArgs amodes = CLbl lbl RetRep : args ++ slowArgs rest
- where (tag, args, rest) = matchSlowPattern amodes
- lbl = mkRtsApplyInfoLabel tag
-
-matchSlowPattern :: [CAddrMode] -> (LitString, [CAddrMode], [CAddrMode])
-matchSlowPattern amodes = (tag, these, rest)
- where reps = map getAmodeRep amodes
- (tag, n) = findMatch (map primRepToArgRep reps)
- (these, rest) = splitAt n amodes
-
--- These cases were found to cover about 99% of all slow calls:
-findMatch (RepP: RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppppp"), 7)
-findMatch (RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("pppppp"), 6)
-findMatch (RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppp"), 5)
-findMatch (RepP: RepP: RepP: RepP: _) = (SLIT("pppp"), 4)
-findMatch (RepP: RepP: RepP: _) = (SLIT("ppp"), 3)
-findMatch (RepP: RepP: RepV: _) = (SLIT("ppv"), 3)
-findMatch (RepP: RepP: _) = (SLIT("pp"), 2)
-findMatch (RepP: RepV: _) = (SLIT("pv"), 2)
-findMatch (RepP: _) = (SLIT("p"), 1)
-findMatch (RepV: _) = (SLIT("v"), 1)
-findMatch (RepN: _) = (SLIT("n"), 1)
-findMatch (RepF: _) = (SLIT("f"), 1)
-findMatch (RepD: _) = (SLIT("d"), 1)
-findMatch (RepL: _) = (SLIT("l"), 1)
-findMatch _ = panic "CgStackery.findMatch"
-
-#ifdef DEBUG
-primRepChar p | isFollowableRep p = 'p'
-primRepChar VoidRep = 'v'
-primRepChar FloatRep = 'f'
-primRepChar DoubleRep = 'd'
-primRepChar p | getPrimRepSize p == 1 = 'n'
-primRepChar p | is64BitRep p = 'l'
-
-traceSlowCall amodes and_then
- = trace ("call: " ++ map primRepChar (map getAmodeRep amodes)) and_then
-#endif
+ = do { rSp <- getRealSp
+ ; let (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp things
+ abs_cs = [ CmmStore (cmmRegOffW spReg (spRel rSp offset)) amode
+ | (amode, offset) <- offsets
+ ]
+ ; returnFC (last_Sp_offset, toOL abs_cs) }
\end{code}
%************************************************************************
Allocate a virtual offset for something.
\begin{code}
-allocPrimStack :: Int -> FCode VirtualSpOffset
-allocPrimStack size = do
- ((virt_sp, frame, free_stk, real_sp, hw_sp),h_usage) <- getUsage
- let push_virt_sp = virt_sp + size
- let (chosen_slot, new_stk_usage) =
- case find_block free_stk of
- Nothing -> (push_virt_sp,
- (push_virt_sp, frame, free_stk, real_sp,
- hw_sp `max` push_virt_sp))
+allocPrimStack :: CgRep -> FCode VirtualSpOffset
+allocPrimStack rep
+ = do { stk_usg <- getStkUsage
+ ; let free_stk = freeStk stk_usg
+ ; case find_block free_stk of
+ Nothing -> do
+ { let push_virt_sp = virtSp stk_usg + size
+ ; setStkUsage (stk_usg { virtSp = push_virt_sp,
+ hwSp = hwSp stk_usg `max` push_virt_sp })
-- Adjust high water mark
- Just slot -> (slot,
- (virt_sp, frame,
- delete_block free_stk slot,
- real_sp, hw_sp))
- setUsage (new_stk_usage, h_usage)
- return chosen_slot
-
- where
- -- find_block looks for a contiguous chunk of free slots
- find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
- find_block [] = Nothing
- find_block ((off,free):slots)
- | take size ((off,free):slots) ==
- zip [off..top_slot] (repeat Free) = Just top_slot
- | otherwise = find_block slots
- -- The stack grows downwards, with increasing virtual offsets.
- -- Therefore, the address of a multi-word object is the *highest*
- -- virtual offset it occupies (top_slot below).
- where top_slot = off+size-1
-
- delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
- (s<=slot-size) || (s>slot) ]
- -- Retain slots which are not in the range
- -- slot-size+1..slot
+ ; return push_virt_sp }
+ Just slot -> do
+ { setStkUsage (stk_usg { freeStk = delete_block free_stk slot })
+ ; return slot }
+ }
+ where
+ size :: WordOff
+ size = cgRepSizeW rep
+
+ -- Find_block looks for a contiguous chunk of free slots
+ -- returning the offset of its topmost word
+ find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset
+ find_block [] = Nothing
+ find_block (slot:slots)
+ | take size (slot:slots) == [slot..top_slot]
+ = Just top_slot
+ | otherwise
+ = find_block slots
+ where -- The stack grows downwards, with increasing virtual offsets.
+ -- Therefore, the address of a multi-word object is the *highest*
+ -- virtual offset it occupies (top_slot below).
+ top_slot = slot+size-1
+
+ delete_block free_stk slot = [ s | s <- free_stk,
+ (s<=slot-size) || (s>slot) ]
+ -- Retain slots which are not in the range
+ -- slot-size+1..slot
\end{code}
Allocate a chunk ON TOP OF the stack.
-ToDo: should really register this memory as NonPointer stuff in the
-free list.
-
\begin{code}
-allocStackTop :: Int -> FCode VirtualSpOffset
-allocStackTop size = do
- ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
- let push_virt_sp = virt_sp + size
- let new_stk_usage = (push_virt_sp, frame, free_stk, real_sp,
- hw_sp `max` push_virt_sp)
- setUsage (new_stk_usage, h_usage)
- return push_virt_sp
+allocStackTop :: WordOff -> FCode VirtualSpOffset
+allocStackTop size
+ = do { stk_usg <- getStkUsage
+ ; let push_virt_sp = virtSp stk_usg + size
+ ; setStkUsage (stk_usg { virtSp = push_virt_sp,
+ hwSp = hwSp stk_usg `max` push_virt_sp })
+ ; return push_virt_sp }
\end{code}
Pop some words from the current top of stack. This is used for
de-allocating the return address in a case alternative.
\begin{code}
-deAllocStackTop :: Int -> FCode VirtualSpOffset
-deAllocStackTop size = do
- ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
- let pop_virt_sp = virt_sp - size
- let new_stk_usage = (pop_virt_sp, frame, free_stk, real_sp, hw_sp)
- setUsage (new_stk_usage, h_usage)
- return pop_virt_sp
+deAllocStackTop :: WordOff -> FCode VirtualSpOffset
+deAllocStackTop size
+ = do { stk_usg <- getStkUsage
+ ; let pop_virt_sp = virtSp stk_usg - size
+ ; setStkUsage (stk_usg { virtSp = pop_virt_sp })
+ ; return pop_virt_sp }
\end{code}
\begin{code}
adjustStackHW :: VirtualSpOffset -> Code
-adjustStackHW offset = do
- ((vSp,fTop,fSp,realSp,hwSp), h_usage) <- getUsage
- setUsage ((vSp, fTop, fSp, realSp, max offset hwSp), h_usage)
+adjustStackHW offset
+ = do { stk_usg <- getStkUsage
+ ; setStkUsage (stk_usg { hwSp = hwSp stk_usg `max` offset }) }
\end{code}
A knot-tying beast.
\begin{code}
getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
-getFinalStackHW fcode = do
- fixC (\hwSp -> do
- fcode hwSp
- ((_,_,_,_, hwSp),_) <- getUsage
- return hwSp)
- return ()
+getFinalStackHW fcode
+ = do { fixC (\hw_sp -> do
+ { fcode hw_sp
+ ; stk_usg <- getStkUsage
+ ; return (hwSp stk_usg) })
+ ; return () }
\end{code}
\begin{code}
setStackFrame :: VirtualSpOffset -> Code
-setStackFrame offset = do
- ((vSp,_,fSp,realSp,hwSp), h_usage) <- getUsage
- setUsage ((vSp, offset, fSp, realSp, hwSp), h_usage)
+setStackFrame offset
+ = do { stk_usg <- getStkUsage
+ ; setStkUsage (stk_usg { frameSp = offset }) }
getStackFrame :: FCode VirtualSpOffset
-getStackFrame = do
- ((vSp,frame,fSp,realSp,hwSp), h_usage) <- getUsage
- return frame
+getStackFrame
+ = do { stk_usg <- getStkUsage
+ ; return (frameSp stk_usg) }
\end{code}
+
+%********************************************************
+%* *
+%* Setting up update frames *
+%* *
+%********************************************************
+
+@pushUpdateFrame@ $updatee$ pushes a general update frame which
+points to $updatee$ as the thing to be updated. It is only used
+when a thunk has just been entered, so the (real) stack pointers
+are guaranteed to be nicely aligned with the top of stack.
+@pushUpdateFrame@ adjusts the virtual and tail stack pointers
+to reflect the frame pushed.
+
\begin{code}
-updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE
- | opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
- | otherwise = uF_SIZE
+pushUpdateFrame :: CmmExpr -> Code -> Code
+
+pushUpdateFrame updatee code
+ = do {
+#ifdef DEBUG
+ EndOfBlockInfo _ sequel <- getEndOfBlockInfo ;
+ ASSERT(case sequel of { OnStack -> True; _ -> False})
+#endif
+
+ allocStackTop (fixedHdrSize +
+ sIZEOF_StgUpdateFrame_NoHdr `quot` wORD_SIZE)
+ ; vsp <- getVirtSp
+ ; setStackFrame vsp
+ ; frame_addr <- getSpRelOffset vsp
+ -- The location of the lowest-address
+ -- word of the update frame itself
+
+ ; setEndOfBlockInfo (EndOfBlockInfo vsp UpdateCode) $
+ do { emitPushUpdateFrame frame_addr updatee
+ ; code }
+ }
+
+emitPushUpdateFrame :: CmmExpr -> CmmExpr -> Code
+emitPushUpdateFrame frame_addr updatee = do
+ stmtsC [ -- Set the info word
+ CmmStore frame_addr (mkLblExpr mkUpdInfoLabel)
+ , -- And the updatee
+ CmmStore (cmmOffsetB frame_addr off_updatee) updatee ]
+ initUpdFrameProf frame_addr
+
+off_updatee :: ByteOff
+off_updatee = fixedHdrSize*wORD_SIZE + oFFSET_StgUpdateFrame_updatee
\end{code}
+
%************************************************************************
%* *
\subsection[CgStackery-free]{Free stack slots}
Explicitly free some stack space.
\begin{code}
-addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
-addFreeStackSlots extra_free slot = do
- ((vsp, frame,free, real, hw),heap_usage) <- getUsage
- let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot))
- let (new_vsp, new_free) = trim vsp all_free
- let new_usage = ((new_vsp, frame, new_free, real, hw), heap_usage)
- setUsage new_usage
-
freeStackSlots :: [VirtualSpOffset] -> Code
-freeStackSlots slots = addFreeStackSlots slots Free
-
-dataStackSlots :: [VirtualSpOffset] -> Code
-dataStackSlots slots = addFreeStackSlots slots NonPointer
-
-addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
+freeStackSlots extra_free
+ = do { stk_usg <- getStkUsage
+ ; let all_free = addFreeSlots (freeStk stk_usg) (sortLt (<) extra_free)
+ ; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free
+ ; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) }
+
+addFreeSlots :: [VirtualSpOffset] -> [VirtualSpOffset] -> [VirtualSpOffset]
+-- Merge the two, assuming both are in increasing order
addFreeSlots cs [] = cs
addFreeSlots [] ns = ns
-addFreeSlots ((c,s):cs) ((n,s'):ns)
- = if c < n then
- (c,s) : addFreeSlots cs ((n,s'):ns)
- else if c > n then
- (n,s') : addFreeSlots ((c,s):cs) ns
- else if s /= s' then -- c == n
- (c,s') : addFreeSlots cs ns
- else
- panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
- ++ show (n:map fst ns))
-
-trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
-trim current_sp free_slots
- = try current_sp free_slots
- where
- try csp [] = (csp,[])
-
- try csp (slot@(off,state):slots) =
- if state == Free && null slots' then
- if csp' < off then
- (csp', [])
- else if csp' == off then
- (csp'-1, [])
- else
- (csp',[slot])
- else
- (csp', slot:slots')
- where
- (csp',slots') = try csp slots
+addFreeSlots (c:cs) (n:ns)
+ | c < n = c : addFreeSlots cs (n:ns)
+ | otherwise = n : addFreeSlots (c:cs) ns
+
+trim :: VirtualSpOffset -> [VirtualSpOffset] -> (VirtualSpOffset, [VirtualSpOffset])
+-- Try to trim back the virtual stack pointer, where there is a
+-- continuous bunch of free slots at the end of the free list
+trim vsp [] = (vsp, [])
+trim vsp (slot:slots)
+ = case trim vsp slots of
+ (vsp', [])
+ | vsp' < slot -> pprTrace "trim: strange" (ppr vsp <+> ppr (slot:slots))
+ (vsp', [])
+ | vsp' == slot -> (vsp'-1, [])
+ | otherwise -> (vsp', [slot])
+ (vsp', slots') -> (vsp', slot:slots')
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.38 2003/06/02 13:27:34 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.39 2004/08/13 13:06:13 simonmar Exp $
%
%********************************************************
%* *
module CgTailCall (
cgTailCall, performTailCall,
performReturn, performPrimReturn,
- mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
+ emitKnownConReturnCode, emitAlgReturnCode,
returnUnboxedTuple, ccallReturnUnboxedTuple,
- mkPrimReturnCode,
+ pushUnboxedTuple,
tailCallPrimOp,
pushReturnAddress
#include "HsVersions.h"
import CgMonad
-import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
-import CgRetConv
-import CgStackery
-import CgUsages ( getSpRelOffset, adjustSpAndHp )
+import CgBindery ( getArgAmodes, getCgIdInfo, CgIdInfo, maybeLetNoEscape,
+ idInfoToAmode, cgIdInfoId, cgIdInfoLF,
+ cgIdInfoArgRep )
+import CgInfoTbls ( entryCode, emitDirectReturnInstr, dataConTagZ,
+ emitVectoredReturnInstr, closureInfoPtr )
+import CgCallConv
+import CgStackery ( setRealSp, mkStkAmodes, adjustStackHW,
+ getSpRelOffset )
+import CgHeapery ( setRealHp, getHpRelOffset )
+import CgUtils ( emitSimultaneously )
+import CgTicky
import ClosureInfo
-
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import AbsCSyn
-import CLabel ( mkRtsPrimOpLabel, mkSeqInfoLabel )
-
-import Id ( Id, idType, idName )
-import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
-import PrimRep ( PrimRep(..) )
-import StgSyn ( StgArg )
+import SMRep ( CgRep, isVoidArg, separateByPtrFollowness )
+import Cmm
+import CmmUtils
+import CLabel ( CLabel, mkRtsPrimOpLabel, mkSeqInfoLabel )
import Type ( isUnLiftedType )
-import Name ( Name )
+import Id ( Id, idName, idUnique, idType )
+import DataCon ( DataCon, dataConTyCon )
+import StgSyn ( StgArg )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
-import Util ( zipWithEqual, splitAtList )
-import ListSetOps ( assocMaybe )
-import PrimRep ( isFollowableRep )
import Outputable
-import Panic ( panic, assertPanic )
-import List ( partition )
+import Monad ( when )
-----------------------------------------------------------------------------
-- Tail Calls
-- Treat unboxed locals exactly like literals (above) except use the addr
-- mode for the local instead of (CLit lit) in the assignment.
--- Case for unboxed returns first:
-cgTailCall fun []
- | isUnLiftedType (idType fun)
- = getCAddrMode fun `thenFC` \ amode ->
- performPrimReturn (ppr fun) amode
-
--- The general case (@fun@ is boxed):
cgTailCall fun args
- = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
- getArgAmodes args `thenFC` \ arg_amodes ->
- performTailCall fun' fun_amode lf_info arg_amodes AbsCNop
-
+ = do { fun_info <- getCgIdInfo fun
+
+ ; if isUnLiftedType (idType fun)
+ then -- Primitive return
+ ASSERT( null args )
+ do { fun_amode <- idInfoToAmode fun_info
+ ; performPrimReturn (cgIdInfoArgRep fun_info) fun_amode }
+
+ else -- Normal case, fun is boxed
+ do { arg_amodes <- getArgAmodes args
+ ; performTailCall fun_info arg_amodes noStmts }
+ }
+
-- -----------------------------------------------------------------------------
-- The guts of a tail-call
performTailCall
- :: Id -- function
- -> CAddrMode -- function amode
- -> LambdaFormInfo
- -> [CAddrMode]
- -> AbstractC -- Pending simultaneous assignments
- -- *** GUARANTEED to contain only stack assignments.
+ :: CgIdInfo -- The function
+ -> [(CgRep,CmmExpr)] -- Args
+ -> CmmStmts -- Pending simultaneous assignments
+ -- *** GUARANTEED to contain only stack assignments.
-> Code
-performTailCall fun fun_amode lf_info arg_amodes pending_assts =
- nodeMustPointToIt lf_info `thenFC` \ node_points ->
- let
- -- assign to node if necessary
- node_asst
- | node_points = CAssign (CReg node) fun_amode
- | otherwise = AbsCNop
- in
-
- getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
-
- let
- -- set up for a let-no-escape if necessary
- join_sp = case fun_amode of
- CJoinPoint sp -> sp
- other -> args_sp
- in
-
- -- decide how to code the tail-call: which registers assignments to make,
- -- what args to push on the stack, and how to make the jump
- constructTailCall (idName fun) lf_info arg_amodes join_sp
- node_points fun_amode sequel
- `thenFC` \ (final_sp, arg_assts, jump_code) ->
-
- let sim_assts = mkAbstractCs [node_asst,
- pending_assts,
- arg_assts]
-
- is_lne = case fun_amode of { CJoinPoint _ -> True; _ -> False }
- in
-
- doFinalJump final_sp sim_assts is_lne (const jump_code)
-
-
--- Figure out how to do a particular tail-call.
-
-constructTailCall
- :: Name
- -> LambdaFormInfo
- -> [CAddrMode]
- -> VirtualSpOffset -- Sp at which to make the call
- -> Bool -- node points to the fun closure?
- -> CAddrMode -- addressing mode of the function
- -> Sequel -- the sequel, in case we need it
- -> FCode (
- VirtualSpOffset, -- Sp after pushing the args
- AbstractC, -- assignments
- Code -- code to do the jump
- )
-
-constructTailCall name lf_info arg_amodes sp node_points fun_amode sequel =
-
- getEntryConvention name lf_info (map getAmodeRep arg_amodes)
- `thenFC` \ entry_conv ->
-
- case entry_conv of
- EnterIt -> returnFC (sp, AbsCNop, code)
- where code = profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC`
- absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE
- [CVal (nodeRel 0) DataPtrRep]))
-
- -- A function, but we have zero arguments. It is already in WHNF,
- -- so we can just return it.
- ReturnIt -> returnFC (sp, asst, code)
- where -- if node doesn't already point to the closure, we have to
- -- load it up.
- asst | node_points = AbsCNop
- | otherwise = CAssign (CReg node) fun_amode
-
- code = sequelToAmode sequel `thenFC` \ dest_amode ->
- absC (CReturn dest_amode DirectReturn)
-
- JumpToIt lbl -> returnFC (sp, AbsCNop, code)
- where code = absC (CJump (CLbl lbl CodePtrRep))
-
- -- a slow function call via the RTS apply routines
- SlowCall ->
- let (apply_fn, new_amodes) = constructSlowCall arg_amodes
-
- -- if node doesn't already point to the closure,
- -- we have to load it up.
- node_asst | node_points = AbsCNop
- | otherwise = CAssign (CReg node) fun_amode
- in
-
- -- Fill in all the arguments on the stack
- mkStkAmodes sp new_amodes `thenFC`
- \ (final_sp, stk_assts) ->
-
- returnFC
- (final_sp + 1, -- add one, because the stg_ap functions
- -- expect there to be a free slot on the stk
- mkAbstractCs [node_asst, stk_assts],
- absC (CJump apply_fn)
- )
-
- -- A direct function call (possibly with some left-over arguments)
- DirectEntry lbl arity regs
-
- -- A let-no-escape is slightly different, because we
+performTailCall fun_info arg_amodes pending_assts
+ | Just join_sp <- maybeLetNoEscape fun_info
+ = -- A let-no-escape is slightly different, because we
-- arrange the stack arguments into pointers and non-pointers
-- to make the heap check easier. The tail-call sequence
-- is very similar to returning an unboxed tuple, so we
-- share some code.
- | is_let_no_escape ->
- pushUnboxedTuple sp arg_amodes `thenFC` \ (final_sp, assts) ->
- returnFC (final_sp, assts, absC (CJump (CLbl lbl CodePtrRep)))
-
-
- -- A normal fast call
- | otherwise ->
- let
- -- first chunk of args go in registers
- (reg_arg_amodes, stk_arg_amodes) =
- splitAtList regs arg_amodes
-
- -- the rest of this function's args go straight on the stack
- (stk_args, extra_stk_args) =
- splitAt (arity - length regs) stk_arg_amodes
-
- -- any "extra" arguments are placed in frames on the
- -- stack after the other arguments.
- slow_stk_args = slowArgs extra_stk_args
-
- reg_assts
- = mkAbstractCs (zipWithEqual "assign_to_reg2"
- assign_to_reg regs reg_arg_amodes)
+ do { (final_sp, arg_assts) <- pushUnboxedTuple join_sp arg_amodes
+ ; emitSimultaneously (pending_assts `plusStmts` arg_assts)
+ ; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info))
+ ; doFinalJump final_sp True {- Is LNE -} (jumpToLbl lbl) }
+
+ | otherwise
+ = do { fun_amode <- idInfoToAmode fun_info
+ ; let node_asst = oneStmt (CmmAssign nodeReg fun_amode)
+ opt_node_asst | nodeMustPointToIt lf_info = node_asst
+ | otherwise = noStmts
+ ; EndOfBlockInfo sp _ <- getEndOfBlockInfo
+
+ ; case (getCallMethod fun_name lf_info (length arg_amodes)) of
+
+ -- Node must always point to things we enter
+ EnterIt -> do
+ { emitSimultaneously (node_asst `plusStmts` pending_assts)
+ ; let target = entryCode (closureInfoPtr (CmmReg nodeReg))
+ ; doFinalJump sp False (stmtC (CmmJump target [])) }
+
+ -- A function, but we have zero arguments. It is already in WHNF,
+ -- so we can just return it.
+ -- As with any return, Node must point to it.
+ ReturnIt -> do
+ { emitSimultaneously (node_asst `plusStmts` pending_assts)
+ ; doFinalJump sp False emitDirectReturnInstr }
+
+ -- A real constructor. Don't bother entering it,
+ -- just do the right sort of return instead.
+ -- As with any return, Node must point to it.
+ ReturnCon con -> do
+ { emitSimultaneously (node_asst `plusStmts` pending_assts)
+ ; doFinalJump sp False (emitKnownConReturnCode con) }
+
+ JumpToIt lbl -> do
+ { emitSimultaneously (opt_node_asst `plusStmts` pending_assts)
+ ; doFinalJump sp False (jumpToLbl lbl) }
+
+ -- A slow function call via the RTS apply routines
+ -- Node must definitely point to the thing
+ SlowCall -> do
+ { let (apply_lbl, new_amodes) = constructSlowCall arg_amodes
- in
- mkStkAmodes sp (stk_args ++ slow_stk_args) `thenFC`
- \ (final_sp, stk_assts) ->
+ -- Fill in all the arguments on the stack
+ ; (final_sp,stk_assts) <- mkStkAmodes sp new_amodes
+
+ ; emitSimultaneously (node_asst `plusStmts` stk_assts
+ `plusStmts` pending_assts)
+
+ ; when (not (null arg_amodes)) $ do
+ { if (isKnownFun lf_info)
+ then tickyKnownCallTooFewArgs
+ else tickyUnknownCall
+ ; tickySlowCallPat (map fst arg_amodes)
+ }
+
+ ; doFinalJump (final_sp + 1)
+ -- Add one, because the stg_ap functions
+ -- expect there to be a free slot on the stk
+ False (jumpToLbl apply_lbl)
+ }
+
+ -- A direct function call (possibly with some left-over arguments)
+ DirectEntry lbl arity -> do
+ { let
+ -- The args beyond the arity go straight on the stack
+ (arity_args, extra_stk_args) = splitAt arity arg_amodes
+
+ -- First chunk of args go in registers
+ (reg_arg_amodes, stk_args) = assignCallRegs arity_args
+
+ -- Any "extra" arguments are placed in frames on the
+ -- stack after the other arguments.
+ slow_stk_args = slowArgs extra_stk_args
+
+ reg_assts = assignToRegs reg_arg_amodes
+
+ ; if null slow_stk_args
+ then tickyKnownCallExact
+ else do tickyKnownCallExtraArgs
+ tickySlowCallPat (map fst extra_stk_args)
+
+ ; (final_sp, stk_assts) <- mkStkAmodes sp
+ (stk_args ++ slow_stk_args)
+
+ ; emitSimultaneously (opt_node_asst `plusStmts`
+ reg_assts `plusStmts`
+ stk_assts `plusStmts`
+ pending_assts)
+
+ ; doFinalJump final_sp False (jumpToLbl lbl) }
+ }
+ where
+ fun_name = idName (cgIdInfoId fun_info)
+ lf_info = cgIdInfoLF fun_info
- returnFC
- (final_sp,
- mkAbstractCs [reg_assts, stk_assts],
- absC (CJump (CLbl lbl CodePtrRep))
- )
- where is_let_no_escape = case fun_amode of
- CJoinPoint _ -> True
- _ -> False
-- -----------------------------------------------------------------------------
-- The final clean-up before we do a jump at the end of a basic block.
-- This code is shared by tail-calls and returns.
-doFinalJump :: VirtualSpOffset -> AbstractC -> Bool -> (Sequel -> Code) -> Code
-doFinalJump final_sp sim_assts is_let_no_escape jump_code =
-
- -- adjust the high-water mark if necessary
- adjustStackHW final_sp `thenC`
+doFinalJump :: VirtualSpOffset -> Bool -> Code -> Code
+doFinalJump final_sp is_let_no_escape jump_code
+ = do { -- Adjust the high-water mark if necessary
+ adjustStackHW final_sp
- -- Do the simultaneous assignments,
- absC (CSimultaneous sim_assts) `thenC`
-
- -- push a return address if necessary (after the assignments
+ -- Push a return address if necessary (after the assignments
-- above, in case we clobber a live stack location)
--
-- DONT push the return address when we're about to jump to a
-- let-no-escape: the final tail call in the let-no-escape
-- will do this.
- getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
- (if is_let_no_escape then nopC
- else pushReturnAddress eob) `thenC`
+ ; eob <- getEndOfBlockInfo
+ ; whenC (not is_let_no_escape) (pushReturnAddress eob)
- -- Final adjustment of Sp/Hp
- adjustSpAndHp final_sp `thenC`
+ -- Final adjustment of Sp/Hp
+ ; adjustSpAndHp final_sp
- -- and do the jump
- jump_code sequel
+ -- and do the jump
+ ; jump_code }
-- -----------------------------------------------------------------------------
-- A general return (just a special case of doFinalJump, above)
-performReturn :: AbstractC -- Simultaneous assignments to perform
- -> (Sequel -> Code) -- The code to execute to actually do
- -- the return, given an addressing mode
- -- for the return address
+performReturn :: Code -- The code to execute to actually do the return
-> Code
-performReturn sim_assts finish_code
- = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
- doFinalJump args_sp sim_assts False{-not a LNE-} finish_code
+performReturn finish_code
+ = do { EndOfBlockInfo args_sp sequel <- getEndOfBlockInfo
+ ; doFinalJump args_sp False{-not a LNE-} finish_code }
-- -----------------------------------------------------------------------------
-- Primitive Returns
-
-- Just load the return value into the right register, and return.
-performPrimReturn :: SDoc -- Just for debugging (sigh)
- -> CAddrMode -- The thing to return
+performPrimReturn :: CgRep -> CmmExpr -- The thing to return
-> Code
-
-performPrimReturn doc amode
- = let
- kind = getAmodeRep amode
- ret_reg = dataReturnConvPrim kind
-
- assign_possibly = case kind of
- VoidRep -> AbsCNop
- kind -> (CAssign (CReg ret_reg) amode)
- in
- performReturn assign_possibly (mkPrimReturnCode doc)
-
-mkPrimReturnCode :: SDoc -- Debugging only
- -> Sequel
- -> Code
-mkPrimReturnCode doc UpdateCode = pprPanic "mkPrimReturnCode: Upd" doc
-mkPrimReturnCode doc sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
- absC (CReturn dest_amode DirectReturn)
- -- Direct, no vectoring
+performPrimReturn rep amode
+ = do { whenC (not (isVoidArg rep))
+ (stmtC (CmmAssign ret_reg amode))
+ ; performReturn emitDirectReturnInstr }
+ where
+ ret_reg = dataReturnConvPrim rep
-- -----------------------------------------------------------------------------
-- Algebraic constructor returns
-- Constructor is built on the heap; Node is set.
--- All that remains is
--- (a) to set TagReg, if necessary
--- (c) to do the right sort of jump.
-
-mkStaticAlgReturnCode :: DataCon -- The constructor
- -> Sequel -- where to return to
- -> Code
-
-mkStaticAlgReturnCode con sequel
- = -- Generate profiling code if necessary
- (case return_convention of
- VectoredReturn sz -> profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz]
- other -> nopC
- ) `thenC`
-
- -- Set tag if necessary
- -- This is done by a macro, because if we are short of registers
- -- we don't set TagReg; instead the continuation gets the tag
- -- by indexing off the info ptr
- (case return_convention of
-
- UnvectoredReturn no_of_constrs
- | no_of_constrs > 1
- -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag])
-
- other -> nopC
- ) `thenC`
-
- -- Generate the right jump or return
- (case sequel of
- CaseAlts _ (Just (alts, _)) False -> -- Ho! We know the constructor so
- -- we can go right to the alternative
-
- case assocMaybe alts tag of
- Just (alt_absC, join_lbl) ->
- absC (CJump (CLbl join_lbl CodePtrRep))
- Nothing -> panic "mkStaticAlgReturnCode: default"
- -- The Nothing case should never happen;
- -- it's the subject of a wad of special-case
- -- code in cgReturnCon
-
- other -> -- OnStack, or (CaseAlts ret_amode Nothing),
- -- or UpdateCode.
- sequelToAmode sequel `thenFC` \ ret_amode ->
- absC (CReturn ret_amode return_info)
- )
+-- All that remains is to do the right sort of jump.
- where
- tag = dataConTag con
- tycon = dataConTyCon con
- return_convention = ctrlReturnConvAlg tycon
- zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
- -- cf AbsCUtils.mkAlgAltsCSwitch
-
- return_info =
- case return_convention of
- UnvectoredReturn _ -> DirectReturn
- VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
-
-
--- -----------------------------------------------------------------------------
--- Returning an enumerated type from a PrimOp
+emitKnownConReturnCode :: DataCon -> Code
+emitKnownConReturnCode con
+ = emitAlgReturnCode (dataConTyCon con)
+ (CmmLit (mkIntCLit (dataConTagZ con)))
+ -- emitAlgReturnCode requires zero-indexed tag
--- This function is used by PrimOps that return enumerated types (i.e.
+emitAlgReturnCode :: TyCon -> CmmExpr -> Code
+-- emitAlgReturnCode is used both by emitKnownConReturnCode,
+-- and by by PrimOps that return enumerated types (i.e.
-- all the comparison operators).
-
-mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
-
-mkDynamicAlgReturnCode tycon dyn_tag sequel
- = case ctrlReturnConvAlg tycon of
- VectoredReturn sz ->
-
- profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC`
- sequelToAmode sequel `thenFC` \ ret_addr ->
- absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
-
- UnvectoredReturn no_of_constrs ->
-
- -- Set tag if necessary
- -- This is done by a macro, because if we are short of registers
- -- we don't set TagReg; instead the continuation gets the tag
- -- by indexing off the info ptr
- (if no_of_constrs > 1 then
- absC (CMacroStmt SET_TAG [dyn_tag])
- else
- nopC
- ) `thenC`
-
-
- sequelToAmode sequel `thenFC` \ ret_addr ->
- -- Generate the right jump or return
- absC (CReturn ret_addr DirectReturn)
+emitAlgReturnCode tycon tag
+ = do { case ctrlReturnConvAlg tycon of
+ VectoredReturn fam_sz -> do { tickyVectoredReturn fam_sz
+ ; emitVectoredReturnInstr tag }
+ UnvectoredReturn _ -> emitDirectReturnInstr
+ }
-- ---------------------------------------------------------------------------
-- let-no-escape functions, because they also can't be partially
-- applied.
-returnUnboxedTuple :: [CAddrMode] -> Code
-returnUnboxedTuple amodes =
- getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
-
- profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
-
- pushUnboxedTuple args_sp amodes `thenFC` \ (final_sp, assts) ->
- doFinalJump final_sp assts False{-not a LNE-} mkUnboxedTupleReturnCode
-
-
-pushUnboxedTuple
- :: VirtualSpOffset -- Sp at which to start pushing
- -> [CAddrMode] -- amodes of the components
- -> FCode (VirtualSpOffset, -- final Sp
- AbstractC) -- assignments (regs+stack)
-
-pushUnboxedTuple sp amodes =
- let
- (arg_regs, _leftovers) = assignRegs [] (map getAmodeRep amodes)
-
- (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs amodes
-
- -- separate the rest of the args into pointers and non-pointers
- ( ptr_args, nptr_args ) =
- partition (isFollowableRep . getAmodeRep) stk_arg_amodes
-
- reg_arg_assts
- = mkAbstractCs (zipWithEqual "assign_to_reg2"
- assign_to_reg arg_regs reg_arg_amodes)
- in
-
- -- push ptrs, then nonptrs, on the stack
- mkStkAmodes sp ptr_args `thenFC` \ (ptr_sp, ptr_assts) ->
- mkStkAmodes ptr_sp nptr_args `thenFC` \ (final_sp, nptr_assts) ->
+returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code
+returnUnboxedTuple amodes
+ = do { eob@(EndOfBlockInfo args_sp sequel) <- getEndOfBlockInfo
+ ; tickyUnboxedTupleReturn (length amodes)
+ ; (final_sp, assts) <- pushUnboxedTuple args_sp amodes
+ ; emitSimultaneously assts
+ ; doFinalJump final_sp False{-not a LNE-} emitDirectReturnInstr }
+
+pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing
+ -> [(CgRep, CmmExpr)] -- amodes of the components
+ -> FCode (VirtualSpOffset, -- final Sp
+ CmmStmts) -- assignments (regs+stack)
+
+pushUnboxedTuple sp []
+ = return (sp, noStmts)
+pushUnboxedTuple sp amodes
+ = do { let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs amodes
+
+ -- separate the rest of the args into pointers and non-pointers
+ (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes
+ reg_arg_assts = assignToRegs reg_arg_amodes
+
+ -- push ptrs, then nonptrs, on the stack
+ ; (ptr_sp, ptr_assts) <- mkStkAmodes sp ptr_args
+ ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args
- returnFC (final_sp,
- mkAbstractCs [reg_arg_assts, ptr_assts, nptr_assts])
+ ; returnFC (final_sp,
+ reg_arg_assts `plusStmts`
+ ptr_assts `plusStmts` nptr_assts) }
-
-mkUnboxedTupleReturnCode :: Sequel -> Code
-mkUnboxedTupleReturnCode sequel
- = case sequel of
- -- can't update with an unboxed tuple!
- UpdateCode -> panic "mkUnboxedTupleReturnCode"
-
- CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) False ->
- absC (CJump (CLbl join_lbl CodePtrRep))
-
- other -> -- OnStack, or (CaseAlts ret_amode something)
- sequelToAmode sequel `thenFC` \ ret_amode ->
- absC (CReturn ret_amode DirectReturn)
-
-- -----------------------------------------------------------------------------
-- Returning unboxed tuples. This is mainly to support _ccall_GC_, where
-- we want to do things in a slightly different order to normal:
-- (in order to avoid pushing it again), so we end up doing a needless
-- indirect jump (ToDo).
-ccallReturnUnboxedTuple :: [CAddrMode] -> Code -> Code
+ccallReturnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -> Code
ccallReturnUnboxedTuple amodes before_jump
- = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
-
- -- push a return address if necessary
- pushReturnAddress eob `thenC`
- setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
-
- -- Adjust Sp/Hp
- adjustSpAndHp args_sp `thenC`
+ = do { eob@(EndOfBlockInfo args_sp _) <- getEndOfBlockInfo
- before_jump `thenC`
-
- returnUnboxedTuple amodes
- )
+ -- Push a return address if necessary
+ ; pushReturnAddress eob
+ ; setEndOfBlockInfo (EndOfBlockInfo args_sp OnStack)
+ (do { adjustSpAndHp args_sp
+ ; before_jump
+ ; returnUnboxedTuple amodes })
+ }
-- -----------------------------------------------------------------------------
-- Calling an out-of-line primop
tailCallPrimOp :: PrimOp -> [StgArg] -> Code
-tailCallPrimOp op args =
- -- we're going to perform a normal-looking tail call,
- -- except that *all* the arguments will be in registers.
- getArgAmodes args `thenFC` \ arg_amodes ->
- let (arg_regs, leftovers) = assignAllRegs [] (map getAmodeRep arg_amodes)
+tailCallPrimOp op args
+ = do { -- We're going to perform a normal-looking tail call,
+ -- except that *all* the arguments will be in registers.
+ -- Hence the ASSERT( null leftovers )
+ arg_amodes <- getArgAmodes args
+ ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes
+ jump_to_primop = jumpToLbl (mkRtsPrimOpLabel op)
- reg_arg_assts
- = mkAbstractCs (zipWithEqual "assign_to_reg2"
- assign_to_reg arg_regs arg_amodes)
+ ; ASSERT(null leftovers) -- no stack-resident args
+ emitSimultaneously (assignToRegs arg_regs)
- jump_to_primop =
- absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep))
- in
-
- ASSERT(null leftovers) -- no stack-resident args
-
- getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
- doFinalJump args_sp reg_arg_assts False{-not a LNE-} (const jump_to_primop)
+ ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo
+ ; doFinalJump args_sp False{-not a LNE-} jump_to_primop }
-- -----------------------------------------------------------------------------
-- Return Addresses
pushReturnAddress :: EndOfBlockInfo -> Code
-pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ False)) =
- getSpRelOffset args_sp `thenFC` \ sp_rel ->
- absC (CAssign (CVal sp_rel RetRep) amode)
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ False))
+ = do { sp_rel <- getSpRelOffset args_sp
+ ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) }
-- For a polymorphic case, we have two return addresses to push: the case
-- return, and stg_seq_frame_info which turns a possible vectored return
-- into a direct one.
-pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ True)) =
- getSpRelOffset (args_sp-1) `thenFC` \ sp_rel ->
- absC (CAssign (CVal sp_rel RetRep) amode) `thenC`
- getSpRelOffset args_sp `thenFC` \ sp_rel ->
- absC (CAssign (CVal sp_rel RetRep) (CLbl mkSeqInfoLabel RetRep))
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ True))
+ = do { sp_rel <- getSpRelOffset (args_sp-1)
+ ; stmtC (CmmStore sp_rel (mkLblExpr lbl))
+ ; sp_rel <- getSpRelOffset args_sp
+ ; stmtC (CmmStore sp_rel (CmmLit (CmmLabel mkSeqInfoLabel))) }
+
pushReturnAddress _ = nopC
-- -----------------------------------------------------------------------------
-- Misc.
-assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
+jumpToLbl :: CLabel -> Code
+-- Passes no argument to the destination procedure
+jumpToLbl lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl)) [{- No args -}])
+assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts
+assignToRegs reg_args
+ = mkStmts [ CmmAssign (CmmGlobal reg_id) expr
+ | (expr, reg_id) <- reg_args ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[CgStackery-adjust]{Adjusting the stack pointers}
+%* *
+%************************************************************************
+
+This function adjusts the stack and heap pointers just before a tail
+call or return. The stack pointer is adjusted to its final position
+(i.e. to point to the last argument for a tail call, or the activation
+record for a return). The heap pointer may be moved backwards, in
+cases where we overallocated at the beginning of the basic block (see
+CgCase.lhs for discussion).
+
+These functions {\em do not} deal with high-water-mark adjustment.
+That's done by functions which allocate stack space.
+
+\begin{code}
+adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr
+ -> Code
+adjustSpAndHp newRealSp
+ = do { -- Adjust stack, if necessary.
+ -- NB: the conditional on the monad-carried realSp
+ -- is out of line (via codeOnly), to avoid a black hole
+ ; new_sp <- getSpRelOffset newRealSp
+ ; checkedAbsC (CmmAssign spReg new_sp) -- Will generate no code in the case
+ ; setRealSp newRealSp -- where realSp==newRealSp
+
+ -- Adjust heap. The virtual heap pointer may be less than the real Hp
+ -- because the latter was advanced to deal with the worst-case branch
+ -- of the code, and we may be in a better-case branch. In that case,
+ -- move the real Hp *back* and retract some ticky allocation count.
+ ; hp_usg <- getHpUsage
+ ; let rHp = realHp hp_usg
+ vHp = virtHp hp_usg
+ ; new_hp <- getHpRelOffset vHp
+ ; checkedAbsC (CmmAssign hpReg new_hp) -- Generates nothing when vHp==rHp
+ ; tickyAllocHeap (vHp - rHp) -- ...ditto
+ ; setRealHp vHp
+ }
\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Code generation for ticky-ticky profiling
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CgTicky (
+ emitTickyCounter,
+
+ tickyDynAlloc,
+ tickyAllocHeap,
+ tickyAllocPrim,
+ tickyAllocThunk,
+ tickyAllocPAP,
+
+ tickyPushUpdateFrame,
+ tickyUpdateFrameOmitted,
+
+ tickyEnterDynCon,
+ tickyEnterStaticCon,
+ tickyEnterViaNode,
+
+ tickyEnterFun,
+ tickyEnterThunk,
+
+ tickyUpdateBhCaf,
+ tickyBlackHole,
+ tickyUnboxedTupleReturn, tickyVectoredReturn,
+ tickyReturnOldCon, tickyReturnNewCon,
+
+ tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
+ tickyUnknownCall, tickySlowCallPat,
+
+ staticTickyHdr,
+ ) where
+
+#include "HsVersions.h"
+#include "../includes/DerivedConstants.h"
+ -- For REP_xxx constants, which are MachReps
+
+import ClosureInfo ( ClosureInfo, closureSize, slopSize, closureSMRep,
+ closureUpdReqd, closureName, isStaticClosure )
+import CgUtils
+import CgMonad
+import SMRep ( ClosureType(..), smRepClosureType, CgRep )
+
+import Cmm
+import MachOp
+import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr, cmmIndexExpr )
+import CLabel ( CLabel, mkRtsDataLabel, mkRednCountsLabel )
+
+import Name ( isInternalName )
+import Id ( Id, idType )
+import CmdLineOpts ( opt_DoTickyProfiling )
+import BasicTypes ( Arity )
+import FastString ( FastString, mkFastString, LitString )
+import Constants -- Lots of field offsets
+import Outputable
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType ( Type, isDictTy, tcSplitTyConApp_maybe,
+ tcSplitFunTy_maybe )
+import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon,
+ maybeTyConSingleCon )
+import Maybe
+
+-----------------------------------------------------------------------------
+--
+-- Ticky-ticky profiling
+--
+-----------------------------------------------------------------------------
+
+staticTickyHdr :: [CmmLit]
+-- The ticky header words in a static closure
+-- Was SET_STATIC_TICKY_HDR
+staticTickyHdr
+ | not opt_DoTickyProfiling = []
+ | otherwise = [zeroCLit]
+
+emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
+emitTickyCounter cl_info args on_stk
+ = ifTicky $
+ do { mod_name <- moduleName
+ ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
+ ; arg_descr_lit <- mkStringCLit arg_descr
+ ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
+ [ CmmInt 0 I16,
+ CmmInt (fromIntegral (length args)) I16, -- Arity
+ CmmInt (fromIntegral on_stk) I16, -- Words passed on stack
+ CmmInt 0 I16, -- 2-byte gap
+ fun_descr_lit,
+ arg_descr_lit,
+ zeroCLit, -- Entry count
+ zeroCLit, -- Allocs
+ zeroCLit -- Link
+ ] }
+ where
+ name = closureName cl_info
+ ticky_ctr_label = mkRednCountsLabel name
+ arg_descr = map (showTypeCategory . idType) args
+ fun_descr mod_name = ppr_for_ticky_name mod_name name
+
+-- When printing the name of a thing in a ticky file, we want to
+-- give the module name even for *local* things. We print
+-- just "x (M)" rather that "M.x" to distinguish them from the global kind.
+ppr_for_ticky_name mod_name name
+ | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
+ | otherwise = showSDocDebug (ppr name)
+
+-- -----------------------------------------------------------------------------
+-- Ticky stack frames
+
+tickyPushUpdateFrame = ifTicky $ bumpTickyCounter SLIT("UPDF_PUSHED_ctr")
+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter SLIT("UPDF_OMITTED_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky entries
+
+tickyEnterDynCon = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_CON_ctr")
+tickyEnterDynThunk = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_THK_ctr")
+tickyEnterStaticCon = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_CON_ctr")
+tickyEnterStaticThunk = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_THK_ctr")
+tickyEnterViaNode = ifTicky $ bumpTickyCounter SLIT("ENT_VIA_NODE_ctr")
+
+tickyEnterThunk :: ClosureInfo -> Code
+tickyEnterThunk cl_info
+ | isStaticClosure cl_info = tickyEnterStaticThunk
+ | otherwise = tickyEnterDynThunk
+
+tickyBlackHole :: Bool{-updatable-} -> Code
+tickyBlackHole updatable
+ = ifTicky (bumpTickyCounter ctr)
+ where
+ ctr | updatable = SLIT("UPD_BH_SINGLE_ENTRY_ctr")
+ | otherwise = SLIT("UPD_BH_UPDATABLE_ctr")
+
+tickyUpdateBhCaf cl_info
+ = ifTicky (bumpTickyCounter ctr)
+ where
+ ctr | closureUpdReqd cl_info = SLIT("UPD_CAF_BH_SINGLE_ENTRY_ctr")
+ | otherwise = SLIT("UPD_CAF_BH_UPDATABLE_ctr")
+
+tickyEnterFun :: ClosureInfo -> Code
+tickyEnterFun cl_info
+ = ifTicky $
+ do { bumpTickyCounter ctr
+ ; fun_ctr_lbl <- getTickyCtrLabel
+ ; registerTickyCtr fun_ctr_lbl
+ ; bumpTickyCounter' fun_ctr_lbl }
+ where
+ ctr | isStaticClosure cl_info = SLIT("TICK_ENT_STATIC_FUN_DIRECT")
+ | otherwise = SLIT("TICK_ENT_DYN_FUN_DIRECT")
+
+registerTickyCtr :: CLabel -> Code
+-- Register a ticky counter
+-- if ( ! f_ct.registeredp ) {
+-- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
+-- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
+-- f_ct.registeredp = 1 }
+registerTickyCtr ctr_lbl
+ = emitIf test (stmtsC register_stmts)
+ where
+ test = CmmMachOp (MO_Not I16)
+ [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
+ oFFSET_StgEntCounter_registeredp)) I16]
+ register_stmts
+ = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
+ (CmmLoad ticky_entry_ctrs wordRep)
+ , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
+ , CmmStore (CmmLit (cmmLabelOffB ctr_lbl
+ oFFSET_StgEntCounter_registeredp))
+ (CmmLit (mkIntCLit 1)) ]
+ ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel SLIT("ticky_entry_ctrs"))
+
+tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
+tickyReturnOldCon arity
+ = ifTicky $ do { bumpTickyCounter SLIT("RET_OLD_ctr")
+ ; bumpHistogram SLIT("RET_OLD_hst") arity }
+tickyReturnNewCon arity
+ | not opt_DoTickyProfiling = nopC
+ | otherwise
+ = ifTicky $ do { bumpTickyCounter SLIT("RET_NEW_ctr")
+ ; bumpHistogram SLIT("RET_NEW_hst") arity }
+
+tickyUnboxedTupleReturn :: Int -> Code
+tickyUnboxedTupleReturn arity
+ = ifTicky $ do { bumpTickyCounter SLIT("RET_UNBOXED_TUP_ctr")
+ ; bumpHistogram SLIT("RET_UNBOXED_TUP_hst") arity }
+
+tickyVectoredReturn :: Int -> Code
+tickyVectoredReturn family_size
+ = ifTicky $ do { bumpTickyCounter SLIT("VEC_RETURN_ctr")
+ ; bumpHistogram SLIT("RET_VEC_RETURN_hst") family_size }
+
+-- -----------------------------------------------------------------------------
+-- Ticky calls
+
+-- Ticks at a *call site*:
+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_TOO_FEW_ARGS_ctr")
+tickyKnownCallExact = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_ctr")
+tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_EXTRA_ctr")
+tickyUnknownCall = ifTicky $ bumpTickyCounter SLIT("UNKNOWN_CALL_ctr")
+
+-- Tick for the call pattern at slow call site (i.e. in addition to
+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
+tickySlowCallPat :: [CgRep] -> Code
+tickySlowCallPat args = return ()
+{- LATER: (introduces recursive module dependency now).
+ case callPattern args of
+ (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
+ (str, False) -> bumpTickyCounter SLIT("TICK_SLOW_CALL_OTHER")
+
+callPattern :: [CgRep] -> (String,Bool)
+callPattern reps
+ | match == length reps = (chars, True)
+ | otherwise = (chars, False)
+ where (_,match) = findMatch reps
+ chars = map argChar reps
+
+argChar VoidArg = 'v'
+argChar PtrArg = 'p'
+argChar NonPtrArg = 'n'
+argChar LongArg = 'l'
+argChar FloatArg = 'f'
+argChar DoubleArg = 'd'
+-}
+
+-- -----------------------------------------------------------------------------
+-- Ticky allocation
+
+tickyDynAlloc :: ClosureInfo -> Code
+-- Called when doing a dynamic heap allocation
+tickyDynAlloc cl_info
+ = ifTicky $
+ case smRepClosureType (closureSMRep cl_info) of
+ Constr -> tick_alloc_con
+ ConstrNoCaf -> tick_alloc_con
+ Fun -> tick_alloc_fun
+ Thunk -> tick_alloc_thk
+ ThunkSelector -> tick_alloc_thk
+ where
+ -- will be needed when we fill in stubs
+ cl_size = closureSize cl_info
+ slop_size = slopSize cl_info
+
+ tick_alloc_thk
+ | closureUpdReqd cl_info = tick_alloc_up_thk
+ | otherwise = tick_alloc_se_thk
+
+ tick_alloc_con = panic "ToDo: tick_alloc"
+ tick_alloc_fun = panic "ToDo: tick_alloc"
+ tick_alloc_up_thk = panic "ToDo: tick_alloc"
+ tick_alloc_se_thk = panic "ToDo: tick_alloc"
+
+tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+tickyAllocPrim hdr goods slop = ifTicky $ panic "ToDo: tickyAllocPrim"
+
+tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
+tickyAllocThunk goods slop = ifTicky $ panic "ToDo: tickyAllocThunk"
+
+tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
+tickyAllocPAP goods slop = ifTicky $ panic "ToDo: tickyAllocPAP"
+
+tickyAllocHeap :: VirtualHpOffset -> Code
+-- Called when doing a heap check [TICK_ALLOC_HEAP]
+tickyAllocHeap hp
+ = ifTicky $
+ do { ticky_ctr <- getTickyCtrLabel
+ ; stmtsC $
+ if hp == 0 then [] -- Inside the stmtC to avoid control
+ else [ -- dependency on the argument
+ -- Bump the allcoation count in the StgEntCounter
+ addToMem REP_StgEntCounter_allocs
+ (CmmLit (cmmLabelOffB ticky_ctr
+ oFFSET_StgEntCounter_allocs)) hp,
+ -- Bump ALLOC_HEAP_ctr
+ addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_ctr")) 1,
+ -- Bump ALLOC_HEAP_tot
+ addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_tot")) hp] }
+
+-- -----------------------------------------------------------------------------
+-- Ticky utils
+
+ifTicky :: Code -> Code
+ifTicky code
+ | opt_DoTickyProfiling = code
+ | otherwise = nopC
+
+addToMemLbl :: MachRep -> CLabel -> Int -> CmmStmt
+addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
+
+-- All the ticky-ticky counters are declared "unsigned long" in C
+bumpTickyCounter :: LitString -> Code
+bumpTickyCounter lbl = bumpTickyCounter' (mkRtsDataLabel lbl)
+
+bumpTickyCounter' :: CLabel -> Code
+bumpTickyCounter' lbl = stmtC (addToMemLbl cLongRep lbl 1)
+
+addToMemLong = addToMem cLongRep
+
+bumpHistogram :: LitString -> Int -> Code
+bumpHistogram lbl n
+ = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep))
+
+bumpHistogramE :: LitString -> CmmExpr -> Code
+bumpHistogramE lbl n
+ = do t <- newTemp cLongRep
+ stmtC (CmmAssign t n)
+ emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg t, eight]) $
+ stmtC (CmmAssign t eight)
+ stmtC (addToMemLong (cmmIndexExpr cLongRep
+ (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
+ (CmmReg t))
+ 1)
+ where
+ eight = CmmLit (CmmInt 8 cLongRep)
+
+------------------------------------------------------------------
+-- Showing the "type category" for ticky-ticky profiling
+
+showTypeCategory :: Type -> Char
+ {- {C,I,F,D} char, int, float, double
+ T tuple
+ S other single-constructor type
+ {c,i,f,d} unboxed ditto
+ t *unpacked* tuple
+ s *unpacked" single-cons...
+
+ v void#
+ a primitive array
+
+ E enumeration type
+ + dictionary, unless it's a ...
+ L List
+ > function
+ M other (multi-constructor) data-con type
+ . other type
+ - reserved for others to mark as "uninteresting"
+ -}
+showTypeCategory ty
+ = if isDictTy ty
+ then '+'
+ else
+ case tcSplitTyConApp_maybe ty of
+ Nothing -> if isJust (tcSplitFunTy_maybe ty)
+ then '>'
+ else '.'
+
+ Just (tycon, _) ->
+ let utc = getUnique tycon in
+ if utc == charDataConKey then 'C'
+ else if utc == intDataConKey then 'I'
+ else if utc == floatDataConKey then 'F'
+ else if utc == doubleDataConKey then 'D'
+ else if utc == smallIntegerDataConKey ||
+ utc == largeIntegerDataConKey then 'J'
+ else if utc == charPrimTyConKey then 'c'
+ else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+ || utc == addrPrimTyConKey) then 'i'
+ else if utc == floatPrimTyConKey then 'f'
+ else if utc == doublePrimTyConKey then 'd'
+ else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
+ else if isEnumerationTyCon tycon then 'E'
+ else if isTupleTyCon tycon then 'T'
+ else if isJust (maybeTyConSingleCon tycon) then 'S'
+ else if utc == listTyConKey then 'L'
+ else 'M' -- oh, well...
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgUpdate]{Manipulating update frames}
-
-\begin{code}
-module CgUpdate ( pushUpdateFrame ) where
-
-#include "HsVersions.h"
-
-import CgMonad
-import AbsCSyn
-
-import CgStackery ( allocStackTop, updateFrameSize, setStackFrame )
-import CgUsages ( getVirtSp )
-import Panic ( assertPanic )
-\end{code}
-
-
-%********************************************************
-%* *
-%* Setting up update frames *
-%* *
-%********************************************************
-\subsection[setting-update-frames]{Setting up update frames}
-
-@pushUpdateFrame@ $updatee$ pushes a general update frame which
-points to $updatee$ as the thing to be updated. It is only used
-when a thunk has just been entered, so the (real) stack pointers
-are guaranteed to be nicely aligned with the top of stack.
-@pushUpdateFrame@ adjusts the virtual and tail stack pointers
-to reflect the frame pushed.
-
-\begin{code}
-pushUpdateFrame :: CAddrMode -> Code -> Code
-
-pushUpdateFrame updatee code
- =
-#ifdef DEBUG
- getEndOfBlockInfo `thenFC` \ eob_info ->
- ASSERT(case eob_info of { EndOfBlockInfo _ (OnStack _) -> True;
- _ -> False})
-#endif
-
- allocStackTop updateFrameSize `thenFC` \ _ ->
- getVirtSp `thenFC` \ vsp ->
-
- setStackFrame vsp `thenC`
-
- setEndOfBlockInfo (EndOfBlockInfo vsp UpdateCode) (
-
- -- Emit the push macro
- absC (CMacroStmt PUSH_UPD_FRAME [
- updatee,
- int_CLit0 -- we just entered a closure, so must be zero
- ])
- `thenC` code
- )
-
-int_CLit0 = mkIntCLit 0 -- out here to avoid pushUpdateFrame CAF (sigh)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgUsages]{Accessing and modifying stacks and heap usage info}
-
-This module provides the functions to access (\tr{get*} functions) and
-modify (\tr{set*} functions) the stacks and heap usage information.
-
-\begin{code}
-module CgUsages (
- initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp,
- setRealAndVirtualSp,
-
- getVirtSp, getRealSp,
-
- getHpRelOffset, getSpRelOffset,
-
- adjustSpAndHp
- ) where
-
-#include "HsVersions.h"
-
-import AbsCSyn
-import PrimRep ( PrimRep(..) )
-import AbsCUtils ( mkAbstractCs )
-import CgMonad
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
-%* *
-%************************************************************************
-
-@initHeapUsage@ applies a function to the amount of heap that it uses.
-It initialises the heap usage to zeros, and passes on an unchanged
-heap usage.
-
-It is usually a prelude to performing a GC check, so everything must
-be in a tidy and consistent state.
-
-rje: Note the slightly suble fixed point behaviour needed here
-\begin{code}
-initHeapUsage :: (VirtualHeapOffset -> Code) -> Code
-
-initHeapUsage fcode = do
- (stk_usage, heap_usage) <- getUsage
- setUsage (stk_usage, (0,0))
- fixC (\heap_usage2 -> do
- fcode (heapHWM heap_usage2)
- (_, heap_usage2) <- getUsage
- return heap_usage2)
- (stk_usage2, heap_usage2) <- getUsage
- setUsage (stk_usage2, heap_usage {-unchanged -})
-\end{code}
-
-\begin{code}
-setVirtHp :: VirtualHeapOffset -> Code
-setVirtHp new_virtHp = do
- (stk, (virtHp, realHp)) <- getUsage
- setUsage (stk, (new_virtHp, realHp))
-\end{code}
-
-\begin{code}
-getVirtAndRealHp :: FCode (VirtualHeapOffset, VirtualHeapOffset)
-getVirtAndRealHp = do
- (_, (virtHp, realHp)) <- getUsage
- return (virtHp, realHp)
-\end{code}
-
-\begin{code}
-setRealHp :: VirtualHeapOffset -> Code
-setRealHp realHp = do
- (stk_usage, (vHp, _)) <- getUsage
- setUsage (stk_usage, (vHp, realHp))
-\end{code}
-
-\begin{code}
-getHpRelOffset :: VirtualHeapOffset -> FCode RegRelative
-getHpRelOffset virtual_offset = do
- (_,(_,realHp)) <- getUsage
- return $ hpRel realHp virtual_offset
-\end{code}
-
-The heap high water mark is the larger of virtHp and hwHp. The latter is
-only records the high water marks of forked-off branches, so to find the
-heap high water mark you have to take the max of virtHp and hwHp. Remember,
-virtHp never retreats!
-
-\begin{code}
-heapHWM (virtHp, realHp) = virtHp
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgUsages-stackery]{Monad things for fiddling with stack usage}
-%* *
-%************************************************************************
-
-@setRealAndVirtualSp@ sets into the environment the offsets of the
-current position of the real and virtual stack pointers in the current
-stack frame. The high-water mark is set too. It generates no code.
-It is used to initialise things at the beginning of a closure body.
-
-\begin{code}
-setRealAndVirtualSp :: VirtualSpOffset -- New real Sp
- -> Code
-
-setRealAndVirtualSp sp = do
- ((vsp,frame,f,realSp,hwsp), h_usage) <- getUsage
- let new_usage = ((sp, frame, f, sp, sp), h_usage)
- setUsage new_usage
-\end{code}
-
-\begin{code}
-getVirtSp :: FCode VirtualSpOffset
-getVirtSp = do
- ((virtSp,_,_,_,_), _) <- getUsage
- return virtSp
-
-getRealSp :: FCode VirtualSpOffset
-getRealSp = do
- ((_,_,_,realSp,_),_) <- getUsage
- return realSp
-\end{code}
-
-\begin{code}
-getSpRelOffset :: VirtualSpOffset -> FCode RegRelative
-getSpRelOffset virtual_offset = do
- ((_,_,_,realSp,_),_) <- getUsage
- return $ spRel realSp virtual_offset
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgStackery-adjust]{Adjusting the stack pointers}
-%* *
-%************************************************************************
-
-This function adjusts the stack and heap pointers just before a tail
-call or return. The stack pointer is adjusted to its final position
-(i.e. to point to the last argument for a tail call, or the activation
-record for a return). The heap pointer may be moved backwards, in
-cases where we overallocated at the beginning of the basic block (see
-CgCase.lhs for discussion).
-
-These functions {\em do not} deal with high-water-mark adjustment.
-That's done by functions which allocate stack space.
-
-\begin{code}
-adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr
- -> Code
-adjustSpAndHp newRealSp = do
- (MkCgInfoDown _ _ _ ticky_ctr _) <- getInfoDown
- (MkCgState absC binds
- ((vSp,frame,fSp,realSp,hwSp),
- (vHp, rHp))) <- getState
- let move_sp = if (newRealSp == realSp) then AbsCNop
- else (CAssign (CReg Sp)
- (CAddr (spRel realSp newRealSp)))
- let move_hp =
- if (rHp == vHp) then AbsCNop
- else mkAbstractCs [
- CAssign (CReg Hp) (CAddr (hpRel rHp vHp)),
- profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit (vHp - rHp), CLbl ticky_ctr DataPtrRep ]
- ]
- let new_usage = ((vSp, frame, fSp, newRealSp, hwSp), (vHp,vHp))
- setState $ MkCgState (mkAbstractCs [absC,move_sp,move_hp]) binds new_usage
-\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Code generator utilities; mostly monadic
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CgUtils (
+ addIdReps,
+ cgLit,
+ emitDataLits, emitRODataLits, emitIf, emitIfThenElse,
+ emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
+ assignTemp, newTemp,
+ emitSimultaneously,
+ emitSwitch, emitLitSwitch,
+ tagToClosure,
+
+ cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
+ cmmOffsetExprW, cmmOffsetExprB,
+ cmmRegOffW, cmmRegOffB,
+ cmmLabelOffW, cmmLabelOffB,
+ cmmOffsetW, cmmOffsetB,
+ cmmOffsetLitW, cmmOffsetLitB,
+ cmmLoadIndexW,
+
+ addToMem, addToMemE,
+ mkWordCLit,
+ mkStringCLit,
+ packHalfWordsCLit,
+ blankWord
+ ) where
+
+#include "HsVersions.h"
+
+import CgMonad
+import TyCon ( TyCon, tyConName )
+import Id ( Id )
+import Constants ( wORD_SIZE )
+import SMRep ( CgRep, StgWord, hALF_WORD_SIZE_IN_BITS, ByteOff,
+ WordOff, idCgRep )
+import PprCmm ( {- instances -} )
+import Cmm
+import CLabel
+import CmmUtils
+import MachOp ( MachRep(..), wordRep, MachOp(..), MachHint(..),
+ mo_wordOr, mo_wordAnd, mo_wordNe, mo_wordEq,
+ mo_wordULt, machRepByteWidth )
+import ForeignCall ( CCallConv(..) )
+import Literal ( Literal(..) )
+import CLabel ( CLabel, mkAsmTempLabel )
+import Digraph ( SCC(..), stronglyConnComp )
+import ListSetOps ( assocDefault )
+import Util ( filterOut, sortLt )
+import Char ( ord )
+import FastString ( LitString, FastString, unpackFS )
+import Outputable
+
+import DATA_BITS
+
+#include "../includes/ghcconfig.h"
+ -- For WORDS_BIGENDIAN
+
+-------------------------------------------------------------------------
+--
+-- Random small functions
+--
+-------------------------------------------------------------------------
+
+addIdReps :: [Id] -> [(CgRep, Id)]
+addIdReps ids = [(idCgRep id, id) | id <- ids]
+
+-------------------------------------------------------------------------
+--
+-- Literals
+--
+-------------------------------------------------------------------------
+
+cgLit :: Literal -> FCode CmmLit
+cgLit (MachStr s) = mkStringCLit (unpackFS s)
+cgLit other_lit = return (mkSimpleLit other_lit)
+
+mkSimpleLit :: Literal -> CmmLit
+mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordRep
+mkSimpleLit MachNullAddr = zeroCLit
+mkSimpleLit (MachInt i) = CmmInt i wordRep
+mkSimpleLit (MachInt64 i) = CmmInt i I64
+mkSimpleLit (MachWord i) = CmmInt i wordRep
+mkSimpleLit (MachWord64 i) = CmmInt i I64
+mkSimpleLit (MachFloat r) = CmmFloat r F32
+mkSimpleLit (MachDouble r) = CmmFloat r F64
+mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn)
+ where
+ is_dyn = False -- ToDo: fix me
+
+mkLtOp :: Literal -> MachOp
+-- On signed literals we must do a signed comparison
+mkLtOp (MachInt _) = MO_S_Lt wordRep
+mkLtOp (MachFloat _) = MO_S_Lt F32
+mkLtOp (MachDouble _) = MO_S_Lt F64
+mkLtOp lit = MO_U_Lt (cmmLitRep (mkSimpleLit lit))
+
+
+---------------------------------------------------
+--
+-- Cmm data type functions
+--
+---------------------------------------------------
+
+-----------------------
+-- The "B" variants take byte offsets
+cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
+cmmRegOffB = cmmRegOff
+
+cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
+cmmOffsetB = cmmOffset
+
+cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprB = cmmOffsetExpr
+
+cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
+cmmLabelOffB = cmmLabelOff
+
+cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
+cmmOffsetLitB = cmmOffsetLit
+
+-----------------------
+-- The "W" variants take word offsets
+cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
+-- The second arg is a *word* offset; need to change it to bytes
+cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
+cmmOffsetExprW e wd_off = cmmIndexExpr wordRep e wd_off
+
+cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
+cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
+
+cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
+cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
+
+cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
+cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
+
+cmmLabelOffW :: CLabel -> WordOff -> CmmLit
+cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
+
+cmmLoadIndexW :: CmmExpr -> Int -> CmmExpr
+cmmLoadIndexW base off
+ = CmmLoad (cmmOffsetW base off) wordRep
+
+-----------------------
+cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
+cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2]
+cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
+cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2]
+cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2]
+cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
+
+cmmNegate :: CmmExpr -> CmmExpr
+cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
+cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e]
+
+blankWord :: CmmStatic
+blankWord = CmmUninitialised wORD_SIZE
+
+-----------------------
+-- Making literals
+
+mkWordCLit :: StgWord -> CmmLit
+mkWordCLit wd = CmmInt (fromIntegral wd) wordRep
+
+packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
+-- Make a single word literal in which the lower_half_word is
+-- at the lower address, and the upper_half_word is at the
+-- higher address
+-- ToDo: consider using half-word lits instead
+-- but be careful: that's vulnerable when reversed
+packHalfWordsCLit lower_half_word upper_half_word
+#ifdef WORDS_BIGENDIAN
+ = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
+ .|. fromIntegral upper_half_word)
+#else
+ = mkWordCLit ((fromIntegral lower_half_word)
+ .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
+#endif
+
+--------------------------------------------------------------------------
+--
+-- Incrementing a memory location
+--
+--------------------------------------------------------------------------
+
+addToMem :: MachRep -- rep of the counter
+ -> CmmExpr -- Address
+ -> Int -- What to add (a word)
+ -> CmmStmt
+addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) rep))
+
+addToMemE :: MachRep -- rep of the counter
+ -> CmmExpr -- Address
+ -> CmmExpr -- What to add (a word-typed expression)
+ -> CmmStmt
+addToMemE rep ptr n
+ = CmmStore ptr (CmmMachOp (MO_Add rep) [CmmLoad ptr rep, n])
+
+-------------------------------------------------------------------------
+--
+-- Converting a closure tag to a closure for enumeration types
+-- (this is the implementation of tagToEnum#).
+--
+-------------------------------------------------------------------------
+
+tagToClosure :: TyCon -> CmmExpr -> CmmExpr
+tagToClosure tycon tag
+ = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
+ where closure_tbl = CmmLit (CmmLabel (mkClosureTblLabel (tyConName tycon)))
+
+-------------------------------------------------------------------------
+--
+-- Conditionals and rts calls
+--
+-------------------------------------------------------------------------
+
+emitIf :: CmmExpr -- Boolean
+ -> Code -- Then part
+ -> Code
+-- Emit (if e then x)
+-- ToDo: reverse the condition to avoid the extra branch instruction if possible
+-- (some conditionals aren't reversible. eg. floating point comparisons cannot
+-- be inverted because there exist some values for which both comparisons
+-- return False, such as NaN.)
+emitIf cond then_part
+ = do { then_id <- newLabelC
+ ; join_id <- newLabelC
+ ; stmtC (CmmCondBranch cond then_id)
+ ; stmtC (CmmBranch join_id)
+ ; labelC then_id
+ ; then_part
+ ; labelC join_id
+ }
+
+emitIfThenElse :: CmmExpr -- Boolean
+ -> Code -- Then part
+ -> Code -- Else part
+ -> Code
+-- Emit (if e then x else y)
+emitIfThenElse cond then_part else_part
+ = do { then_id <- newLabelC
+ ; else_id <- newLabelC
+ ; join_id <- newLabelC
+ ; stmtC (CmmCondBranch cond then_id)
+ ; else_part
+ ; stmtC (CmmBranch join_id)
+ ; labelC then_id
+ ; then_part
+ ; labelC join_id
+ }
+
+emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code
+emitRtsCall fun args = emitRtsCall' [] fun args Nothing
+ -- The 'Nothing' says "save all global registers"
+
+emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code
+emitRtsCallWithVols fun args vols
+ = emitRtsCall' [] fun args (Just vols)
+
+emitRtsCallWithResult :: CmmReg -> MachHint -> LitString
+ -> [(CmmExpr,MachHint)] -> Code
+emitRtsCallWithResult res hint fun args
+ = emitRtsCall' [(res,hint)] fun args Nothing
+
+-- Make a call to an RTS C procedure
+emitRtsCall'
+ :: [(CmmReg,MachHint)]
+ -> LitString
+ -> [(CmmExpr,MachHint)]
+ -> Maybe [GlobalReg]
+ -> Code
+emitRtsCall' res fun args vols = stmtC (CmmCall target res args vols)
+ where
+ target = CmmForeignCall fun_expr CCallConv
+ fun_expr = mkLblExpr (mkRtsCodeLabel fun)
+
+
+-------------------------------------------------------------------------
+--
+-- Strings gnerate a top-level data block
+--
+-------------------------------------------------------------------------
+
+emitDataLits :: CLabel -> [CmmLit] -> Code
+-- Emit a data-segment data block
+emitDataLits lbl lits
+ = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+
+emitRODataLits :: CLabel -> [CmmLit] -> Code
+-- Emit a read-only data block
+emitRODataLits lbl lits
+ = emitData ReadOnlyData (CmmDataLabel lbl : map CmmStaticLit lits)
+
+mkStringCLit :: String -> FCode CmmLit
+-- Make a global definition for the string,
+-- and return its label
+mkStringCLit str
+ = do { uniq <- newUnique
+ ; let lbl = mkAsmTempLabel uniq
+ ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString str]
+ ; return (CmmLabel lbl) }
+
+-------------------------------------------------------------------------
+--
+-- Assigning expressions to temporaries
+--
+-------------------------------------------------------------------------
+
+assignTemp :: CmmExpr -> FCode CmmExpr
+-- For a non-trivial expression, e, create a local
+-- variable and assign the expression to it
+assignTemp e
+ | isTrivialCmmExpr e = return e
+ | otherwise = do { reg <- newTemp (cmmExprRep e)
+ ; stmtC (CmmAssign reg e)
+ ; return (CmmReg reg) }
+
+
+newTemp :: MachRep -> FCode CmmReg
+newTemp rep = do { uniq <- newUnique; return (CmmLocal (LocalReg uniq rep)) }
+
+
+-------------------------------------------------------------------------
+--
+-- Building case analysis
+--
+-------------------------------------------------------------------------
+
+emitSwitch
+ :: CmmExpr -- Tag to switch on
+ -> [(ConTagZ, CgStmts)] -- Tagged branches
+ -> Maybe CgStmts -- Default branch (if any)
+ -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
+ -- outside this range is undefined
+ -> Code
+
+-- ONLY A DEFAULT BRANCH: no case analysis to do
+emitSwitch tag_expr [] (Just stmts) _ _
+ = emitCgStmts stmts
+
+-- Right, off we go
+emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
+ = -- Just sort the branches before calling mk_sritch
+ do { mb_deflt_id <-
+ case mb_deflt of
+ Nothing -> return Nothing
+ Just stmts -> do id <- forkCgStmts stmts; return (Just id)
+
+ ; stmts <- mk_switch tag_expr (sortLt lt branches)
+ mb_deflt_id lo_tag hi_tag
+ ; emitCgStmts stmts
+ }
+ where
+ (t1,_) `lt` (t2,_) = t1 < t2
+
+
+mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
+ -> Maybe BlockId -> ConTagZ -> ConTagZ
+ -> FCode CgStmts
+
+-- SINGLETON TAG RANGE: no case analysis to do
+mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag
+ | lo_tag == hi_tag
+ = ASSERT( tag == lo_tag )
+ return stmts
+
+-- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
+mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag
+ = return stmts
+ -- The simplifier might have eliminated a case
+ -- so we may have e.g. case xs of
+ -- [] -> e
+ -- In that situation we can be sure the (:) case
+ -- can't happen, so no need to test
+
+-- SINGLETON BRANCH: one equality check to do
+mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag
+ = return (CmmCondBranch cond deflt `consCgStmt` stmts)
+ where
+ cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
+ -- We have lo_tag < hi_tag, but there's only one branch,
+ -- so there must be a default
+
+-- ToDo: we might want to check for the two branch case, where one of
+-- the branches is the tag 0, because comparing '== 0' is likely to be
+-- more efficient than other kinds of comparison.
+
+-- DENSE TAG RANGE: use a switch statment
+mk_switch tag_expr branches mb_deflt lo_tag hi_tag
+ | use_switch -- Use a switch
+ = do { deflt_id <- get_deflt_id mb_deflt
+ ; branch_ids <- mapM forkCgStmts (map snd branches)
+ ; let
+ tagged_blk_ids = zip (map fst branches) branch_ids
+
+ find_branch :: BlockId -> ConTagZ -> BlockId
+ find_branch deflt_id i = assocDefault deflt_id tagged_blk_ids i
+
+ arms = [ Just (find_branch deflt_id (i+lo_tag))
+ | i <- [0..n_tags-1]]
+
+ switch_stmt = CmmSwitch (cmmOffset tag_expr (- lo_tag)) arms
+
+ ; return (oneCgStmt switch_stmt)
+ }
+
+ | otherwise -- Use an if-tree
+ = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
+ -- To avoid duplication
+ ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt lo_tag (mid_tag-1)
+ ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt mid_tag hi_tag
+ ; lo_id <- forkCgStmts lo_stmts
+ ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit mid_tag))
+ branch_stmt = CmmCondBranch cond lo_id
+ ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` hi_stmts))
+ }
+ where
+ use_switch = ASSERT( n_branches > 1 && n_tags > 1 )
+ n_tags > 2 && (small || dense)
+ -- a 2-branch switch always turns into an if.
+ small = n_tags <= 4
+ dense = n_branches > (n_tags `div` 2)
+ exhaustive = n_tags == n_branches
+ n_tags = hi_tag - lo_tag + 1
+ n_branches = length branches
+
+ -- INVARIANT: Provided hi_tag > lo_tag (which is true)
+ -- lo_tag <= mid_tag < hi_tag
+ -- lo_branches have tags < mid_tag
+ -- hi_branches have tags >= mid_tag
+
+ (mid_tag,_) = branches !! (n_branches `div` 2)
+ -- 2 branches => n_branches `div` 2 = 1
+ -- => branches !! 1 give the *second* tag
+ -- There are always at least 2 branches here
+
+ (lo_branches, hi_branches) = span is_lo branches
+ is_lo (t,_) = t < mid_tag
+
+ -- Add a default block if the case is not exhaustive
+ get_deflt_id (Just deflt_id) = return deflt_id
+ get_deflt_id Nothing
+ | exhaustive
+ = return (pprPanic "mk_deflt_blks" (ppr tag_expr))
+ | otherwise
+ = do { stmts <- getCgStmts (stmtC jump_to_impossible)
+ ; id <- forkCgStmts stmts
+ ; return id }
+
+ jump_to_impossible
+ = CmmJump (mkLblExpr mkErrorStdEntryLabel) []
+
+
+assignTemp' e
+ | isTrivialCmmExpr e = return (CmmNop, e)
+ | otherwise = do { reg <- newTemp (cmmExprRep e)
+ ; return (CmmAssign reg e, CmmReg reg) }
+
+
+emitLitSwitch :: CmmExpr -- Tag to switch on
+ -> [(Literal, CgStmts)] -- Tagged branches
+ -> CgStmts -- Default branch (always)
+ -> Code -- Emit the code
+-- Used for general literals, whose size might not be a word,
+-- where there is always a default case, and where we don't know
+-- the range of values for certain. For simplicity we always generate a tree.
+emitLitSwitch scrut [] deflt
+ = emitCgStmts deflt
+emitLitSwitch scrut branches deflt_blk
+ = do { scrut' <- assignTemp scrut
+ ; deflt_blk_id <- forkCgStmts deflt_blk
+ ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLt lt branches)
+ ; emitCgStmts blk }
+ where
+ lt (t1,_) (t2,_) = t1 < t2
+
+mk_lit_switch :: CmmExpr -> BlockId
+ -> [(Literal,CgStmts)]
+ -> FCode CgStmts
+mk_lit_switch scrut deflt_blk_id [(lit,blk)]
+ = return (consCgStmt if_stmt blk)
+ where
+ cmm_lit = mkSimpleLit lit
+ rep = cmmLitRep cmm_lit
+ cond = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
+ if_stmt = CmmCondBranch cond deflt_blk_id
+
+mk_lit_switch scrut deflt_blk_id branches
+ = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
+ ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
+ ; lo_blk_id <- forkCgStmts lo_blk
+ ; let if_stmt = CmmCondBranch cond lo_blk_id
+ ; return (if_stmt `consCgStmt` hi_blk) }
+ where
+ n_branches = length branches
+ (mid_lit,_) = branches !! (n_branches `div` 2)
+ -- See notes above re mid_tag
+
+ (lo_branches, hi_branches) = span is_lo branches
+ is_lo (t,_) = t < mid_lit
+
+ cond = CmmMachOp (mkLtOp mid_lit)
+ [scrut, CmmLit (mkSimpleLit mid_lit)]
+
+-------------------------------------------------------------------------
+--
+-- Simultaneous assignment
+--
+-------------------------------------------------------------------------
+
+
+emitSimultaneously :: CmmStmts -> Code
+-- Emit code to perform the assignments in the
+-- input simultaneously, using temporary variables when necessary.
+--
+-- The Stmts must be:
+-- CmmNop, CmmComment, CmmAssign, CmmStore
+-- and nothing else
+
+
+-- We use the strongly-connected component algorithm, in which
+-- * the vertices are the statements
+-- * an edge goes from s1 to s2 iff
+-- s1 assigns to something s2 uses
+-- that is, if s1 should *follow* s2 in the final order
+
+type CVertex = (Int, CmmStmt) -- Give each vertex a unique number,
+ -- for fast comparison
+
+emitSimultaneously stmts
+ = codeOnly $
+ case filterOut isNopStmt (stmtList stmts) of
+ -- Remove no-ops
+ [] -> nopC
+ [stmt] -> stmtC stmt -- It's often just one stmt
+ stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
+
+doSimultaneously1 :: [CVertex] -> Code
+doSimultaneously1 vertices
+ = let
+ edges = [ (vertex, key1, edges_from stmt1)
+ | vertex@(key1, stmt1) <- vertices
+ ]
+ edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
+ stmt1 `mustFollow` stmt2
+ ]
+ components = stronglyConnComp edges
+
+ -- do_components deal with one strongly-connected component
+ -- Not cyclic, or singleton? Just do it
+ do_component (AcyclicSCC (n,stmt)) = stmtC stmt
+ do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
+
+ -- Cyclic? Then go via temporaries. Pick one to
+ -- break the loop and try again with the rest.
+ do_component (CyclicSCC ((n,first_stmt) : rest))
+ = do { from_temp <- go_via_temp first_stmt
+ ; doSimultaneously1 rest
+ ; stmtC from_temp }
+
+ go_via_temp (CmmAssign dest src)
+ = do { tmp <- newTemp (cmmRegRep dest)
+ ; stmtC (CmmAssign tmp src)
+ ; return (CmmAssign dest (CmmReg tmp)) }
+ go_via_temp (CmmStore dest src)
+ = do { tmp <- newTemp (cmmExprRep src)
+ ; stmtC (CmmAssign tmp src)
+ ; return (CmmStore dest (CmmReg tmp)) }
+ in
+ mapCs do_component components
+
+mustFollow :: CmmStmt -> CmmStmt -> Bool
+CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
+CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
+CmmNop `mustFollow` stmt = False
+CmmComment _ `mustFollow` stmt = False
+
+
+anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
+-- True if the fn is true of any input of the stmt
+anySrc p (CmmAssign _ e) = p e
+anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side
+anySrc p (CmmComment _) = False
+anySrc p CmmNop = False
+anySrc p other = True -- Conservative
+
+regUsedIn :: CmmReg -> CmmExpr -> Bool
+reg `regUsedIn` CmmLit _ = False
+reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
+reg `regUsedIn` CmmReg reg' = reg == reg'
+reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
+reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
+
+locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
+-- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
+-- 'e'. Returns True if it's not sure.
+locUsedIn loc rep (CmmLit _) = False
+locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
+locUsedIn loc rep (CmmReg reg') = False
+locUsedIn loc rep (CmmRegOff reg' _) = False
+locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
+
+possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
+-- Assumes that distinct registers (eg Hp, Sp) do not
+-- point to the same location, nor any offset thereof.
+possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
+possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2
+possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2
+possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
+ = r1==r2 && end1 > start2 && end2 > start1
+ where
+ end1 = start1 + machRepByteWidth rep1
+ end2 = start2 + machRepByteWidth rep2
+
+possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
+possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+% (c) The Univserity of Glasgow 1992-2004
%
-% $Id: ClosureInfo.lhs,v 1.62 2004/03/31 15:23:17 simonmar Exp $
-%
-\section[ClosureInfo]{Data structures which describe closures}
+
+ Data structures which describe closures, and
+ operations over those data structures
+
+ Nothing monadic in here
Much of the rationale for these things is in the ``details'' part of
the STG paper.
\begin{code}
module ClosureInfo (
ClosureInfo, LambdaFormInfo, SMRep, -- all abstract
- StandardFormInfo, ArgDescr(..),
+ StandardFormInfo,
- CallingConvention(..),
+ ArgDescr(..), Liveness(..),
+ C_SRT(..), needsSRT,
- mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
+ mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
+ mkClosureInfo, mkConInfo,
+
closureSize, closureNonHdrSize,
closureGoodStuffSize, closurePtrsSize,
- slopSize,
+ slopSize,
- layOutDynClosure, layOutStaticClosure, layOutStaticNoFVClosure,
- layOutDynConstr, layOutStaticConstr,
- mkVirtHeapOffsets, mkStaticClosure,
+ closureName, infoTableLabelFromCI,
+ closureLabelFromCI, closureSRT,
+ closureLFInfo, closureSMRep, closureUpdReqd,
+ closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
+ closureFunInfo, isStandardFormThunk, isKnownFun,
- nodeMustPointToIt, getEntryConvention,
- FCode, CgInfoDownwards, CgState,
+ enterIdLabel, enterReturnPtLabel,
+
+ nodeMustPointToIt,
+ CallMethod(..), getCallMethod,
blackHoleOnEntry,
staticClosureRequired,
-
- closureName, infoTableLabelFromCI,
- closureLabelFromCI, closureSRT,
- entryLabelFromCI,
- closureLFInfo, closureSMRep, closureUpdReqd,
- closureSingleEntry, closureReEntrant, closureSemiTag,
- closureFunInfo, isStandardFormThunk,
+ getClosureType,
isToplevClosure,
- closureTypeDescr, -- profiling
+ closureValDescr, closureTypeDescr, -- profiling
isStaticClosure,
- allocProfilingMsg,
cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
staticClosureNeedsLink,
-
- mkInfoTable, mkRetInfoTable, mkVecInfoTable,
) where
-#include "../includes/config.h"
#include "../includes/MachDeps.h"
#include "HsVersions.h"
-import AbsCSyn
import StgSyn
-import CgMonad
+import SMRep -- all of it
-import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
-import CgRetConv ( assignRegs )
import CLabel
+
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
opt_Parallel, opt_DoTickyProfiling,
- opt_SMP, opt_Unregisterised )
-import Id ( Id, idType, idArity, idName, idPrimRep )
-import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isNullaryDataCon, dataConName
- )
-import Name ( Name, nameUnique, getOccName, getName, getOccString )
+ opt_SMP )
+import Id ( Id, idType, idArity, idName )
+import DataCon ( DataCon, dataConTyCon, isNullaryDataCon, dataConName )
+import Name ( Name, nameUnique, getOccName, getOccString )
import OccName ( occNameUserString )
-import PrimRep
-import SMRep -- all of it
import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
import TcType ( tcSplitSigmaTy )
import TyCon ( isFunTyCon, isAbstractTyCon )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName )
-import Util ( mapAccumL, listLengthCmp, lengthIs )
import FastString
import Outputable
-import Literal
import Constants
-import Bitmap
-
-import Maybe ( isJust )
-import DATA_BITS
import TypeRep -- TEMP
\end{code}
+
%************************************************************************
%* *
\subsection[ClosureInfo-datatypes]{Data types for closure information}
closureDescr :: !String -- closure description (for profiling)
}
- -- constructor closures don't have a unique info table label (they use
+ -- Constructor closures don't have a unique info table label (they use
-- the constructor's info table), and they don't have an SRT.
| ConInfo {
closureCon :: !DataCon,
closureSMRep :: !SMRep
}
+
+-- C_SRT is what StgSyn.SRT gets translated to...
+-- we add a label for the table, and expect only the 'offset/length' form
+
+data C_SRT = NoC_SRT
+ | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
+
+needsSRT :: C_SRT -> Bool
+needsSRT NoC_SRT = False
+needsSRT (C_SRT _ _ _) = True
\end{code}
%************************************************************************
data LambdaFormInfo
= LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
- !Int -- Arity
+ !Int -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
ArgDescr -- Argument descriptor (should reall be in ClosureInfo)
- | LFCon -- Constructor
+ | LFCon -- A saturated constructor application
DataCon -- The constructor
| LFThunk -- Thunk (zero arity)
CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info).
-data StandardFormInfo -- Tells whether this thunk has one of a small number
- -- of standard forms
+-------------------------
+-- An ArgDsecr describes the argument pattern of a function
- = NonStandardThunk -- No, it isn't
+data ArgDescr
+ = ArgSpec -- Fits one of the standard patterns
+ !Int -- RTS type identifier ARG_P, ARG_N, ...
- | SelectorThunk
- Int -- 0-origin offset of ak within the "goods" of
- -- constructor (Recall that the a1,...,an may be laid
- -- out in the heap in a non-obvious order.)
+ | ArgGen -- General case
+ Liveness -- Details about the arguments
-{- A SelectorThunk is of form
- case x of
- con a1,..,an -> ak
+-------------------------
+-- We represent liveness bitmaps as a Bitmap (whose internal
+-- representation really is a bitmap). These are pinned onto case return
+-- vectors to indicate the state of the stack for the garbage collector.
+--
+-- In the compiled program, liveness bitmaps that fit inside a single
+-- word (StgWord) are stored as a single word, while larger bitmaps are
+-- stored as a pointer to an array of words.
- and the constructor is from a single-constr type.
--}
+data Liveness
+ = SmallLiveness -- Liveness info that fits in one word
+ StgWord -- Here's the bitmap
+
+ | BigLiveness -- Liveness info witha a multi-word bitmap
+ CLabel -- Label for the bitmap
- | ApThunk
- Int -- arity
-{- An ApThunk is of form
+-------------------------
+-- StandardFormInfo tells whether this thunk has one of
+-- a small number of standard forms
- x1 ... xn
+data StandardFormInfo
+ = NonStandardThunk
+ -- Not of of the standard forms
- The code for the thunk just pushes x2..xn on the stack and enters x1.
- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
- in the RTS to save space.
--}
+ | SelectorThunk
+ -- A SelectorThunk is of form
+ -- case x of
+ -- con a1,..,an -> ak
+ -- and the constructor is from a single-constr type.
+ WordOff -- 0-origin offset of ak within the "goods" of
+ -- constructor (Recall that the a1,...,an may be laid
+ -- out in the heap in a non-obvious order.)
+ | ApThunk
+ -- An ApThunk is of form
+ -- x1 ... xn
+ -- The code for the thunk just pushes x2..xn on the stack and enters x1.
+ -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+ -- in the RTS to save space.
+ Int -- Arity, n
\end{code}
%************************************************************************
%* *
%************************************************************************
-@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure.
-
\begin{code}
-mkClosureLFInfo :: Id -- The binder
- -> TopLevelFlag -- True of top level
- -> [Id] -- Free vars
- -> UpdateFlag -- Update flag
- -> [Id] -- Args
- -> LambdaFormInfo
-
-mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
- = LFReEntrant top (length args) (null fvs) (mkArgDescr (getName bndr) args)
-
-mkClosureLFInfo bndr top fvs upd_flag []
- = ASSERT( not updatable || not (isUnLiftedType id_ty) )
- LFThunk top (null fvs) updatable NonStandardThunk
- (might_be_a_function id_ty)
- where
- updatable = isUpdatable upd_flag
- id_ty = idType bndr
+mkLFReEntrant :: TopLevelFlag -- True of top level
+ -> [Id] -- Free vars
+ -> [Id] -- Args
+ -> ArgDescr -- Argument descriptor
+ -> LambdaFormInfo
+
+mkLFReEntrant top fvs args arg_descr
+ = LFReEntrant top (length args) (null fvs) arg_descr
+
+mkLFThunk thunk_ty top fvs upd_flag
+ = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
+ LFThunk top (null fvs)
+ (isUpdatable upd_flag)
+ NonStandardThunk
+ (might_be_a_function thunk_ty)
might_be_a_function :: Type -> Bool
might_be_a_function ty
| Just (tc,_) <- splitTyConApp_maybe (repType ty),
- not (isFunTyCon tc) && not (isAbstractTyCon tc) = False
+ not (isFunTyCon tc) && not (isAbstractTyCon tc) = False
-- don't forget to check for abstract types, which might
-- be functions too.
| otherwise = True
%************************************************************************
%* *
+ Building ClosureInfos
+%* *
+%************************************************************************
+
+\begin{code}
+mkClosureInfo :: Bool -- Is static
+ -> Id
+ -> LambdaFormInfo
+ -> Int -> Int -- Total and pointer words
+ -> C_SRT
+ -> String -- String descriptor
+ -> ClosureInfo
+mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
+ = ClosureInfo { closureName = name,
+ closureLFInfo = lf_info,
+ closureSMRep = sm_rep,
+ closureSRT = srt_info,
+ closureType = idType id,
+ closureDescr = descr }
+ where
+ name = idName id
+ sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
+
+mkConInfo :: Bool -- Is static
+ -> DataCon
+ -> Int -> Int -- Total and pointer words
+ -> ClosureInfo
+mkConInfo is_static data_con tot_wds ptr_wds
+ = ConInfo { closureSMRep = sm_rep,
+ closureCon = data_con }
+ where
+ sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
+\end{code}
+
+%************************************************************************
+%* *
\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}}
%* *
%************************************************************************
\begin{code}
-closureSize :: ClosureInfo -> HeapOffset
+closureSize :: ClosureInfo -> WordOff
closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
-closureNonHdrSize :: ClosureInfo -> Int
+closureNonHdrSize :: ClosureInfo -> WordOff
closureNonHdrSize cl_info
= tot_wds + computeSlopSize tot_wds
(closureSMRep cl_info)
LFThunk TopLevel _ _ _ _ }) = True
closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
-slopSize :: ClosureInfo -> Int
+slopSize :: ClosureInfo -> WordOff
slopSize cl_info
= computeSlopSize (closureGoodStuffSize cl_info)
(closureSMRep cl_info)
(closureNeedsUpdSpace cl_info)
-closureGoodStuffSize :: ClosureInfo -> Int
+closureGoodStuffSize :: ClosureInfo -> WordOff
closureGoodStuffSize cl_info
= let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs + nonptrs
-closurePtrsSize :: ClosureInfo -> Int
+closurePtrsSize :: ClosureInfo -> WordOff
closurePtrsSize cl_info
= let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs
-- not exported:
-sizes_from_SMRep :: SMRep -> (Int,Int)
+sizes_from_SMRep :: SMRep -> (WordOff,WordOff)
sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs)
sizes_from_SMRep BlackHoleRep = (0, 0)
\end{code}
don't bother taking that into account here.
\begin{code}
-computeSlopSize :: Int -> SMRep -> Bool -> Int
+computeSlopSize :: WordOff -> SMRep -> Bool -> WordOff
computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
%************************************************************************
%* *
-\subsection[layOutDynClosure]{Lay out a closure}
-%* *
-%************************************************************************
-
-\begin{code}
-layOutDynClosure, layOutStaticClosure
- :: Id -- STG identifier of this closure
- -> (a -> PrimRep) -- how to get a PrimRep for the fields
- -> [a] -- the "things" being layed out
- -> LambdaFormInfo -- what sort of closure it is
- -> C_SRT -- its SRT
- -> String -- closure description
- -> (ClosureInfo, -- info about the closure
- [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them
-
-layOutDynClosure = layOutClosure False
-layOutStaticClosure = layOutClosure True
-
-layOutStaticNoFVClosure id lf_info srt_info descr
- = fst (layOutClosure True id (panic "kind_fn") [] lf_info srt_info descr)
-
-layOutClosure
- :: Bool -- True <=> static closure
- -> Id -- STG identifier of this closure
- -> (a -> PrimRep) -- how to get a PrimRep for the fields
- -> [a] -- the "things" being layed out
- -> LambdaFormInfo -- what sort of closure it is
- -> C_SRT -- its SRT
- -> String -- closure description
- -> (ClosureInfo, -- info about the closure
- [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them
-
-layOutClosure is_static id kind_fn things lf_info srt_info descr
- = (ClosureInfo { closureName = name,
- closureLFInfo = lf_info,
- closureSMRep = sm_rep,
- closureSRT = srt_info,
- closureType = idType id,
- closureDescr = descr },
- things_w_offsets)
- where
- name = idName id
- (tot_wds, -- #ptr_wds + #nonptr_wds
- ptr_wds, -- #ptr_wds
- things_w_offsets) = mkVirtHeapOffsets kind_fn things
- sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
-
-
-layOutDynConstr, layOutStaticConstr
- :: DataCon
- -> (a -> PrimRep)
- -> [a]
- -> (ClosureInfo,
- [(a,VirtualHeapOffset)])
-
-layOutDynConstr = layOutConstr False
-layOutStaticConstr = layOutConstr True
-
-layOutConstr is_static data_con kind_fn args
- = (ConInfo { closureSMRep = sm_rep,
- closureCon = data_con },
- things_w_offsets)
- where
- (tot_wds, -- #ptr_wds + #nonptr_wds
- ptr_wds, -- #ptr_wds
- things_w_offsets) = mkVirtHeapOffsets kind_fn args
- sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[mkStaticClosure]{Make a static closure}
-%* *
-%************************************************************************
-
-Make a static closure, adding on any extra padding needed for CAFs,
-and adding a static link field if necessary.
-
-\begin{code}
-mkStaticClosure lbl cl_info ccs fields cafrefs
- | opt_SccProfilingOn =
- CStaticClosure
- lbl
- cl_info
- (mkCCostCentreStack ccs)
- all_fields
- | otherwise =
- CStaticClosure
- lbl
- cl_info
- (panic "absent cc")
- all_fields
-
- where
- all_fields = fields ++ padding_wds ++ static_link_field
-
- upd_reqd = closureUpdReqd cl_info
-
- -- for the purposes of laying out the static closure, we consider all
- -- thunks to be "updatable", so that the static link field is always
- -- in the same place.
- padding_wds
- | not upd_reqd = []
- | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s
- where n = max 0 (mIN_UPD_SIZE - length fields)
-
- -- We always have a static link field for a thunk, it's used to
- -- save the closure's info pointer when we're reverting CAFs
- -- (see comment in Storage.c)
- static_link_field
- | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value]
- | otherwise = []
-
- -- for a static constructor which has NoCafRefs, we set the
- -- static link field to a non-zero value so the garbage
- -- collector will ignore it.
- static_link_value
- | cafrefs = mkIntCLit 0
- | otherwise = mkIntCLit 1
-\end{code}
-
-%************************************************************************
-%* *
\subsection[SMreps]{Choosing SM reps}
%* *
%************************************************************************
chooseSMRep
:: Bool -- True <=> static closure
-> LambdaFormInfo
- -> Int -> Int -- Tot wds, ptr wds
+ -> WordOff -> WordOff -- Tot wds, ptr wds
-> SMRep
chooseSMRep is_static lf_info tot_wds ptr_wds
= let
nonptr_wds = tot_wds - ptr_wds
- closure_type = getClosureType is_static tot_wds ptr_wds lf_info
+ closure_type = getClosureType is_static ptr_wds lf_info
in
GenericRep is_static ptr_wds nonptr_wds closure_type
--- we *do* get non-updatable top-level thunks sometimes. eg. f = g
+-- We *do* get non-updatable top-level thunks sometimes. eg. f = g
-- gets compiled to a jump to g (if g has non-zero arity), instead of
-- messing around with update frames and PAPs. We set the closure type
-- to FUN_STATIC in this case.
-getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType
-getClosureType is_static tot_wds ptr_wds lf_info
+getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType
+getClosureType is_static ptr_wds lf_info
= case lf_info of
LFCon con | is_static && ptr_wds == 0 -> ConstrNoCaf
| otherwise -> Constr
%************************************************************************
%* *
-\subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure}
-%* *
-%************************************************************************
-
-@mkVirtHeapOffsets@ (the heap version) always returns boxed things with
-smaller offsets than the unboxed things, and furthermore, the offsets in
-the result list
-
-\begin{code}
-mkVirtHeapOffsets ::
- (a -> PrimRep) -- To be able to grab kinds;
- -- w/ a kind, we can find boxedness
- -> [a] -- Things to make offsets for
- -> (Int, -- *Total* number of words allocated
- Int, -- Number of words allocated for *pointers*
- [(a, VirtualHeapOffset)])
- -- Things with their offsets from start of
- -- object in order of increasing offset
-
--- First in list gets lowest offset, which is initial offset + 1.
-
-mkVirtHeapOffsets kind_fun things
- = let (ptrs, non_ptrs) = separateByPtrFollowness kind_fun things
- (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
- (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
- in
- (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
- where
- computeOffset wds_so_far thing
- = (wds_so_far + (getPrimRepSize . kind_fun) thing,
- (thing, fixedHdrSize + wds_so_far)
- )
-\end{code}
-
-%************************************************************************
-%* *
\subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@}
%* *
%************************************************************************
Be sure to see the stg-details notes about these...
\begin{code}
-nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
-nodeMustPointToIt lf_info
-
- = case lf_info of
- LFReEntrant top _ no_fvs _ -> returnFC (
- not no_fvs || -- Certainly if it has fvs we need to point to it
- isNotTopLevel top
+nodeMustPointToIt :: LambdaFormInfo -> Bool
+nodeMustPointToIt (LFReEntrant top _ no_fvs _)
+ = not no_fvs || -- Certainly if it has fvs we need to point to it
+ isNotTopLevel top
-- If it is not top level we will point to it
-- We can have a \r closure with no_fvs which
-- is not top level as special case cgRhsClosure
-- For lex_profiling we also access the cost centre for a
-- non-inherited function i.e. not top level
-- the not top case above ensures this is ok.
- )
- LFCon _ -> returnFC True
+nodeMustPointToIt (LFCon _) = True
-- Strictly speaking, the above two don't need Node to point
-- to it if the arity = 0. But this is a *really* unlikely
-- having Node point to the result of an update. SLPJ
-- 27/11/92.
- LFThunk _ no_fvs updatable NonStandardThunk _
- -> returnFC (updatable || not no_fvs || opt_SccProfilingOn)
-
+nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
+ = updatable || not no_fvs || opt_SccProfilingOn
-- For the non-updatable (single-entry case):
--
-- True if has fvs (in which case we need access to them, and we
-- or profiling (in which case we need to recover the cost centre
-- from inside it)
- LFThunk _ no_fvs updatable some_standard_form_thunk _
- -> returnFC True
- -- Node must point to any standard-form thunk.
+nodeMustPointToIt (LFThunk _ no_fvs updatable some_standard_form_thunk _)
+ = True -- Node must point to any standard-form thunk
- LFUnknown _ -> returnFC True
- LFBlackHole _ -> returnFC True
- -- BH entry may require Node to point
-
- LFLetNoEscape _ -> returnFC False
+nodeMustPointToIt (LFUnknown _) = True
+nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point
+nodeMustPointToIt (LFLetNoEscape _) = False
\end{code}
The entry conventions depend on the type of closure being entered,
(rather than directly) to catch double-entry.
\begin{code}
-data CallingConvention
+data CallMethod
= EnterIt -- no args, not a function
| JumpToIt CLabel -- no args, not a function, but we
-- zero args to apply to it, so just
-- return it.
+ | ReturnCon DataCon -- It's a data constructor, just return it
+
| SlowCall -- Unknown fun, or known fun with
-- too few args.
| DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
Int -- Its arity
- [MagicId] -- Its register assignments
- -- (possibly empty)
-
-getEntryConvention :: Name -- Function being applied
- -> LambdaFormInfo -- Its info
- -> [PrimRep] -- Available arguments
- -> FCode CallingConvention
-
-getEntryConvention name lf_info arg_kinds
- = nodeMustPointToIt lf_info `thenFC` \ node_points ->
- returnFC (
-
- -- if we're parallel, then we must always enter via node. The reason
- -- is that the closure may have been fetched since we allocated it.
-
- if (node_points && opt_Parallel) then EnterIt else
-
- -- Commented out by SDM after futher thoughts:
- -- - the only closure type that can be blackholed is a thunk
- -- - we already enter thunks via node (unless the closure is
- -- non-updatable, in which case why is it being re-entered...)
-
- case lf_info of
-
- LFReEntrant _ arity _ _ ->
- if null arg_kinds then
- if arity == 0 then
- EnterIt -- a non-updatable thunk
- else
- ReturnIt -- no args at all
- else if listLengthCmp arg_kinds arity == LT then
- SlowCall -- not enough args
- else
- DirectEntry (mkEntryLabel name) arity arg_regs
- where
- (arg_regs, _) = assignRegs [node] (take arity arg_kinds)
- -- we don't use node to pass args now (SDM)
-
- LFCon con
- | isNullaryDataCon con
- -- a real constructor. Don't bother entering it, just jump
- -- to the constructor entry code directly.
- -> --false:ASSERT (null arg_kinds)
- -- Should have no args (meaning what?)
- JumpToIt (mkStaticConEntryLabel (dataConName con))
-
- | otherwise {- not nullary -}
- -> --false:ASSERT (null arg_kinds)
- -- Should have no args (meaning what?)
- JumpToIt (mkConEntryLabel (dataConName con))
-
- LFThunk _ _ updatable std_form_info is_fun
- -- must always "call" a function-typed thing, cannot just enter it
- | is_fun -> SlowCall
- | updatable || opt_DoTickyProfiling -- to catch double entry
- || opt_SMP -- always enter via node on SMP, since the
+
+getCallMethod :: Name -- Function being applied
+ -> LambdaFormInfo -- Its info
+ -> Int -- Number of available arguments
+ -> CallMethod
+
+getCallMethod name lf_info n_args
+ | nodeMustPointToIt lf_info && opt_Parallel
+ = -- If we're parallel, then we must always enter via node.
+ -- The reason is that the closure may have been
+ -- fetched since we allocated it.
+ EnterIt
+
+getCallMethod name (LFReEntrant _ arity _ _) n_args
+ | n_args == 0 = ASSERT( arity /= 0 )
+ ReturnIt -- No args at all
+ | n_args < arity = SlowCall -- Not enough args
+ | otherwise = DirectEntry (enterIdLabel name) arity
+
+getCallMethod name (LFCon con) n_args
+ = ASSERT( n_args == 0 )
+ ReturnCon con
+
+getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args
+ | is_fun -- Must always "call" a function-typed
+ = SlowCall -- thing, cannot just enter it [in eval/apply, the entry code
+ -- is the fast-entry code]
+
+ | updatable || opt_DoTickyProfiling -- to catch double entry
+ || opt_SMP -- Always enter via node on SMP, since the
-- thunk might have been blackholed in the
-- meantime.
- -> ASSERT(null arg_kinds) EnterIt
- | otherwise
- -> ASSERT(null arg_kinds)
- JumpToIt (thunkEntryLabel name std_form_info updatable)
-
- LFUnknown True -> SlowCall -- might be a function
- LFUnknown False -> ASSERT2 (null arg_kinds, ppr name <+> ppr arg_kinds) EnterIt -- not a function
-
- LFBlackHole _ -> SlowCall -- Presumably the black hole has by now
- -- been updated, but we don't know with
- -- what, so we slow call it
-
- LFLetNoEscape 0
- -> JumpToIt (mkReturnPtLabel (nameUnique name))
-
- LFLetNoEscape arity
- -> if (not (arg_kinds `lengthIs` arity)) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
- DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
- where
- (arg_regs, _) = assignRegs [] arg_kinds
- -- node never points to a LetNoEscape, see above --SDM
- --live_regs = if node_points then [node] else []
- )
+ = ASSERT( n_args == 0 ) EnterIt
-blackHoleOnEntry :: ClosureInfo -> Bool
+ | otherwise -- Jump direct to code for single-entry thunks
+ = ASSERT( n_args == 0 )
+ JumpToIt (thunkEntryLabel name std_form_info updatable)
+
+getCallMethod name (LFUnknown True) n_args
+ = SlowCall -- might be a function
+
+getCallMethod name (LFUnknown False) n_args
+ = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
+ EnterIt -- Not a function
+getCallMethod name (LFBlackHole _) n_args
+ = SlowCall -- Presumably the black hole has by now
+ -- been updated, but we don't know with
+ -- what, so we slow call it
+
+getCallMethod name (LFLetNoEscape 0) n_args
+ = JumpToIt (enterReturnPtLabel (nameUnique name))
+
+getCallMethod name (LFLetNoEscape arity) n_args
+ | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
+ | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
+
+blackHoleOnEntry :: ClosureInfo -> Bool
-- Static closures are never themselves black-holed.
-- Updatable ones will be overwritten with a CAFList cell, which points to a
-- black hole;
other -> panic "blackHoleOnEntry" -- Should never happen
isStandardFormThunk :: LambdaFormInfo -> Bool
-
isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True
isStandardFormThunk other_lf_info = False
+isKnownFun :: LambdaFormInfo -> Bool
+isKnownFun (LFReEntrant _ _ _ _) = True
+isKnownFun (LFLetNoEscape _) = True
+isKnownFun _ = False
\end{code}
-----------------------------------------------------------------------------
closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
closureReEntrant other_closure = False
-closureSemiTag :: ClosureInfo -> Maybe Int
-closureSemiTag (ConInfo { closureCon = data_con })
- = Just (dataConTag data_con - fIRST_TAG)
-closureSemiTag _ = Nothing
+isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
+isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
+isConstrClosure_maybe _ = Nothing
closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = LFReEntrant _ arity _ arg_desc})
LFThunk{} -> mkInfoTableLabel name
- LFReEntrant _ _ _ (ArgGen _ _) -> mkInfoTableLabel name
- LFReEntrant _ _ _ _ -> mkInfoTableLabel name
+ LFReEntrant _ _ _ _ -> mkInfoTableLabel name
other -> panic "infoTableLabelFromCI"
where
name = dataConName con
-mkConEntryPtr :: DataCon -> SMRep -> CLabel
-mkConEntryPtr con rep
- | isStaticRep rep = mkStaticConEntryLabel (dataConName con)
- | otherwise = mkConEntryLabel (dataConName con)
-
closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm
closureLabelFromCI _ = panic "closureLabelFromCI"
-entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI (ClosureInfo { closureName = id,
- closureLFInfo = lf_info,
- closureSMRep = rep })
- = case lf_info of
- LFThunk _ _ upd_flag std_form_info _ ->
- thunkEntryLabel id std_form_info upd_flag
- other -> mkEntryLabel id
-
-entryLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
- = mkConEntryPtr con rep
-
-
-- thunkEntryLabel is a local help function, not exported. It's used from both
--- entryLabelFromCI and getEntryConvention.
+-- entryLabelFromCI and getCallMethod.
thunkEntryLabel thunk_id (ApThunk arity) is_updatable
- = mkApEntryLabel is_updatable arity
+ = enterApLabel is_updatable arity
thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
- = mkSelectorEntryLabel upd_flag offset
+ = enterSelectorLabel upd_flag offset
thunkEntryLabel thunk_id _ is_updatable
- = mkEntryLabel thunk_id
-\end{code}
+ = enterIdLabel thunk_id
-\begin{code}
-allocProfilingMsg :: ClosureInfo -> FastString
-allocProfilingMsg ConInfo{} = FSLIT("TICK_ALLOC_CON")
-allocProfilingMsg ClosureInfo{ closureLFInfo = lf_info }
- = case lf_info of
- LFReEntrant _ _ _ _ -> FSLIT("TICK_ALLOC_FUN")
- LFThunk _ _ True _ _ -> FSLIT("TICK_ALLOC_UP_THK") -- updatable
- LFThunk _ _ False _ _ -> FSLIT("TICK_ALLOC_SE_THK") -- nonupdatable
- LFBlackHole _ -> FSLIT("TICK_ALLOC_BH")
- _ -> panic "allocProfilingMsg"
+enterApLabel is_updatable arity
+ | tablesNextToCode = mkApInfoTableLabel is_updatable arity
+ | otherwise = mkApEntryLabel is_updatable arity
+
+enterSelectorLabel upd_flag offset
+ | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
+ | otherwise = mkSelectorEntryLabel upd_flag offset
+
+enterIdLabel id
+ | tablesNextToCode = mkInfoTableLabel id
+ | otherwise = mkEntryLabel id
+
+enterReturnPtLabel name
+ | tablesNextToCode = mkReturnInfoLabel name
+ | otherwise = mkReturnPtLabel name
\end{code}
+
We need a black-hole closure info to pass to @allocDynClosure@ when we
want to allocate the black hole on entry to a CAF. These are the only
ways to build an LFBlackHole, maintaining the invariant that it really
in the closure info using @closureTypeDescr@.
\begin{code}
-closureTypeDescr :: ClosureInfo -> String
+closureValDescr, closureTypeDescr :: ClosureInfo -> String
+closureValDescr (ClosureInfo {closureDescr = descr})
+ = descr
+closureValDescr (ConInfo {closureCon = con})
+ = occNameUserString (getOccName con)
+
closureTypeDescr (ClosureInfo { closureType = ty })
= getTyDescription ty
closureTypeDescr (ConInfo { closureCon = data_con })
getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
-%************************************************************************
-%* *
-\subsection{Making argument bitmaps}
-%* *
-%************************************************************************
-
-\begin{code}
--- bring in ARG_P, ARG_N, etc.
-#include "../includes/StgFun.h"
-
-data ArgDescr
- = ArgSpec
- !Int -- ARG_P, ARG_N, ...
- | ArgGen
- CLabel -- label for a slow-entry point
- Liveness -- the arg bitmap: describes pointedness of arguments
-
-mkArgDescr :: Name -> [Id] -> ArgDescr
-mkArgDescr nm args = argDescr nm (filter nonVoidRep (map idPrimRep args))
- where nonVoidRep VoidRep = False
- nonVoidRep _ = True
-
-argDescr nm [PtrRep] = ArgSpec ARG_P
-argDescr nm [FloatRep] = ArgSpec ARG_F
-argDescr nm [DoubleRep] = ArgSpec ARG_D
-argDescr nm [r] | is64BitRep r = ArgSpec ARG_L
-argDescr nm [r] | isNonPtrRep r = ArgSpec ARG_N
-
-argDescr nm [r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NN
-argDescr nm [r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NP
-argDescr nm [PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PN
-argDescr nm [PtrRep,PtrRep] = ArgSpec ARG_PP
-
-argDescr nm [r1,r2,r3] | isNonPtrRep r1 && isNonPtrRep r2 && isNonPtrRep r3 = ArgSpec ARG_NNN
-argDescr nm [r1,r2,PtrRep] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NNP
-argDescr nm [r1,PtrRep,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NPN
-argDescr nm [r1,PtrRep,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NPP
-argDescr nm [PtrRep,r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_PNN
-argDescr nm [PtrRep,r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_PNP
-argDescr nm [PtrRep,PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PPN
-argDescr nm [PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPP
-
-argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPP
-argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPP
-argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPPP
-
-argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness
- where bitmap = argBits reps
- lbl = mkBitmapLabel name
- liveness = Liveness lbl (length bitmap) (mkBitmap bitmap)
-
-argBits [] = []
-argBits (rep : args)
- | isFollowableRep rep = False : argBits args
- | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating info tables}
-%* *
-%************************************************************************
-
-Here we make a concrete info table, represented as a list of CAddrMode
-(it can't be simply a list of Word, because the SRT field is
-represented by a label+offset expression).
-
-\begin{code}
-mkInfoTable :: ClosureInfo -> [CAddrMode]
-mkInfoTable cl_info
- | tablesNextToCode = extra_bits ++ std_info
- | otherwise = std_info ++ extra_bits
- where
- std_info = mkStdInfoTable entry_amode
- ty_descr_amode cl_descr_amode cl_type srt_len layout_amode
-
- entry_amode = CLbl (entryLabelFromCI cl_info) CodePtrRep
-
- closure_descr =
- case cl_info of
- ClosureInfo { closureDescr = descr } -> descr
- ConInfo { closureCon = con } -> occNameUserString (getOccName con)
-
- ty_descr_amode = CLit (MachStr (mkFastString (closureTypeDescr cl_info)))
- cl_descr_amode = CLit (MachStr (mkFastString closure_descr))
-
- cl_type = getSMRepClosureTypeInt (closureSMRep cl_info)
-
- srt = closureSRT cl_info
- needs_srt = needsSRT srt
-
- semi_tag = closureSemiTag cl_info
- is_con = isJust semi_tag
-
- (srt_label,srt_len)
- | Just tag <- semi_tag = (mkIntCLit 0, fromIntegral tag) -- constructor
- | otherwise =
- case srt of
- NoC_SRT -> (mkIntCLit 0, 0)
- C_SRT lbl off bitmap ->
- (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
- bitmap)
-
- ptrs = closurePtrsSize cl_info
- nptrs = size - ptrs
- size = closureNonHdrSize cl_info
-
- layout_info :: StgWord
-#ifdef WORDS_BIGENDIAN
- layout_info = (fromIntegral ptrs `shiftL` hALF_WORD) .|. fromIntegral nptrs
-#else
- layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` hALF_WORD)
-#endif
-
- layout_amode = mkWordCLit layout_info
-
- extra_bits
- | is_fun = fun_extra_bits
- | is_con = []
- | needs_srt = [srt_label]
- | otherwise = []
-
- maybe_fun_stuff = closureFunInfo cl_info
- is_fun = isJust maybe_fun_stuff
- (Just (arity, arg_descr)) = maybe_fun_stuff
-
- fun_extra_bits
- | tablesNextToCode = reg_fun_extra_bits
- | otherwise = reverse reg_fun_extra_bits
-
- reg_fun_extra_bits
- | ArgGen slow_lbl liveness <- arg_descr
- = [
- CLbl slow_lbl CodePtrRep,
- livenessToAddrMode liveness,
- srt_label,
- fun_amode
- ]
- | needs_srt = [srt_label, fun_amode]
- | otherwise = [fun_amode]
-
-#ifdef WORDS_BIGENDIAN
- fun_desc = (fromIntegral fun_type `shiftL` hALF_WORD) .|. fromIntegral arity
-#else
- fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` hALF_WORD)
-#endif
-
- fun_amode = mkWordCLit fun_desc
-
- fun_type = case arg_descr of
- ArgSpec n -> n
- ArgGen _ (Liveness _ size _)
- | size <= mAX_SMALL_BITMAP_SIZE -> ARG_GEN
- | otherwise -> ARG_GEN_BIG
-
--- Return info tables come in two flavours: direct returns and
--- vectored returns.
-
-mkRetInfoTable :: CLabel -> C_SRT -> Liveness -> [CAddrMode]
-mkRetInfoTable entry_lbl srt liveness
- = mkBitmapInfoTable (CLbl entry_lbl CodePtrRep) srt liveness []
-
-mkVecInfoTable :: [CAddrMode] -> C_SRT -> Liveness -> [CAddrMode]
-mkVecInfoTable vector srt liveness
- = mkBitmapInfoTable zero_amode srt liveness vector
-
-mkBitmapInfoTable
- :: CAddrMode
- -> C_SRT -> Liveness
- -> [CAddrMode]
- -> [CAddrMode]
-mkBitmapInfoTable entry_amode srt liveness vector
- | tablesNextToCode = extra_bits ++ std_info
- | otherwise = std_info ++ extra_bits
- where
- std_info = mkStdInfoTable entry_amode zero_amode zero_amode
- cl_type srt_len liveness_amode
-
- liveness_amode = livenessToAddrMode liveness
-
- (srt_label,srt_len) =
- case srt of
- NoC_SRT -> (mkIntCLit 0, 0)
- C_SRT lbl off bitmap ->
- (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
- bitmap)
-
- cl_type = case (null vector, isBigLiveness liveness) of
- (True, True) -> rET_BIG
- (True, False) -> rET_SMALL
- (False, True) -> rET_VEC_BIG
- (False, False) -> rET_VEC_SMALL
-
- srt_bit | needsSRT srt || not (null vector) = [srt_label]
- | otherwise = []
-
- extra_bits | tablesNextToCode = reverse vector ++ srt_bit
- | otherwise = srt_bit ++ vector
-
--- The standard bits of an info table. This part of the info table
--- corresponds to the StgInfoTable type defined in InfoTables.h.
-
-mkStdInfoTable
- :: CAddrMode -- entry label
- -> CAddrMode -- closure type descr (profiling)
- -> CAddrMode -- closure descr (profiling)
- -> Int -- closure type
- -> StgHalfWord -- SRT length
- -> CAddrMode -- layout field
- -> [CAddrMode]
-mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode
- = std_info
- where
- std_info
- | tablesNextToCode = std_info'
- | otherwise = entry_lbl : std_info'
-
- std_info' =
- -- par info
- prof_info ++
- -- ticky info
- -- debug info
- [layout_amode] ++
- CLit (MachWord (fromIntegral type_info)) :
- []
-
- prof_info
- | opt_SccProfilingOn = [ type_descr, closure_descr ]
- | otherwise = []
-
- -- sigh: building up the info table is endian-dependent.
- -- ToDo: do this using .byte and .word directives.
- type_info :: StgWord
-#ifdef WORDS_BIGENDIAN
- type_info = (fromIntegral cl_type `shiftL` hALF_WORD) .|.
- (fromIntegral srt_len)
-#else
- type_info = (fromIntegral cl_type) .|.
- (fromIntegral srt_len `shiftL` hALF_WORD)
-#endif
-
-isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
-
-livenessToAddrMode :: Liveness -> CAddrMode
-livenessToAddrMode (Liveness lbl size bits)
- | size <= mAX_SMALL_BITMAP_SIZE = small
- | otherwise = CLbl lbl DataPtrRep
- where
- small = mkWordCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT))
- small_bits = case bits of
- [] -> 0
- [b] -> fromIntegral b
- _ -> panic "livenessToAddrMode"
-
-zero_amode = mkIntCLit 0
-
--- IA64 mangler doesn't place tables next to code
-tablesNextToCode :: Bool
-#ifdef ia64_TARGET_ARCH
-tablesNextToCode = False
-#else
-tablesNextToCode = not opt_Unregisterised
-#endif
-\end{code}
#include "HsVersions.h"
+import DriverState ( v_Build_tag, v_MainModIs )
+
-- Kludge (??) so that CgExpr is reached via at least one non-SOURCE
-- import. Before, that wasn't the case, and CM therefore didn't
-- bother to compile it.
import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT
+import CgProf
+import CgMonad
+import CgBindery ( CgIdInfo, addBindC, addBindsC, getCgIdInfo,
+ cgIdInfoId )
+import CgClosure ( cgTopRhsClosure )
+import CgCon ( cgTopRhsCon, cgTyCon )
+import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall )
+
+import CLabel ( mkSRTLabel, mkClosureLabel, moduleRegdLabel,
+ mkPlainModuleInitLabel, mkModuleInitLabel )
+import Cmm
+import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
+import PprCmm ( pprCmms )
+import MachOp ( wordRep, MachHint(..) )
-import DriverState ( v_Build_tag, v_MainModIs )
import StgSyn
-import CgMonad
-import AbsCSyn
import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN_Name, pREL_TOP_HANDLER )
-import CLabel ( mkSRTLabel, mkClosureLabel,
- mkPlainModuleInitLabel, mkModuleInitLabel )
-import PprAbsC ( dumpRealC )
-import AbsCUtils ( mkAbstractCs, flattenAbsC )
-import CgBindery ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )
-import CgClosure ( cgTopRhsClosure )
-import CgCon ( cgTopRhsCon )
-import CgConTbls ( genStaticConBits )
-import ClosureInfo ( mkClosureLFInfo )
-import CmdLineOpts ( DynFlags, DynFlag(..),
- opt_SccProfilingOn, opt_EnsureSplittableC )
+import CmdLineOpts ( DynFlags, DynFlag(..), opt_EnsureSplittableC,
+ opt_SccProfilingOn )
+
import HscTypes ( ForeignStubs(..), TypeEnv, typeEnvTyCons )
import CostCentre ( CollectedCCs )
import Id ( Id, idName, setIdName )
import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
import OccName ( mkLocalOcc )
-import PrimRep ( PrimRep(..) )
import TyCon ( isDataTyCon )
import Module ( Module, mkModuleName )
-import BasicTypes ( TopLevelFlag(..) )
-import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn, showPass )
-import Panic ( assertPanic )
+import Panic ( assertPanic, trace )
import qualified Module ( moduleName )
#ifdef DEBUG
-> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
- -> IO AbstractC -- Output
+ -> IO [Cmm] -- Output
codeGen dflags this_mod type_env foreign_stubs imported_mods
cost_centre_info stg_binds
= do
- showPass dflags "CodeGen"
- fl_uniqs <- mkSplitUniqSupply 'f'
- way <- readIORef v_Build_tag
- mb_main_mod <- readIORef v_MainModIs
-
- let
- tycons = typeEnvTyCons type_env
- data_tycons = filter isDataTyCon tycons
-
- mapM_ (\x -> seq x (return ())) data_tycons
-
- let
-
- cinfo = MkCompInfo this_mod
-
- datatype_stuff = genStaticConBits cinfo data_tycons
- code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
- init_stuff = mkModuleInit way cost_centre_info
- this_mod mb_main_mod
- foreign_stubs imported_mods
-
- abstractC = mkAbstractCs [ maybeSplitCode,
- init_stuff,
- code_stuff,
- datatype_stuff]
+ { showPass dflags "CodeGen"
+ ; way <- readIORef v_Build_tag
+ ; mb_main_mod <- readIORef v_MainModIs
+
+ ; let tycons = typeEnvTyCons type_env
+ data_tycons = filter isDataTyCon tycons
+
+-- Why?
+-- ; mapM_ (\x -> seq x (return ())) data_tycons
+
+ ; code_stuff <- initC this_mod $ do
+ { cmm_binds <- mapM (getCmm . cgTopBinding) stg_binds
+ ; cmm_tycons <- mapM cgTyCon data_tycons
+ ; cmm_init <- getCmm (mkModuleInit way cost_centre_info
+ this_mod mb_main_mod
+ foreign_stubs imported_mods)
+ ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
+ }
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- (say) PrelBase_True_closure, which is defined in
-- code_stuff
- dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
+ ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
- return $! flattenAbsC fl_uniqs abstractC
+ ; return code_stuff }
\end{code}
%************************************************************************
%* *
%************************************************************************
+/* -----------------------------------------------------------------------------
+ Module initialisation
+
+ The module initialisation code looks like this, roughly:
+
+ FN(__stginit_Foo) {
+ JMP_(__stginit_Foo_1_p)
+ }
+
+ FN(__stginit_Foo_1_p) {
+ ...
+ }
+
+ We have one version of the init code with a module version and the
+ 'way' attached to it. The version number helps to catch cases
+ where modules are not compiled in dependency order before being
+ linked: if a module has been compiled since any modules which depend on
+ it, then the latter modules will refer to a different version in their
+ init blocks and a link error will ensue.
+
+ The 'way' suffix helps to catch cases where modules compiled in different
+ ways are linked together (eg. profiled and non-profiled).
+
+ We provide a plain, unadorned, version of the module init code
+ which just jumps to the version with the label and way attached. The
+ reason for this is that when using foreign exports, the caller of
+ startupHaskell() must supply the name of the init function for the "top"
+ module in the program, and we don't want to require that this name
+ has the version and way info appended to it.
+ -------------------------------------------------------------------------- */
+
+We initialise the module tree by keeping a work-stack,
+ * pointed to by Sp
+ * that grows downward
+ * Sp points to the last occupied slot
+
+
\begin{code}
mkModuleInit
:: String -- the "way"
-> Maybe String -- Just m ==> we have flag: -main-is Foo.baz
-> ForeignStubs
-> [Module]
- -> AbstractC
+ -> Code
mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods
- = let
- (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
+ = do {
- register_foreign_exports
- = case foreign_stubs of
- NoStubs -> []
- ForeignStubs _ _ _ fe_bndrs -> map mk_export_register fe_bndrs
+ -- Allocate the static boolean that records if this
+ -- module has been registered already
+ ; emitData Data [CmmDataLabel moduleRegdLabel,
+ CmmStaticLit zeroCLit]
- mk_export_register bndr
- = CMacroStmt REGISTER_FOREIGN_EXPORT [lbl]
- where
- lbl = CLbl (mkClosureLabel (idName bndr)) PtrRep
- -- we don't want/need to init GHC.Prim, so filter it out
+ ; emitSimpleProc real_init_lbl $ do
+ { -- The return-code pops the work stack by
+ -- incrementing Sp, and then jumpd to the popped item
+ ret_blk <- forkLabelledCode $ stmtsC
+ [ CmmAssign spReg (cmmRegOffW spReg 1)
+ , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
- mk_import_register mod
- | mod == gHC_PRIM = AbsCNop
- | otherwise = CMacroStmt REGISTER_IMPORT [
- CLbl (mkModuleInitLabel mod way) AddrRep
- ]
+ ; init_blk <- forkLabelledCode $ do
+ { mod_init_code; stmtC (CmmBranch ret_blk) }
+
+ ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
+ ret_blk)
+ ; stmtC (CmmBranch init_blk)
+ }
- extra_imported_mods
- | Module.moduleName this_mod == main_mod_name = [ pREL_TOP_HANDLER ]
- | otherwise = [ ]
- register_mod_imports =
- map mk_import_register (imported_mods ++ extra_imported_mods)
+ -- Make the "plain" procedure jump to the "real" init procedure
+ ; emitSimpleProc plain_init_lbl jump_to_init
-- When compiling the module in which the 'main' function lives,
+ -- (that is, Module.moduleName this_mod == main_mod_name)
-- we inject an extra stg_init procedure for stg_init_ZCMain, for the
-- RTS to invoke. We must consult the -main-is flag in case the
-- user specified a different function to Main.main
- main_mod_name = case mb_main_mod of
- Just mod_name -> mkModuleName mod_name
- Nothing -> mAIN_Name
- main_init_block
- | Module.moduleName this_mod /= main_mod_name
- = AbsCNop -- The normal case
- | otherwise -- this_mod contains the main function
- = CCodeBlock (mkPlainModuleInitLabel rOOT_MAIN)
- (CJump (CLbl (mkPlainModuleInitLabel this_mod) CodePtrRep))
-
- in
- mkAbstractCs [
- cc_decls,
- CModuleInitBlock (mkPlainModuleInitLabel this_mod)
- (mkModuleInitLabel this_mod way)
- (mkAbstractCs (register_foreign_exports ++
- cc_regs :
- register_mod_imports)),
- main_init_block
- ]
+ ; whenC (Module.moduleName this_mod == main_mod_name)
+ (emitSimpleProc plain_main_init_lbl jump_to_init)
+ }
+ where
+ plain_init_lbl = mkPlainModuleInitLabel this_mod
+ real_init_lbl = mkModuleInitLabel this_mod way
+ plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
+
+ jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
+
+ mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep
+
+ main_mod_name = case mb_main_mod of
+ Just mod_name -> mkModuleName mod_name
+ Nothing -> mAIN_Name
+
+ -- Main refers to GHC.TopHandler.runIO, so make sure we call the
+ -- init function for GHC.TopHandler.
+ extra_imported_mods
+ | Module.moduleName this_mod == main_mod_name = [pREL_TOP_HANDLER]
+ | otherwise = []
+
+ mod_init_code = do
+ { -- Set mod_reg to 1 to record that we've been here
+ stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
+
+ -- Now do local stuff
+ ; registerForeignExports foreign_stubs
+ ; initCostCentres cost_centre_info
+ ; mapCs (registerModuleImport way) (imported_mods++extra_imported_mods)
+ }
+
+
+-----------------------
+registerModuleImport :: String -> Module -> Code
+registerModuleImport way mod
+ | mod == gHC_PRIM
+ = nopC
+ | otherwise -- Push the init procedure onto the work stack
+ = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
+ , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ]
+
+-----------------------
+registerForeignExports :: ForeignStubs -> Code
+registerForeignExports NoStubs
+ = nopC
+registerForeignExports (ForeignStubs _ _ _ fe_bndrs)
+ = mapM_ mk_export_register fe_bndrs
+ where
+ mk_export_register bndr
+ = emitRtsCall SLIT("getStablePtr")
+ [ (CmmLit (CmmLabel (mkClosureLabel (idName bndr))), PtrHint) ]
\end{code}
+
+
Cost-centre profiling: Besides the usual stuff, we must produce
declarations for the cost-centres defined in this module;
code-generator.)
\begin{code}
-mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
- | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
- | otherwise =
- ( mkAbstractCs (
- map (CCostCentreDecl True) local_CCs ++
- map (CCostCentreDecl False) extern_CCs ++
- map CCostCentreStackDecl singleton_CCSs),
- mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
- )
- where
- mkCcRegister ccs cc_stacks
- = let
- register_ccs = mkAbstractCs (map mk_register ccs)
- register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
- in
- [ register_ccs, register_cc_stacks ]
- where
- mk_register cc
- = CCallProfCCMacro FSLIT("REGISTER_CC") [mkCCostCentre cc]
-
- mk_register_ccs ccs
- = CCallProfCCMacro FSLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
+initCostCentres :: CollectedCCs -> Code
+-- Emit the declarations, and return code to register them
+initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
+ | not opt_SccProfilingOn = nopC
+ | otherwise
+ = do { mapM_ emitCostCentreDecl local_CCs
+ ; mapM_ emitCostCentreStackDecl singleton_CCSs
+ ; mapM_ emitRegisterCC local_CCs
+ ; mapM_ emitRegisterCCS singleton_CCSs
+ }
\end{code}
%************************************************************************
\begin{code}
cgTopBinding :: (StgBinding,[(Id,[Id])]) -> Code
cgTopBinding (StgNonRec id rhs, srts)
- = absC maybeSplitCode `thenC`
- maybeExternaliseId id `thenFC` \ id' ->
- mapM_ (mkSRT [id']) srts `thenC`
- cgTopRhs id' rhs `thenFC` \ (id, info) ->
- addBindC id info `thenC`
- -- Add the un-externalised Id to the envt, so we
- -- find it when we look up occurrences
- nopC
+ = do { id' <- maybeExternaliseId id
+ ; mapM_ (mkSRT [id']) srts
+ ; (id,info) <- cgTopRhs id' rhs
+ ; addBindC id info -- Add the *un-externalised* Id to the envt,
+ -- so we find it when we look up occurrences
+ }
cgTopBinding (StgRec pairs, srts)
- = absC maybeSplitCode `thenC`
- let
- (bndrs, rhss) = unzip pairs
- in
- mapFCs maybeExternaliseId bndrs `thenFC` \ bndrs' ->
- let
- pairs' = zip bndrs' rhss
- in
- mapM_ (mkSRT bndrs') srts `thenC`
- fixC (\ new_binds ->
- addBindsC new_binds `thenC`
- mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
- ) `thenFC` \ new_binds ->
- nopC
+ = do { let (bndrs, rhss) = unzip pairs
+ ; bndrs' <- mapFCs maybeExternaliseId bndrs
+ ; let pairs' = zip bndrs' rhss
+ ; mapM_ (mkSRT bndrs') srts
+ ; new_binds <- fixC (\ new_binds -> do
+ { addBindsC new_binds
+ ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
+ ; nopC }
mkSRT :: [Id] -> (Id,[Id]) -> Code
mkSRT these (id,[]) = nopC
mkSRT these (id,ids)
- = mapFCs remap ids `thenFC` \ ids ->
- remap id `thenFC` \ id ->
- absC (CSRT (mkSRTLabel (idName id)) (map (mkClosureLabel . idName) ids))
+ = do { ids <- mapFCs remap ids
+ ; id <- remap id
+ ; emitRODataLits (mkSRTLabel (idName id))
+ (map (CmmLabel . mkClosureLabel . idName) ids)
+ }
where
- -- sigh, better map all the ids against the environment in case they've
- -- been externalised (see maybeExternaliseId below).
+ -- Sigh, better map all the ids against the environment in
+ -- case they've been externalised (see maybeExternaliseId below).
remap id = case filter (==id) these of
- [] -> getCAddrModeAndInfo id
- `thenFC` \ (id, _, _) -> returnFC id
(id':_) -> returnFC id'
+ [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
-- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
-- to enclose the listFCs in cgTopBinding, but that tickled the
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
= ASSERT(null fvs) -- There should be no free variables
- let
- srt_label = mkSRTLabel (idName bndr)
- lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args
- in
- setSRTLabel srt_label $
- forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info)
+ setSRTLabel (mkSRTLabel (idName bndr)) $
+ forkStatics (cgTopRhsClosure bndr cc bi srt upd_flag args body)
\end{code}
maybeExternaliseId :: Id -> FCode Id
maybeExternaliseId id
| opt_EnsureSplittableC, -- Externalise the name for -split-objs
- isInternalName name
- = moduleName `thenFC` \ mod ->
- returnFC (setIdName id (mkExternalName uniq mod new_occ Nothing (nameSrcLoc name)))
- | otherwise
- = returnFC id
+ isInternalName name = do { mod <- moduleName
+ ; returnFC (setIdName id (externalise mod)) }
+ | otherwise = returnFC id
where
- name = idName id
- uniq = nameUnique name
- new_occ = mkLocalOcc uniq (nameOccName name)
+ externalise mod = mkExternalName uniq mod new_occ Nothing loc
+ name = idName id
+ uniq = nameUnique name
+ new_occ = mkLocalOcc uniq (nameOccName name)
+ loc = nameSrcLoc name
-- We want to conjure up a name that can't clash with any
-- existing name. So we generate
-- Mod_$L243foo
-- where 243 is the unique.
-
-maybeSplitCode
- | opt_EnsureSplittableC = CSplitMarker
- | otherwise = AbsCNop
\end{code}
\begin{code}
module SMRep (
+ -- Words and bytes
+ StgWord, StgHalfWord,
+ hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
+ WordOff, ByteOff,
+
+ -- Argument/return representations
+ CgRep(..), nonVoidArg,
+ argMachRep, primRepToCgRep, primRepHint,
+ isFollowableArg, isVoidArg,
+ isFloatingArg, isNonPtrArg, is64BitArg,
+ separateByPtrFollowness,
+ cgRepSizeW, cgRepSizeB,
+ retAddrSizeW,
+
+ typeCgRep, idCgRep, tyConCgRep, typeHint,
+
+ -- Closure repesentation
SMRep(..), ClosureType(..),
isStaticRep,
fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize,
- stdItblSize, retItblSize,
- getSMRepClosureTypeInt,
+ profHdrSize,
+ tablesNextToCode,
+ smRepClosureType, smRepClosureTypeInt,
- rET_SMALL, rET_VEC_SMALL, rET_BIG, rET_VEC_BIG,
-
- StgWord, StgHalfWord, hALF_WORD,
+ rET_SMALL, rET_VEC_SMALL, rET_BIG, rET_VEC_BIG
) where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
-import CmdLineOpts
+import Id ( Id, idType )
+import Type ( Type, typePrimRep, PrimRep(..) )
+import TyCon ( TyCon, tyConPrimRep )
+import MachOp ( MachRep(..), MachHint(..), wordRep )
+import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros, opt_Unregisterised )
import Constants
import Outputable
import DATA_WORD
\end{code}
+
+%************************************************************************
+%* *
+ Words and bytes
+%* *
+%************************************************************************
+
+\begin{code}
+type WordOff = Int -- Word offset, or word count
+type ByteOff = Int -- Byte offset, or byte count
+\end{code}
+
+StgWord is a type representing an StgWord on the target platform.
+
+\begin{code}
+#if SIZEOF_HSWORD == 4
+type StgWord = Word32
+type StgHalfWord = Word16
+hALF_WORD_SIZE = 2 :: ByteOff
+hALF_WORD_SIZE_IN_BITS = 16 :: Int
+#elif SIZEOF_HSWORD == 8
+type StgWord = Word64
+type StgHalfWord = Word32
+hALF_WORD_SIZE = 4 :: ByteOff
+hALF_WORD_SIZE_IN_BITS = 32 :: Int
+#else
+#error unknown SIZEOF_HSWORD
+#endif
+\end{code}
+
+
+%************************************************************************
+%* *
+ CgRep
+%* *
+%************************************************************************
+
+An CgRep is an abstraction of a Type which tells the code generator
+all it needs to know about the calling convention for arguments (and
+results) of that type. In particular, the ArgReps of a function's
+arguments are used to decide which of the RTS's generic apply
+functions to call when applying an unknown function.
+
+It contains more information than the back-end data type MachRep,
+so one can easily convert from CgRep -> MachRep. (Except that
+there's no MachRep for a VoidRep.)
+
+It distinguishes
+ pointers from non-pointers (we sort the pointers together
+ when building closures)
+
+ void from other types: a void argument is different from no argument
+
+All 64-bit types map to the same CgRep, because they're passed in the
+same register, but a PtrArg is still different from an NonPtrArg
+because the function's entry convention has to take into account the
+pointer-hood of arguments for the purposes of describing the stack on
+entry to the garbage collector.
+
+\begin{code}
+data CgRep
+ = VoidArg -- Void
+ | PtrArg -- Word-sized Ptr
+ | NonPtrArg -- Word-sized non-pointer
+ | LongArg -- 64-bit non-pointer
+ | FloatArg -- 32-bit float
+ | DoubleArg -- 64-bit float
+ deriving Eq
+
+instance Outputable CgRep where
+ ppr VoidArg = ptext SLIT("V_")
+ ppr PtrArg = ptext SLIT("P_")
+ ppr NonPtrArg = ptext SLIT("I_")
+ ppr LongArg = ptext SLIT("L_")
+ ppr FloatArg = ptext SLIT("F_")
+ ppr DoubleArg = ptext SLIT("D_")
+
+argMachRep :: CgRep -> MachRep
+argMachRep PtrArg = wordRep
+argMachRep NonPtrArg = wordRep
+argMachRep LongArg = I64
+argMachRep FloatArg = F32
+argMachRep DoubleArg = F64
+argMachRep VoidArg = panic "argMachRep:VoidRep"
+
+primRepToCgRep :: PrimRep -> CgRep
+primRepToCgRep VoidRep = VoidArg
+primRepToCgRep PtrRep = PtrArg
+primRepToCgRep IntRep = NonPtrArg
+primRepToCgRep WordRep = NonPtrArg
+primRepToCgRep Int64Rep = LongArg
+primRepToCgRep Word64Rep = LongArg
+primRepToCgRep AddrRep = NonPtrArg
+primRepToCgRep FloatRep = FloatArg
+primRepToCgRep DoubleRep = DoubleArg
+
+primRepHint :: PrimRep -> MachHint
+primRepHint VoidRep = panic "primRepHint:VoidRep"
+primRepHint PtrRep = PtrHint
+primRepHint IntRep = SignedHint
+primRepHint WordRep = NoHint
+primRepHint Int64Rep = SignedHint
+primRepHint Word64Rep = NoHint
+primRepHint AddrRep = PtrHint -- NB! PtrHint, but NonPtrArg
+primRepHint FloatRep = FloatHint
+primRepHint DoubleRep = FloatHint
+
+idCgRep :: Id -> CgRep
+idCgRep = typeCgRep . idType
+
+tyConCgRep :: TyCon -> CgRep
+tyConCgRep = primRepToCgRep . tyConPrimRep
+
+typeCgRep :: Type -> CgRep
+typeCgRep = primRepToCgRep . typePrimRep
+
+typeHint :: Type -> MachHint
+typeHint = primRepHint . typePrimRep
+\end{code}
+
+Whether or not the thing is a pointer that the garbage-collector
+should follow. Or, to put it another (less confusing) way, whether
+the object in question is a heap object.
+
+Depending on the outcome, this predicate determines what stack
+the pointer/object possibly will have to be saved onto, and the
+computation of GC liveness info.
+
+\begin{code}
+isFollowableArg :: CgRep -> Bool -- True <=> points to a heap object
+isFollowableArg PtrArg = True
+isFollowableArg other = False
+
+isVoidArg :: CgRep -> Bool
+isVoidArg VoidArg = True
+isVoidArg other = False
+
+nonVoidArg :: CgRep -> Bool
+nonVoidArg VoidArg = False
+nonVoidArg other = True
+
+-- isFloatingArg is used to distinguish @Double@ and @Float@ which
+-- cause inadvertent numeric conversions if you aren't jolly careful.
+-- See codeGen/CgCon:cgTopRhsCon.
+
+isFloatingArg :: CgRep -> Bool
+isFloatingArg DoubleArg = True
+isFloatingArg FloatArg = True
+isFloatingArg _ = False
+
+isNonPtrArg :: CgRep -> Bool
+-- Identify anything which is one word large and not a pointer.
+isNonPtrArg NonPtrArg = True
+isNonPtrArg other = False
+
+is64BitArg :: CgRep -> Bool
+is64BitArg LongArg = True
+is64BitArg _ = False
+\end{code}
+
+\begin{code}
+separateByPtrFollowness :: [(CgRep,a)] -> ([(CgRep,a)], [(CgRep,a)])
+-- Returns (ptrs, non-ptrs)
+separateByPtrFollowness things
+ = sep_things things [] []
+ -- accumulating params for follow-able and don't-follow things...
+ where
+ sep_things [] bs us = (reverse bs, reverse us)
+ sep_things ((PtrArg,a):ts) bs us = sep_things ts ((PtrArg,a):bs) us
+ sep_things (t :ts) bs us = sep_things ts bs (t:us)
+\end{code}
+
+\begin{code}
+cgRepSizeB :: CgRep -> ByteOff
+cgRepSizeB DoubleArg = dOUBLE_SIZE
+cgRepSizeB LongArg = wORD64_SIZE
+cgRepSizeB VoidArg = 0
+cgRepSizeB _ = wORD_SIZE
+
+cgRepSizeW :: CgRep -> ByteOff
+cgRepSizeW DoubleArg = dOUBLE_SIZE `quot` wORD_SIZE
+cgRepSizeW LongArg = wORD64_SIZE `quot` wORD_SIZE
+cgRepSizeW VoidArg = 0
+cgRepSizeW _ = 1
+
+retAddrSizeW :: WordOff
+retAddrSizeW = 1 -- One word
+\end{code}
+
%************************************************************************
%* *
\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}
Size of a closure header.
\begin{code}
-fixedHdrSize :: Int{-words-}
+fixedHdrSize :: WordOff
fixedHdrSize = sTD_HDR_SIZE + profHdrSize + granHdrSize
-profHdrSize :: Int{-words-}
+profHdrSize :: WordOff
profHdrSize | opt_SccProfilingOn = pROF_HDR_SIZE
| otherwise = 0
-granHdrSize :: Int{-words-}
+granHdrSize :: WordOff
granHdrSize | opt_GranMacros = gRAN_HDR_SIZE
| otherwise = 0
-arrWordsHdrSize :: Int{-words-}
-arrWordsHdrSize = fixedHdrSize + aRR_WORDS_HDR_SIZE
+arrWordsHdrSize :: ByteOff
+arrWordsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgArrWords_NoHdr
-arrPtrsHdrSize :: Int{-words-}
-arrPtrsHdrSize = fixedHdrSize + aRR_PTRS_HDR_SIZE
+arrPtrsHdrSize :: ByteOff
+arrPtrsHdrSize = fixedHdrSize*wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr
\end{code}
-Size of an info table.
-
\begin{code}
-stdItblSize :: Int{-words-}
-stdItblSize = sTD_ITBL_SIZE + profItblSize + granItblSize + tickyItblSize
-
-retItblSize :: Int{-words-}
-retItblSize = stdItblSize + rET_ITBL_SIZE
-
-profItblSize :: Int{-words-}
-profItblSize | opt_SccProfilingOn = pROF_ITBL_SIZE
- | otherwise = 0
-
-granItblSize :: Int{-words-}
-granItblSize | opt_GranMacros = gRAN_ITBL_SIZE
- | otherwise = 0
-
-tickyItblSize :: Int{-words-}
-tickyItblSize | opt_DoTickyProfiling = tICKY_ITBL_SIZE
- | otherwise = 0
+-- IA64 mangler doesn't place tables next to code
+tablesNextToCode :: Bool
+#ifdef ia64_TARGET_ARCH
+tablesNextToCode = False
+#else
+tablesNextToCode = not opt_Unregisterised
+#endif
\end{code}
\begin{code}
#include "../includes/ClosureTypes.h"
-- Defines CONSTR, CONSTR_1_0 etc
-getSMRepClosureTypeInt :: SMRep -> Int
-getSMRepClosureTypeInt (GenericRep False 1 0 Constr) = CONSTR_1_0
-getSMRepClosureTypeInt (GenericRep False 0 1 Constr) = CONSTR_0_1
-getSMRepClosureTypeInt (GenericRep False 2 0 Constr) = CONSTR_2_0
-getSMRepClosureTypeInt (GenericRep False 1 1 Constr) = CONSTR_1_1
-getSMRepClosureTypeInt (GenericRep False 0 2 Constr) = CONSTR_0_2
-getSMRepClosureTypeInt (GenericRep False _ _ Constr) = CONSTR
-getSMRepClosureTypeInt (GenericRep False 1 0 Fun) = FUN_1_0
-getSMRepClosureTypeInt (GenericRep False 0 1 Fun) = FUN_0_1
-getSMRepClosureTypeInt (GenericRep False 2 0 Fun) = FUN_2_0
-getSMRepClosureTypeInt (GenericRep False 1 1 Fun) = FUN_1_1
-getSMRepClosureTypeInt (GenericRep False 0 2 Fun) = FUN_0_2
-getSMRepClosureTypeInt (GenericRep False _ _ Fun) = FUN
+smRepClosureType :: SMRep -> ClosureType
+smRepClosureType (GenericRep _ _ _ ty) = ty
+smRepClosureType BlackHoleRep = panic "smRepClosureType: black hole"
+
+smRepClosureTypeInt :: SMRep -> Int
+smRepClosureTypeInt (GenericRep False 1 0 Constr) = CONSTR_1_0
+smRepClosureTypeInt (GenericRep False 0 1 Constr) = CONSTR_0_1
+smRepClosureTypeInt (GenericRep False 2 0 Constr) = CONSTR_2_0
+smRepClosureTypeInt (GenericRep False 1 1 Constr) = CONSTR_1_1
+smRepClosureTypeInt (GenericRep False 0 2 Constr) = CONSTR_0_2
+smRepClosureTypeInt (GenericRep False _ _ Constr) = CONSTR
+
+smRepClosureTypeInt (GenericRep False 1 0 Fun) = FUN_1_0
+smRepClosureTypeInt (GenericRep False 0 1 Fun) = FUN_0_1
+smRepClosureTypeInt (GenericRep False 2 0 Fun) = FUN_2_0
+smRepClosureTypeInt (GenericRep False 1 1 Fun) = FUN_1_1
+smRepClosureTypeInt (GenericRep False 0 2 Fun) = FUN_0_2
+smRepClosureTypeInt (GenericRep False _ _ Fun) = FUN
-getSMRepClosureTypeInt (GenericRep False 1 0 Thunk) = THUNK_1_0
-getSMRepClosureTypeInt (GenericRep False 0 1 Thunk) = THUNK_0_1
-getSMRepClosureTypeInt (GenericRep False 2 0 Thunk) = THUNK_2_0
-getSMRepClosureTypeInt (GenericRep False 1 1 Thunk) = THUNK_1_1
-getSMRepClosureTypeInt (GenericRep False 0 2 Thunk) = THUNK_0_2
-getSMRepClosureTypeInt (GenericRep False _ _ Thunk) = THUNK
+smRepClosureTypeInt (GenericRep False 1 0 Thunk) = THUNK_1_0
+smRepClosureTypeInt (GenericRep False 0 1 Thunk) = THUNK_0_1
+smRepClosureTypeInt (GenericRep False 2 0 Thunk) = THUNK_2_0
+smRepClosureTypeInt (GenericRep False 1 1 Thunk) = THUNK_1_1
+smRepClosureTypeInt (GenericRep False 0 2 Thunk) = THUNK_0_2
+smRepClosureTypeInt (GenericRep False _ _ Thunk) = THUNK
-getSMRepClosureTypeInt (GenericRep False _ _ ThunkSelector) = THUNK_SELECTOR
+smRepClosureTypeInt (GenericRep False _ _ ThunkSelector) = THUNK_SELECTOR
-getSMRepClosureTypeInt (GenericRep True _ _ Constr) = CONSTR_STATIC
-getSMRepClosureTypeInt (GenericRep True _ _ ConstrNoCaf) = CONSTR_NOCAF_STATIC
-getSMRepClosureTypeInt (GenericRep True _ _ Fun) = FUN_STATIC
-getSMRepClosureTypeInt (GenericRep True _ _ Thunk) = THUNK_STATIC
+smRepClosureTypeInt (GenericRep True _ _ Constr) = CONSTR_STATIC
+smRepClosureTypeInt (GenericRep True _ _ ConstrNoCaf) = CONSTR_NOCAF_STATIC
+smRepClosureTypeInt (GenericRep True _ _ Fun) = FUN_STATIC
+smRepClosureTypeInt (GenericRep True _ _ Thunk) = THUNK_STATIC
-getSMRepClosureTypeInt BlackHoleRep = BLACKHOLE
+smRepClosureTypeInt BlackHoleRep = BLACKHOLE
-getSMRepClosureTypeInt rep = panic "getSMRepClosureTypeInt"
+smRepClosureTypeInt rep = panic "smRepClosuretypeint"
-- We export these ones
rET_VEC_BIG = (RET_VEC_BIG :: Int)
\end{code}
-A type representing an StgWord on the target platform.
-
-\begin{code}
-#if SIZEOF_HSWORD == 4
-type StgWord = Word32
-type StgHalfWord = Word16
-hALF_WORD = 16 :: Int
-#elif SIZEOF_HSWORD == 8
-type StgWord = Word64
-type StgHalfWord = Word32
-hALF_WORD = 32 :: Int
-#else
-#error unknown SIZEOF_HSWORD
-#endif
-\end{code}
% The Compilation Manager
%
\begin{code}
-{-# OPTIONS -fvia-C #-}
module CompManager (
ModuleGraph, ModSummary(..),
import Id ( Id, mkWildId )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
-import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety,
+ CCallConv(..), CLabelString )
import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
import ForeignCall ( ForeignCall, CCallTarget(..) )
)
import BasicTypes ( Boxity(..) )
import Literal ( mkMachInt )
-import CStrings ( CLabelString )
import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
int8TyConKey, int16TyConKey, int32TyConKey,
word8TyConKey, word16TyConKey, word32TyConKey
import HsSyn ( ForeignDecl(..), ForeignExport(..), LForeignDecl,
ForeignImport(..), CImportSpec(..) )
+import MachOp ( machRepByteWidth )
+import SMRep ( argMachRep, primRepToCgRep )
import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkSysLocal, setInlinePragma )
import Literal ( Literal(..) )
import HscTypes ( ForeignStubs(..) )
import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe,
- CExportSpec(..),
+ CExportSpec(..), CLabelString,
CCallConv(..), ccallConvToInt,
ccallConvAttribute
)
-import CStrings ( CLabelString )
import TysWiredIn ( unitTy, tupleTyCon )
import TysPrim ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
-import PrimRep ( getPrimRepSizeInBytes )
import PrelNames ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
checkDotnetResName )
import BasicTypes ( Activation( NeverActive ) )
-- (probably in the RTS.)
adjustor = FSLIT("createAdjustor")
- sz_args = sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args)
+ sz_args = sum (map (machRepByteWidth.argMachRep.primRepToCgRep.typePrimRep) stub_args)
mb_sz_args = case cconv of
StdCallConv -> Just sz_args
_ -> Nothing
import Literal ( Literal(..) )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
-import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep )
import Constants ( wORD_SIZE )
import FastString ( FastString(..) )
-import SMRep ( StgWord )
+import SMRep ( CgRep(..), StgWord )
import FiniteMap
import Outputable
literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
-push_alts WordRep = bci_PUSH_ALTS_N
-push_alts IntRep = bci_PUSH_ALTS_N
-push_alts AddrRep = bci_PUSH_ALTS_N
-push_alts CharRep = bci_PUSH_ALTS_N
-push_alts FloatRep = bci_PUSH_ALTS_F
-push_alts DoubleRep = bci_PUSH_ALTS_D
-push_alts VoidRep = bci_PUSH_ALTS_V
-push_alts pk
- | is64BitRep pk = bci_PUSH_ALTS_L
- | isFollowableRep pk = bci_PUSH_ALTS_P
-
-return_ubx WordRep = bci_RETURN_N
-return_ubx IntRep = bci_RETURN_N
-return_ubx AddrRep = bci_RETURN_N
-return_ubx CharRep = bci_RETURN_N
-return_ubx FloatRep = bci_RETURN_F
-return_ubx DoubleRep = bci_RETURN_D
-return_ubx VoidRep = bci_RETURN_V
-return_ubx pk
- | is64BitRep pk = bci_RETURN_L
- | isFollowableRep pk = bci_RETURN_P
+push_alts NonPtrArg = bci_PUSH_ALTS_N
+push_alts FloatArg = bci_PUSH_ALTS_F
+push_alts DoubleArg = bci_PUSH_ALTS_D
+push_alts VoidArg = bci_PUSH_ALTS_V
+push_alts LongArg = bci_PUSH_ALTS_L
+push_alts PtrArg = bci_PUSH_ALTS_P
+
+return_ubx NonPtrArg = bci_RETURN_N
+return_ubx FloatArg = bci_RETURN_F
+return_ubx DoubleArg = bci_RETURN_D
+return_ubx VoidArg = bci_RETURN_V
+return_ubx LongArg = bci_RETURN_L
+return_ubx PtrArg = bci_RETURN_P
-- The size in 16-bit entities of an instruction.
#include "HsVersions.h"
import Outputable
-import PrimRep ( PrimRep(..), getPrimRepSize )
+import SMRep ( CgRep(..), cgRepSizeW )
import ForeignCall ( CCallConv(..) )
-- DON'T remove apparently unused imports here ..
we don't clear our own (single) arg off the C stack.
-}
mkMarshalCode :: CCallConv
- -> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
+ -> (Int, CgRep) -> Int -> [(Int, CgRep)]
-> IO (Ptr Word8)
mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
= let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
mkMarshalCode_wrk :: CCallConv
- -> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
+ -> (Int, CgRep) -> Int -> [(Int, CgRep)]
-> [Word8]
mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
offsets_to_pushW
= concat
[ -- reversed because x86 is little-endian
- reverse [a_offW .. a_offW + getPrimRepSize a_rep - 1]
+ reverse [a_offW .. a_offW + cgRepSizeW a_rep - 1]
-- reversed because args are pushed L -> R onto C stack
| (a_offW, a_rep) <- reverse arg_offs_n_reps
++ movl_offespmem_esi 32
{- For each arg in args_offs_n_reps, examine the associated
- PrimRep to determine how many words there are. This gives a
+ CgRep to determine how many words there are. This gives a
bunch of offsets on the H stack to copy to the C stack:
movl off1(%esi), %ecx
f64 = fstpl_offesimem 0
in
case r_rep of
- CharRep -> i32
- IntRep -> i32
- WordRep -> i32
- AddrRep -> i32
- DoubleRep -> f64
- FloatRep -> f32
- -- Word64Rep -> i64
- -- Int64Rep -> i64
- VoidRep -> []
+ NonPtrArg -> i32
+ DoubleArg -> f64
+ FloatArg -> f32
+ -- LongArg -> i64
+ VoidArg -> []
other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(x86)"
(ppr r_rep)
offsets_to_pushW
= concat
- [ [a_offW .. a_offW + getPrimRepSize a_rep - 1]
+ [ [a_offW .. a_offW + cgRepSizeW a_rep - 1]
| (a_offW, a_rep) <- arg_offs_n_reps
]
[mkSAVE sp (- ({-92-}112 + 4*argWs_on_stack_ROUNDED_UP)) sp]
{- For each arg in args_offs_n_reps, examine the associated
- PrimRep to determine how many words there are. This gives a
+ CgRep to determine how many words there are. This gives a
bunch of offsets on the H stack. Move the first 6 words into
%o0 .. %o5 and the rest on the stack, starting at [%sp+92].
Use %g1 as a temp.
f64 = [mkSTF f0 i0 0, mkSTF f1 i0 4]
in
case r_rep of
- CharRep -> i32
- IntRep -> i32
- WordRep -> i32
- AddrRep -> i32
- DoubleRep -> f64
- FloatRep -> f32
- VoidRep -> []
+ NonPtrArg -> i32
+ DoubleArg -> f64
+ FloatArg -> f32
+ VoidArg -> []
other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(sparc)"
(ppr r_rep)
result_off = r_offW * bytes_per_word
linkageArea = 24
- parameterArea = sum [ getPrimRepSize a_rep * bytes_per_word
+ parameterArea = sum [ cgRepSizeW a_rep * bytes_per_word
| (_, a_rep) <- arg_offs_n_reps ]
savedRegisterArea = 4
frameSize = padTo16 (linkageArea + max parameterArea 32 + savedRegisterArea)
pass_parameters ((a_offW, a_rep):args) nextFPR offsetW =
let
haskellArgOffset = a_offW * bytes_per_word
- offsetW' = offsetW + getPrimRepSize a_rep
+ offsetW' = offsetW + cgRepSizeW a_rep
pass_word w
| offsetW + w < 8 =
dst = linkageArea + (offsetW+w) * bytes_per_word
in
case a_rep of
- FloatRep | nextFPR < 14 ->
+ FloatArg | nextFPR < 14 ->
(0xc01f0000 -- lfs fX, haskellArgOffset(r31)
.|. (fromIntegral haskellArgOffset .&. 0xFFFF)
.|. (fromIntegral nextFPR `shiftL` 21))
: pass_parameters args (nextFPR+1) offsetW'
- DoubleRep | nextFPR < 14 ->
+ DoubleArg | nextFPR < 14 ->
(0xc81f0000 -- lfd fX, haskellArgOffset(r31)
.|. (fromIntegral haskellArgOffset .&. 0xFFFF)
.|. (fromIntegral nextFPR `shiftL` 21))
: pass_parameters args (nextFPR+1) offsetW'
_ ->
- concatMap pass_word [0 .. getPrimRepSize a_rep - 1]
+ concatMap pass_word [0 .. cgRepSizeW a_rep - 1]
++ pass_parameters args nextFPR offsetW'
gather_result = case r_rep of
- VoidRep -> []
- FloatRep ->
+ VoidArg -> []
+ FloatArg ->
[0xd03f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
-- stfs f1, result_off(r31)
- DoubleRep ->
+ DoubleArg ->
[0xd83f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
-- stfs f1, result_off(r31)
- _ | getPrimRepSize r_rep == 2 ->
+ _ | cgRepSizeW r_rep == 2 ->
[0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF),
0x909f0000 .|. (fromIntegral (result_off+4) .&. 0xFFFF)]
-- stw r3, result_off(r31)
-- stw r4, result_off+4(r31)
- _ | getPrimRepSize r_rep == 1 ->
+ _ | cgRepSizeW r_rep == 1 ->
[0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
-- stw r3, result_off(r31)
in
import CoreUtils ( exprType )
import CoreSyn
import PprCore ( pprCoreExpr )
-import Literal ( Literal(..), literalPrimRep )
-import PrimRep
+import Literal ( Literal(..), literalType )
import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
-import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe )
+import Type ( isUnLiftedType, splitTyConApp_maybe )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
dataConRepArity )
import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon
)
-import PrimRep ( isFollowableRep )
import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( showPass, dumpIfSet_dyn )
-import Unique ( mkPseudoUnique3 )
+import Unique ( mkPseudoUniqueE )
import FastString ( FastString(..), unpackFS )
import Panic ( GhcException(..) )
-import SMRep ( arrWordsHdrSize, arrPtrsHdrSize, StgWord )
+import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord,
+ CgRep(..), cgRepSizeW, isFollowableArg, idCgRep )
import Bitmap ( intsToReverseBitmap, mkBitmap )
import OrdList
import Constants ( wORD_SIZE )
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
- let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel")
+ let invented_name = mkSystemName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
invented_id = mkLocalId invented_name (panic "invented_id's type")
(BcM_State final_ctr mallocd, proto_bco)
$$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
$$ text "end-env"
where
- pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idPrimRep var)
+ pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var)
cmp_snd x y = compare (snd x) (snd y)
-- Create a BCO and do a spot of peephole optimisation on the insns
peep []
= []
-argBits :: [PrimRep] -> [Bool]
+argBits :: [CgRep] -> [Bool]
argBits [] = []
argBits (rep : args)
- | isFollowableRep rep = False : argBits args
- | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
+ | isFollowableArg rep = False : argBits args
+ | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args
-- -----------------------------------------------------------------------------
-- schemeTopBind
p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
-- make the arg bitmap
- bits = argBits (reverse (map idPrimRep all_args))
+ bits = argBits (reverse (map idCgRep all_args))
bitmap_size = length bits
bitmap = mkBitmap bits
in
`snocOL` RETURN_UBX v_rep) -- go
where
v_type = idType v
- v_rep = typePrimRep v_type
+ v_rep = typeCgRep v_type
schemeE d s p (AnnLit literal)
= pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) ->
- let l_rep = literalPrimRep literal
+ let l_rep = typeCgRep (literalType literal)
in returnBc (push -- value onto stack
`appOL` mkSLIDE szw (d-s) -- clear to sequel
`snocOL` RETURN_UBX l_rep) -- go
schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
- | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
+ | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
-- Convert
- -- case .... of x { (# VoidRep'd-thing, a #) -> ... }
+ -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
-- to
-- case .... of a { DEFAULT -> ... }
-- becuse the return convention for both are identical.
-- Note that it does not matter losing the void-rep thing from the
-- envt (it won't be bound now) because we never look such things up.
- = --trace "automagic mashing of case alts (# VoidRep, a #)" $
+ = --trace "automagic mashing of case alts (# VoidArg, a #)" $
doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
- | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind2)
- = --trace "automagic mashing of case alts (# a, VoidRep #)" $
+ | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
+ = --trace "automagic mashing of case alts (# a, VoidArg #)" $
doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
--
-- 1. The fn denotes a ccall. Defer to generateCCall.
--
--- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat
+-- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat
-- it simply as b -- since the representations are identical
--- (the VoidRep takes up zero stack space). Also, spot
+-- (the VoidArg takes up zero stack space). Also, spot
-- (# b #) and treat it as b.
--
-- 3. Application of a constructor, by defn saturated.
| Just con <- maybe_saturated_dcon,
isUnboxedTupleCon con
= case args_r_to_l of
- [arg1,arg2] | isVoidRepAtom arg1 ->
+ [arg1,arg2] | isVoidArgAtom arg1 ->
unboxedTupleReturn d s p arg2
- [arg1,arg2] | isVoidRepAtom arg2 ->
+ [arg1,arg2] | isVoidArgAtom arg2 ->
unboxedTupleReturn d s p arg1
_other -> unboxedTupleException
-> Id -> [AnnExpr' Id VarSet]
-> BcM BCInstrList
doTailCall init_d s p fn args
- = do_pushes init_d args (map (primRepToArgRep.atomRep) args)
+ = do_pushes init_d args (map atomRep args)
where
do_pushes d [] reps = do
ASSERTM( null reps )
return (final_d, push_code `appOL` more_push_code)
-- v. similar to CgStackery.findMatch, ToDo: merge
-findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: RepP: rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
= (PUSH_APPLY_PPPPPPP, 7, rest)
-findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
= (PUSH_APPLY_PPPPPP, 6, rest)
-findPushSeq (RepP: RepP: RepP: RepP: RepP: rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
= (PUSH_APPLY_PPPPP, 5, rest)
-findPushSeq (RepP: RepP: RepP: RepP: rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
= (PUSH_APPLY_PPPP, 4, rest)
-findPushSeq (RepP: RepP: RepP: rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: rest)
= (PUSH_APPLY_PPP, 3, rest)
-findPushSeq (RepP: RepP: rest)
+findPushSeq (PtrArg: PtrArg: rest)
= (PUSH_APPLY_PP, 2, rest)
-findPushSeq (RepP: rest)
+findPushSeq (PtrArg: rest)
= (PUSH_APPLY_P, 1, rest)
-findPushSeq (RepV: rest)
+findPushSeq (VoidArg: rest)
= (PUSH_APPLY_V, 1, rest)
-findPushSeq (RepN: rest)
+findPushSeq (NonPtrArg: rest)
= (PUSH_APPLY_N, 1, rest)
-findPushSeq (RepF: rest)
+findPushSeq (FloatArg: rest)
= (PUSH_APPLY_F, 1, rest)
-findPushSeq (RepD: rest)
+findPushSeq (DoubleArg: rest)
= (PUSH_APPLY_D, 1, rest)
-findPushSeq (RepL: rest)
+findPushSeq (LongArg: rest)
= (PUSH_APPLY_L, 1, rest)
findPushSeq _
= panic "ByteCodeGen.findPushSeq"
-- algebraic alt with some binders
| ASSERT(isAlgCase) otherwise =
let
- (ptrs,nptrs) = partition (isFollowableRep.idPrimRep) real_bndrs
+ (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
ptr_sizes = map idSizeW ptrs
nptrs_sizes = map idSizeW nptrs
bind_sizes = ptr_sizes ++ nptrs_sizes
binds = fmToList p
rel_slots = concat (map spread binds)
spread (id, offset)
- | isFollowableRep (idPrimRep id) = [ rel_offset ]
+ | isFollowableArg (idCgRep id) = [ rel_offset ]
| otherwise = []
where rel_offset = d - offset - 1
alt_bco' <- emitBc alt_bco
let push_alts
| isAlgCase = PUSH_ALTS alt_bco'
- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typePrimRep bndr_ty)
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
returnBc (push_alts `consOL` scrut_code)
generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
= let
-- useful constants
- addr_sizeW = getPrimRepSize AddrRep
+ addr_sizeW = cgRepSizeW NonPtrArg
-- Get the args on the stack, with tags and suitably
-- dereferenced for the CCall. For each arg, return the
-- depth to the first word of the bits for that arg, and the
- -- PrimRep of what was actually pushed.
+ -- CgRep of what was actually pushed.
pargs d [] = returnBc []
pargs d (a:az)
-> pargs (d + addr_sizeW) az `thenBc` \ rest ->
parg_ArrayishRep arrPtrsHdrSize d p a
`thenBc` \ code ->
- returnBc ((code,AddrRep):rest)
+ returnBc ((code,NonPtrArg):rest)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-> pargs (d + addr_sizeW) az `thenBc` \ rest ->
parg_ArrayishRep arrWordsHdrSize d p a
`thenBc` \ code ->
- returnBc ((code,AddrRep):rest)
+ returnBc ((code,NonPtrArg):rest)
-- Default case: push taggedly, but otherwise intact.
other
-- Do magic for Ptr/Byte arrays. Push a ptr to the array on
-- the stack but then advance it over the headers, so as to
-- point to the payload.
- parg_ArrayishRep hdrSizeW d p a
+ parg_ArrayishRep hdrSize d p a
= pushAtom d p a `thenBc` \ (push_fo, _) ->
-- The ptr points at the header. Advance it over the
-- header and then pretend this is an Addr#.
- returnBc (push_fo `snocOL`
- SWIZZLE 0 (hdrSizeW * getPrimRepSize WordRep
- * wORD_SIZE))
+ returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize)
in
pargs d0 args_r_to_l `thenBc` \ code_n_reps ->
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
push_args = concatOL pushs_arg
- d_after_args = d0 + sum (map getPrimRepSize a_reps_pushed_r_to_l)
+ d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l)
a_reps_pushed_RAW
- | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
+ | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg
= panic "ByteCodeGen.generateCCall: missing or invalid World token?"
| otherwise
= reverse (tail a_reps_pushed_r_to_l)
-- Get the result rep.
(returns_void, r_rep)
= case maybe_getCCallReturnRep (idType fn) of
- Nothing -> (True, VoidRep)
+ Nothing -> (True, VoidArg)
Just rr -> (False, rr)
{-
Because the Haskell stack grows down, the a_reps refer to
= (nilOL, d_after_args)
-- Push the return placeholder. For a call returning nothing,
- -- this is a VoidRep (tag).
- r_sizeW = getPrimRepSize r_rep
+ -- this is a VoidArg (tag).
+ r_sizeW = cgRepSizeW r_rep
d_after_r = d_after_Addr + r_sizeW
r_lit = mkDummyLiteral r_rep
push_r = (if returns_void
addr_offW = r_sizeW
arg1_offW = r_sizeW + addr_sizeW
args_offW = map (arg1_offW +)
- (init (scanl (+) 0 (map getPrimRepSize a_reps)))
+ (init (scanl (+) 0 (map cgRepSizeW a_reps)))
in
ioToBc (mkMarshalCode cconv
(r_offW, r_rep) addr_offW
wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
`snocOL` RETURN_UBX r_rep
in
- --trace (show (arg1_offW, args_offW , (map getPrimRepSize a_reps) )) $
+ --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $
returnBc (
push_args `appOL`
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
-mkDummyLiteral :: PrimRep -> Literal
+mkDummyLiteral :: CgRep -> Literal
mkDummyLiteral pr
= case pr of
- CharRep -> MachChar (chr 0)
- IntRep -> MachInt 0
- WordRep -> MachWord 0
- DoubleRep -> MachDouble 0
- FloatRep -> MachFloat 0
- AddrRep | getPrimRepSize AddrRep == getPrimRepSize WordRep -> MachWord 0
+ NonPtrArg -> MachWord 0
+ DoubleArg -> MachDouble 0
+ FloatArg -> MachFloat 0
_ -> moan64 "mkDummyLiteral" (ppr pr)
-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
--
-- to Just IntRep
--- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
+-- and check that an unboxed pair is returned wherein the first arg is VoidArg'd.
--
-- Alternatively, for call-targets returning nothing, convert
--
--
-- to Nothing
-maybe_getCCallReturnRep :: Type -> Maybe PrimRep
+maybe_getCCallReturnRep :: Type -> Maybe CgRep
maybe_getCCallReturnRep fn_ty
= let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
maybe_r_rep_to_go
= if isSingleton r_reps then Nothing else Just (r_reps !! 1)
(r_tycon, r_reps)
= case splitTyConApp_maybe (repType r_ty) of
- (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
+ (Just (tyc, tys)) -> (tyc, map typeCgRep tys)
Nothing -> blargh
- ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
- || r_reps == [VoidRep] )
+ ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps)
+ || r_reps == [VoidArg] )
&& isUnboxedTupleTyCon r_tycon
&& case maybe_r_rep_to_go of
Nothing -> True
- Just r_rep -> r_rep /= PtrRep
+ Just r_rep -> r_rep /= PtrArg
-- if it was, it would be impossible
-- to create a valid return value
-- placeholder on the stack
pushAtom d p (AnnVar v)
- | idPrimRep v == VoidRep
+ | idCgRep v == VoidArg
= returnBc (nilOL, 0)
| isFCallId v
pushAtom d p (AnnLit lit)
= case lit of
- MachLabel fs _ -> code CodePtrRep
- MachWord w -> code WordRep
- MachInt i -> code IntRep
- MachFloat r -> code FloatRep
- MachDouble r -> code DoubleRep
- MachChar c -> code CharRep
+ MachLabel fs _ -> code NonPtrArg
+ MachWord w -> code NonPtrArg
+ MachInt i -> code PtrArg
+ MachFloat r -> code FloatArg
+ MachDouble r -> code DoubleArg
+ MachChar c -> code NonPtrArg
MachStr s -> pushStr s
where
code rep
- = let size_host_words = getPrimRepSize rep
+ = let size_host_words = cgRepSizeW rep
in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
size_host_words)
lookupBCEnv_maybe = lookupFM
idSizeW :: Id -> Int
-idSizeW id = getPrimRepSize (typePrimRep (idType id))
+idSizeW id = cgRepSizeW (typeCgRep (idType id))
unboxedTupleException :: a
unboxedTupleException
isTypeAtom (AnnType _) = True
isTypeAtom _ = False
-isVoidRepAtom :: AnnExpr' id ann -> Bool
-isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep
-isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e
-isVoidRepAtom _ = False
+isVoidArgAtom :: AnnExpr' id ann -> Bool
+isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg
+isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e
+isVoidArgAtom _ = False
-atomRep :: AnnExpr' Id ann -> PrimRep
-atomRep (AnnVar v) = typePrimRep (idType v)
-atomRep (AnnLit l) = literalPrimRep l
+atomRep :: AnnExpr' Id ann -> CgRep
+atomRep (AnnVar v) = typeCgRep (idType v)
+atomRep (AnnLit l) = typeCgRep (literalType l)
atomRep (AnnNote n b) = atomRep (snd b)
atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
isPtrAtom :: AnnExpr' Id ann -> Bool
-isPtrAtom e = isFollowableRep (atomRep e)
+isPtrAtom e = atomRep e == PtrArg
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'. Return the values which the stack environment
import CoreSyn
import PprCore ( pprCoreExpr, pprCoreAlt )
import Literal ( Literal )
-import PrimRep ( PrimRep )
import DataCon ( DataCon )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
-import SMRep ( StgWord )
+import SMRep ( StgWord, CgRep )
import GHC.Ptr
-- ----------------------------------------------------------------------------
-- Push an alt continuation
| PUSH_ALTS (ProtoBCO Name)
- | PUSH_ALTS_UNLIFTED (ProtoBCO Name) PrimRep
+ | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep
-- Pushing literals
| PUSH_UBX (Either Literal (Ptr ())) Int
-- To Infinity And Beyond
| ENTER
| RETURN -- return a lifted value
- | RETURN_UBX PrimRep -- return an unlifted value, here's its rep
+ | RETURN_UBX CgRep -- return an unlifted value, here's its rep
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
import Name ( Name, getName )
import NameEnv
-import Type ( typePrimRep )
+import SMRep ( typeCgRep )
import DataCon ( DataCon, dataConRepArgTys )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Constants ( mIN_SIZE_NonUpdHeapObject )
-import ClosureInfo ( mkVirtHeapOffsets )
+import CgHeapery ( mkVirtHeapOffsets )
import FastString ( FastString(..) )
import Util ( lengthIs, listLengthCmp )
mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
mk_itbl dcon conNo entry_addr
- = let (tot_wds, ptr_wds, _)
- = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
+ = let rep_args = [ (typeCgRep arg,arg)
+ | arg <- dataConRepArgTys dcon ]
+ (tot_wds, ptr_wds, _) = mkVirtHeapOffsets rep_args
+
ptrs = ptr_wds
nptrs = tot_wds - ptr_wds
nptrs_really
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.172 2004/08/12 13:10:35 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.173 2004/08/13 13:06:42 simonmar Exp $
--
-- GHC Interactive User Interface
--
ghciWelcomeMsg
) where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import CompManager
linkPackages,
) where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker )
import CoreSyn ( RuleName )
import BasicTypes ( Activation(..) )
import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
- CExportSpec(..))
+ CExportSpec(..), CLabelString )
-- others:
import FunDeps ( pprFundeps )
import Class ( FunDep )
-import CStrings ( CLabelString )
import Outputable
import Util ( count )
import SrcLoc ( Located(..), unLoc )
data DynFlag
-- debugging flags
- = Opt_D_dump_absC
+ = Opt_D_dump_cmm
| Opt_D_dump_asm
| Opt_D_dump_cpranal
| Opt_D_dump_deriv
| Opt_D_dump_inlinings
| Opt_D_dump_occur_anal
| Opt_D_dump_parsed
- | Opt_D_dump_realC
| Opt_D_dump_rn
| Opt_D_dump_simpl
| Opt_D_dump_simpl_iterations
| Opt_D_dump_worker_wrapper
| Opt_D_dump_rn_trace
| Opt_D_dump_rn_stats
- | Opt_D_dump_stix
+ | Opt_D_dump_opt_cmm
| Opt_D_dump_simpl_stats
| Opt_D_dump_tc_trace
| Opt_D_dump_if_trace
| Opt_D_dump_minimal_imports
| Opt_DoCoreLinting
| Opt_DoStgLinting
+ | Opt_DoCmmLinting
| Opt_WarnIsError -- -Werror; makes warnings fatal
| Opt_WarnDuplicateExports
import OccurAnal ( occurAnalyseBinds )
#endif
+import PprC ( writeCs )
+import CmmLint ( cmmLint )
import Packages
import DriverState ( getExplicitPackagesAnd, getPackageCIncludes )
import FastString ( unpackFS )
-import AbsCSyn ( AbstractC )
-import PprAbsC ( dumpRealC, writeRealC )
+import Cmm ( Cmm )
import HscTypes
import CmdLineOpts
-import ErrUtils ( dumpIfSet_dyn, showPass )
+import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
import Outputable
import Pretty ( Mode(..), printDoc )
import Module ( Module )
import ListSetOps ( removeDupsEq )
+import Maybes ( firstJust )
-import Directory ( doesFileExist )
+import Directory ( doesFileExist )
+import Data.List ( intersperse )
import Monad ( when )
import IO
\end{code}
-
%************************************************************************
%* *
\subsection{Steering}
-> Module
-> ForeignStubs
-> Dependencies
- -> AbstractC -- Compiled abstract C
+ -> [Cmm] -- Compiled C--
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
codeOutput dflags this_mod foreign_stubs deps flat_abstractC
-- Dunno if the above comment is still meaningful now. JRS 001024.
- do { showPass dflags "CodeOutput"
+ do { when (dopt Opt_DoCmmLinting dflags) $ do
+ { showPass dflags "CmmLint"
+ ; let lints = map cmmLint flat_abstractC
+ ; case firstJust lints of
+ Just err -> do { printDump err
+ ; ghcExit 1
+ }
+ Nothing -> return ()
+ }
+
+ ; showPass dflags "CodeOutput"
; let filenm = dopt_OutName dflags
; stubs_exist <- outputForeignStubs dflags foreign_stubs
; case dopt_HscLang dflags of {
\begin{code}
outputC dflags filenm flat_absC
(stub_h_exists, _) dependencies foreign_stubs
- = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
-
+ = do
-- figure out which header files to #include in the generated .hc file:
--
-- * extra_includes from packages
hPutStr h cc_injects
when stub_h_exists $
hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
- writeRealC h flat_absC
+ writeCs h flat_absC
\end{code}
#ifndef OMIT_NATIVE_CODEGEN
= do ncg_uniqs <- mkSplitUniqSupply 'n'
- let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen"
- nativeCodeGen flat_absC ncg_uniqs
- dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
+ ncg_output_d <- _scc_ "NativeCodeGen"
+ nativeCodeGen dflags flat_absC ncg_uniqs
dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
_scc_ "OutputAsm" doOutput filenm $
\f -> printDoc LeftMode f ncg_output_d
stub_c_file_exists
<- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
("#define IN_STG_CODE 0\n" ++
- "#include \"RtsAPI.h\"\n" ++
+ "#include \"Rts.h\"\n" ++
rts_includes ++
cplusplus_hdr)
cplusplus_ftr
\section[Constants]{Info about this compilation}
\begin{code}
-module Constants (
- mAX_CONTEXT_REDUCTION_DEPTH,
- mAX_TUPLE_SIZE,
-
- mAX_SPEC_THUNK_SIZE,
- mAX_SPEC_FUN_SIZE,
- mAX_SPEC_CONSTR_SIZE,
- mAX_SPEC_SELECTEE_SIZE,
- mAX_SPEC_AP_SIZE,
-
- mIN_UPD_SIZE,
- mIN_SIZE_NonUpdHeapObject,
-
- sTD_HDR_SIZE,
- pROF_HDR_SIZE,
- gRAN_HDR_SIZE,
- aRR_WORDS_HDR_SIZE,
- aRR_PTRS_HDR_SIZE,
- rESERVED_C_STACK_BYTES,
- rESERVED_STACK_WORDS,
-
- sTD_ITBL_SIZE,
- rET_ITBL_SIZE,
- pROF_ITBL_SIZE,
- gRAN_ITBL_SIZE,
- tICKY_ITBL_SIZE,
-
- mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
-
- uF_SIZE,
- pROF_UF_SIZE,
- gRAN_UF_SIZE, -- HWL
- uF_RET,
- uF_UPDATEE,
-
- mAX_Vanilla_REG,
- mAX_Float_REG,
- mAX_Double_REG,
- mAX_Long_REG,
-
- mAX_Real_Vanilla_REG,
- mAX_Real_Float_REG,
- mAX_Real_Double_REG,
- mAX_Real_Long_REG,
-
- mAX_INTLIKE, mIN_INTLIKE,
- mAX_CHARLIKE, mIN_CHARLIKE,
-
- spRelToInt,
-
- dOUBLE_SIZE,
- iNT64_SIZE,
- wORD64_SIZE,
-
- wORD_SIZE,
- wORD_SIZE_IN_BITS,
-
- bLOCK_SIZE,
- bLOCK_SIZE_W,
-
- bITMAP_BITS_SHIFT,
- ) where
+module Constants (module Constants) where
-- This magical #include brings in all the everybody-knows-these magic
-- constants unfortunately, we need to be *explicit* about which one
-- be in trouble.
#include "HsVersions.h"
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "../includes/MachRegs.h"
#include "../includes/Constants.h"
#include "../includes/MachDeps.h"
\end{code}
\begin{code}
-mIN_INTLIKE, mAX_INTLIKE :: Integer -- Only used to compare with (MachInt Integer)
+mIN_INTLIKE, mAX_INTLIKE :: Int
mIN_INTLIKE = MIN_INTLIKE
mAX_INTLIKE = MAX_INTLIKE
-mIN_CHARLIKE, mAX_CHARLIKE :: Int -- Only used to compare with (MachChar Int)
+mIN_CHARLIKE, mAX_CHARLIKE :: Int
mIN_CHARLIKE = MIN_CHARLIKE
mAX_CHARLIKE = MAX_CHARLIKE
\end{code}
-A little function that abstracts the stack direction. Note that most
-of the code generator is dependent on the stack direction anyway, so
-changing this on its own spells certain doom. ToDo: remove?
-
-\begin{code}
--- THIS IS DIRECTION SENSITIVE!
-
--- stack grows down, positive virtual offsets correspond to negative
--- additions to the stack pointer.
-
-spRelToInt :: Int{-VirtualSpOffset-} -> Int{-VirtualSpOffset-} -> Int
-spRelToInt sp off = sp - off
-\end{code}
-
A section of code-generator-related MAGIC CONSTANTS.
\begin{code}
mAX_FAMILY_SIZE_FOR_VEC_RETURNS = (MAX_VECTORED_RTN::Int) -- pretty arbitrary
-- If you change this, you may need to change runtimes/standard/Update.lhc
-
--- The update frame sizes
-uF_SIZE = (STD_UF_SIZE::Int)
-
--- Same again, with profiling
-pROF_UF_SIZE = (PROF_UF_SIZE::Int)
-
--- Same again, with gransim
-gRAN_UF_SIZE = (GRAN_UF_SIZE::Int)
-
--- Offsets in an update frame. They don't change with profiling!
-uF_RET = (UF_RET::Int)
-uF_UPDATEE = (UF_UPDATEE::Int)
\end{code}
\begin{code}
sTD_HDR_SIZE = (STD_HDR_SIZE :: Int)
pROF_HDR_SIZE = (PROF_HDR_SIZE :: Int)
gRAN_HDR_SIZE = (GRAN_HDR_SIZE :: Int)
-aRR_WORDS_HDR_SIZE = (ARR_WORDS_HDR_SIZE :: Int)
-aRR_PTRS_HDR_SIZE = (ARR_PTRS_HDR_SIZE :: Int)
\end{code}
Info Table sizes.
Size of a double in StgWords.
\begin{code}
-dOUBLE_SIZE = (SIZEOF_DOUBLE `quot` SIZEOF_HSWORD :: Int)
-wORD64_SIZE = (8 `quot` SIZEOF_HSWORD :: Int)
+dOUBLE_SIZE = SIZEOF_DOUBLE :: Int
+wORD64_SIZE = 8 :: Int
iNT64_SIZE = wORD64_SIZE
\end{code}
\begin{code}
bLOCK_SIZE = (BLOCK_SIZE :: Int)
-bLOCK_SIZE_W = (bLOCK_SIZE `div` wORD_SIZE :: Int)
+bLOCK_SIZE_W = (bLOCK_SIZE `quot` wORD_SIZE :: Int)
\end{code}
Number of bits to shift a bitfield left by in an info table.
\begin{code}
bITMAP_BITS_SHIFT = (BITMAP_BITS_SHIFT :: Int)
\end{code}
+
+Constants derived from headers in ghc/includes, generated by the program
+../includes/mkDerivedConstants.c.
+
+\begin{code}
+#include "../includes/GHCConstants.h"
+\end{code}
) where
#include "HsVersions.h"
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
import MkIface ( showIface )
import DriverState
------ Debugging ----------------------------------------------------
, ( "dstg-stats", NoArg (writeIORef v_StgStats True) )
- , ( "ddump-absC", NoArg (setDynFlag Opt_D_dump_absC) )
+ , ( "ddump-cmm", NoArg (setDynFlag Opt_D_dump_cmm) )
, ( "ddump-asm", NoArg (setDynFlag Opt_D_dump_asm) )
, ( "ddump-cpranal", NoArg (setDynFlag Opt_D_dump_cpranal) )
, ( "ddump-deriv", NoArg (setDynFlag Opt_D_dump_deriv) )
, ( "ddump-inlinings", NoArg (setDynFlag Opt_D_dump_inlinings) )
, ( "ddump-occur-anal", NoArg (setDynFlag Opt_D_dump_occur_anal) )
, ( "ddump-parsed", NoArg (setDynFlag Opt_D_dump_parsed) )
- , ( "ddump-realC", NoArg (setDynFlag Opt_D_dump_realC) )
, ( "ddump-rn", NoArg (setDynFlag Opt_D_dump_rn) )
, ( "ddump-simpl", NoArg (setDynFlag Opt_D_dump_simpl) )
, ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) )
, ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) )
, ( "ddump-splices", NoArg (setDynFlag Opt_D_dump_splices) )
, ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) )
- , ( "ddump-stix", NoArg (setDynFlag Opt_D_dump_stix) )
+ , ( "ddump-opt-cmm", NoArg (setDynFlag Opt_D_dump_opt_cmm) )
, ( "ddump-simpl-stats", NoArg (setDynFlag Opt_D_dump_simpl_stats) )
, ( "ddump-bcos", NoArg (setDynFlag Opt_D_dump_BCOs) )
, ( "dsource-stats", NoArg (setDynFlag Opt_D_source_stats) )
, ( "ddump-vect", NoArg (setDynFlag Opt_D_dump_vect) )
, ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting) )
, ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting) )
+ , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting) )
------ Machine dependant (-m<blah>) stuff ---------------------------
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.28 2003/10/22 14:31:09 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.29 2004/08/13 13:06:57 simonmar Exp $
--
-- GHC Driver
--
--
-----------------------------------------------------------------------------
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
module DriverPhases (
Phase(..),
| SplitAs
| As
| Ln
+ | CmmCpp -- pre-process Cmm source
+ | Cmm -- parse & compile Cmm code
#ifdef ILX
| Ilx2Il
| Ilasm
-- pipeline will stop at some point (see DriverPipeline.runPipeline).
x `happensBefore` y
| x `elem` haskell_pipe = y `elem` tail (dropWhile (/= x) haskell_pipe)
+ | x `elem` cmm_pipe = y `elem` tail (dropWhile (/= x) cmm_pipe)
| x `elem` c_pipe = y `elem` tail (dropWhile (/= x) c_pipe)
| otherwise = False
-haskell_pipe = [Unlit,Cpp,HsPp,Hsc,HCc,Mangle,SplitMangle,As,SplitAs,Ln]
+haskell_post_hsc = [HCc,Mangle,SplitMangle,As,SplitAs,Ln]
+haskell_pipe = Unlit : Cpp : HsPp : Hsc : haskell_post_hsc
+cmm_pipe = CmmCpp : Cmm : haskell_post_hsc
c_pipe = [Cc,As,Ln]
-- the first compilation phase for a given file is determined
startPhase "s" = As
startPhase "S" = As
startPhase "o" = Ln
+startPhase "cmm" = CmmCpp
+startPhase "cmmcpp" = Cmm
startPhase _ = Ln -- all unknown file types
-- the output suffix for a given phase is uniquely determined by
phaseInputExt As = "s"
phaseInputExt SplitAs = "split_s" -- not really generated
phaseInputExt Ln = "o"
+phaseInputExt CmmCpp = "cmm"
+phaseInputExt Cmm = "cmmcpp"
#ifdef ILX
phaseInputExt Ilx2Il = "ilx"
phaseInputExt Ilasm = "il"
#endif
-haskellish_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s" ]
-haskellish_src_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr"]
+haskellish_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s", "cmm" ]
+haskellish_src_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "cmm" ]
cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S" ]
extcoreish_suffixes = [ "hcr" ]
haskellish_user_src_suffixes = [ "hs", "lhs" ]
--
-----------------------------------------------------------------------------
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
module DriverPipeline (
-- to the next phase of the pipeline.
return (Just HsPp, maybe_loc, input_fn)
else do
- hscpp_opts <- getOpts opt_P
- hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
-
- cmdline_include_paths <- readIORef v_Include_paths
-
- pkg_include_dirs <- getPackageIncludePath []
- let include_paths = foldr (\ x xs -> "-I" : x : xs) []
- (cmdline_include_paths ++ pkg_include_dirs)
-
- verb <- getVerbFlag
- (md_c_flags, _) <- machdepCCOpts
-
output_fn <- get_output_fn HsPp maybe_loc
-
- SysTools.runCpp ([SysTools.Option verb]
- ++ map SysTools.Option include_paths
- ++ map SysTools.Option hs_src_cpp_opts
- ++ map SysTools.Option hscpp_opts
- ++ map SysTools.Option md_c_flags
- ++ [ SysTools.Option "-x"
- , SysTools.Option "c"
- , SysTools.Option input_fn
- -- We hackily use Option instead of FileOption here, so that the file
- -- name is not back-slashed on Windows. cpp is capable of
- -- dealing with / in filenames, so it works fine. Furthermore
- -- if we put in backslashes, cpp outputs #line directives
- -- with *double* backslashes. And that in turn means that
- -- our error messages get double backslashes in them.
- -- In due course we should arrange that the lexer deals
- -- with these \\ escapes properly.
- , SysTools.Option "-o"
- , SysTools.FileOption "" output_fn
- ])
-
+ doCpp True{-raw-} False{-no CC opts-} input_fn output_fn
return (Just HsPp, maybe_loc, output_fn)
-------------------------------------------------------------------------------
_ -> return (Just next_phase, Just location, output_fn)
-----------------------------------------------------------------------------
+-- Cmm phase
+
+runPhase CmmCpp basename suff input_fn get_output_fn maybe_loc
+ = do
+ output_fn <- get_output_fn Cmm maybe_loc
+ doCpp False{-not raw-} True{-include CC opts-} input_fn output_fn
+ return (Just Cmm, maybe_loc, output_fn)
+
+runPhase Cmm basename suff input_fn get_output_fn maybe_loc
+ = do
+ dyn_flags <- getDynFlags
+ hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
+ next_phase <- hscNextPhase hsc_lang
+ output_fn <- get_output_fn next_phase maybe_loc
+
+ let dyn_flags' = dyn_flags { hscLang = hsc_lang,
+ hscOutName = output_fn,
+ hscStubCOutName = basename ++ "_stub.c",
+ hscStubHOutName = basename ++ "_stub.h",
+ extCoreName = basename ++ ".hcr" }
+
+ ok <- hscCmmFile dyn_flags' input_fn
+
+ when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))
+
+ return (Just next_phase, maybe_loc, output_fn)
+
+-----------------------------------------------------------------------------
-- Cc phase
-- we don't support preprocessing .c files (with -E) now. Doing so introduces
-- -----------------------------------------------------------------------------
-- Misc.
+doCpp :: Bool -> Bool -> FilePath -> FilePath -> IO ()
+doCpp raw include_cc_opts input_fn output_fn = do
+ hscpp_opts <- getOpts opt_P
+
+ cmdline_include_paths <- readIORef v_Include_paths
+
+ pkg_include_dirs <- getPackageIncludePath []
+ let include_paths = foldr (\ x xs -> "-I" : x : xs) []
+ (cmdline_include_paths ++ pkg_include_dirs)
+
+ verb <- getVerbFlag
+
+ cc_opts <- if not include_cc_opts
+ then return []
+ else do optc <- getOpts opt_c
+ (md_c_flags, _) <- machdepCCOpts
+ return (optc ++ md_c_flags)
+
+ let cpp_prog args | raw = SysTools.runCpp args
+ | otherwise = SysTools.runCc (SysTools.Option "-E" : args)
+
+ cpp_prog ([SysTools.Option verb]
+ ++ map SysTools.Option include_paths
+ ++ map SysTools.Option hsSourceCppOpts
+ ++ map SysTools.Option hscpp_opts
+ ++ map SysTools.Option cc_opts
+ ++ [ SysTools.Option "-x"
+ , SysTools.Option "c"
+ , SysTools.Option input_fn
+ -- We hackily use Option instead of FileOption here, so that the file
+ -- name is not back-slashed on Windows. cpp is capable of
+ -- dealing with / in filenames, so it works fine. Furthermore
+ -- if we put in backslashes, cpp outputs #line directives
+ -- with *double* backslashes. And that in turn means that
+ -- our error messages get double backslashes in them.
+ -- In due course we should arrange that the lexer deals
+ -- with these \\ escapes properly.
+ , SysTools.Option "-o"
+ , SysTools.FileOption "" output_fn
+ ])
+
+-- -----------------------------------------------------------------------------
+-- Misc.
+
hscNextPhase :: HscLang -> IO Phase
hscNextPhase hsc_lang = do
split <- readIORef v_Split_object_files
| current_hsc_lang == HscInterpreted = current_hsc_lang
-- force -fvia-C if we are being asked for a .hc file
| todo == StopBefore HCc || keep_hc = HscC
- -- force -fvia-C when profiling or ticky-ticky is on
- | opt_SccProfilingOn || opt_DoTickyProfiling = HscC
-- otherwise, stick to the plan
| otherwise = current_hsc_lang
return hsc_lang
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.104 2004/04/30 15:51:10 simonmar Exp $
--
-- Settings for the driver
--
module DriverState where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import ParsePkgConf ( loadPackageConfig )
-----------------------------------------------------------------------------
-- Global compilation flags
--- Cpp-related flags
-v_Hs_source_cpp_opts = global
+-- Default CPP defines in Haskell source
+hsSourceCppOpts =
[ "-D__HASKELL1__="++cHaskell1Version
, "-D__GLASGOW_HASKELL__="++cProjectVersionInt
, "-D__HASKELL98__"
, "-D__CONCURRENT_HASKELL__"
]
-{-# NOINLINE v_Hs_source_cpp_opts #-}
-- Keep output from intermediate phases
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.42 2004/06/24 09:35:13 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.43 2004/08/13 13:07:02 simonmar Exp $
--
-- Utils for the driver
--
remove_spaces, escapeSpaces,
) where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import Util
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags || verbosity dflags >= 4
- = if flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm]
- then printForC stdout (mkDumpDoc hdr doc)
- else printDump (mkDumpDoc hdr doc)
+ = printDump (mkDumpDoc hdr doc)
| otherwise
= return ()
\begin{code}
module HscMain (
- HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd
+ HscResult(..), hscMain, newHscEnv, hscCmmFile, hscBufferFrontEnd
#ifdef GHCI
, hscStmt, hscTcExpr, hscKcType, hscThing,
, compileExpr
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
+import CmmParse ( parseCmmFile )
import CodeOutput ( codeOutput )
import CmdLineOpts
}
+hscCmmFile :: DynFlags -> FilePath -> IO Bool
+hscCmmFile dflags filename = do
+ maybe_cmm <- parseCmmFile dflags filename
+ case maybe_cmm of
+ Nothing -> return False
+ Just cmm -> do
+ codeOutput dflags no_mod NoStubs noDependencies [cmm]
+ return True
+ where
+ no_mod = panic "hscCmmFile: no_mod"
+
+
myParseModule dflags src_filename
= do -------------------------- Parser ----------------
showPass dflags "Parser"
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.137 2004/08/12 13:10:40 simonmar Exp $
+-- $Id: Main.hs,v 1.138 2004/08/13 13:07:05 simonmar Exp $
--
-- GHC Driver program
--
-----------------------------------------------------------------------------
-- with path so that ghc -M can find config.h
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
module Main (main) where
-- by module basis, using only the -fvia-C and -fasm flags. If the global
-- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
dyn_flags <- getDynFlags
- build_tag <- readIORef v_Build_tag
let lang = case mode of
DoInteractive -> HscInterpreted
DoEval _ -> HscInterpreted
- _other | build_tag /= "" -> HscC
- | otherwise -> hscLang dyn_flags
- -- for ways other that the normal way, we must
- -- compile via C.
+ _other -> hscLang dyn_flags
setDynFlags (dyn_flags{ stgToDo = stg_todo,
hscLang = lang,
import Directory ( doesFileExist, removeFile )
import List ( partition )
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
-- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
-- lines on mingw32, so we disallow it now.
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-
-\begin{code}
-module AbsCStixGen ( genCodeAbstractC ) where
-
-#include "HsVersions.h"
-
-import Ratio ( Rational )
-
-import AbsCSyn
-import Stix
-import MachMisc
-
-import AbsCUtils ( getAmodeRep, mixedTypeLocn,
- nonemptyAbsC, mkAbsCStmts
- )
-import PprAbsC ( dumpRealC )
-import SMRep ( retItblSize )
-import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
- mkClosureTblLabel, mkClosureLabel,
- labelDynamic, mkSplitMarkerLabel )
-import ClosureInfo
-import Literal ( Literal(..), word2IntLit )
-import StgSyn ( StgOp(..) )
-import MachOp ( MachOp(..), resultRepOfMachOp )
-import PrimRep ( isFloatingRep, is64BitRep,
- PrimRep(..), getPrimRepSizeInBytes )
-import StixMacro ( macroCode, checkCode )
-import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
-import Outputable ( pprPanic, ppr )
-import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
-import Util ( naturalMergeSortLe )
-import Panic ( panic )
-import TyCon ( tyConDataCons )
-import Name ( NamedThing(..) )
-import CmdLineOpts ( opt_EnsureSplittableC )
-import Outputable ( assertPanic )
-
-import Char ( ord )
-
--- DEBUGGING ONLY
---import TRACE ( trace )
---import Outputable ( showSDoc )
---import MachOp ( pprMachOp )
-
-#include "nativeGen/NCG.h"
-\end{code}
-
-For each independent chunk of AbstractC code, we generate a list of
-@StixTree@s, where each tree corresponds to a single Stix instruction.
-We leave the chunks separated so that register allocation can be
-performed locally within the chunk.
-
-\begin{code}
-genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
-
-genCodeAbstractC absC
- = gentopcode absC
- where
- a2stix = amodeToStix
- a2stix' = amodeToStix'
- volsaves = volatileSaves
- volrestores = volatileRestores
- -- real code follows... ---------
-\end{code}
-
-Here we handle top-level things, like @CCodeBlock@s and
-@CClosureInfoTable@s.
-
-\begin{code}
- {-
- genCodeTopAbsC
- :: AbstractC
- -> UniqSM [StixTree]
- -}
-
- gentopcode (CCodeBlock lbl absC)
- = gencode absC `thenUs` \ code ->
- returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
-
- gentopcode stmt@(CStaticClosure lbl closure_info _ _)
- = genCodeStaticClosure stmt `thenUs` \ code ->
- returnUs ( StSegment DataSegment
- : StLabel lbl : code []
- )
-
- gentopcode stmt@(CRetVector lbl amodes srt liveness)
- = returnUs ( StSegment TextSegment
- : StData PtrRep table
- : StLabel lbl
- : []
- )
- where
- table = map amodeToStix (mkVecInfoTable amodes srt liveness)
-
- gentopcode stmt@(CRetDirect uniq absC srt liveness)
- = gencode absC `thenUs` \ code ->
- returnUs ( StSegment TextSegment
- : StData PtrRep table
- : StLabel info_lbl
- : StLabel ret_lbl
- : code [])
- where
- info_lbl = mkReturnInfoLabel uniq
- ret_lbl = mkReturnPtLabel uniq
- table = map amodeToStix (mkRetInfoTable ret_lbl srt liveness)
-
- gentopcode stmt@(CClosureInfoAndCode cl_info entry)
- = gencode entry `thenUs` \ slow_code ->
- returnUs ( StSegment TextSegment
- : StData PtrRep table
- : StLabel info_lbl
- : StFunBegin entry_lbl
- : slow_code [StFunEnd entry_lbl])
- where
- entry_lbl = entryLabelFromCI cl_info
- info_lbl = infoTableLabelFromCI cl_info
- table = map amodeToStix (mkInfoTable cl_info)
-
- gentopcode stmt@(CSRT lbl closures)
- = returnUs [ StSegment TextSegment
- , StLabel lbl
- , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
- ]
- where
- mk_StCLbl_for_SRT :: CLabel -> StixExpr
- mk_StCLbl_for_SRT label
- | labelDynamic label
- = StIndex Int8Rep (StCLbl label) (StInt 1)
- | otherwise
- = StCLbl label
-
- gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
- = returnUs
- [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (map StInt (toInteger size : map toInteger mask))
- ]
-
- gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap)
- = returnUs
- [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (
- StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) :
- map StInt (toInteger len : map toInteger bitmap)
- )
- ]
-
- gentopcode stmt@(CClosureTbl tycon)
- = returnUs [ StSegment TextSegment
- , StLabel (mkClosureTblLabel tycon)
- , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName)
- (tyConDataCons tycon) )
- ]
-
- gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
- = gencode absC `thenUs` \ code ->
- getUniqLabelNCG `thenUs` \ tmp_lbl ->
- getUniqLabelNCG `thenUs` \ flag_lbl ->
- returnUs ( StSegment DataSegment
- : StLabel flag_lbl
- : StData IntRep [StInt 0]
- : StSegment TextSegment
- : StLabel plain_lbl
- : StJump NoDestInfo (StCLbl lbl)
- : StLabel lbl
- : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
- [StInd IntRep (StCLbl flag_lbl),
- StInt 0])
- : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
- : code
- [ StLabel tmp_lbl
- , StAssignReg PtrRep stgSp
- (StIndex PtrRep (StReg stgSp) (StInt (-1)))
- , StJump NoDestInfo (StInd WordRep (StReg stgSp))
- ])
-
- gentopcode absC
- = gencode absC `thenUs` \ code ->
- returnUs (StSegment TextSegment : code [])
-\end{code}
-
-\begin{code}
- {-
- genCodeStaticClosure
- :: AbstractC
- -> UniqSM StixTreeList
- -}
- genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes)
- = returnUs (\xs -> table ++ xs)
- where
- table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
- foldr do_one_amode [] amodes
-
- do_one_amode amode rest
- | rep == VoidRep = rest
- | otherwise = StData (promote_to_word rep) [a2stix amode] : rest
- where
- rep = getAmodeRep amode
-
- -- We need to promote any item smaller than a word to a word
- promote_to_word pk
- | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
- | otherwise = IntRep
-\end{code}
-
-Now the individual AbstractC statements.
-
-\begin{code}
- {-
- gencode
- :: AbstractC
- -> UniqSM StixTreeList
- -}
-\end{code}
-
-@AbsCNop@s just disappear.
-
-\begin{code}
-
- gencode AbsCNop = returnUs id
-
-\end{code}
-
-Split markers just insert a __stg_split_marker, which is caught by the
-split-mangler later on and used to split the assembly into chunks.
-
-\begin{code}
-
- gencode CSplitMarker
- | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
- | otherwise = returnUs id
-
-\end{code}
-
-AbstractC instruction sequences are handled individually, and the
-resulting StixTreeLists are joined together.
-
-\begin{code}
-
- gencode (AbsCStmts c1 c2)
- = gencode c1 `thenUs` \ b1 ->
- gencode c2 `thenUs` \ b2 ->
- returnUs (b1 . b2)
-
- gencode (CSequential stuff)
- = foo stuff
- where
- foo [] = returnUs id
- foo (s:ss) = gencode s `thenUs` \ stix ->
- foo ss `thenUs` \ stixes ->
- returnUs (stix . stixes)
-
-\end{code}
-
-Initialising closure headers in the heap...a fairly complex ordeal if
-done properly. For now, we just set the info pointer, but we should
-really take a peek at the flags to determine whether or not there are
-other things to be done (setting cost centres, age headers, global
-addresses, etc.)
-
-\begin{code}
-
- gencode (CInitHdr cl_info reg_rel _ _)
- = let
- lhs = a2stix reg_rel
- lbl = infoTableLabelFromCI cl_info
- in
- returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
-
-\end{code}
-
-Heap/Stack Checks.
-
-\begin{code}
-
- gencode (CCheck macro args assts)
- = gencode assts `thenUs` \assts_stix ->
- checkCode macro args assts_stix
-
-\end{code}
-
-Assignment, the curse of von Neumann, is the center of the code we
-produce. In most cases, the type of the assignment is determined
-by the type of the destination. However, when the destination can
-have mixed types, the type of the assignment is ``StgWord'' (we use
-PtrRep for lack of anything better). Think: do we also want a cast
-of the source? Be careful about floats/doubles.
-
-\begin{code}
-
- gencode (CAssign lhs rhs)
- | lhs_rep == VoidRep
- = returnUs id
- | otherwise
- = let -- This is a Hack. Should be cleaned up.
- -- JRS, 10 Dec 01
- pk' | ncg_target_is_32bit && is64BitRep lhs_rep
- = lhs_rep
- | otherwise
- = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep)
- then IntRep
- else lhs_rep
- lhs' = a2stix lhs
- rhs' = a2stix' rhs
- in
- returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
- where
- lhs_rep = getAmodeRep lhs
-
-\end{code}
-
-Unconditional jumps, including the special ``enter closure'' operation.
-Note that the new entry convention requires that we load the InfoPtr (R2)
-with the address of the info table before jumping to the entry code for Node.
-
-For a vectored return, we must subtract the size of the info table to
-get at the return vector. This depends on the size of the info table,
-which varies depending on whether we're profiling etc.
-
-\begin{code}
-
- gencode (CJump dest)
- = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
-
- gencode (CFallThrough (CLbl lbl _))
- = returnUs (\xs -> StFallThrough lbl : xs)
-
- gencode (CReturn dest DirectReturn)
- = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
-
- gencode (CReturn table (StaticVectoredReturn n))
- = returnUs (\xs -> StJump NoDestInfo dest : xs)
- where
- dest = StInd PtrRep (StIndex PtrRep (a2stix table)
- (StInt (toInteger (-n-retItblSize-1))))
-
- gencode (CReturn table (DynamicVectoredReturn am))
- = returnUs (\xs -> StJump NoDestInfo dest : xs)
- where
- dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
- dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
- StInt (toInteger (retItblSize+1))]
-
-\end{code}
-
-Now the PrimOps, some of which may need caller-saves register wrappers.
-
-\begin{code}
- gencode (COpStmt results (StgFCallOp fcall _) args vols)
- = ASSERT( null vols )
- foreignCallCode (nonVoid results) fcall (nonVoid args)
-
- gencode (COpStmt results (StgPrimOp op) args vols)
- = panic "AbsCStixGen.gencode: un-translated PrimOp"
-
- gencode (CMachOpStmt res mop args vols)
- = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res)
- (StMachOp mop (map a2stix args))
- : xs
- )
-\end{code}
-
-Now the dreaded conditional jump.
-
-Now the if statement. Almost *all* flow of control are of this form.
-@
- if (am==lit) { absC } else { absCdef }
-@
- =>
-@
- IF am = lit GOTO l1:
- absC
- jump l2:
- l1:
- absCdef
- l2:
-@
-
-\begin{code}
-
- gencode (CSwitch discrim alts deflt)
- = case alts of
- [] -> gencode deflt
-
- [(tag,alt_code)] -> case maybe_empty_deflt of
- Nothing -> gencode alt_code
- Just dc -> mkIfThenElse discrim tag alt_code dc
-
- [(tag1@(MachInt i1), alt_code1),
- (tag2@(MachInt i2), alt_code2)]
- | deflt_is_empty && i1 == 0 && i2 == 1
- -> mkIfThenElse discrim tag1 alt_code1 alt_code2
- | deflt_is_empty && i1 == 1 && i2 == 0
- -> mkIfThenElse discrim tag2 alt_code2 alt_code1
-
- -- If the @discrim@ is simple, then this unfolding is safe.
- other | simple_discrim -> mkSimpleSwitches discrim alts deflt
-
- -- Otherwise, we need to do a bit of work.
- other -> getUniqueUs `thenUs` \ u ->
- gencode (AbsCStmts
- (CAssign (CTemp u pk) discrim)
- (CSwitch (CTemp u pk) alts deflt))
-
- where
- maybe_empty_deflt = nonemptyAbsC deflt
- deflt_is_empty = case maybe_empty_deflt of
- Nothing -> True
- Just _ -> False
-
- pk = getAmodeRep discrim
-
- simple_discrim = case discrim of
- CReg _ -> True
- CTemp _ _ -> True
- other -> False
-\end{code}
-
-
-
-Finally, all of the disgusting AbstractC macros.
-
-\begin{code}
-
- gencode (CMacroStmt macro args) = macroCode macro (map amodeToStix args)
-
- gencode (CCallProfCtrMacro macro _)
- = returnUs (\xs -> StComment macro : xs)
-
- gencode (CCallProfCCMacro macro _)
- = returnUs (\xs -> StComment macro : xs)
-
- gencode CCallTypedef{} = returnUs id
-
- gencode other
- = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
-
- nonVoid = filter ((/= VoidRep) . getAmodeRep)
-\end{code}
-
-Here, we generate a jump table if there are more than four (integer)
-alternatives and the jump table occupancy is greater than 50%.
-Otherwise, we generate a binary comparison tree. (Perhaps this could
-be tuned.)
-
-\begin{code}
-
- intTag :: Literal -> Integer
- intTag (MachChar c) = toInteger (ord c)
- intTag (MachInt i) = i
- intTag (MachWord w) = intTag (word2IntLit (MachWord w))
- intTag _ = panic "intTag"
-
- fltTag :: Literal -> Rational
-
- fltTag (MachFloat f) = f
- fltTag (MachDouble d) = d
- fltTag x = pprPanic "fltTag" (ppr x)
-
- {-
- mkSimpleSwitches
- :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
- -> UniqSM StixTreeList
- -}
- mkSimpleSwitches am alts absC
- = getUniqLabelNCG `thenUs` \ udlbl ->
- getUniqLabelNCG `thenUs` \ ujlbl ->
- let am' = a2stix am
- joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
- sortedAlts = naturalMergeSortLe leAlt joinedAlts
- -- naturalMergeSortLe, because we often get sorted alts to begin with
-
- lowTag = intTag (fst (head sortedAlts))
- highTag = intTag (fst (last sortedAlts))
-
- -- lowest and highest possible values the discriminant could take
- lowest = if floating then targetMinDouble else targetMinInt
- highest = if floating then targetMaxDouble else targetMaxInt
- in
- (
- if not floating && choices > 4
- && highTag - lowTag < toInteger (2 * choices)
- then
- mkJumpTable am' sortedAlts lowTag highTag udlbl
- else
- mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
- )
- `thenUs` \ alt_code ->
- gencode absC `thenUs` \ dflt_code ->
-
- returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
-
- where
- floating = isFloatingRep (getAmodeRep am)
- choices = length alts
-
- (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
- (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
- (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
- (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
-
-\end{code}
-
-We use jump tables when doing an integer switch on a relatively dense
-list of alternatives. We expect to be given a list of alternatives,
-sorted by tag, and a range of values for which we are to generate a
-table. Of course, the tags of the alternatives should lie within the
-indicated range. The alternatives need not cover the range; a default
-target is provided for the missing alternatives.
-
-If a join is necessary after the switch, the alternatives should
-already finish with a jump to the join point.
-
-\begin{code}
- {-
- mkJumpTable
- :: StixTree -- discriminant
- -> [(Literal, AbstractC)] -- alternatives
- -> Integer -- low tag
- -> Integer -- high tag
- -> CLabel -- default label
- -> UniqSM StixTreeList
- -}
-
- mkJumpTable am alts lowTag highTag dflt
- = getUniqLabelNCG `thenUs` \ utlbl ->
- mapUs genLabel alts `thenUs` \ branches ->
- let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
- cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
-
- offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
- dsts = DestInfo (dflt : map fst branches)
-
- jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
- tlbl = StLabel utlbl
- table = StData PtrRep (mkTable branches [lowTag..highTag] [])
- in
- mapUs mkBranch branches `thenUs` \ alts ->
-
- returnUs (\xs -> cjmpLo : cjmpHi : jump :
- StSegment DataSegment : tlbl : table :
- StSegment TextSegment : foldr1 (.) alts xs)
-
- where
- genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
-
- mkBranch (lbl,(_,alt)) =
- gencode alt `thenUs` \ alt_code ->
- returnUs (\xs -> StLabel lbl : alt_code xs)
-
- mkTable _ [] tbl = reverse tbl
- mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
- mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
- | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
- | otherwise = mkTable alts xs (StCLbl dflt : tbl)
-
-\end{code}
-
-We generate binary comparison trees when a jump table is inappropriate.
-We expect to be given a list of alternatives, sorted by tag, and for
-convenience, the length of the alternative list. We recursively break
-the list in half and do a comparison on the first tag of the second half
-of the list. (Odd lists are broken so that the second half of the list
-is longer.) We can handle either integer or floating kind alternatives,
-so long as they are not mixed. (We assume that the type of the discriminant
-determines the type of the alternatives.)
-
-As with the jump table approach, if a join is necessary after the switch, the
-alternatives should already finish with a jump to the join point.
-
-\begin{code}
- {-
- mkBinaryTree
- :: StixTree -- discriminant
- -> Bool -- floating point?
- -> [(Literal, AbstractC)] -- alternatives
- -> Int -- number of choices
- -> Literal -- low tag
- -> Literal -- high tag
- -> CLabel -- default code label
- -> UniqSM StixTreeList
- -}
-
- mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
- | rangeOfOne = gencode alt
- | otherwise
- = let tag' = a2stix (CLit tag)
- cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
- test = StMachOp cmpOp [am, tag']
- cjmp = StCondJump udlbl test
- in
- gencode alt `thenUs` \ alt_code ->
- returnUs (\xs -> cjmp : alt_code xs)
-
- where
- rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
- -- When there is only one possible tag left in range, we skip the comparison
-
- mkBinaryTree am floating alts choices lowTag highTag udlbl
- = getUniqLabelNCG `thenUs` \ uhlbl ->
- let tag' = a2stix (CLit splitTag)
- cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
- test = StMachOp cmpOp [am, tag']
- cjmp = StCondJump uhlbl test
- in
- mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
- `thenUs` \ lo_code ->
- mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
- `thenUs` \ hi_code ->
-
- returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
-
- where
- half = choices `div` 2
- (alts_lo, alts_hi) = splitAt half alts
- splitTag = fst (head alts_hi)
-
-\end{code}
-
-\begin{code}
- {-
- mkIfThenElse
- :: CAddrMode -- discriminant
- -> Literal -- tag
- -> AbstractC -- if-part
- -> AbstractC -- else-part
- -> UniqSM StixTreeList
- -}
-
- mkIfThenElse discrim tag alt deflt
- = getUniqLabelNCG `thenUs` \ ujlbl ->
- getUniqLabelNCG `thenUs` \ utlbl ->
- let discrim' = a2stix discrim
- tag' = a2stix (CLit tag)
- cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
- test = StMachOp cmpOp [discrim', tag']
- cjmp = StCondJump utlbl test
- dest = StLabel utlbl
- join = StLabel ujlbl
- in
- gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
- gencode deflt `thenUs` \ dflt_code ->
- returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
-
-
-mkJoin :: AbstractC -> CLabel -> AbstractC
-mkJoin code lbl
- | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
- | otherwise = code
-\end{code}
-
-%---------------------------------------------------------------------------
-
-This answers the question: Can the code fall through to the next
-line(s) of code? This errs towards saying True if it can't choose,
-because it is used for eliminating needless jumps. In other words, if
-you might possibly {\em not} jump, then say yes to falling through.
-
-\begin{code}
-mightFallThrough :: AbstractC -> Bool
-
-mightFallThrough absC = ft absC True
- where
- ft AbsCNop if_empty = if_empty
-
- ft (CJump _) if_empty = False
- ft (CReturn _ _) if_empty = False
- ft (CSwitch _ alts deflt) if_empty
- = ft deflt if_empty ||
- or [ft alt if_empty | (_,alt) <- alts]
-
- ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
- ft _ if_empty = if_empty
-
-{- Old algorithm, which called nonemptyAbsC for every subexpression! =========
-fallThroughAbsC (AbsCStmts c1 c2)
- = case nonemptyAbsC c2 of
- Nothing -> fallThroughAbsC c1
- Just x -> fallThroughAbsC x
-fallThroughAbsC (CJump _) = False
-fallThroughAbsC (CReturn _ _) = False
-fallThroughAbsC (CSwitch _ choices deflt)
- = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
- || or (map (fallThroughAbsC . snd) choices)
-fallThroughAbsC other = True
-
-isEmptyAbsC :: AbstractC -> Bool
-isEmptyAbsC = not . maybeToBool . nonemptyAbsC
-================= End of old, quadratic, algorithm -}
-\end{code}
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-- This is the top-level module in the native code generator.
+--
+-- -----------------------------------------------------------------------------
\begin{code}
module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
#include "NCG.h"
-import MachMisc
+import MachInstrs
import MachRegs
-import MachCode
+import MachCodeGen
import PprMach
+import RegisterAlloc
+import RegAllocInfo ( jumpDests )
+import NCGMonad
+
+import Cmm
+import PprCmm ( pprStmt, pprCmms )
+import MachOp
+import CLabel ( CLabel, mkSplitMarkerLabel )
+#if powerpc_TARGET_ARCH
+import CLabel ( mkRtsCodeLabel )
+#endif
-import AbsCStixGen ( genCodeAbstractC )
-import AbsCSyn ( AbstractC, MagicId(..) )
-import AbsCUtils ( mkAbsCStmtList, magicIdPrimRep )
-import AsmRegAlloc ( runRegAllocate )
-import MachOp ( MachOp(..), isCommutableMachOp, isComparisonMachOp )
-import RegAllocInfo ( findReservedRegs )
-import Stix ( StixReg(..), StixStmt(..), StixExpr(..), StixVReg(..),
- pprStixStmts, pprStixStmt,
- stixStmt_CountTempUses, stixStmt_Subst,
- liftStrings,
- initNat,
- mkNatM_State,
- uniqOfNatM_State, deltaOfNatM_State,
- importsOfNatM_State )
-import UniqSupply ( returnUs, thenUs, initUs,
- UniqSM, UniqSupply,
- lazyMapUs )
-import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) )
+import UniqFM
+import Unique ( Unique, getUnique )
+import UniqSupply
+import FastTypes
#if darwin_TARGET_OS
import PprMach ( pprDyldSymbolStub )
import List ( group, sort )
#endif
+import ErrUtils ( dumpIfSet_dyn )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_Static,
+ opt_EnsureSplittableC )
+import Digraph
import qualified Pretty
import Outputable
import FastString
#ifdef NCG_DEBUG
import List ( intersperse )
#endif
-\end{code}
-The 96/03 native-code generator has machine-independent and
-machine-dependent modules (those \tr{#include}'ing \tr{NCG.h}).
+import DATA_INT
+import DATA_WORD
+import DATA_BITS
+import GLAEXTS
-This module (@AsmCodeGen@) is the top-level machine-independent
-module. It uses @AbsCStixGen.genCodeAbstractC@ to produce @StixTree@s
-(defined in module @Stix@), using support code from @StixPrim@
-(primitive operations), @StixMacro@ (Abstract C macros), and
-@StixInteger@ (GMP arbitrary-precision operations).
+{-
+The native-code generator has machine-independent and
+machine-dependent modules.
-Before entering machine-dependent land, we do some machine-independent
-@genericOpt@imisations (defined below) on the @StixTree@s.
+This module ("AsmCodeGen") is the top-level machine-independent
+module. Before entering machine-dependent land, we do some
+machine-independent optimisations (defined below) on the
+'CmmStmts's.
-We convert to the machine-specific @Instr@ datatype with
-@stmt2Instrs@, assuming an ``infinite'' supply of registers. We then
-use a machine-independent register allocator (@runRegAllocate@) to
-rejoin reality. Obviously, @runRegAllocate@ has machine-specific
-helper functions (see about @RegAllocInfo@ below).
+We convert to the machine-specific 'Instr' datatype with
+'cmmCodeGen', assuming an infinite supply of registers. We then use
+a machine-independent register allocator ('regAlloc') to rejoin
+reality. Obviously, 'regAlloc' has machine-specific helper
+functions (see about "RegAllocInfo" below).
+
+Finally, we order the basic blocks of the function so as to minimise
+the number of jumps between blocks, by utilising fallthrough wherever
+possible.
The machine-dependent bits break down as follows:
-\begin{description}
-\item[@MachRegs@:] Everything about the target platform's machine
+
+ * ["MachRegs"] Everything about the target platform's machine
registers (and immediate operands, and addresses, which tend to
intermingle/interact with registers).
-\item[@MachMisc@:] Includes the @Instr@ datatype (possibly should
+ * ["MachInstrs"] Includes the 'Instr' datatype (possibly should
have a module of its own), plus a miscellany of other things
- (e.g., @targetDoubleSize@, @smStablePtrTable@, ...)
+ (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
-\item[@MachCode@:] @stmt2Instrs@ is where @Stix@ stuff turns into
+ * ["MachCodeGen"] is where 'Cmm' stuff turns into
machine instructions.
-\item[@PprMach@:] @pprInstr@ turns an @Instr@ into text (well, really
- an @Doc@).
+ * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
+ a 'Doc').
-\item[@RegAllocInfo@:] In the register allocator, we manipulate
- @MRegsState@s, which are @BitSet@s, one bit per machine register.
+ * ["RegAllocInfo"] In the register allocator, we manipulate
+ 'MRegsState's, which are 'BitSet's, one bit per machine register.
When we want to say something about a specific machine register
(e.g., ``it gets clobbered by this instruction''), we set/unset
- its bit. Obviously, we do this @BitSet@ thing for efficiency
+ its bit. Obviously, we do this 'BitSet' thing for efficiency
reasons.
- The @RegAllocInfo@ module collects together the machine-specific
+ The 'RegAllocInfo' module collects together the machine-specific
info needed to do register allocation.
-\end{description}
-So, here we go:
+ * ["RegisterAlloc"] The (machine-independent) register allocator.
+-}
-\begin{code}
-nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, Pretty.Doc)
-nativeCodeGen absC us
- = let absCstmts = mkAbsCStmtList absC
- (results, us1) = initUs us (lazyMapUs absCtoNat absCstmts)
- stix_sdocs = [ stix | (stix, insn, imports) <- results ]
- insn_sdocs = [ insn | (stix, insn, imports) <- results ]
- imports = [ imports | (stix, insn, imports) <- results ]
+-- -----------------------------------------------------------------------------
+-- Top-level of the native codegen
- insn_sdoc = my_vcat insn_sdocs IF_OS_darwin(Pretty.$$ dyld_stubs,)
- stix_sdoc = vcat stix_sdocs
+-- NB. We *lazilly* compile each block of code for space reasons.
-#if darwin_TARGET_OS
- -- Generate "symbol stubs" for all external symbols that might
- -- come from a dynamic library.
+nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
+nativeCodeGen dflags cmms us
+ | not opt_Static
+ = panic "NCG does not handle dynamic libraries right now"
+ -- ToDo: MachCodeGen used to have derefDLL function which expanded
+ -- dynamic CLabels (labelDynamic lbl == True) into the appropriate
+ -- dereferences. This should be done in the pre-NCG cmmToCmm pass instead.
+ -- It doesn't apply to static data, of course. There are hacks so that
+ -- the RTS knows what to do for references to closures in a DLL in SRTs,
+ -- and we never generate a reference to a closure in another DLL in a
+ -- static constructor.
- dyld_stubs = Pretty.vcat $ map pprDyldSymbolStub $
- map head $ group $ sort $ concat imports
-#endif
+ | otherwise
+ = let ((ppr_cmms, insn_sdoc, imports), _) = initUs us $
+ cgCmm (concat (map add_split cmms))
-# ifdef NCG_DEBUG
- my_trace m x = trace m x
- my_vcat sds = Pretty.vcat (
- intersperse (
- Pretty.char ' '
- Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
- Pretty.$$ Pretty.char ' '
- )
- sds
- )
-# else
- my_vcat sds = Pretty.vcat sds
- my_trace m x = x
-# endif
- in
- my_trace "nativeGen: begin"
- (stix_sdoc, insn_sdoc)
-
-
-absCtoNat :: AbstractC -> UniqSM (SDoc, Pretty.Doc, [FastString])
-absCtoNat absC
- = _scc_ "genCodeAbstractC" genCodeAbstractC absC `thenUs` \ stixRaw ->
- _scc_ "genericOpt" genericOpt stixRaw `bind` \ stixOpt ->
- _scc_ "liftStrings" liftStrings stixOpt `thenUs` \ stixLifted ->
- _scc_ "genMachCode" genMachCode stixLifted `thenUs` \ (pre_regalloc, imports) ->
- _scc_ "regAlloc" regAlloc pre_regalloc `bind` \ almost_final ->
- _scc_ "x86fp_kludge" x86fp_kludge almost_final `bind` \ final_mach_code ->
- _scc_ "vcat" Pretty.vcat (map pprInstr final_mach_code) `bind` \ final_sdoc ->
- _scc_ "pprStixTrees" pprStixStmts stixOpt `bind` \ stix_sdoc ->
- returnUs ({-\_ -> Pretty.vcat (map pprInstr almost_final),-}
- stix_sdoc, final_sdoc, imports)
- where
- bind f x = x f
+ cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [(Bool, CLabel)])
+ cgCmm tops =
+ lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
+ let (cmms,docs,imps) = unzip3 results in
+ returnUs (Cmm cmms, my_vcat docs, concat imps)
+ in do
+ dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms])
+ return (insn_sdoc Pretty.$$ dyld_stubs imports)
- x86fp_kludge :: [Instr] -> [Instr]
- x86fp_kludge = IF_ARCH_i386(i386_insert_ffrees,id)
+ where
- regAlloc :: InstrBlock -> [Instr]
- regAlloc = runRegAllocate allocatableRegs findReservedRegs
-\end{code}
+ add_split (Cmm tops)
+ | opt_EnsureSplittableC = split_marker : tops
+ | otherwise = tops
-Top level code generator for a chunk of stix code. For this part of
-the computation, we switch from the UniqSM monad to the NatM monad.
-The latter carries not only a Unique, but also an Int denoting the
-current C stack pointer offset in the generated code; this is needed
-for creating correct spill offsets on architectures which don't offer,
-or for which it would be prohibitively expensive to employ, a frame
-pointer register. Viz, x86.
+ split_marker = CmmProc [] mkSplitMarkerLabel [] []
-The offset is measured in bytes, and indicates the difference between
-the current (simulated) C stack-ptr and the value it was at the
-beginning of the block. For stacks which grow down, this value should
-be either zero or negative.
+#if darwin_TARGET_OS
+ -- Generate "symbol stubs" for all external symbols that might
+ -- come from a dynamic library.
+ dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
+ map head $ group $ sort imps
+#else
+ dyld_stubs imps = Pretty.empty
+#endif
-Switching between the two monads whilst carrying along the same Unique
-supply breaks abstraction. Is that bad?
+#ifndef NCG_DEBUG
+ my_vcat sds = Pretty.vcat sds
+#else
+ my_vcat sds = Pretty.vcat (
+ intersperse (
+ Pretty.char ' '
+ Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
+ Pretty.$$ Pretty.char ' '
+ )
+ sds
+ )
+#endif
-\begin{code}
-genMachCode :: [StixStmt] -> UniqSM (InstrBlock, [FastString])
-genMachCode stmts initial_us
+-- Complete native code generation phase for a single top-level chunk
+-- of Cmm.
+
+cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [(Bool,CLabel)])
+cmmNativeGen dflags cmm
+ = {-# SCC "fixAssigns" #-}
+ fixAssignsTop cmm `thenUs` \ fixed_cmm ->
+ {-# SCC "genericOpt" #-}
+ cmmToCmm fixed_cmm `bind` \ cmm ->
+ (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance
+ then cmm
+ else CmmData Text []) `bind` \ ppr_cmm ->
+ {-# SCC "genMachCode" #-}
+ genMachCode cmm `thenUs` \ (pre_regalloc, imports) ->
+ {-# SCC "regAlloc" #-}
+ map regAlloc pre_regalloc `bind` \ with_regs ->
+ {-# SCC "sequenceBlocks" #-}
+ map sequenceTop with_regs `bind` \ sequenced ->
+ {-# SCC "x86fp_kludge" #-}
+ map x86fp_kludge sequenced `bind` \ final_mach_code ->
+ {-# SCC "vcat" #-}
+ Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc ->
+
+ returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", imports)
+ where
+ x86fp_kludge :: NatCmmTop -> NatCmmTop
+ x86fp_kludge top@(CmmData _ _) = top
+#if i386_TARGET_ARCH
+ x86fp_kludge top@(CmmProc info lbl params code) =
+ CmmProc info lbl params (map bb_i386_insert_ffrees code)
+ where
+ bb_i386_insert_ffrees (BasicBlock id instrs) =
+ BasicBlock id (i386_insert_ffrees instrs)
+#else
+ x86fp_kludge top = top
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Sequencing the basic blocks
+
+-- Cmm BasicBlocks are self-contained entities: they always end in a
+-- jump, either non-local or to another basic block in the same proc.
+-- In this phase, we attempt to place the basic blocks in a sequence
+-- such that as many of the local jumps as possible turn into
+-- fallthroughs.
+
+sequenceTop :: NatCmmTop -> NatCmmTop
+sequenceTop top@(CmmData _ _) = top
+sequenceTop (CmmProc info lbl params blocks) =
+ CmmProc info lbl params (sequenceBlocks blocks)
+
+-- The algorithm is very simple (and stupid): we make a graph out of
+-- the blocks where there is an edge from one block to another iff the
+-- first block ends by jumping to the second. Then we topologically
+-- sort this graph. Then traverse the list: for each block, we first
+-- output the block, then if it has an out edge, we move the
+-- destination of the out edge to the front of the list, and continue.
+
+sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
+sequenceBlocks [] = []
+sequenceBlocks (entry:blocks) =
+ seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
+ -- the first block is the entry point ==> it must remain at the start.
+
+sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
+sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
+
+getOutEdges :: [Instr] -> [Unique]
+getOutEdges instrs = case jumpDests (last instrs) [] of
+ [one] -> [getUnique one]
+ _many -> []
+ -- we're only interested in the last instruction of
+ -- the block, and only if it has a single destination.
+
+mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
+
+seqBlocks [] = []
+seqBlocks ((block,_,[]) : rest)
+ = block : seqBlocks rest
+seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
+ | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
+ | otherwise = block : seqBlocks rest'
+ where
+ (can_fallthrough, rest') = reorder next [] rest
+ -- TODO: we should do a better job for cycles; try to maximise the
+ -- fallthroughs within a loop.
+seqBlocks _ = panic "AsmCodegen:seqBlocks"
+
+reorder id accum [] = (False, reverse accum)
+reorder id accum (b@(block,id',out) : rest)
+ | id == id' = (True, (block,id,out) : reverse accum ++ rest)
+ | otherwise = reorder id (b:accum) rest
+
+-- -----------------------------------------------------------------------------
+-- Instruction selection
+
+-- Native code instruction selection for a chunk of stix code. For
+-- this part of the computation, we switch from the UniqSM monad to
+-- the NatM monad. The latter carries not only a Unique, but also an
+-- Int denoting the current C stack pointer offset in the generated
+-- code; this is needed for creating correct spill offsets on
+-- architectures which don't offer, or for which it would be
+-- prohibitively expensive to employ, a frame pointer register. Viz,
+-- x86.
+
+-- The offset is measured in bytes, and indicates the difference
+-- between the current (simulated) C stack-ptr and the value it was at
+-- the beginning of the block. For stacks which grow down, this value
+-- should be either zero or negative.
+
+-- Switching between the two monads whilst carrying along the same
+-- Unique supply breaks abstraction. Is that bad?
+
+genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [(Bool,CLabel)])
+
+genMachCode cmm_top initial_us
= let initial_st = mkNatM_State initial_us 0
- (instr_list, final_st) = initNat initial_st (stmtsToInstrs stmts)
- final_us = uniqOfNatM_State final_st
- final_delta = deltaOfNatM_State final_st
- final_imports = importsOfNatM_State final_st
+ (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
+ final_us = natm_us final_st
+ final_delta = natm_delta final_st
+ final_imports = natm_imports final_st
in
if final_delta == 0
- then ((instr_list, final_imports), final_us)
+ then ((new_tops, final_imports), final_us)
else pprPanic "genMachCode: nonzero final delta"
(int final_delta)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[NCOpt]{The Generic Optimiser}
-%* *
-%************************************************************************
-
-This is called between translating Abstract C to its Tree and actually
-using the Native Code Generator to generate the annotations. It's a
-chance to do some strength reductions.
-
-** Remember these all have to be machine independent ***
-
-Note that constant-folding should have already happened, but we might
-have introduced some new opportunities for constant-folding wrt
-address manipulations.
-
-\begin{code}
-genericOpt :: [StixStmt] -> [StixStmt]
-genericOpt = map stixStmt_ConFold . stixPeep
-
-
-
-stixPeep :: [StixStmt] -> [StixStmt]
--- This transformation assumes that the temp assigned to in t1
--- is not assigned to in t2; for otherwise the target of the
--- second assignment would be substituted for, giving nonsense
--- code. As far as I can see, StixTemps are only ever assigned
--- to once. It would be nice to be sure!
-
-stixPeep ( t1@(StAssignReg pka (StixTemp (StixVReg u pk)) rhs)
- : t2
- : ts )
- | stixStmt_CountTempUses u t2 == 1
- && sum (map (stixStmt_CountTempUses u) ts) == 0
- =
-# ifdef NCG_DEBUG
- trace ("nativeGen: inlining " ++ showSDoc (pprStixExpr rhs))
-# endif
- (stixPeep (stixStmt_Subst u rhs t2 : ts))
-
-stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts)
-stixPeep [t1] = [t1]
-stixPeep [] = []
-\end{code}
+-- -----------------------------------------------------------------------------
+-- Fixup assignments to global registers so that they assign to
+-- locations within the RegTable, if appropriate.
+
+-- Note that we currently don't fixup reads here: they're done by
+-- the generic optimiser below, to avoid having two separate passes
+-- over the Cmm.
+
+fixAssignsTop :: CmmTop -> UniqSM CmmTop
+fixAssignsTop top@(CmmData _ _) = returnUs top
+fixAssignsTop (CmmProc info lbl params blocks) =
+ mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
+ returnUs (CmmProc info lbl params blocks')
+
+fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
+fixAssignsBlock (BasicBlock id stmts) =
+ fixAssigns stmts `thenUs` \ stmts' ->
+ returnUs (BasicBlock id stmts')
+
+fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
+fixAssigns stmts =
+ mapUs fixAssign stmts `thenUs` \ stmtss ->
+ returnUs (concat stmtss)
+
+fixAssign :: CmmStmt -> UniqSM [CmmStmt]
+fixAssign (CmmAssign (CmmGlobal BaseReg) src)
+ = panic "cmmStmtConFold: assignment to BaseReg";
+
+fixAssign (CmmAssign (CmmGlobal reg) src)
+ | Left realreg <- reg_or_addr
+ = returnUs [CmmAssign (CmmGlobal reg) (cmmExprConFold src)]
+ | Right baseRegAddr <- reg_or_addr
+ = returnUs [CmmStore baseRegAddr src]
+ -- Replace register leaves with appropriate StixTrees for
+ -- the given target. GlobalRegs which map to a reg on this
+ -- arch are left unchanged. Assigning to BaseReg is always
+ -- illegal, so we check for that.
+ where
+ reg_or_addr = get_GlobalReg_reg_or_addr reg
+
+fixAssign (CmmCall target results args vols)
+ = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
+ returnUs (CmmCall target results' args vols : concat stores)
+ where
+ fixResult g@(CmmGlobal reg,hint) =
+ case get_GlobalReg_reg_or_addr reg of
+ Left realreg -> returnUs (g, [])
+ Right baseRegAddr ->
+ getUniqueUs `thenUs` \ uq ->
+ let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
+ returnUs ((local,hint),
+ [CmmStore baseRegAddr (CmmReg local)])
+ fixResult other =
+ returnUs (other,[])
+
+fixAssign other_stmt = returnUs [other_stmt]
+
+-- -----------------------------------------------------------------------------
+-- Generic Cmm optimiser
+
+{-
+Here we do:
+
+ (a) Constant folding
+ (b) Simple inlining: a temporary which is assigned to and then
+ used, once, can be shorted.
+ (c) Replacement of references to GlobalRegs which do not have
+ machine registers by the appropriate memory load (eg.
+ Hp ==> *(BaseReg + 34) ).
+
+Ideas for other things we could do (ToDo):
+
+ - shortcut jumps-to-jumps
+ - eliminate dead code blocks
+-}
+
+cmmToCmm :: CmmTop -> CmmTop
+cmmToCmm top@(CmmData _ _) = top
+cmmToCmm (CmmProc info lbl params blocks) =
+ CmmProc info lbl params (map cmmBlockConFold (cmmPeep blocks))
+
+cmmBlockConFold :: CmmBasicBlock -> CmmBasicBlock
+cmmBlockConFold (BasicBlock id stmts) = BasicBlock id (map cmmStmtConFold stmts)
+
+cmmStmtConFold stmt
+ = case stmt of
+ CmmAssign reg src
+ -> case cmmExprConFold src of
+ CmmReg reg' | reg == reg' -> CmmNop
+ new_src -> CmmAssign reg new_src
+
+ CmmStore addr src
+ -> CmmStore (cmmExprConFold addr) (cmmExprConFold src)
+
+ CmmJump addr regs
+ -> CmmJump (cmmExprConFold addr) regs
+
+ CmmCall target regs args vols
+ -> CmmCall (case target of
+ CmmForeignCall e conv ->
+ CmmForeignCall (cmmExprConFold e) conv
+ other -> other)
+ regs
+ [ (cmmExprConFold arg,hint) | (arg,hint) <- args ]
+ vols
+
+ CmmCondBranch test dest
+ -> let test_opt = cmmExprConFold test
+ in
+ case test_opt of
+ CmmLit (CmmInt 0 _) ->
+ CmmComment (mkFastString ("deleted: " ++
+ showSDoc (pprStmt stmt)))
-For most nodes, just optimize the children.
+ CmmLit (CmmInt n _) -> CmmBranch dest
+ other -> CmmCondBranch (cmmExprConFold test) dest
-\begin{code}
-stixExpr_ConFold :: StixExpr -> StixExpr
-stixStmt_ConFold :: StixStmt -> StixStmt
+ CmmSwitch expr ids
+ -> CmmSwitch (cmmExprConFold expr) ids
-stixStmt_ConFold stmt
- = case stmt of
- StAssignReg pk reg@(StixTemp _) src
- -> StAssignReg pk reg (stixExpr_ConFold src)
- StAssignReg pk reg@(StixMagicId mid) src
- -- Replace register leaves with appropriate StixTrees for
- -- the given target. MagicIds which map to a reg on this arch are left unchanged.
- -- Assigning to BaseReg is always illegal, so we check for that.
- -> case mid of {
- BaseReg -> panic "stixStmt_ConFold: assignment to BaseReg";
- other ->
- case get_MagicId_reg_or_addr mid of
- Left realreg
- -> StAssignReg pk reg (stixExpr_ConFold src)
- Right baseRegAddr
- -> stixStmt_ConFold (StAssignMem pk baseRegAddr src)
- }
- StAssignMem pk addr src
- -> StAssignMem pk (stixExpr_ConFold addr) (stixExpr_ConFold src)
- StVoidable expr
- -> StVoidable (stixExpr_ConFold expr)
- StJump dsts addr
- -> StJump dsts (stixExpr_ConFold addr)
- StCondJump addr test
- -> let test_opt = stixExpr_ConFold test
- in
- if manifestlyZero test_opt
- then StComment (mkFastString ("deleted: " ++ showSDoc (pprStixStmt stmt)))
- else StCondJump addr (stixExpr_ConFold test)
- StData pk datas
- -> StData pk (map stixExpr_ConFold datas)
other
-> other
- where
- manifestlyZero (StInt 0) = True
- manifestlyZero other = False
-stixExpr_ConFold expr
+
+cmmExprConFold expr
= case expr of
- StInd pk addr
- -> StInd pk (stixExpr_ConFold addr)
- StCall fn cconv pk args
- -> StCall fn cconv pk (map stixExpr_ConFold args)
- StIndex pk (StIndex pk' base off) off'
- -- Fold indices together when the types match:
- | pk == pk'
- -> StIndex pk (stixExpr_ConFold base)
- (stixExpr_ConFold (StMachOp MO_Nat_Add [off, off']))
- StIndex pk base off
- -> StIndex pk (stixExpr_ConFold base) (stixExpr_ConFold off)
-
- StMachOp mop args
- -- For PrimOps, we first optimize the children, and then we try
+ CmmLoad addr rep
+ -> CmmLoad (cmmExprConFold addr) rep
+
+ CmmMachOp mop args
+ -- For MachOps, we first optimize the children, and then we try
-- our hand at some constant-folding.
- -> stixMachOpFold mop (map stixExpr_ConFold args)
- StReg (StixMagicId mid)
- -- Replace register leaves with appropriate StixTrees for
- -- the given target. MagicIds which map to a reg on this arch are left unchanged.
- -- For the rest, BaseReg is taken to mean the address of the reg table
- -- in MainCapability, and for all others we generate an indirection to
- -- its location in the register table.
- -> case get_MagicId_reg_or_addr mid of
+ -> cmmMachOpFold mop (map cmmExprConFold args)
+
+#if powerpc_TARGET_ARCH
+ -- On powerpc, it's easier to jump directly to a label than
+ -- to use the register table, so we replace these registers
+ -- with the corresponding labels:
+ CmmReg (CmmGlobal GCEnter1)
+ -> CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
+ CmmReg (CmmGlobal GCFun)
+ -> CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
+#endif
+
+ CmmReg (CmmGlobal mid)
+ -- Replace register leaves with appropriate StixTrees for
+ -- the given target. MagicIds which map to a reg on this
+ -- arch are left unchanged. For the rest, BaseReg is taken
+ -- to mean the address of the reg table in MainCapability,
+ -- and for all others we generate an indirection to its
+ -- location in the register table.
+ -> case get_GlobalReg_reg_or_addr mid of
Left realreg -> expr
Right baseRegAddr
-> case mid of
- BaseReg -> stixExpr_ConFold baseRegAddr
- other -> stixExpr_ConFold (StInd (magicIdPrimRep mid) baseRegAddr)
+ BaseReg -> cmmExprConFold baseRegAddr
+ other -> cmmExprConFold (CmmLoad baseRegAddr
+ (globalRegRep mid))
+ -- eliminate zero offsets
+ CmmRegOff reg 0
+ -> cmmExprConFold (CmmReg reg)
+
+ CmmRegOff (CmmGlobal mid) offset
+ -- RegOf leaves are just a shorthand form. If the reg maps
+ -- to a real reg, we keep the shorthand, otherwise, we just
+ -- expand it and defer to the above code.
+ -> case get_GlobalReg_reg_or_addr mid of
+ Left realreg -> expr
+ Right baseRegAddr
+ -> cmmExprConFold (CmmMachOp (MO_Add wordRep) [
+ CmmReg (CmmGlobal mid),
+ CmmLit (CmmInt (fromIntegral offset)
+ wordRep)])
other
-> other
-\end{code}
-Now, try to constant-fold the PrimOps. The arguments have already
-been optimized and folded.
-\begin{code}
-stixMachOpFold
- :: MachOp -- The operation from an StMachOp
- -> [StixExpr] -- The optimized arguments
- -> StixExpr
+-- -----------------------------------------------------------------------------
+-- MachOp constant folder
-stixMachOpFold mop arg@[StInt x]
- = case mop of
- MO_NatS_Neg -> StInt (-x)
- other -> StMachOp mop arg
+-- Now, try to constant-fold the MachOps. The arguments have already
+-- been optimized and folded.
-stixMachOpFold mop args@[StInt x, StInt y]
- = case mop of
- MO_32U_Gt -> StInt (if x > y then 1 else 0)
- MO_32U_Ge -> StInt (if x >= y then 1 else 0)
- MO_32U_Eq -> StInt (if x == y then 1 else 0)
- MO_32U_Ne -> StInt (if x /= y then 1 else 0)
- MO_32U_Lt -> StInt (if x < y then 1 else 0)
- MO_32U_Le -> StInt (if x <= y then 1 else 0)
- MO_Nat_Add -> StInt (x + y)
- MO_Nat_Sub -> StInt (x - y)
- MO_NatS_Mul -> StInt (x * y)
- MO_NatS_Quot | y /= 0 -> StInt (x `quot` y)
- MO_NatS_Rem | y /= 0 -> StInt (x `rem` y)
- MO_NatS_Gt -> StInt (if x > y then 1 else 0)
- MO_NatS_Ge -> StInt (if x >= y then 1 else 0)
- MO_Nat_Eq -> StInt (if x == y then 1 else 0)
- MO_Nat_Ne -> StInt (if x /= y then 1 else 0)
- MO_NatS_Lt -> StInt (if x < y then 1 else 0)
- MO_NatS_Le -> StInt (if x <= y then 1 else 0)
- MO_Nat_Shl | y >= 0 && y < 32 -> do_shl x y
- other -> StMachOp mop args
- where
- do_shl :: Integer -> Integer -> StixExpr
- do_shl v 0 = StInt v
- do_shl v n | n > 0 = do_shl (v*2) (n-1)
-\end{code}
+cmmMachOpFold
+ :: MachOp -- The operation from an CmmMachOp
+ -> [CmmExpr] -- The optimized arguments
+ -> CmmExpr
-When possible, shift the constants to the right-hand side, so that we
-can match for strength reductions. Note that the code generator will
-also assume that constants have been shifted to the right when
-possible.
+cmmMachOpFold op arg@[CmmLit (CmmInt x rep)]
+ = case op of
+ MO_S_Neg r -> CmmLit (CmmInt (-x) rep)
+ MO_Not r -> CmmLit (CmmInt (complement x) rep)
-\begin{code}
-stixMachOpFold op [x@(StInt _), y] | isCommutableMachOp op
- = stixMachOpFold op [y, x]
-\end{code}
-
-We can often do something with constants of 0 and 1 ...
+ -- these are interesting: we must first narrow to the
+ -- "from" type, in order to truncate to the correct size.
+ -- The final narrow/widen to the destination type
+ -- is implicit in the CmmLit.
+ MO_S_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
+ MO_U_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
+ _ -> panic "cmmMachOpFold: unknown unary op"
-\begin{code}
-stixMachOpFold mop args@[x, y@(StInt 0)]
- = case mop of
- MO_Nat_Add -> x
- MO_Nat_Sub -> x
- MO_NatS_Mul -> y
- MO_NatU_Mul -> y
- MO_Nat_And -> y
- MO_Nat_Or -> x
- MO_Nat_Xor -> x
- MO_Nat_Shl -> x
- MO_Nat_Shr -> x
- MO_Nat_Sar -> x
- MO_Nat_Ne | x_is_comparison -> x
- other -> StMachOp mop args
- where
- x_is_comparison
- = case x of
- StMachOp mopp [_, _] -> isComparisonMachOp mopp
- _ -> False
+-- Eliminate conversion NOPs
+cmmMachOpFold (MO_S_Conv rep1 rep2) [x] | rep1 == rep2 = x
+cmmMachOpFold (MO_U_Conv rep1 rep2) [x] | rep1 == rep2 = x
-stixMachOpFold mop args@[x, y@(StInt 1)]
- = case mop of
- MO_NatS_Mul -> x
- MO_NatU_Mul -> x
- MO_NatS_Quot -> x
- MO_NatU_Quot -> x
- MO_NatS_Rem -> StInt 0
- MO_NatU_Rem -> StInt 0
- other -> StMachOp mop args
-\end{code}
+-- ToDo: eliminate multiple conversions. Be careful though: can't remove
+-- a narrowing, and can't remove conversions to/from floating point types.
-Now look for multiplication/division by powers of 2 (integers).
+-- ToDo: eliminate nested comparisons:
+-- CmmMachOp MO_Lt [CmmMachOp MO_Eq [x,y], CmmLit (CmmInt 0 _)]
+-- turns into a simple equality test.
-\begin{code}
-stixMachOpFold mop args@[x, y@(StInt n)]
+cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
= case mop of
- MO_NatS_Mul
+ -- for comparisons: don't forget to narrow the arguments before
+ -- comparing, since they might be out of range.
+ MO_Eq r -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordRep)
+ MO_Ne r -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordRep)
+
+ MO_U_Gt r -> CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordRep)
+ MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordRep)
+ MO_U_Lt r -> CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordRep)
+ MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordRep)
+
+ MO_S_Gt r -> CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordRep)
+ MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordRep)
+ MO_S_Lt r -> CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordRep)
+ MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordRep)
+
+ MO_Add r -> CmmLit (CmmInt (x + y) r)
+ MO_Sub r -> CmmLit (CmmInt (x - y) r)
+ MO_Mul r -> CmmLit (CmmInt (x * y) r)
+ MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r)
+ MO_S_Rem r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r)
+
+ MO_And r -> CmmLit (CmmInt (x .&. y) r)
+ MO_Or r -> CmmLit (CmmInt (x .|. y) r)
+ MO_Xor r -> CmmLit (CmmInt (x `xor` y) r)
+
+ MO_Shl r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
+ MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
+ MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
+
+ other -> CmmMachOp mop args
+
+ where
+ x_u = narrowU xrep x
+ y_u = narrowU xrep y
+ x_s = narrowS xrep x
+ y_s = narrowS xrep y
+
+
+-- When possible, shift the constants to the right-hand side, so that we
+-- can match for strength reductions. Note that the code generator will
+-- also assume that constants have been shifted to the right when
+-- possible.
+
+cmmMachOpFold op [x@(CmmLit _), y]
+ | not (isLit y) && isCommutableMachOp op
+ = cmmMachOpFold op [y, x]
+ where
+ isLit (CmmLit _) = True
+ isLit _ = False
+
+-- Turn (a+b)+c into a+(b+c) where possible. Because literals are
+-- moved to the right, it is more likely that we will find
+-- opportunities for constant folding when the expression is
+-- right-associated.
+--
+-- ToDo: this appears to introduce a quadratic behaviour due to the
+-- nested cmmMachOpFold. Can we fix this?
+cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
+ | mop1 == mop2 && isAssociative mop1
+ = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]]
+ where
+ isAssociative (MO_Add _) = True
+ isAssociative (MO_Mul _) = True
+ isAssociative (MO_And _) = True
+ isAssociative (MO_Or _) = True
+ isAssociative (MO_Xor _) = True
+ isAssociative _ = False
+
+-- Make a RegOff if we can
+cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
+ = CmmRegOff reg (fromIntegral (narrowS rep n))
+cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
+ = CmmRegOff reg (off + fromIntegral (narrowS rep n))
+cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
+ = CmmRegOff reg (- fromIntegral (narrowS rep n))
+cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
+ = CmmRegOff reg (off - fromIntegral (narrowS rep n))
+
+-- Fold label(+/-)offset into a CmmLit where possible
+
+cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
+ = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
+cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
+ = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
+cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
+ = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
+
+-- We can often do something with constants of 0 and 1 ...
+
+cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
+ = case mop of
+ MO_Add r -> x
+ MO_Sub r -> x
+ MO_Mul r -> y
+ MO_And r -> y
+ MO_Or r -> x
+ MO_Xor r -> x
+ MO_Shl r -> x
+ MO_S_Shr r -> x
+ MO_U_Shr r -> x
+ MO_Ne r | isComparisonExpr x -> x
+ MO_Eq r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_U_Gt r | isComparisonExpr x -> x
+ MO_S_Gt r | isComparisonExpr x -> x
+ MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
+ MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
+ MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
+ MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
+ MO_U_Le r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_S_Le r | Just x' <- maybeInvertConditionalExpr x -> x'
+ other -> CmmMachOp mop args
+
+cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
+ = case mop of
+ MO_Mul r -> x
+ MO_S_Quot r -> x
+ MO_U_Quot r -> x
+ MO_S_Rem r -> CmmLit (CmmInt 0 rep)
+ MO_U_Rem r -> CmmLit (CmmInt 0 rep)
+ MO_Ne r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_Eq r | isComparisonExpr x -> x
+ MO_U_Lt r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_S_Lt r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
+ MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
+ MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
+ MO_S_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
+ MO_U_Ge r | isComparisonExpr x -> x
+ MO_S_Ge r | isComparisonExpr x -> x
+ other -> CmmMachOp mop args
+
+-- Now look for multiplication/division by powers of 2 (integers).
+
+cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
+ = case mop of
+ MO_Mul rep
-> case exactLog2 n of
Nothing -> unchanged
- Just p -> StMachOp MO_Nat_Shl [x, StInt p]
- MO_NatS_Quot
+ Just p -> CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)]
+ MO_S_Quot rep
-> case exactLog2 n of
Nothing -> unchanged
- Just p -> StMachOp MO_Nat_Shr [x, StInt p]
+ Just p -> CmmMachOp (MO_S_Shr rep) [x, CmmLit (CmmInt p rep)]
other
-> unchanged
where
- unchanged = StMachOp mop args
+ unchanged = CmmMachOp mop args
+
+-- Anything else is just too hard.
+
+cmmMachOpFold mop args = CmmMachOp mop args
+
+
+-- -----------------------------------------------------------------------------
+-- exactLog2
+
+-- This algorithm for determining the $\log_2$ of exact powers of 2 comes
+-- from GCC. It requires bit manipulation primitives, and we use GHC
+-- extensions. Tough.
+--
+-- Used to be in MachInstrs --SDM.
+-- ToDo: remove use of unboxery --SDM.
+
+w2i x = word2Int# x
+i2w x = int2Word# x
+
+exactLog2 :: Integer -> Maybe Integer
+exactLog2 x
+ = if (x <= 0 || x >= 2147483648) then
+ Nothing
+ else
+ case iUnbox (fromInteger x) of { x# ->
+ if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
+ Nothing
+ else
+ Just (toInteger (iBox (pow2 x#)))
+ }
+ where
+ pow2 x# | x# ==# 1# = 0#
+ | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#))
+
+
+-- -----------------------------------------------------------------------------
+-- widening / narrowing
+
+narrowU :: MachRep -> Integer -> Integer
+narrowU I8 x = fromIntegral (fromIntegral x :: Word8)
+narrowU I16 x = fromIntegral (fromIntegral x :: Word16)
+narrowU I32 x = fromIntegral (fromIntegral x :: Word32)
+narrowU I64 x = fromIntegral (fromIntegral x :: Word64)
+narrowU _ _ = panic "narrowTo"
+
+narrowS :: MachRep -> Integer -> Integer
+narrowS I8 x = fromIntegral (fromIntegral x :: Int8)
+narrowS I16 x = fromIntegral (fromIntegral x :: Int16)
+narrowS I32 x = fromIntegral (fromIntegral x :: Int32)
+narrowS I64 x = fromIntegral (fromIntegral x :: Int64)
+narrowS _ _ = panic "narrowTo"
+
+-- -----------------------------------------------------------------------------
+-- The mini-inliner
+
+-- This pass inlines assignments to temporaries that are used just
+-- once in the very next statement only. Generalising this would be
+-- quite difficult (have to take into account aliasing of memory
+-- writes, and so on), but at the moment it catches a number of useful
+-- cases and lets the code generator generate much better code.
+
+-- NB. This assumes that temporaries are single-assignment.
+
+cmmPeep :: [CmmBasicBlock] -> [CmmBasicBlock]
+cmmPeep blocks = map do_inline blocks
+ where
+ blockUses (BasicBlock _ stmts)
+ = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts)
+
+ uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks)
+
+ do_inline (BasicBlock id stmts)
+ = BasicBlock id (cmmMiniInline uses stmts)
+
+
+cmmMiniInline :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
+cmmMiniInline uses [] = []
+cmmMiniInline uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
+ | Just 1 <- lookupUFM uses u,
+ Just stmts' <- lookForInline u expr stmts
+ =
+#ifdef NCG_DEBUG
+ trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
+#endif
+ cmmMiniInline uses stmts'
+
+cmmMiniInline uses (stmt:stmts)
+ = stmt : cmmMiniInline uses stmts
+
+
+-- Try to inline a temporary assignment. We can skip over assignments to
+-- other tempoararies, because we know that expressions aren't side-effecting
+-- and temporaries are single-assignment.
+lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
+ | u /= u'
+ = case lookupUFM (getExprUses rhs) u of
+ Just 1 -> Just (inlineStmt u expr stmt : rest)
+ _other -> case lookForInline u expr rest of
+ Nothing -> Nothing
+ Just stmts -> Just (stmt:stmts)
+
+lookForInline u expr (stmt:stmts)
+ = case lookupUFM (getStmtUses stmt) u of
+ Just 1 -> Just (inlineStmt u expr stmt : stmts)
+ _other -> Nothing
+
+-- -----------------------------------------------------------------------------
+-- Boring Cmm traversals for collecting usage info and substitutions.
+
+getStmtUses :: CmmStmt -> UniqFM Int
+getStmtUses (CmmAssign _ e) = getExprUses e
+getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
+getStmtUses (CmmCall target _ es _)
+ = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
+ where uses (CmmForeignCall e _) = getExprUses e
+ uses _ = emptyUFM
+getStmtUses (CmmCondBranch e _) = getExprUses e
+getStmtUses (CmmSwitch e _) = getExprUses e
+getStmtUses (CmmJump e _) = getExprUses e
+getStmtUses _ = emptyUFM
+
+getExprUses :: CmmExpr -> UniqFM Int
+getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
+getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
+getExprUses (CmmLoad e _) = getExprUses e
+getExprUses (CmmMachOp _ es) = getExprsUses es
+getExprUses _other = emptyUFM
+
+getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
+
+inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
+inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
+inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
+inlineStmt u a (CmmCall target regs es vols)
+ = CmmCall (infn target) regs es' vols
+ where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
+ infn (CmmPrim p) = CmmPrim p
+ es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
+inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
+inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
+inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
+inlineStmt u a other_stmt = other_stmt
+
+inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
+inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
+ | u == u' = a
+ | otherwise = e
+inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
+ | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
+ | otherwise = e
+inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
+inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
+inlineExpr u a other_expr = other_expr
+
+-- -----------------------------------------------------------------------------
+-- Utils
+
+bind f x = x $! f
+
+isComparisonExpr :: CmmExpr -> Bool
+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
+isComparisonExpr _other = False
+
+maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr
+maybeInvertConditionalExpr (CmmMachOp op args)
+ | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args)
+maybeInvertConditionalExpr _ = Nothing
\end{code}
-Anything else is just too hard.
-
-\begin{code}
-stixMachOpFold mop args = StMachOp mop args
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-2000
-%
-\section[AsmRegAlloc]{Register allocator}
-
-\begin{code}
-module AsmRegAlloc ( runRegAllocate ) where
-
-#include "HsVersions.h"
-
-import MachCode ( InstrBlock )
-import MachMisc ( Instr(..) )
-import PprMach ( pprInstr ) -- Just for debugging
-import MachRegs
-import RegAllocInfo
-
-import FiniteMap ( FiniteMap, emptyFM,
- lookupFM, eltsFM, addToFM_C, addToFM,
- listToFM, fmToList )
-import OrdList ( fromOL )
-import Outputable
-import Unique ( mkPseudoUnique3 )
-import CLabel ( CLabel, pprCLabel )
-import FastTypes
-
-import List ( mapAccumL, nub, sort )
-import Array ( Array, array, (!), bounds )
-\end{code}
-
-This is the generic register allocator. It does allocation for all
-architectures. Details for specific architectures are given in
-RegAllocInfo.lhs. In practice the allocator needs to know next to
-nothing about an architecture to do its job:
-
-* It needs to be given a list of the registers it can allocate to.
-
-* It needs to be able to find out which registers each insn reads and
- writes.
-
-* It needs be able to change registers in instructions into other
- registers.
-
-* It needs to be able to find out where execution could go after an
- in instruction.
-
-* It needs to be able to discover sets of registers which can be
- used to attempt spilling.
-
-First we try something extremely simple. If that fails, we have to do
-things the hard way.
-
-\begin{code}
-runRegAllocate
- :: [Reg]
- -> ([Instr] -> [[Reg]])
- -> InstrBlock
- -> [Instr]
-
-runRegAllocate regs find_reserve_regs instrs
- = --trace ("runRegAllocate: " ++ show regs) (
- case simpleAlloc of
- Just simple -> --trace "SIMPLE"
- simple
- Nothing -> --trace "GENERAL"
- (tryGeneral reserves)
- --)
- where
- tryGeneral []
- = pprPanic "nativeGen: spilling failed. Workaround: compile with -fvia-C.\n"
- ( (text "reserves = " <> ppr reserves)
- $$
- (text "code = ")
- $$
- (vcat (map (docToSDoc.pprInstr) flatInstrs))
- )
- tryGeneral (resv:resvs)
- = case generalAlloc resv of
- Just success -> success
- Nothing -> tryGeneral resvs
-
- reserves = find_reserve_regs flatInstrs
- flatInstrs = fromOL instrs
- simpleAlloc = doSimpleAlloc regs flatInstrs
- generalAlloc resvd = doGeneralAlloc regs resvd flatInstrs
-\end{code}
-
-Rather than invoke the heavyweight machinery in @doGeneralAlloc@ for
-each and every code block, we first try using this simple, fast and
-utterly braindead allocator. In practice it handles about 60\% of the
-code blocks really fast, even with only 3 integer registers available.
-Since we can always give up and fall back to @doGeneralAlloc@,
-@doSimpleAlloc@ is geared to handling the common case as fast as
-possible. It will succeed only if:
-
-* The code mentions registers only of integer class, not floating
- class.
-
-* The code doesn't mention any real registers, so we don't have to
- think about dodging and weaving to work around fixed register uses.
-
-* The code mentions at most N virtual registers, where N is the number
- of real registers for allocation.
-
-If those conditions are satisfied, we simply trundle along the code,
-doling out a real register every time we see mention of a new virtual
-register. We either succeed at this, or give up when one of the above
-three conditions is no longer satisfied.
-
-\begin{code}
-doSimpleAlloc :: [Reg] -> [Instr] -> Maybe [Instr]
-doSimpleAlloc available_real_regs instrs
- = let available_iregs
- = filter ((== RcInteger).regClass) available_real_regs
-
- trundle :: [( {-Virtual-}Reg, {-Real-}Reg )]
- -> [ {-Real-}Reg ]
- -> [Instr]
- -> [Instr]
- -> Maybe [Instr]
- trundle vreg_map uncommitted_rregs ris_done []
- = Just (reverse ris_done)
- trundle vreg_map uncommitted_rregs ris_done (i:is)
- = case regUsage i of
- RU rds wrs
-
- -- Mentions no regs? Move on quickly
- | null rds_l && null wrs_l
- -> trundle vreg_map uncommitted_rregs (i:ris_done) is
-
- -- A case we can't be bothered to handle?
- | any isFloatingOrReal rds_l || any isFloatingOrReal wrs_l
- -> Nothing
-
- -- Update the rreg commitments, and map the insn
- | otherwise
- -> case upd_commitment (wrs_l++rds_l)
- vreg_map uncommitted_rregs of
- Nothing -- out of rregs; give up
- -> Nothing
- Just (vreg_map2, uncommitted_rregs2)
- -> let i2 = patchRegs i (subst_reg vreg_map2)
- in trundle vreg_map2 uncommitted_rregs2
- (i2:ris_done) is
- where
- isFloatingOrReal reg
- = isRealReg reg || regClass reg == RcFloat
- || regClass reg == RcDouble
-
- rds_l = regSetToList rds
- wrs_l = regSetToList wrs
-
- upd_commitment [] vr_map uncomm
- = Just (vr_map, uncomm)
- upd_commitment (reg:regs) vr_map uncomm
- | isRealReg reg
- = upd_commitment regs vr_map uncomm
- | reg `elem` (map fst vr_map)
- = upd_commitment regs vr_map uncomm
- | null uncomm
- = Nothing
- | otherwise
- = upd_commitment regs ((reg, head uncomm):vr_map)
- (tail uncomm)
-
- subst_reg vreg_map r
- -- If it's a RealReg, it must be STG-specific one
- -- (Hp,Sp,BaseReg,etc), since regUsage filters them out,
- -- so isFloatingOrReal would not have objected to it.
- | isRealReg r
- = r
- | otherwise
- = case [rr | (vr,rr) <- vreg_map, vr == r] of
- [rr2] -> rr2
- other -> pprPanic
- "doSimpleAlloc: unmapped VirtualReg"
- (ppr r)
- in
- trundle [] available_iregs [] instrs
-\end{code}
-
-From here onwards is the general register allocator and spiller. For
-each flow edge (possible transition between instructions), we compute
-which virtual and real registers are live on that edge. Then the
-mapping is inverted, to give a mapping from register (virtual+real) to
-sets of flow edges on which the register is live. Finally, we can use
-those sets to decide whether a virtual reg v can be assigned to a real
-reg r, by checking that v's live-edge-set does not intersect with r's
-current live-edge-set. Having made that assignment, we then augment
-r's current live-edge-set (its current commitment, you could say) with
-v's live-edge-set.
-
-doGeneralAlloc takes reserve_regs as the regs to use as spill
-temporaries. First it tries to allocate using all regs except
-reserve_regs. If that fails, it inserts spill code and tries again to
-allocate regs, but this time with the spill temporaries available.
-Even this might not work if there are insufficient spill temporaries:
-in the worst case on x86, we'd need 3 of them, for insns like addl
-(%reg1,%reg2,4) %reg3, since this insn uses all 3 regs as input.
-
-\begin{code}
-doGeneralAlloc
- :: [Reg] -- all allocatable regs
- -> [Reg] -- the reserve regs
- -> [Instr] -- instrs in
- -> Maybe [Instr] -- instrs out
-
-doGeneralAlloc all_regs reserve_regs instrs
- -- succeeded without spilling
- | prespill_ok
- = Just prespill_insns
-
- -- failed, and no spill regs avail, so pointless to attempt spilling
- | null reserve_regs = Nothing
- -- success after spilling
- | postspill_ok = maybetrace (spillMsg True) (Just postspill_insns)
- -- still not enough reserves after spilling; we have to give up
- | otherwise = maybetrace (spillMsg False) Nothing
- where
- prespill_regs
- = filter (`notElem` reserve_regs) all_regs
- (prespill_ok, prespill_insns)
- = allocUsingTheseRegs instrs prespill_regs
- instrs_with_spill_code
- = insertSpillCode prespill_insns
- (postspill_ok, postspill_insns)
- = allocUsingTheseRegs instrs_with_spill_code all_regs
-
- spillMsg success
- = "nativeGen: spilling "
- ++ (if success then "succeeded" else "failed ")
- ++ " using "
- ++ showSDoc (hsep (map ppr reserve_regs))
-
-# ifdef NCG_DEBUG
- maybetrace msg x = trace msg x
-# else
- maybetrace msg x = x
-# endif
-\end{code}
-
-Here we patch instructions that reference ``registers'' which are
-really in memory somewhere (the mapping is under the control of the
-machine-specific code generator). We place the appropriate load
-sequences before any instructions that use memory registers as
-sources, and we place the appropriate spill sequences after any
-instructions that use memory registers as destinations. The offending
-instructions are rewritten with new dynamic registers, so generalAlloc
-has to run register allocation again after all of this is said and
-done.
-
-On some architectures (x86, currently), we do without a frame-pointer,
-and instead spill relative to the stack pointer (%esp on x86).
-Because the stack pointer may move, the patcher needs to keep track of
-the current stack pointer "delta". That's easy, because all it needs
-to do is spot the DELTA bogus-insns which will have been inserted by
-the relevant insn selector precisely so as to notify the spiller of
-stack-pointer movement. The delta is passed to loadReg and spillReg,
-since they generate the actual spill code. We expect the final delta
-to be the same as the starting one (zero), reflecting the fact that
-changes to the stack pointer should not extend beyond a basic block.
-
-Finally, there is the issue of mapping an arbitrary set of unallocated
-VirtualRegs into a contiguous sequence of spill slots. The failed
-allocation will have left the code peppered with references to
-VirtualRegs, each of which contains a unique. So we make an env which
-maps these VirtualRegs to integers, starting from zero, and pass that
-env through to loadReg and spillReg. There, they are used to look up
-spill slot numbers for the uniques.
-
-\begin{code}
-insertSpillCode :: [Instr] -> [Instr]
-insertSpillCode insns
- = let uniques_in_insns
- = map getVRegUnique
- (regSetToList
- (foldl unionRegSets emptyRegSet
- (map vregs_in_insn insns)))
- vregs_in_insn i
- = case regUsage i of
- RU rds wrs -> filterRegSet isVirtualReg
- (rds `unionRegSets` wrs)
- vreg_to_slot_map :: FiniteMap VRegUnique Int
- vreg_to_slot_map
- = listToFM (zip uniques_in_insns [0..])
-
- ((final_stack_delta, final_ctr), insnss)
- = mapAccumL (patchInstr vreg_to_slot_map) (0,0) insns
- in
- if final_stack_delta == 0
- then concat insnss
- else pprPanic "patchMem: non-zero final delta"
- (int final_stack_delta)
-
-
--- patchInstr has as a running state two Ints, one the current stack delta,
--- needed to figure out offsets to stack slots on archs where we spill relative
--- to the stack pointer, as opposed to the frame pointer. The other is a
--- counter, used to manufacture new temporary register names.
-
-patchInstr :: FiniteMap VRegUnique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr])
-patchInstr vreg_to_slot_map (delta,ctr) instr
-
- | null memSrcs && null memDsts
- = ((delta',ctr), [instr])
-
- | otherwise
- = ((delta',ctr'), loadSrcs ++ [instr'] ++ spillDsts)
- where
- delta' = case instr of DELTA d -> d ; _ -> delta
-
- (RU srcs dsts) = regUsage instr
-
- -- The instr being patched may mention several vregs -- those which
- -- could not be assigned real registers. For each such vreg, we
- -- invent a new vreg, used only around this instruction and nowhere
- -- else. These new vregs replace the unallocatable vregs; they are
- -- loaded from the spill area, the instruction is done with them,
- -- and results if any are then written back to the spill area.
- vregs_in_instr
- = nub (filter isVirtualReg
- (regSetToList srcs ++ regSetToList dsts))
- n_vregs_in_instr
- = length vregs_in_instr
- ctr'
- = ctr + n_vregs_in_instr
- vreg_env
- = zip vregs_in_instr [ctr, ctr+1 ..]
-
- mkTmpReg vreg
- | isVirtualReg vreg
- = case [vi | (vreg', vi) <- vreg_env, vreg' == vreg] of
- [i] -> case regClass vreg of
- RcInteger -> VirtualRegI (pseudoVReg i)
- RcFloat -> VirtualRegF (pseudoVReg i)
- RcDouble -> VirtualRegD (pseudoVReg i)
- _ -> pprPanic "patchInstr: unmapped VReg" (ppr vreg)
- | otherwise
- = vreg
-
- pseudoVReg i = VRegUniqueLo (mkPseudoUnique3 i)
-
- memSrcs = filter isVirtualReg (regSetToList srcs)
- memDsts = filter isVirtualReg (regSetToList dsts)
-
- loadSrcs = map load memSrcs
- spillDsts = map spill memDsts
-
- load mem = loadReg vreg_to_slot_map delta mem (mkTmpReg mem)
- spill mem = spillReg vreg_to_slot_map delta' (mkTmpReg mem) mem
-
- instr' = patchRegs instr mkTmpReg
-\end{code}
-
-allocUsingTheseRegs is the register allocator proper. It attempts
-to allocate dynamic regs to real regs, given a list of real regs
-which it may use. If it fails due to lack of real regs, the returned
-instructions use what real regs there are, but will retain uses of
-dynamic regs for which a real reg could not be found. It is these
-leftover dynamic reg references which insertSpillCode will later
-assign to spill slots.
-
-Some implementation notes.
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Instructions are numbered sequentially, starting at zero.
-
-A flow edge (FE) is a pair of insn numbers (MkFE Int Int) denoting
-a possible flow of control from the first insn to the second.
-
-The input to the register allocator is a list of instructions, which
-mention Regs. A Reg can be a RealReg -- a real machine reg -- or a
-VirtualReg, which carries a unique. After allocation, all the
-VirtualReg references will have been converted into RealRegs, and
-possible some spill code will have been inserted.
-
-The heart of the register allocator works in four phases.
-
-1. (find_flow_edges) Calculate all the FEs for the code list.
- Return them not as a [FE], but implicitly, as a pair of
- Array Int [Int], being the successor and predecessor maps
- for instructions.
-
-2. (calc_liveness) Returns a FiniteMap FE RegSet. For each
- FE, indicates the set of registers live on that FE. Note
- that the set includes both RealRegs and VirtualRegs. The
- former appear because the code could mention fixed register
- usages, and we need to take them into account from the start.
-
-3. (calc_live_range_sets) Invert the above mapping, giving a
- FiniteMap Reg FeSet, indicating, for each virtual and real
- reg mentioned in the code, which FEs it is live on.
-
-4. (calc_vreg_to_rreg_mapping) For virtual reg, try and find
- an allocatable real register for it. Each real register has
- a "current commitment", indicating the set of FEs it is
- currently live on. A virtual reg v can be assigned to
- real reg r iff v's live-fe-set does not intersect with r's
- current commitment fe-set. If the assignment is made,
- v's live-fe-set is union'd into r's current commitment fe-set.
- There is also the minor restriction that v and r must be of
- the same register class (integer or floating).
-
- Once this mapping is established, we simply apply it to the
- input insns, and that's it.
-
- If no suitable real register can be found, the vreg is mapped
- to itself, and we deem allocation to have failed. The partially
- allocated code is returned. The higher echelons of the allocator
- (doGeneralAlloc and runRegAlloc) then cooperate to insert spill
- code and re-run allocation, until a successful allocation is found.
-\begin{code}
-
-allocUsingTheseRegs :: [Instr] -> [Reg] -> (Bool, [Instr])
-allocUsingTheseRegs instrs available_real_regs
- = let (all_vregs_mapped, v_to_r_mapping)
- = calc_vreg_to_rreg_mapping instrs available_real_regs
- new_insns
- = map (flip patchRegs sr) instrs
- sr reg
- | isRealReg reg
- = reg
- | otherwise
- = case lookupFM v_to_r_mapping reg of
- Just r -> r
- Nothing -> pprPanic "allocateUsingTheseRegs: unmapped vreg: "
- (ppr reg)
- in
- --trace ("allocUsingTheseRegs: " ++ show available_real_regs) (
- (all_vregs_mapped, new_insns)
- --)
-
-
--- the heart of the matter.
-calc_vreg_to_rreg_mapping :: [Instr] -> [Reg] -> (Bool, FiniteMap Reg Reg)
-calc_vreg_to_rreg_mapping insns available_real_regs
- = let
- lr_sets :: FiniteMap Reg FeSet
- lr_sets = calc_live_range_sets insns
-
- -- lr_sets maps: vregs mentioned in insns to sets of live FEs
- -- and also: rregs mentioned in insns to sets of live FEs
- -- We need to extract the rreg mapping, and use it as the
- -- initial real-register-commitment. Also, add to the initial
- -- commitment, empty commitments for any real regs not
- -- mentioned in it.
-
- -- which real regs do we want to keep track of in the running
- -- commitment mapping? Precisely the available_real_regs.
- -- We don't care about real regs mentioned by insns which are
- -- not in this list, since we're not allocating to them.
- initial_rr_commitment :: FiniteMap Reg FeSet
- initial_rr_commitment
- = listToFM [(rreg,
- case lookupFM lr_sets rreg of
- Nothing -> emptyFeSet
- Just fixed_use_fes -> fixed_use_fes
- )
- | rreg <- available_real_regs]
-
- -- These are the vregs for which we actually have to (try to)
- -- assign a real register. (ie, the whole reason we're here at all :)
- vreg_liveness_list :: [(Reg, FeSet)]
- vreg_liveness_list = filter (not.isRealReg.fst)
- (fmToList lr_sets)
-
- -- A loop, which attempts to assign each vreg to a rreg.
- loop rr_commitment v_to_r_map []
- = v_to_r_map
- loop rr_commitment v_to_r_map ((vreg,vreg_live_fes):not_yet_done)
- = let
- -- find a real reg which is not live for any of vreg_live_fes
- cand_reals
- = [rreg
- | (rreg,rreg_live_FEs) <- fmToList rr_commitment,
- regClass vreg == regClass rreg,
- isEmptyFeSet (intersectionFeSets rreg_live_FEs
- vreg_live_fes)
- ]
- in
- case cand_reals of
- [] -> -- bummer. No register is available. Just go on to
- -- the next vreg, mapping the vreg to itself.
- loop rr_commitment (addToFM v_to_r_map vreg vreg)
- not_yet_done
- (r:_)
- -> -- Hurrah! Found a free reg of the right class.
- -- Now we need to update the RR commitment.
- loop rr_commitment2 (addToFM v_to_r_map vreg r)
- not_yet_done
- where
- rr_commitment2
- = addToFM_C unionFeSets rr_commitment r
- vreg_live_fes
-
- -- the final vreg to rreg mapping
- vreg_assignment
- = loop initial_rr_commitment emptyFM vreg_liveness_list
- -- did we succeed in mapping everyone to a real reg?
- allocation_succeeded
- = all isRealReg (eltsFM vreg_assignment)
- in
- (allocation_succeeded, vreg_assignment)
-
-
-
--- calculate liveness, then produce the live range info
--- as a mapping of VRegs to the set of FEs on which they are live.
--- The difficult part is inverting the mapping of Reg -> FeSet
--- to produce a mapping FE -> RegSet.
-
-calc_live_range_sets :: [Instr] -> FiniteMap Reg FeSet
-calc_live_range_sets insns
- = let
- -- this is the "original" (old) mapping
- lis :: FiniteMap FE RegSet
- lis = calc_liveness insns
-
- -- establish the totality of reg names mentioned by the
- -- insns, by scanning over the insns.
- all_mentioned_regs :: RegSet
- all_mentioned_regs
- = foldl unionRegSets emptyRegSet
- (map (\i -> case regUsage i of
- RU rds wrs -> unionRegSets rds wrs)
- insns)
-
- -- Initial inverted mapping, from Reg to sets of FEs
- initial_imap :: FiniteMap Reg FeSet
- initial_imap
- = listToFM [(reg, emptyFeSet)
- | reg <- regSetToList all_mentioned_regs]
-
- -- Update the new map with one element of the old map
- upd_imap :: FiniteMap Reg FeSet -> (FE, RegSet)
- -> FiniteMap Reg FeSet
- upd_imap imap (fe, regset)
- = foldl upd_1_imap imap (regSetToList regset)
- where
- upd_1_imap curr reg
- = addToFM_C unionFeSets curr reg (unitFeSet fe)
-
- -- the complete inverse mapping
- final_imap :: FiniteMap Reg FeSet
- final_imap
- = foldl upd_imap initial_imap (fmToList lis)
- in
- final_imap
-
-
-
--- Given the insns, calculate the FEs, and then doing fixpointing to
--- figure out the set of live regs (virtual regs AND real regs) live
--- on each FE.
-
-calc_liveness :: [Instr] -> FiniteMap FE RegSet
-calc_liveness insns
- = let (pred_map, succ_map)
- = find_flow_edges insns
-
- -- We use the convention that if the current approximation
- -- doesn't give a mapping for some FE, that FE maps to the
- -- empty set.
- initial_approx, fixpoint :: FiniteMap FE RegSet
- initial_approx
- = mk_initial_approx 0 insns succ_map emptyFM
- fixpoint
- = fix_set initial_approx 1
- -- If you want to live dangerously, and promise that the code
- -- doesn't contain any loops (ie, there are no back edges in
- -- the flow graph), you should be able to get away with this:
- -- = upd_liveness_info pred_map succ_map insn_array initial_approx
- -- But since I'm paranoid, and since it hardly makes any difference
- -- to the compiler run-time (about 0.1%), I prefer to do the
- -- the full fixpointing game.
-
- insn_array
- = let n = length insns
- in array (0, n-1) (zip [0..] insns)
-
- sameSets [] [] = True
- sameSets (c:cs) (n:ns) = eqRegSets c n && sameSets cs ns
- sameSets _ _ = False
-
- fix_set curr_approx iter_number
- = let next_approx
- = upd_liveness_info pred_map succ_map insn_array curr_approx
- curr_sets
- = eltsFM curr_approx
- next_sets
- = eltsFM next_approx
- same
- = sameSets curr_sets next_sets
- final_approx
- = if same then curr_approx
- else fix_set next_approx (iter_number+1)
- in
- --trace (let qqq (fe, regset)
- -- = show fe ++ " " ++ show (regSetToList regset)
- -- in
- -- "\n::iteration " ++ show iter_number ++ "\n"
- -- ++ (unlines . map qqq . fmToList)
- -- next_approx ++"\n"
- -- )
- final_approx
- in
- fixpoint
-
-
--- Create a correct initial approximation. For each instruction that
--- writes a register, we deem that the register is live on the
--- flow edges leaving the instruction. Subsequent iterations of
--- the liveness AbI augment this based purely on reads of regs, not
--- writes. We need to start off with at least this minimal write-
--- based information in order that writes to vregs which are never
--- used have non-empty live ranges. If we don't do that, we eventually
--- wind up assigning such vregs to any old real reg, since they don't
--- apparently conflict -- you can't conflict with an empty live range.
--- This kludge is unfortunate, but we need to do it to cover not only
--- writes to vregs which are never used, but also to deal correctly
--- with the fact that calls to C will trash the callee saves registers.
-
-mk_initial_approx :: Int -> [Instr] -> Array Int [Int]
- -> FiniteMap FE RegSet
- -> FiniteMap FE RegSet
-mk_initial_approx ino [] succ_map ia_so_far
- = ia_so_far
-mk_initial_approx ino (i:is) succ_map ia_so_far
- = let wrs
- = case regUsage i of RU rrr www -> www
- new_fes
- = [case iUnbox ino of { inoh ->
- case iUnbox ino_succ of { ino_succh ->
- MkFE inoh ino_succh
- }}
- | ino_succ <- succ_map ! ino]
-
- loop [] ia = ia
- loop (fe:fes) ia
- = loop fes (addToFM_C unionRegSets ia fe wrs)
-
- next_ia
- = loop new_fes ia_so_far
- in
- mk_initial_approx (ino+1) is succ_map next_ia
-
-
--- Do one step in the liveness info calculation (AbI :). Given the
--- prior approximation (which tells you a subset of live VRegs+RRegs
--- for each flow edge), calculate new information for all FEs.
--- Rather than do this by iterating over FEs, it's easier to iterate
--- over insns, and update their incoming FEs.
-
-upd_liveness_info :: Array Int [Int] -- instruction pred map
- -> Array Int [Int] -- instruction succ map
- -> Array Int Instr -- array of instructions
- -> FiniteMap FE RegSet -- previous approx
- -> FiniteMap FE RegSet -- improved approx
-
-upd_liveness_info pred_map succ_map insn_array prev_approx
- = do_insns hi prev_approx
- where
- (lo, hi) = bounds insn_array
-
- enquireMapFE :: FiniteMap FE RegSet -> FE
- -> RegSet
- enquireMapFE fm fe
- = case lookupFM fm fe of
- Just set -> set
- Nothing -> emptyRegSet
-
- -- Work backwards, from the highest numbered insn to the lowest.
- -- This is a heuristic which causes faster convergence to the
- -- fixed point. In particular, for straight-line code with no
- -- branches at all, arrives at the fixpoint in one iteration.
- do_insns ino approx
- | ino < lo
- = approx
- | otherwise
- = let fes_to_futures
- = [case iUnbox ino of { inoh ->
- case iUnbox future_ino of { future_inoh ->
- MkFE inoh future_inoh
- }}
- | future_ino <- succ_map ! ino]
- future_lives
- = map (enquireMapFE approx) fes_to_futures
- future_live
- = foldr unionRegSets emptyRegSet future_lives
-
- fes_from_histories
- = [case iUnbox history_ino of { history_inoh ->
- case iUnbox ino of { inoh ->
- MkFE history_inoh inoh
- }}
- | history_ino <- pred_map ! ino]
- new_approx
- = foldl update_one_history approx fes_from_histories
-
- insn
- = insn_array ! ino
- history_independent_component
- = case regUsage insn of
- RU rds wrs
- -> unionRegSets rds
- (minusRegSets future_live wrs)
-
- update_one_history :: FiniteMap FE RegSet
- -> FE
- -> FiniteMap FE RegSet
- update_one_history approx0 fe
- = addToFM_C unionRegSets approx0 fe
- history_independent_component
-
- rest_done
- = do_insns (ino-1) new_approx
- in
- rest_done
-
-
-
--- Extract the flow edges from a list of insns. Express the information
--- as two mappings, from insn number to insn numbers of predecessors,
--- and from insn number to insn numbers of successors. (Since that's
--- what we need to know when computing live ranges later). Instructions
--- are numbered starting at zero. This function is long and complex
--- in order to be efficient; it could equally well be shorter and slower.
-
-find_flow_edges :: [Instr] -> (Array Int [Int],
- Array Int [Int])
-find_flow_edges insns
- = let
- -- First phase: make a temp env which maps labels
- -- to insn numbers, so the second pass can know the insn
- -- numbers for jump targets.
-
- label_env :: FiniteMap CLabel Int
-
- mk_label_env n env [] = env
- mk_label_env n env ((LABEL clbl):is)
- = mk_label_env (n+1) (addToFM env clbl n) is
- mk_label_env n env (i:is)
- = mk_label_env (n+1) env is
-
- label_env = mk_label_env 0 emptyFM insns
-
- find_label :: CLabel -> Int
- find_label jmptarget
- = case lookupFM label_env jmptarget of
- Just ino -> ino
- Nothing -> pprPanic "find_flow_edges: unmapped label"
- (pprCLabel jmptarget)
-
- -- Second phase: traverse the insns, and make up the successor map.
-
- least_ino, greatest_ino :: Int
- least_ino = 0
- greatest_ino = length insns - 1
-
- mk_succ_map :: Int -> [(Int, [Int])] -> [Instr] -> [(Int, [Int])]
-
- mk_succ_map i_num rsucc_map []
- = reverse rsucc_map
-
- mk_succ_map i_num rsucc_map (i:is)
- = let i_num_1 = i_num + 1
- in
- case insnFuture i of
-
- NoFuture
- -> -- A non-local jump. We can regard this insn as a terminal
- -- insn in the graph, so we don't add any edges.
- mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is
-
- Next
- | null is -- this is the last insn, and it doesn't go anywhere
- -- (a meaningless scenario); handle it anyway
- -> mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is
-
- | otherwise -- flows to next insn; add fe i_num -> i_num+1
- -> mk_succ_map i_num_1 ((i_num, [i_num_1]): rsucc_map)
- is
-
- Branch lab -- jmps to lab; add fe i_num -> i_target
- -> let i_target = find_label lab
- in
- mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map) is
-
- NextOrBranch lab
- | null is -- jmps to label, or falls through, and this is
- -- the last insn (a meaningless scenario);
- -- flag an error
- -> error "find_flow_edges: NextOrBranch is last"
-
- | otherwise -- add fes i_num -> i_num+1
- -- and i_num -> i_target
- -> let i_target = find_label lab
- in
- mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map)
- is
- MultiFuture labels
- -> -- A jump, whose targets are listed explicitly.
- -- (Generated from table-based switch translations).
- -- Add fes i_num -> x for each x in labels
- let is_target = nub (map find_label labels)
- in
- mk_succ_map i_num_1 ((i_num, is_target):rsucc_map) is
-
- -- Third phase: invert the successor map to get the predecessor
- -- map, using an algorithm which is quadratic in the worst case,
- -- but runs in almost-linear time, because of the nature of our
- -- inputs: most insns have a single successor, the next insn.
-
- invert :: [(Int, [Int])] -> [(Int, [Int])]
- invert fmap
- = let inverted_pairs
- = concatMap ( \ (a, bs) -> [(b,a) | b <- bs] ) fmap
- sorted_inverted_pairs
- = isort inverted_pairs
-
- grp :: Int -> [Int] -> [(Int,Int)] -> [(Int,[Int])]
- grp k vs [] = [(k, vs)]
- grp k vs ((kk,vv):rest)
- | k == kk = grp k (vv:vs) rest
- | otherwise = (k,vs) : grp kk [vv] rest
-
- grp_start [] = []
- grp_start ((kk,vv):rest) = grp kk [vv] rest
-
- grouped
- = grp_start sorted_inverted_pairs
-
- -- make sure that the reverse mapping maps all inos
- add_empties ino []
- | ino > greatest_ino = []
- | otherwise = (ino,[]): add_empties (ino+1) []
- add_empties ino ((k,vs):rest)
- | ino < k = (ino,[]): add_empties (ino+1) ((k,vs):rest)
- | ino == k = (k,vs) : add_empties (ino+1) rest
-
- -- This is nearly linear provided that the fsts of the
- -- list are nearly in order -- a critical assumption
- -- for efficiency.
- isort :: [(Int,Int)] -> [(Int,Int)]
- isort [] = []
- isort (x:xs) = insert x (isort xs)
-
- insert :: (Int,Int) -> [(Int,Int)] -> [(Int,Int)]
- insert y [] = [y]
- insert y (z:zs)
- -- specifically, this first test should almost always
- -- be True in order for the near-linearity to happen
- | fst y <= fst z = y:z:zs
- | otherwise = z: insert y zs
- in
- add_empties least_ino grouped
-
- -- Finally ...
-
- succ_list
- = mk_succ_map 0 [] insns
- succ_map
- = array (least_ino, greatest_ino) succ_list
- pred_list
- = invert succ_list
- pred_map
- = array (least_ino, greatest_ino) pred_list
- in
- (pred_map, succ_map)
-
-
--- That's all, folks! From here on is just some dull supporting stuff.
-
--- A data type for flow edges
-data FE
- = MkFE FastInt FastInt deriving (Eq, Ord)
-
--- deriving Show on types with unboxed fields doesn't work
-instance Show FE where
- showsPrec _ (MkFE s d)
- = showString "MkFE" . shows (iBox s) . shows ' ' . shows (iBox d)
-
--- Blargh. Use ghc stuff soon! Or: perhaps that's not such a good
--- idea. Most of these sets are either empty or very small, and it
--- might be that the overheads of the FiniteMap based set implementation
--- is a net loss. The same might be true of RegSets.
-
-newtype FeSet = MkFeSet [FE]
-
-feSetFromList xs
- = MkFeSet (nukeDups (sort xs))
- where nukeDups :: [FE] -> [FE]
- nukeDups [] = []
- nukeDups [x] = [x]
- nukeDups (x:y:xys)
- = if x == y then nukeDups (y:xys)
- else x : nukeDups (y:xys)
-
-feSetToList (MkFeSet xs) = xs
-isEmptyFeSet (MkFeSet xs) = null xs
-emptyFeSet = MkFeSet []
-eqFeSet (MkFeSet xs1) (MkFeSet xs2) = xs1 == xs2
-unitFeSet x = MkFeSet [x]
-
-elemFeSet x (MkFeSet xs)
- = f xs
- where
- f [] = False
- f (y:ys) | x == y = True
- | x < y = False
- | otherwise = f ys
-
-unionFeSets (MkFeSet xs1) (MkFeSet xs2)
- = MkFeSet (f xs1 xs2)
- where
- f [] bs = bs
- f as [] = as
- f (a:as) (b:bs)
- | a < b = a : f as (b:bs)
- | a > b = b : f (a:as) bs
- | otherwise = a : f as bs
-
-minusFeSets (MkFeSet xs1) (MkFeSet xs2)
- = MkFeSet (f xs1 xs2)
- where
- f [] bs = []
- f as [] = as
- f (a:as) (b:bs)
- | a < b = a : f as (b:bs)
- | a > b = f (a:as) bs
- | otherwise = f as bs
-
-intersectionFeSets (MkFeSet xs1) (MkFeSet xs2)
- = MkFeSet (f xs1 xs2)
- where
- f [] bs = []
- f as [] = []
- f (a:as) (b:bs)
- | a < b = f as (b:bs)
- | a > b = f (a:as) bs
- | otherwise = a : f as bs
-
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[MachCode]{Generating machine code}
-
-This is a big module, but, if you pay attention to
-(a) the sectioning, (b) the type signatures, and
-(c) the \tr{#if blah_TARGET_ARCH} things, the
-structure should not be too overwhelming.
-
-\begin{code}
-module MachCode ( stmtsToInstrs, InstrBlock ) where
-
-#include "HsVersions.h"
-#include "nativeGen/NCG.h"
-
-import MachMisc -- may differ per-platform
-import MachRegs
-import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
- snocOL, consOL, concatOL )
-import MachOp ( MachOp(..), pprMachOp )
-import AbsCUtils ( magicIdPrimRep )
-import PprAbsC ( pprMagicId )
-import ForeignCall ( CCallConv(..) )
-import CLabel ( CLabel, labelDynamic )
-#if sparc_TARGET_ARCH || alpha_TARGET_ARCH
-import CLabel ( isAsmTemp )
-#endif
-import Maybes ( maybeToBool )
-import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
-#if powerpc_TARGET_ARCH
- getPrimRepSize,
-#endif
- getPrimRepSizeInBytes )
-import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
- StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
- DestInfo, hasDestInfo,
- pprStixExpr, repOfStixExpr,
- NatM, thenNat, returnNat, mapNat,
- mapAndUnzipNat, mapAccumLNat,
- getDeltaNat, setDeltaNat,
- IF_ARCH_powerpc(addImportNat COMMA,)
- ncgPrimopMoan,
- ncg_target_is_32bit
- )
-import Pretty
-import Outputable ( panic, pprPanic, showSDoc )
-import qualified Outputable
-import CmdLineOpts ( opt_Static )
-import Stix ( pprStixStmt )
-
-import Maybe ( fromMaybe )
-
--- DEBUGGING ONLY
-import Outputable ( assertPanic )
-import FastString
-import TRACE ( trace )
-
-infixr 3 `bind`
-\end{code}
-
-@InstrBlock@s are the insn sequences generated by the insn selectors.
-They are really trees of insns to facilitate fast appending, where a
-left-to-right traversal (pre-order?) yields the insns in the correct
-order.
-
-\begin{code}
-type InstrBlock = OrdList Instr
-
-x `bind` f = f x
-
-isLeft (Left _) = True
-isLeft (Right _) = False
-
-unLeft (Left x) = x
-\end{code}
-
-Code extractor for an entire stix tree---stix statement level.
-
-\begin{code}
-stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
-stmtsToInstrs stmts
- = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
- returnNat (concatOL instrss)
-
-
-stmtToInstrs :: StixStmt -> NatM InstrBlock
-stmtToInstrs stmt = case stmt of
- StComment s -> returnNat (unitOL (COMMENT s))
- StSegment seg -> returnNat (unitOL (SEGMENT seg))
-
- StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
- LABEL lab)))
- StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
- returnNat nilOL)
-
- StLabel lab -> returnNat (unitOL (LABEL lab))
-
- StJump dsts arg -> genJump dsts (derefDLL arg)
- StCondJump lab arg -> genCondJump lab (derefDLL arg)
-
- -- A call returning void, ie one done for its side-effects. Note
- -- that this is the only StVoidable we handle.
- StVoidable (StCall fn cconv VoidRep args)
- -> genCCall fn cconv VoidRep (map derefDLL args)
-
- StAssignMem pk addr src
- | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
- | ncg_target_is_32bit
- && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
- | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
- StAssignReg pk reg src
- | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
- | ncg_target_is_32bit
- && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
- | otherwise -> assignReg_IntCode pk reg (derefDLL src)
-
- StFallThrough lbl
- -- When falling through on the Alpha, we still have to load pv
- -- with the address of the next routine, so that it can load gp.
- -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
- ,returnNat nilOL)
-
- StData kind args
- -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
- returnNat (DATA (primRepToSize kind) imms
- `consOL` concatOL codes)
- where
- getData :: StixExpr -> NatM (InstrBlock, Imm)
- getData (StInt i) = returnNat (nilOL, ImmInteger i)
- getData (StDouble d) = returnNat (nilOL, ImmDouble d)
- getData (StFloat d) = returnNat (nilOL, ImmFloat d)
- getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
- getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
- -- the linker can handle simple arithmetic...
- getData (StIndex rep (StCLbl lbl) (StInt off)) =
- returnNat (nilOL,
- ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
-
- -- Top-level lifted-out string. The segment will already have been set
- -- (see Stix.liftStrings).
- StDataString str
- -> returnNat (unitOL (ASCII True (unpackFS str)))
-
-#ifdef DEBUG
- other -> pprPanic "stmtToInstrs" (pprStixStmt other)
-#endif
-
--- Walk a Stix tree, and insert dereferences to CLabels which are marked
--- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
--- not all such CLabel occurrences need this dereferencing -- SRTs don't
--- for one.
-derefDLL :: StixExpr -> StixExpr
-derefDLL tree
- | opt_Static -- short out the entire deal if not doing DLLs
- = tree
- | otherwise
- = qq tree
- where
- qq t
- = case t of
- StCLbl lbl -> if labelDynamic lbl
- then StInd PtrRep (StCLbl lbl)
- else t
- -- all the rest are boring
- StIndex pk base offset -> StIndex pk (qq base) (qq offset)
- StMachOp mop args -> StMachOp mop (map qq args)
- StInd pk addr -> StInd pk (qq addr)
- StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
- StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
- StInt _ -> t
- StFloat _ -> t
- StDouble _ -> t
- StString _ -> t
- StReg _ -> t
- _ -> pprPanic "derefDLL: unhandled case"
- (pprStixExpr t)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{General things for putting together code sequences}
-%* *
-%************************************************************************
-
-\begin{code}
-mangleIndexTree :: StixExpr -> StixExpr
-
-mangleIndexTree (StIndex pk base (StInt i))
- = StMachOp MO_Nat_Add [base, off]
- where
- off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
-
-mangleIndexTree (StIndex pk base off)
- = StMachOp MO_Nat_Add [
- base,
- let s = shift pk
- in if s == 0 then off
- else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
- ]
- where
- shift :: PrimRep -> Int
- shift rep = case getPrimRepSizeInBytes rep of
- 1 -> 0
- 2 -> 1
- 4 -> 2
- 8 -> 3
- other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
- (Outputable.int other)
-\end{code}
-
-\begin{code}
-maybeImm :: StixExpr -> Maybe Imm
-
-maybeImm (StCLbl l)
- = Just (ImmCLbl l)
-maybeImm (StIndex rep (StCLbl l) (StInt off))
- = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
-maybeImm (StInt i)
- | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
- = Just (ImmInt (fromInteger i))
- | otherwise
- = Just (ImmInteger i)
-
-maybeImm _ = Nothing
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @Register64@ type}
-%* *
-%************************************************************************
-
-Simple support for generating 64-bit code (ie, 64 bit values and 64
-bit assignments) on 32-bit platforms. Unlike the main code generator
-we merely shoot for generating working code as simply as possible, and
-pay little attention to code quality. Specifically, there is no
-attempt to deal cleverly with the fixed-vs-floating register
-distinction; all values are generated into (pairs of) floating
-registers, even if this would mean some redundant reg-reg moves as a
-result. Only one of the VRegUniques is returned, since it will be
-of the VRegUniqueLo form, and the upper-half VReg can be determined
-by applying getHiVRegFromLo to it.
-
-\begin{code}
-
-data ChildCode64 -- a.k.a "Register64"
- = ChildCode64
- InstrBlock -- code
- VRegUnique -- unique for the lower 32-bit temporary
- -- which contains the result; use getHiVRegFromLo to find
- -- the other VRegUnique.
- -- Rules of this simplified insn selection game are
- -- therefore that the returned VRegUnique may be modified
-
-assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
-assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
-iselExpr64 :: StixExpr -> NatM ChildCode64
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-assignMem_I64Code addrTree valueTree
- = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
- getRegister addrTree `thenNat` \ register_addr ->
- getNewRegNCG IntRep `thenNat` \ t_addr ->
- let rlo = VirtualRegI vrlo
- rhi = getHiVRegFromLo rlo
- code_addr = registerCode register_addr t_addr
- reg_addr = registerName register_addr t_addr
- -- Little-endian store
- mov_lo = MOV L (OpReg rlo)
- (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
- mov_hi = MOV L (OpReg rhi)
- (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
- in
- returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
-
-assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
- = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
- let
- r_dst_lo = mkVReg u_dst IntRep
- r_src_lo = VirtualRegI vr_src_lo
- r_dst_hi = getHiVRegFromLo r_dst_lo
- r_src_hi = getHiVRegFromLo r_src_lo
- mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
- mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
- in
- returnNat (
- vcode `snocOL` mov_lo `snocOL` mov_hi
- )
-
-assignReg_I64Code lvalue valueTree
- = pprPanic "assignReg_I64Code(i386): invalid lvalue"
- (pprStixReg lvalue)
-
-
-
-iselExpr64 (StInd pk addrTree)
- | is64BitRep pk
- = getRegister addrTree `thenNat` \ register_addr ->
- getNewRegNCG IntRep `thenNat` \ t_addr ->
- getNewRegNCG IntRep `thenNat` \ rlo ->
- let rhi = getHiVRegFromLo rlo
- code_addr = registerCode register_addr t_addr
- reg_addr = registerName register_addr t_addr
- mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
- (OpReg rlo)
- mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
- (OpReg rhi)
- in
- returnNat (
- ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
- (getVRegUnique rlo)
- )
-
-iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
- | is64BitRep pk
- = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
- let r_dst_hi = getHiVRegFromLo r_dst_lo
- r_src_lo = mkVReg vu IntRep
- r_src_hi = getHiVRegFromLo r_src_lo
- mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
- mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
- in
- returnNat (
- ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
- )
-
-iselExpr64 (StCall fn cconv kind args)
- | is64BitRep kind
- = genCCall fn cconv kind args `thenNat` \ call ->
- getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
- let r_dst_hi = getHiVRegFromLo r_dst_lo
- mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
- mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
- in
- returnNat (
- ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
- (getVRegUnique r_dst_lo)
- )
-
-iselExpr64 expr
- = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-assignMem_I64Code addrTree valueTree
- = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
- getRegister addrTree `thenNat` \ register_addr ->
- getNewRegNCG IntRep `thenNat` \ t_addr ->
- let rlo = VirtualRegI vrlo
- rhi = getHiVRegFromLo rlo
- code_addr = registerCode register_addr t_addr
- reg_addr = registerName register_addr t_addr
- -- Big-endian store
- mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
- mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
- in
- returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
-
-
-assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
- = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
- let
- r_dst_lo = mkVReg u_dst IntRep
- r_src_lo = VirtualRegI vr_src_lo
- r_dst_hi = getHiVRegFromLo r_dst_lo
- r_src_hi = getHiVRegFromLo r_src_lo
- mov_lo = mkMOV r_src_lo r_dst_lo
- mov_hi = mkMOV r_src_hi r_dst_hi
- mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
- in
- returnNat (
- vcode `snocOL` mov_hi `snocOL` mov_lo
- )
-assignReg_I64Code lvalue valueTree
- = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
- (pprStixReg lvalue)
-
-
--- Don't delete this -- it's very handy for debugging.
---iselExpr64 expr
--- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
--- = panic "iselExpr64(???)"
-
-iselExpr64 (StInd pk addrTree)
- | is64BitRep pk
- = getRegister addrTree `thenNat` \ register_addr ->
- getNewRegNCG IntRep `thenNat` \ t_addr ->
- getNewRegNCG IntRep `thenNat` \ rlo ->
- let rhi = getHiVRegFromLo rlo
- code_addr = registerCode register_addr t_addr
- reg_addr = registerName register_addr t_addr
- mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
- mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
- in
- returnNat (
- ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
- (getVRegUnique rlo)
- )
-
-iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
- | is64BitRep pk
- = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
- let r_dst_hi = getHiVRegFromLo r_dst_lo
- r_src_lo = mkVReg vu IntRep
- r_src_hi = getHiVRegFromLo r_src_lo
- mov_lo = mkMOV r_src_lo r_dst_lo
- mov_hi = mkMOV r_src_hi r_dst_hi
- mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
- in
- returnNat (
- ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
- )
-
-iselExpr64 (StCall fn cconv kind args)
- | is64BitRep kind
- = genCCall fn cconv kind args `thenNat` \ call ->
- getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
- let r_dst_hi = getHiVRegFromLo r_dst_lo
- mov_lo = mkMOV o0 r_dst_lo
- mov_hi = mkMOV o1 r_dst_hi
- mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
- in
- returnNat (
- ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
- (getVRegUnique r_dst_lo)
- )
-
-iselExpr64 expr
- = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
-
-#endif /* sparc_TARGET_ARCH */
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if powerpc_TARGET_ARCH
-
-assignMem_I64Code addrTree valueTree
- = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
- getRegister addrTree `thenNat` \ register_addr ->
- getNewRegNCG IntRep `thenNat` \ t_addr ->
- let rlo = VirtualRegI vrlo
- rhi = getHiVRegFromLo rlo
- code_addr = registerCode register_addr t_addr
- reg_addr = registerName register_addr t_addr
- -- Big-endian store
- mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
- mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
- in
- returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
-
-
-assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
- = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
- let
- r_dst_lo = mkVReg u_dst IntRep
- r_src_lo = VirtualRegI vr_src_lo
- r_dst_hi = getHiVRegFromLo r_dst_lo
- r_src_hi = getHiVRegFromLo r_src_lo
- mov_lo = MR r_dst_lo r_src_lo
- mov_hi = MR r_dst_hi r_src_hi
- in
- returnNat (
- vcode `snocOL` mov_hi `snocOL` mov_lo
- )
-assignReg_I64Code lvalue valueTree
- = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
- (pprStixReg lvalue)
-
-
--- Don't delete this -- it's very handy for debugging.
---iselExpr64 expr
--- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
--- = panic "iselExpr64(???)"
-
-iselExpr64 (StInd pk addrTree)
- | is64BitRep pk
- = getRegister addrTree `thenNat` \ register_addr ->
- getNewRegNCG IntRep `thenNat` \ t_addr ->
- getNewRegNCG IntRep `thenNat` \ rlo ->
- let rhi = getHiVRegFromLo rlo
- code_addr = registerCode register_addr t_addr
- reg_addr = registerName register_addr t_addr
- mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
- mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
- in
- returnNat (
- ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
- (getVRegUnique rlo)
- )
-
-iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
- | is64BitRep pk
- = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
- let r_dst_hi = getHiVRegFromLo r_dst_lo
- r_src_lo = mkVReg vu IntRep
- r_src_hi = getHiVRegFromLo r_src_lo
- mov_lo = MR r_dst_lo r_src_lo
- mov_hi = MR r_dst_hi r_src_hi
- in
- returnNat (
- ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
- )
-
-iselExpr64 (StCall fn cconv kind args)
- | is64BitRep kind
- = genCCall fn cconv kind args `thenNat` \ call ->
- getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
- let r_dst_hi = getHiVRegFromLo r_dst_lo
- mov_lo = MR r_dst_lo r4
- mov_hi = MR r_dst_hi r3
- in
- returnNat (
- ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
- (getVRegUnique r_dst_lo)
- )
-
-iselExpr64 expr
- = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @Register@ type}
-%* *
-%************************************************************************
-
-@Register@s passed up the tree. If the stix code forces the register
-to live in a pre-decided machine register, it comes out as @Fixed@;
-otherwise, it comes out as @Any@, and the parent can decide which
-register to put it in.
-
-\begin{code}
-data Register
- = Fixed PrimRep Reg InstrBlock
- | Any PrimRep (Reg -> InstrBlock)
-
-registerCode :: Register -> Reg -> InstrBlock
-registerCode (Fixed _ _ code) reg = code
-registerCode (Any _ code) reg = code reg
-
-registerCodeF (Fixed _ _ code) = code
-registerCodeF (Any _ _) = panic "registerCodeF"
-
-registerCodeA (Any _ code) = code
-registerCodeA (Fixed _ _ _) = panic "registerCodeA"
-
-registerName :: Register -> Reg -> Reg
-registerName (Fixed _ reg _) _ = reg
-registerName (Any _ _) reg = reg
-
-registerNameF (Fixed _ reg _) = reg
-registerNameF (Any _ _) = panic "registerNameF"
-
-registerRep :: Register -> PrimRep
-registerRep (Fixed pk _ _) = pk
-registerRep (Any pk _) = pk
-
-swizzleRegisterRep :: Register -> PrimRep -> Register
-swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
-swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
-
-{-# INLINE registerCode #-}
-{-# INLINE registerCodeF #-}
-{-# INLINE registerName #-}
-{-# INLINE registerNameF #-}
-{-# INLINE registerRep #-}
-{-# INLINE isFixed #-}
-{-# INLINE isAny #-}
-
-isFixed, isAny :: Register -> Bool
-isFixed (Fixed _ _ _) = True
-isFixed (Any _ _) = False
-
-isAny = not . isFixed
-\end{code}
-
-Generate code to get a subtree into a @Register@:
-\begin{code}
-
-getRegisterReg :: StixReg -> NatM Register
-getRegister :: StixExpr -> NatM Register
-
-
-getRegisterReg (StixMagicId mid)
- = case get_MagicId_reg_or_addr mid of
- Left (RealReg rrno)
- -> let pk = magicIdPrimRep mid
- in returnNat (Fixed pk (RealReg rrno) nilOL)
- Right baseRegAddr
- -- By this stage, the only MagicIds remaining should be the
- -- ones which map to a real machine register on this platform. Hence ...
- -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
-
-getRegisterReg (StixTemp (StixVReg u pk))
- = returnNat (Fixed pk (mkVReg u pk) nilOL)
-
--------------
-
--- Don't delete this -- it's very handy for debugging.
---getRegister expr
--- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
--- = panic "getRegister(???)"
-
-getRegister (StReg reg)
- = getRegisterReg reg
-
-getRegister tree@(StIndex _ _ _)
- = getRegister (mangleIndexTree tree)
-
-getRegister (StCall fn cconv kind args)
- | not (ncg_target_is_32bit && is64BitRep kind)
- = genCCall fn cconv kind args `thenNat` \ call ->
- returnNat (Fixed kind reg call)
- where
- reg = if isFloatingRep kind
- then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
- else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
-
-getRegister (StString s)
- = getNatLabelNCG `thenNat` \ lbl ->
- let
- imm_lbl = ImmCLbl lbl
-
- code dst = toOL [
- SEGMENT RoDataSegment,
- LABEL lbl,
- ASCII True (unpackFS s),
- SEGMENT TextSegment,
-#if alpha_TARGET_ARCH
- LDA dst (AddrImm imm_lbl)
-#endif
-#if i386_TARGET_ARCH
- MOV L (OpImm imm_lbl) (OpReg dst)
-#endif
-#if sparc_TARGET_ARCH
- SETHI (HI imm_lbl) dst,
- OR False dst (RIImm (LO imm_lbl)) dst
-#endif
-#if powerpc_TARGET_ARCH
- LIS dst (HI imm_lbl),
- OR dst dst (RIImm (LO imm_lbl))
-#endif
- ]
- in
- returnNat (Any PtrRep code)
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
--- end of machine-"independent" bit; here we go on the rest...
-
-#if alpha_TARGET_ARCH
-
-getRegister (StDouble d)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA TF [ImmLab (rational d)],
- SEGMENT TextSegment,
- LDA tmp (AddrImm (ImmCLbl lbl)),
- LD TF dst (AddrReg tmp)]
- in
- returnNat (Any DoubleRep code)
-
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (NEG Q False) x
-
- NotOp -> trivialUCode NOT x
-
- FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
- DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
-
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
-
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP pr x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP pr x
-
- Double2FloatOp -> coerceFltCode x
- Float2DoubleOp -> coerceFltCode x
-
- other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
- where
- fn = case other_op of
- FloatExpOp -> FSLIT("exp")
- FloatLogOp -> FSLIT("log")
- FloatSqrtOp -> FSLIT("sqrt")
- FloatSinOp -> FSLIT("sin")
- FloatCosOp -> FSLIT("cos")
- FloatTanOp -> FSLIT("tan")
- FloatAsinOp -> FSLIT("asin")
- FloatAcosOp -> FSLIT("acos")
- FloatAtanOp -> FSLIT("atan")
- FloatSinhOp -> FSLIT("sinh")
- FloatCoshOp -> FSLIT("cosh")
- FloatTanhOp -> FSLIT("tanh")
- DoubleExpOp -> FSLIT("exp")
- DoubleLogOp -> FSLIT("log")
- DoubleSqrtOp -> FSLIT("sqrt")
- DoubleSinOp -> FSLIT("sin")
- DoubleCosOp -> FSLIT("cos")
- DoubleTanOp -> FSLIT("tan")
- DoubleAsinOp -> FSLIT("asin")
- DoubleAcosOp -> FSLIT("acos")
- DoubleAtanOp -> FSLIT("atan")
- DoubleSinhOp -> FSLIT("sinh")
- DoubleCoshOp -> FSLIT("cosh")
- DoubleTanhOp -> FSLIT("tanh")
- where
- pr = panic "MachCode.getRegister: no primrep needed for Alpha"
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
- = case primop of
- CharGtOp -> trivialCode (CMP LTT) y x
- CharGeOp -> trivialCode (CMP LE) y x
- CharEqOp -> trivialCode (CMP EQQ) x y
- CharNeOp -> int_NE_code x y
- CharLtOp -> trivialCode (CMP LTT) x y
- CharLeOp -> trivialCode (CMP LE) x y
-
- IntGtOp -> trivialCode (CMP LTT) y x
- IntGeOp -> trivialCode (CMP LE) y x
- IntEqOp -> trivialCode (CMP EQQ) x y
- IntNeOp -> int_NE_code x y
- IntLtOp -> trivialCode (CMP LTT) x y
- IntLeOp -> trivialCode (CMP LE) x y
-
- WordGtOp -> trivialCode (CMP ULT) y x
- WordGeOp -> trivialCode (CMP ULE) x y
- WordEqOp -> trivialCode (CMP EQQ) x y
- WordNeOp -> int_NE_code x y
- WordLtOp -> trivialCode (CMP ULT) x y
- WordLeOp -> trivialCode (CMP ULE) x y
-
- AddrGtOp -> trivialCode (CMP ULT) y x
- AddrGeOp -> trivialCode (CMP ULE) y x
- AddrEqOp -> trivialCode (CMP EQQ) x y
- AddrNeOp -> int_NE_code x y
- AddrLtOp -> trivialCode (CMP ULT) x y
- AddrLeOp -> trivialCode (CMP ULE) x y
-
- FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
- FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
- FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
- FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
- FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
- FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
-
- DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
- DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
- DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
- DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
- DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
- DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
-
- IntAddOp -> trivialCode (ADD Q False) x y
- IntSubOp -> trivialCode (SUB Q False) x y
- IntMulOp -> trivialCode (MUL Q False) x y
- IntQuotOp -> trivialCode (DIV Q False) x y
- IntRemOp -> trivialCode (REM Q False) x y
-
- WordAddOp -> trivialCode (ADD Q False) x y
- WordSubOp -> trivialCode (SUB Q False) x y
- WordMulOp -> trivialCode (MUL Q False) x y
- WordQuotOp -> trivialCode (DIV Q True) x y
- WordRemOp -> trivialCode (REM Q True) x y
-
- FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
- FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
- FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
- FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
-
- DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
- DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
- DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
- DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
-
- AddrAddOp -> trivialCode (ADD Q False) x y
- AddrSubOp -> trivialCode (SUB Q False) x y
- AddrRemOp -> trivialCode (REM Q True) x y
-
- AndOp -> trivialCode AND x y
- OrOp -> trivialCode OR x y
- XorOp -> trivialCode XOR x y
- SllOp -> trivialCode SLL x y
- SrlOp -> trivialCode SRL x y
-
- ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
- ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
- ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
-
- FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
- DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
- where
- {- ------------------------------------------------------------
- Some bizarre special code for getting condition codes into
- registers. Integer non-equality is a test for equality
- followed by an XOR with 1. (Integer comparisons always set
- the result register to 0 or 1.) Floating point comparisons of
- any kind leave the result in a floating point register, so we
- need to wrangle an integer register out of things.
- -}
- int_NE_code :: StixTree -> StixTree -> NatM Register
-
- int_NE_code x y
- = trivialCode (CMP EQQ) x y `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
- in
- returnNat (Any IntRep code__2)
-
- {- ------------------------------------------------------------
- Comments for int_NE_code also apply to cmpF_code
- -}
- cmpF_code
- :: (Reg -> Reg -> Reg -> Instr)
- -> Cond
- -> StixTree -> StixTree
- -> NatM Register
-
- cmpF_code instr cond x y
- = trivialFCode pr instr x y `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- getNatLabelNCG `thenNat` \ lbl ->
- let
- code = registerCode register tmp
- result = registerName register tmp
-
- code__2 dst = code . mkSeqInstrs [
- OR zeroh (RIImm (ImmInt 1)) dst,
- BF cond result (ImmCLbl lbl),
- OR zeroh (RIReg zeroh) dst,
- LABEL lbl]
- in
- returnNat (Any IntRep code__2)
- where
- pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
- ------------------------------------------------------------
-
-getRegister (StInd pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code . mkSeqInstr (LD size dst src)
- in
- returnNat (Any pk code__2)
-
-getRegister (StInt i)
- | fits8Bits i
- = let
- code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
- in
- returnNat (Any IntRep code)
- | otherwise
- = let
- code dst = mkSeqInstr (LDI Q dst src)
- in
- returnNat (Any IntRep code)
- where
- src = ImmInt (fromInteger i)
-
-getRegister leaf
- | maybeToBool imm
- = let
- code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
- in
- returnNat (Any PtrRep code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-getRegister (StFloat f)
- = getNatLabelNCG `thenNat` \ lbl ->
- let code dst = toOL [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA F [ImmFloat f],
- SEGMENT TextSegment,
- GLD F (ImmAddr (ImmCLbl lbl) 0) dst
- ]
- in
- returnNat (Any FloatRep code)
-
-
-getRegister (StDouble d)
-
- | d == 0.0
- = let code dst = unitOL (GLDZ dst)
- in returnNat (Any DoubleRep code)
-
- | d == 1.0
- = let code dst = unitOL (GLD1 dst)
- in returnNat (Any DoubleRep code)
-
- | otherwise
- = getNatLabelNCG `thenNat` \ lbl ->
- let code dst = toOL [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA DF [ImmDouble d],
- SEGMENT TextSegment,
- GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
- ]
- in
- returnNat (Any DoubleRep code)
-
-
-getRegister (StMachOp mop [x]) -- unary MachOps
- = case mop of
- MO_NatS_Neg -> trivialUCode (NEGI L) x
- MO_Nat_Not -> trivialUCode (NOT L) x
- MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
-
- MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
- MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
-
- MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
- MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
-
- MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
- MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
-
- MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
- MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
-
- MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
- MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
-
- MO_Flt_to_NatS -> coerceFP2Int FloatRep x
- MO_NatS_to_Flt -> coerceInt2FP FloatRep x
- MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
- MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
-
- -- Conversions which are a nop on x86
- MO_32U_to_NatS -> conversionNop IntRep x
- MO_32S_to_NatS -> conversionNop IntRep x
- MO_NatS_to_32U -> conversionNop WordRep x
- MO_32U_to_NatU -> conversionNop WordRep x
-
- MO_NatU_to_NatS -> conversionNop IntRep x
- MO_NatS_to_NatU -> conversionNop WordRep x
- MO_NatP_to_NatU -> conversionNop WordRep x
- MO_NatU_to_NatP -> conversionNop PtrRep x
- MO_NatS_to_NatP -> conversionNop PtrRep x
- MO_NatP_to_NatS -> conversionNop IntRep x
-
- MO_Dbl_to_Flt -> conversionNop FloatRep x
- MO_Flt_to_Dbl -> conversionNop DoubleRep x
-
- -- sign-extending widenings
- MO_8U_to_NatU -> integerExtend False 24 x
- MO_8S_to_NatS -> integerExtend True 24 x
- MO_16U_to_NatU -> integerExtend False 16 x
- MO_16S_to_NatS -> integerExtend True 16 x
- MO_8U_to_32U -> integerExtend False 24 x
-
- other_op
- -> getRegister (
- (if is_float_op then demote else id)
- (StCall (Left fn) CCallConv DoubleRep
- [(if is_float_op then promote else id) x])
- )
- where
- integerExtend signed nBits x
- = getRegister (
- StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
- [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
- )
-
- conversionNop new_rep expr
- = getRegister expr `thenNat` \ e_code ->
- returnNat (swizzleRegisterRep e_code new_rep)
-
- promote x = StMachOp MO_Flt_to_Dbl [x]
- demote x = StMachOp MO_Dbl_to_Flt [x]
- (is_float_op, fn)
- = case mop of
- MO_Flt_Exp -> (True, FSLIT("exp"))
- MO_Flt_Log -> (True, FSLIT("log"))
-
- MO_Flt_Asin -> (True, FSLIT("asin"))
- MO_Flt_Acos -> (True, FSLIT("acos"))
- MO_Flt_Atan -> (True, FSLIT("atan"))
-
- MO_Flt_Sinh -> (True, FSLIT("sinh"))
- MO_Flt_Cosh -> (True, FSLIT("cosh"))
- MO_Flt_Tanh -> (True, FSLIT("tanh"))
-
- MO_Dbl_Exp -> (False, FSLIT("exp"))
- MO_Dbl_Log -> (False, FSLIT("log"))
-
- MO_Dbl_Asin -> (False, FSLIT("asin"))
- MO_Dbl_Acos -> (False, FSLIT("acos"))
- MO_Dbl_Atan -> (False, FSLIT("atan"))
-
- MO_Dbl_Sinh -> (False, FSLIT("sinh"))
- MO_Dbl_Cosh -> (False, FSLIT("cosh"))
- MO_Dbl_Tanh -> (False, FSLIT("tanh"))
-
- other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
- (pprMachOp mop)
-
-
-getRegister (StMachOp mop [x, y]) -- dyadic MachOps
- = case mop of
- MO_32U_Gt -> condIntReg GTT x y
- MO_32U_Ge -> condIntReg GE x y
- MO_32U_Eq -> condIntReg EQQ x y
- MO_32U_Ne -> condIntReg NE x y
- MO_32U_Lt -> condIntReg LTT x y
- MO_32U_Le -> condIntReg LE x y
-
- MO_Nat_Eq -> condIntReg EQQ x y
- MO_Nat_Ne -> condIntReg NE x y
-
- MO_NatS_Gt -> condIntReg GTT x y
- MO_NatS_Ge -> condIntReg GE x y
- MO_NatS_Lt -> condIntReg LTT x y
- MO_NatS_Le -> condIntReg LE x y
-
- MO_NatU_Gt -> condIntReg GU x y
- MO_NatU_Ge -> condIntReg GEU x y
- MO_NatU_Lt -> condIntReg LU x y
- MO_NatU_Le -> condIntReg LEU x y
-
- MO_Flt_Gt -> condFltReg GTT x y
- MO_Flt_Ge -> condFltReg GE x y
- MO_Flt_Eq -> condFltReg EQQ x y
- MO_Flt_Ne -> condFltReg NE x y
- MO_Flt_Lt -> condFltReg LTT x y
- MO_Flt_Le -> condFltReg LE x y
-
- MO_Dbl_Gt -> condFltReg GTT x y
- MO_Dbl_Ge -> condFltReg GE x y
- MO_Dbl_Eq -> condFltReg EQQ x y
- MO_Dbl_Ne -> condFltReg NE x y
- MO_Dbl_Lt -> condFltReg LTT x y
- MO_Dbl_Le -> condFltReg LE x y
-
- MO_Nat_Add -> add_code L x y
- MO_Nat_Sub -> sub_code L x y
- MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
- MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
- MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
- MO_NatU_Rem -> trivialCode (REM L) Nothing x y
- MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
- MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
- MO_NatS_MulMayOflo -> imulMayOflo x y
-
- MO_Flt_Add -> trivialFCode FloatRep GADD x y
- MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
- MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
- MO_Flt_Div -> trivialFCode FloatRep GDIV x y
-
- MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
- MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
- MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
- MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
-
- MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
- MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
- MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
-
- {- Shift ops on x86s have constraints on their source, it
- either has to be Imm, CL or 1
- => trivialCode's is not restrictive enough (sigh.)
- -}
- MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
- MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
- MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
-
- MO_Flt_Pwr -> getRegister (demote
- (StCall (Left FSLIT("pow")) CCallConv DoubleRep
- [promote x, promote y])
- )
- MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
- [x, y])
- other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
- where
- promote x = StMachOp MO_Flt_to_Dbl [x]
- demote x = StMachOp MO_Dbl_to_Flt [x]
-
- --------------------
- imulMayOflo :: StixExpr -> StixExpr -> NatM Register
- imulMayOflo a1 a2
- = getNewRegNCG IntRep `thenNat` \ t1 ->
- getNewRegNCG IntRep `thenNat` \ t2 ->
- getNewRegNCG IntRep `thenNat` \ res_lo ->
- getNewRegNCG IntRep `thenNat` \ res_hi ->
- getRegister a1 `thenNat` \ reg1 ->
- getRegister a2 `thenNat` \ reg2 ->
- let code1 = registerCode reg1 t1
- code2 = registerCode reg2 t2
- src1 = registerName reg1 t1
- src2 = registerName reg2 t2
- code dst = code1 `appOL` code2 `appOL`
- toOL [
- MOV L (OpReg src1) (OpReg res_hi),
- MOV L (OpReg src2) (OpReg res_lo),
- IMUL64 res_hi res_lo, -- result in res_hi:res_lo
- SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
- SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
- MOV L (OpReg res_lo) (OpReg dst)
- -- dst==0 if high part == sign extended low part
- ]
- in
- returnNat (Any IntRep code)
-
- --------------------
- shift_code :: (Imm -> Operand -> Instr)
- -> StixExpr
- -> StixExpr
- -> NatM Register
-
- {- Case1: shift length as immediate -}
- -- Code is the same as the first eq. for trivialCode -- sigh.
- shift_code instr x y{-amount-}
- | maybeToBool imm
- = getRegister x `thenNat` \ regx ->
- let mkcode dst
- = if isAny regx
- then registerCodeA regx dst `bind` \ code_x ->
- code_x `snocOL`
- instr imm__2 (OpReg dst)
- else registerCodeF regx `bind` \ code_x ->
- registerNameF regx `bind` \ r_x ->
- code_x `snocOL`
- MOV L (OpReg r_x) (OpReg dst) `snocOL`
- instr imm__2 (OpReg dst)
- in
- returnNat (Any IntRep mkcode)
- where
- imm = maybeImm y
- imm__2 = case imm of Just x -> x
-
- {- Case2: shift length is complex (non-immediate) -}
- -- Since ECX is always used as a spill temporary, we can't
- -- use it here to do non-immediate shifts. No big deal --
- -- they are only very rare, and we can use an equivalent
- -- test-and-jump sequence which doesn't use ECX.
- -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
- -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
- shift_code instr x y{-amount-}
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNatLabelNCG `thenNat` \ lbl_test3 ->
- getNatLabelNCG `thenNat` \ lbl_test2 ->
- getNatLabelNCG `thenNat` \ lbl_test1 ->
- getNatLabelNCG `thenNat` \ lbl_test0 ->
- getNatLabelNCG `thenNat` \ lbl_after ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let code__2 dst
- = let src_val = registerName register1 dst
- code_val = registerCode register1 dst
- src_amt = registerName register2 tmp
- code_amt = registerCode register2 tmp
- r_dst = OpReg dst
- r_tmp = OpReg tmp
- in
- code_amt `snocOL`
- MOV L (OpReg src_amt) r_tmp `appOL`
- code_val `snocOL`
- MOV L (OpReg src_val) r_dst `appOL`
- toOL [
- COMMENT (mkFastString "begin shift sequence"),
- MOV L (OpReg src_val) r_dst,
- MOV L (OpReg src_amt) r_tmp,
-
- BT L (ImmInt 4) r_tmp,
- JXX GEU lbl_test3,
- instr (ImmInt 16) r_dst,
-
- LABEL lbl_test3,
- BT L (ImmInt 3) r_tmp,
- JXX GEU lbl_test2,
- instr (ImmInt 8) r_dst,
-
- LABEL lbl_test2,
- BT L (ImmInt 2) r_tmp,
- JXX GEU lbl_test1,
- instr (ImmInt 4) r_dst,
-
- LABEL lbl_test1,
- BT L (ImmInt 1) r_tmp,
- JXX GEU lbl_test0,
- instr (ImmInt 2) r_dst,
-
- LABEL lbl_test0,
- BT L (ImmInt 0) r_tmp,
- JXX GEU lbl_after,
- instr (ImmInt 1) r_dst,
- LABEL lbl_after,
-
- COMMENT (mkFastString "end shift sequence")
- ]
- in
- returnNat (Any IntRep code__2)
-
- --------------------
- add_code :: Size -> StixExpr -> StixExpr -> NatM Register
-
- add_code sz x (StInt y)
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 dst
- = code `snocOL`
- LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
- (OpReg dst)
- in
- returnNat (Any IntRep code__2)
-
- add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
-
- --------------------
- sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
-
- sub_code sz x (StInt y)
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (-(fromInteger y))
- code__2 dst
- = code `snocOL`
- LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
- (OpReg dst)
- in
- returnNat (Any IntRep code__2)
-
- sub_code sz x y = trivialCode (SUB sz) Nothing x y
-
-getRegister (StInd pk mem)
- | not (is64BitRep pk)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code `snocOL`
- if pk == DoubleRep || pk == FloatRep
- then GLD size src dst
- else (case size of
- B -> MOVSxL B
- Bu -> MOVZxL Bu
- W -> MOVSxL W
- Wu -> MOVZxL Wu
- L -> MOV L
- Lu -> MOV L)
- (OpAddr src) (OpReg dst)
- in
- returnNat (Any pk code__2)
-
-getRegister (StInt i)
- = let
- src = ImmInt (fromInteger i)
- code dst
- | i == 0
- = unitOL (XOR L (OpReg dst) (OpReg dst))
- | otherwise
- = unitOL (MOV L (OpImm src) (OpReg dst))
- in
- returnNat (Any IntRep code)
-
-getRegister leaf
- | maybeToBool imm
- = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
- in
- returnNat (Any PtrRep code)
- | otherwise
- = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-getRegister (StFloat d)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = toOL [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA F [ImmFloat d],
- SEGMENT TextSegment,
- SETHI (HI (ImmCLbl lbl)) tmp,
- LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
- in
- returnNat (Any FloatRep code)
-
-getRegister (StDouble d)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = toOL [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA DF [ImmDouble d],
- SEGMENT TextSegment,
- SETHI (HI (ImmCLbl lbl)) tmp,
- LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
- in
- returnNat (Any DoubleRep code)
-
-
-getRegister (StMachOp mop [x]) -- unary PrimOps
- = case mop of
- MO_NatS_Neg -> trivialUCode (SUB False False g0) x
- MO_Nat_Not -> trivialUCode (XNOR False g0) x
- MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
-
- MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
- MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
-
- MO_Dbl_to_Flt -> coerceDbl2Flt x
- MO_Flt_to_Dbl -> coerceFlt2Dbl x
-
- MO_Flt_to_NatS -> coerceFP2Int FloatRep x
- MO_NatS_to_Flt -> coerceInt2FP FloatRep x
- MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
- MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
-
- -- Conversions which are a nop on sparc
- MO_32U_to_NatS -> conversionNop IntRep x
- MO_32S_to_NatS -> conversionNop IntRep x
- MO_NatS_to_32U -> conversionNop WordRep x
- MO_32U_to_NatU -> conversionNop WordRep x
-
- MO_NatU_to_NatS -> conversionNop IntRep x
- MO_NatS_to_NatU -> conversionNop WordRep x
- MO_NatP_to_NatU -> conversionNop WordRep x
- MO_NatU_to_NatP -> conversionNop PtrRep x
- MO_NatS_to_NatP -> conversionNop PtrRep x
- MO_NatP_to_NatS -> conversionNop IntRep x
-
- -- sign-extending widenings
- MO_8U_to_32U -> integerExtend False 24 x
- MO_8U_to_NatU -> integerExtend False 24 x
- MO_8S_to_NatS -> integerExtend True 24 x
- MO_16U_to_NatU -> integerExtend False 16 x
- MO_16S_to_NatS -> integerExtend True 16 x
-
- other_op ->
- let fixed_x = if is_float_op -- promote to double
- then StMachOp MO_Flt_to_Dbl [x]
- else x
- in
- getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
- where
- integerExtend signed nBits x
- = getRegister (
- StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
- [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
- )
- conversionNop new_rep expr
- = getRegister expr `thenNat` \ e_code ->
- returnNat (swizzleRegisterRep e_code new_rep)
-
- (is_float_op, fn)
- = case mop of
- MO_Flt_Exp -> (True, FSLIT("exp"))
- MO_Flt_Log -> (True, FSLIT("log"))
- MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
-
- MO_Flt_Sin -> (True, FSLIT("sin"))
- MO_Flt_Cos -> (True, FSLIT("cos"))
- MO_Flt_Tan -> (True, FSLIT("tan"))
-
- MO_Flt_Asin -> (True, FSLIT("asin"))
- MO_Flt_Acos -> (True, FSLIT("acos"))
- MO_Flt_Atan -> (True, FSLIT("atan"))
-
- MO_Flt_Sinh -> (True, FSLIT("sinh"))
- MO_Flt_Cosh -> (True, FSLIT("cosh"))
- MO_Flt_Tanh -> (True, FSLIT("tanh"))
-
- MO_Dbl_Exp -> (False, FSLIT("exp"))
- MO_Dbl_Log -> (False, FSLIT("log"))
- MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
-
- MO_Dbl_Sin -> (False, FSLIT("sin"))
- MO_Dbl_Cos -> (False, FSLIT("cos"))
- MO_Dbl_Tan -> (False, FSLIT("tan"))
-
- MO_Dbl_Asin -> (False, FSLIT("asin"))
- MO_Dbl_Acos -> (False, FSLIT("acos"))
- MO_Dbl_Atan -> (False, FSLIT("atan"))
-
- MO_Dbl_Sinh -> (False, FSLIT("sinh"))
- MO_Dbl_Cosh -> (False, FSLIT("cosh"))
- MO_Dbl_Tanh -> (False, FSLIT("tanh"))
-
- other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
- (pprMachOp mop)
-
-
-getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
- = case mop of
- MO_32U_Gt -> condIntReg GTT x y
- MO_32U_Ge -> condIntReg GE x y
- MO_32U_Eq -> condIntReg EQQ x y
- MO_32U_Ne -> condIntReg NE x y
- MO_32U_Lt -> condIntReg LTT x y
- MO_32U_Le -> condIntReg LE x y
-
- MO_Nat_Eq -> condIntReg EQQ x y
- MO_Nat_Ne -> condIntReg NE x y
-
- MO_NatS_Gt -> condIntReg GTT x y
- MO_NatS_Ge -> condIntReg GE x y
- MO_NatS_Lt -> condIntReg LTT x y
- MO_NatS_Le -> condIntReg LE x y
-
- MO_NatU_Gt -> condIntReg GU x y
- MO_NatU_Ge -> condIntReg GEU x y
- MO_NatU_Lt -> condIntReg LU x y
- MO_NatU_Le -> condIntReg LEU x y
-
- MO_Flt_Gt -> condFltReg GTT x y
- MO_Flt_Ge -> condFltReg GE x y
- MO_Flt_Eq -> condFltReg EQQ x y
- MO_Flt_Ne -> condFltReg NE x y
- MO_Flt_Lt -> condFltReg LTT x y
- MO_Flt_Le -> condFltReg LE x y
-
- MO_Dbl_Gt -> condFltReg GTT x y
- MO_Dbl_Ge -> condFltReg GE x y
- MO_Dbl_Eq -> condFltReg EQQ x y
- MO_Dbl_Ne -> condFltReg NE x y
- MO_Dbl_Lt -> condFltReg LTT x y
- MO_Dbl_Le -> condFltReg LE x y
-
- MO_Nat_Add -> trivialCode (ADD False False) x y
- MO_Nat_Sub -> trivialCode (SUB False False) x y
-
- MO_NatS_Mul -> trivialCode (SMUL False) x y
- MO_NatU_Mul -> trivialCode (UMUL False) x y
- MO_NatS_MulMayOflo -> imulMayOflo x y
-
- -- ToDo: teach about V8+ SPARC div instructions
- MO_NatS_Quot -> idiv FSLIT(".div") x y
- MO_NatS_Rem -> idiv FSLIT(".rem") x y
- MO_NatU_Quot -> idiv FSLIT(".udiv") x y
- MO_NatU_Rem -> idiv FSLIT(".urem") x y
-
- MO_Flt_Add -> trivialFCode FloatRep FADD x y
- MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
- MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
- MO_Flt_Div -> trivialFCode FloatRep FDIV x y
-
- MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
- MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
- MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
- MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
-
- MO_Nat_And -> trivialCode (AND False) x y
- MO_Nat_Or -> trivialCode (OR False) x y
- MO_Nat_Xor -> trivialCode (XOR False) x y
-
- MO_Nat_Shl -> trivialCode SLL x y
- MO_Nat_Shr -> trivialCode SRL x y
- MO_Nat_Sar -> trivialCode SRA x y
-
- MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
- [promote x, promote y])
- where promote x = StMachOp MO_Flt_to_Dbl [x]
- MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
- [x, y])
-
- other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
- where
- idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
-
- --------------------
- imulMayOflo :: StixExpr -> StixExpr -> NatM Register
- imulMayOflo a1 a2
- = getNewRegNCG IntRep `thenNat` \ t1 ->
- getNewRegNCG IntRep `thenNat` \ t2 ->
- getNewRegNCG IntRep `thenNat` \ res_lo ->
- getNewRegNCG IntRep `thenNat` \ res_hi ->
- getRegister a1 `thenNat` \ reg1 ->
- getRegister a2 `thenNat` \ reg2 ->
- let code1 = registerCode reg1 t1
- code2 = registerCode reg2 t2
- src1 = registerName reg1 t1
- src2 = registerName reg2 t2
- code dst = code1 `appOL` code2 `appOL`
- toOL [
- SMUL False src1 (RIReg src2) res_lo,
- RDY res_hi,
- SRA res_lo (RIImm (ImmInt 31)) res_lo,
- SUB False False res_lo (RIReg res_hi) dst
- ]
- in
- returnNat (Any IntRep code)
-
-getRegister (StInd pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code `snocOL` LD size src dst
- in
- returnNat (Any pk code__2)
-
-getRegister (StInt i)
- | fits13Bits i
- = let
- src = ImmInt (fromInteger i)
- code dst = unitOL (OR False g0 (RIImm src) dst)
- in
- returnNat (Any IntRep code)
-
-getRegister leaf
- | maybeToBool imm
- = let
- code dst = toOL [
- SETHI (HI imm__2) dst,
- OR False dst (RIImm (LO imm__2)) dst]
- in
- returnNat (Any PtrRep code)
- | otherwise
- = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-getRegister (StMachOp mop [x]) -- unary MachOps
- = case mop of
- MO_NatS_Neg -> trivialUCode NEG x
- MO_Nat_Not -> trivialUCode NOT x
- MO_32U_to_8U -> trivialCode AND x (StInt 255)
-
- MO_Flt_to_NatS -> coerceFP2Int FloatRep x
- MO_NatS_to_Flt -> coerceInt2FP FloatRep x
- MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
- MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
-
- -- Conversions which are a nop on PPC
- MO_NatS_to_32U -> conversionNop WordRep x
- MO_32U_to_NatS -> conversionNop IntRep x
- MO_32U_to_NatU -> conversionNop WordRep x
-
- MO_NatU_to_NatS -> conversionNop IntRep x
- MO_NatS_to_NatU -> conversionNop WordRep x
- MO_NatP_to_NatU -> conversionNop WordRep x
- MO_NatU_to_NatP -> conversionNop PtrRep x
- MO_NatS_to_NatP -> conversionNop PtrRep x
- MO_NatP_to_NatS -> conversionNop IntRep x
-
- MO_Dbl_to_Flt -> conversionNop FloatRep x
- MO_Flt_to_Dbl -> conversionNop DoubleRep x
-
- -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
- MO_8U_to_NatU -> integerExtend False 24 x
- MO_8S_to_NatS -> integerExtend True 24 x
- MO_16U_to_NatU -> integerExtend False 16 x
- MO_16S_to_NatS -> integerExtend True 16 x
- MO_8U_to_32U -> integerExtend False 24 x
-
- MO_Flt_Neg -> trivialUFCode FloatRep FNEG x
- MO_Dbl_Neg -> trivialUFCode FloatRep FNEG x
-
- other_op -> getRegister (StCall (Left fn) CCallConv DoubleRep [x])
- where
- integerExtend signed nBits x
- = getRegister (
- StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
- [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
- )
- conversionNop new_rep expr
- = getRegister expr `thenNat` \ e_code ->
- returnNat (swizzleRegisterRep e_code new_rep)
-
- (is_float_op, fn)
- = case mop of
- MO_Flt_Exp -> (True, FSLIT("exp"))
- MO_Flt_Log -> (True, FSLIT("log"))
- MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
-
- MO_Flt_Sin -> (True, FSLIT("sin"))
- MO_Flt_Cos -> (True, FSLIT("cos"))
- MO_Flt_Tan -> (True, FSLIT("tan"))
-
- MO_Flt_Asin -> (True, FSLIT("asin"))
- MO_Flt_Acos -> (True, FSLIT("acos"))
- MO_Flt_Atan -> (True, FSLIT("atan"))
-
- MO_Flt_Sinh -> (True, FSLIT("sinh"))
- MO_Flt_Cosh -> (True, FSLIT("cosh"))
- MO_Flt_Tanh -> (True, FSLIT("tanh"))
-
- MO_Dbl_Exp -> (False, FSLIT("exp"))
- MO_Dbl_Log -> (False, FSLIT("log"))
- MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
-
- MO_Dbl_Sin -> (False, FSLIT("sin"))
- MO_Dbl_Cos -> (False, FSLIT("cos"))
- MO_Dbl_Tan -> (False, FSLIT("tan"))
-
- MO_Dbl_Asin -> (False, FSLIT("asin"))
- MO_Dbl_Acos -> (False, FSLIT("acos"))
- MO_Dbl_Atan -> (False, FSLIT("atan"))
-
- MO_Dbl_Sinh -> (False, FSLIT("sinh"))
- MO_Dbl_Cosh -> (False, FSLIT("cosh"))
- MO_Dbl_Tanh -> (False, FSLIT("tanh"))
-
- other -> pprPanic "getRegister(powerpc) - unary StMachOp"
- (pprMachOp mop)
-
-
-getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
- = case mop of
- MO_32U_Gt -> condIntReg GTT x y
- MO_32U_Ge -> condIntReg GE x y
- MO_32U_Eq -> condIntReg EQQ x y
- MO_32U_Ne -> condIntReg NE x y
- MO_32U_Lt -> condIntReg LTT x y
- MO_32U_Le -> condIntReg LE x y
-
- MO_Nat_Eq -> condIntReg EQQ x y
- MO_Nat_Ne -> condIntReg NE x y
-
- MO_NatS_Gt -> condIntReg GTT x y
- MO_NatS_Ge -> condIntReg GE x y
- MO_NatS_Lt -> condIntReg LTT x y
- MO_NatS_Le -> condIntReg LE x y
-
- MO_NatU_Gt -> condIntReg GU x y
- MO_NatU_Ge -> condIntReg GEU x y
- MO_NatU_Lt -> condIntReg LU x y
- MO_NatU_Le -> condIntReg LEU x y
-
- MO_Flt_Gt -> condFltReg GTT x y
- MO_Flt_Ge -> condFltReg GE x y
- MO_Flt_Eq -> condFltReg EQQ x y
- MO_Flt_Ne -> condFltReg NE x y
- MO_Flt_Lt -> condFltReg LTT x y
- MO_Flt_Le -> condFltReg LE x y
-
- MO_Dbl_Gt -> condFltReg GTT x y
- MO_Dbl_Ge -> condFltReg GE x y
- MO_Dbl_Eq -> condFltReg EQQ x y
- MO_Dbl_Ne -> condFltReg NE x y
- MO_Dbl_Lt -> condFltReg LTT x y
- MO_Dbl_Le -> condFltReg LE x y
-
- MO_Nat_Add -> trivialCode ADD x y
- MO_Nat_Sub -> fromMaybe (trivialCode2 SUBF y x) $
- case y of -- subfi ('substract from' with immediate) doesn't exist
- StInt imm -> if fits16Bits imm && imm /= (-32768)
- then Just $ trivialCode ADD x (StInt (-imm))
- else Nothing
- _ -> Nothing
-
- MO_NatS_Mul -> trivialCode MULLW x y
- MO_NatU_Mul -> trivialCode MULLW x y
- -- MO_NatS_MulMayOflo ->
-
- MO_NatS_Quot -> trivialCode2 DIVW x y
- MO_NatU_Quot -> trivialCode2 DIVWU x y
-
- MO_NatS_Rem -> remainderCode DIVW x y
- MO_NatU_Rem -> remainderCode DIVWU x y
-
- MO_Nat_And -> trivialCode AND x y
- MO_Nat_Or -> trivialCode OR x y
- MO_Nat_Xor -> trivialCode XOR x y
-
- MO_Nat_Shl -> trivialCode SLW x y
- MO_Nat_Shr -> trivialCode SRW x y
- MO_Nat_Sar -> trivialCode SRAW x y
-
- MO_Flt_Add -> trivialFCode FloatRep FADD x y
- MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
- MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
- MO_Flt_Div -> trivialFCode FloatRep FDIV x y
-
- MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
- MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
- MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
- MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
-
- MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
- [x, y])
- MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
- [x, y])
-
- other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
-
-getRegister (StInd pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code `snocOL` LD size dst src
- in
- returnNat (Any pk code__2)
-
-getRegister (StInt i)
- | fits16Bits i
- = let
- src = ImmInt (fromInteger i)
- code dst = unitOL (LI dst src)
- in
- returnNat (Any IntRep code)
-
-getRegister (StFloat d)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = toOL [
- SEGMENT RoDataSegment,
- LABEL lbl,
- DATA F [ImmFloat d],
- SEGMENT TextSegment,
- LIS tmp (HA (ImmCLbl lbl)),
- LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
- in
- returnNat (Any FloatRep code)
-
-getRegister (StDouble d)
- = getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let code dst = toOL [
- SEGMENT RoDataSegment,
- LABEL lbl,
- DATA DF [ImmDouble d],
- SEGMENT TextSegment,
- LIS tmp (HA (ImmCLbl lbl)),
- LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
- in
- returnNat (Any DoubleRep code)
-
-getRegister leaf
- | maybeToBool imm
- = let
- code dst = toOL [
- LIS dst (HI imm__2),
- OR dst dst (RIImm (LO imm__2))]
- in
- returnNat (Any PtrRep code)
- | otherwise
- = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @Amode@ type}
-%* *
-%************************************************************************
-
-@Amode@s: Memory addressing modes passed up the tree.
-\begin{code}
-data Amode = Amode MachRegsAddr InstrBlock
-
-amodeAddr (Amode addr _) = addr
-amodeCode (Amode _ code) = code
-\end{code}
-
-Now, given a tree (the argument to an StInd) that references memory,
-produce a suitable addressing mode.
-
-A Rule of the Game (tm) for Amodes: use of the addr bit must
-immediately follow use of the code part, since the code part puts
-values in registers which the addr then refers to. So you can't put
-anything in between, lest it overwrite some of those registers. If
-you need to do some other computation between the code part and use of
-the addr bit, first store the effective address from the amode in a
-temporary, then do the other computation, and then use the temporary:
-
- code
- LEA amode, tmp
- ... other computation ...
- ... (tmp) ...
-
-\begin{code}
-getAmode :: StixExpr -> NatM Amode
-
-getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-getAmode (StPrim IntSubOp [x, StInt i])
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-getAmode (StPrim IntAddOp [x, StInt i])
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
- | maybeToBool imm
- = returnNat (Amode (AddrImm imm__2) id)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- in
- returnNat (Amode (AddrReg reg) code)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
--- This is all just ridiculous, since it carefully undoes
--- what mangleIndexTree has just done.
-getAmode (StMachOp MO_Nat_Sub [x, StInt i])
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-
-getAmode (StMachOp MO_Nat_Add [x, StInt i])
- | maybeToBool imm
- = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
- where
- imm = maybeImm x
- imm__2 = case imm of Just x -> x
-
-getAmode (StMachOp MO_Nat_Add [x, StInt i])
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-
-getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
- | shift == 0 || shift == 1 || shift == 2 || shift == 3
- = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- let
- code1 = registerCode register1 tmp1
- reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- reg2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2
- base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
- in
- returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
- code__2)
-
-getAmode leaf
- | maybeToBool imm
- = returnNat (Amode (ImmAddr imm__2 0) nilOL)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- in
- returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-getAmode (StMachOp MO_Nat_Sub [x, StInt i])
- | fits13Bits (-i)
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-
-getAmode (StMachOp MO_Nat_Add [x, StInt i])
- | fits13Bits i
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-getAmode (StMachOp MO_Nat_Add [x, y])
- = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- let
- code1 = registerCode register1 tmp1
- reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- reg2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2
- in
- returnNat (Amode (AddrRegReg reg1 reg2) code__2)
-
-getAmode leaf
- | maybeToBool imm
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = unitOL (SETHI (HI imm__2) tmp)
- in
- returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt 0
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-#endif /* sparc_TARGET_ARCH */
-
-#ifdef powerpc_TARGET_ARCH
-getAmode (StMachOp MO_Nat_Sub [x, StInt i])
- | fits16Bits (-i)
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-
-getAmode (StMachOp MO_Nat_Add [x, StInt i])
- | fits16Bits i
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnNat (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
- | maybeToBool imm
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = unitOL (LIS tmp (HA imm__2))
- in
- returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt 0
- in
- returnNat (Amode (AddrRegImm reg off) code)
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @CondCode@ type}
-%* *
-%************************************************************************
-
-Condition codes passed up the tree.
-\begin{code}
-data CondCode = CondCode Bool Cond InstrBlock
-
-condName (CondCode _ cond _) = cond
-condFloat (CondCode is_float _ _) = is_float
-condCode (CondCode _ _ code) = code
-\end{code}
-
-Set up a condition code for a conditional branch.
-
-\begin{code}
-getCondCode :: StixExpr -> NatM CondCode
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-getCondCode = panic "MachCode.getCondCode: not on Alphas"
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
--- yes, they really do seem to want exactly the same!
-
-getCondCode (StMachOp mop [x, y])
- = case mop of
- MO_32U_Gt -> condIntCode GTT x y
- MO_32U_Ge -> condIntCode GE x y
- MO_32U_Eq -> condIntCode EQQ x y
- MO_32U_Ne -> condIntCode NE x y
- MO_32U_Lt -> condIntCode LTT x y
- MO_32U_Le -> condIntCode LE x y
-
- MO_Nat_Eq -> condIntCode EQQ x y
- MO_Nat_Ne -> condIntCode NE x y
-
- MO_NatS_Gt -> condIntCode GTT x y
- MO_NatS_Ge -> condIntCode GE x y
- MO_NatS_Lt -> condIntCode LTT x y
- MO_NatS_Le -> condIntCode LE x y
-
- MO_NatU_Gt -> condIntCode GU x y
- MO_NatU_Ge -> condIntCode GEU x y
- MO_NatU_Lt -> condIntCode LU x y
- MO_NatU_Le -> condIntCode LEU x y
-
- MO_Flt_Gt -> condFltCode GTT x y
- MO_Flt_Ge -> condFltCode GE x y
- MO_Flt_Eq -> condFltCode EQQ x y
- MO_Flt_Ne -> condFltCode NE x y
- MO_Flt_Lt -> condFltCode LTT x y
- MO_Flt_Le -> condFltCode LE x y
-
- MO_Dbl_Gt -> condFltCode GTT x y
- MO_Dbl_Ge -> condFltCode GE x y
- MO_Dbl_Eq -> condFltCode EQQ x y
- MO_Dbl_Ne -> condFltCode NE x y
- MO_Dbl_Lt -> condFltCode LTT x y
- MO_Dbl_Le -> condFltCode LE x y
-
- other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
-
-getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
-
-#endif /* i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH */
-
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-% -----------------
-
-@cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
-passed back up the tree.
-
-\begin{code}
-condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
-
-#if alpha_TARGET_ARCH
-condIntCode = panic "MachCode.condIntCode: not on Alphas"
-condFltCode = panic "MachCode.condFltCode: not on Alphas"
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
--- memory vs immediate
-condIntCode cond (StInd pk x) y
- | Just i <- maybeImm y
- = getAmode x `thenNat` \ amode ->
- let
- code1 = amodeCode amode
- x__2 = amodeAddr amode
- sz = primRepToSize pk
- code__2 = code1 `snocOL`
- CMP sz (OpImm i) (OpAddr x__2)
- in
- returnNat (CondCode False cond code__2)
-
--- anything vs zero
-condIntCode cond x (StInt 0)
- = getRegister x `thenNat` \ register1 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code__2 = code1 `snocOL`
- TEST L (OpReg src1) (OpReg src1)
- in
- returnNat (CondCode False cond code__2)
-
--- anything vs immediate
-condIntCode cond x y
- | Just i <- maybeImm y
- = getRegister x `thenNat` \ register1 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code__2 = code1 `snocOL`
- CMP L (OpImm i) (OpReg src1)
- in
- returnNat (CondCode False cond code__2)
-
--- memory vs anything
-condIntCode cond (StInd pk x) y
- = getAmode x `thenNat` \ amode_x ->
- getRegister y `thenNat` \ reg_y ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- c_x = amodeCode amode_x
- am_x = amodeAddr amode_x
- c_y = registerCode reg_y tmp
- r_y = registerName reg_y tmp
- sz = primRepToSize pk
-
- -- optimisation: if there's no code for x, just an amode,
- -- use whatever reg y winds up in. Assumes that c_y doesn't
- -- clobber any regs in the amode am_x, which I'm not sure is
- -- justified. The otherwise clause makes the same assumption.
- code__2 | isNilOL c_x
- = c_y `snocOL`
- CMP sz (OpReg r_y) (OpAddr am_x)
-
- | otherwise
- = c_y `snocOL`
- MOV L (OpReg r_y) (OpReg tmp) `appOL`
- c_x `snocOL`
- CMP sz (OpReg tmp) (OpAddr am_x)
- in
- returnNat (CondCode False cond code__2)
-
--- anything vs memory
---
-condIntCode cond y (StInd pk x)
- = getAmode x `thenNat` \ amode_x ->
- getRegister y `thenNat` \ reg_y ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- c_x = amodeCode amode_x
- am_x = amodeAddr amode_x
- c_y = registerCode reg_y tmp
- r_y = registerName reg_y tmp
- sz = primRepToSize pk
- -- same optimisation and nagging doubts as previous clause
- code__2 | isNilOL c_x
- = c_y `snocOL`
- CMP sz (OpAddr am_x) (OpReg r_y)
-
- | otherwise
- = c_y `snocOL`
- MOV L (OpReg r_y) (OpReg tmp) `appOL`
- c_x `snocOL`
- CMP sz (OpAddr am_x) (OpReg tmp)
- in
- returnNat (CondCode False cond code__2)
-
--- anything vs anything
-condIntCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 = code1 `snocOL`
- MOV L (OpReg src1) (OpReg tmp1) `appOL`
- code2 `snocOL`
- CMP L (OpReg src2) (OpReg tmp1)
- in
- returnNat (CondCode False cond code__2)
-
------------
-condFltCode cond x y
- = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
- getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 | isAny register1
- = code1 `appOL` -- result in tmp1
- code2 `snocOL`
- GCMP cond tmp1 src2
-
- | otherwise
- = code1 `snocOL`
- GMOV src1 tmp1 `appOL`
- code2 `snocOL`
- GCMP cond tmp1 src2
- in
- -- The GCMP insn does the test and sets the zero flag if comparable
- -- and true. Hence we always supply EQQ as the condition to test.
- returnNat (CondCode True EQQ code__2)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-condIntCode cond x (StInt y)
- | fits13Bits y
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
- in
- returnNat (CondCode False cond code__2)
-
-condIntCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2 `snocOL`
- SUB False True src1 (RIReg src2) g0
- in
- returnNat (CondCode False cond code__2)
-
------------
-condFltCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- promote x = FxTOy F DF x tmp
-
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- pk2 = registerRep register2
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 =
- if pk1 == pk2 then
- code1 `appOL` code2 `snocOL`
- FCMP True (primRepToSize pk1) src1 src2
- else if pk1 == FloatRep then
- code1 `snocOL` promote src1 `appOL` code2 `snocOL`
- FCMP True DF tmp src2
- else
- code1 `appOL` code2 `snocOL` promote src2 `snocOL`
- FCMP True DF src1 tmp
- in
- returnNat (CondCode True cond code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-condIntCode cond x (StInt y)
- | fits16Bits y
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 = code `snocOL`
- (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
- in
- returnNat (CondCode False cond code__2)
-
-condIntCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2 `snocOL`
- (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
- in
- returnNat (CondCode False cond code__2)
-
-condFltCode cond x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 = code1 `appOL` code2 `snocOL`
- FCMP src1 src2
- in
- returnNat (CondCode False cond code__2)
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating assignments}
-%* *
-%************************************************************************
-
-Assignments are really at the heart of the whole code generation
-business. Almost all top-level nodes of any real importance are
-assignments, which correspond to loads, stores, or register transfers.
-If we're really lucky, some of the register transfers will go away,
-because we can use the destination register to complete the code
-generation for the right hand side. This only fails when the right
-hand side is forced into a fixed register (e.g. the result of a call).
-
-\begin{code}
-assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
-assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
-
-assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
-assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-assignIntCode pk (StInd _ dst) src
- = getNewRegNCG IntRep `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode []
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- returnNat code__2
-
-assignIntCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- dst__2 = registerName register1 zeroh
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
- else code
- in
- returnNat code__2
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
--- non-FP assignment to memory
-assignMem_IntCode pk addr src
- = getAmode addr `thenNat` \ amode ->
- get_op_RI src `thenNat` \ (codesrc, opsrc) ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- -- In general, if the address computation for dst may require
- -- some insns preceding the addressing mode itself. So there's
- -- no guarantee that the code for dst and the code for src won't
- -- write the same register. This means either the address or
- -- the value needs to be copied into a temporary. We detect the
- -- common case where the amode has no code, and elide the copy.
- codea = amodeCode amode
- dst__a = amodeAddr amode
-
- code | isNilOL codea
- = codesrc `snocOL`
- MOV (primRepToSize pk) opsrc (OpAddr dst__a)
- | otherwise
- = codea `snocOL`
- LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
- codesrc `snocOL`
- MOV (primRepToSize pk) opsrc
- (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
- in
- returnNat code
- where
- get_op_RI
- :: StixExpr
- -> NatM (InstrBlock,Operand) -- code, operator
-
- get_op_RI op
- | Just x <- maybeImm op
- = returnNat (nilOL, OpImm x)
-
- get_op_RI op
- = getRegister op `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let code = registerCode register tmp
- reg = registerName register tmp
- in
- returnNat (code, OpReg reg)
-
--- Assign; dst is a reg, rhs is mem
-assignReg_IntCode pk reg (StInd pks src)
- = getNewRegNCG PtrRep `thenNat` \ tmp ->
- getAmode src `thenNat` \ amode ->
- getRegisterReg reg `thenNat` \ reg_dst ->
- let
- c_addr = amodeCode amode
- am_addr = amodeAddr amode
- r_dst = registerName reg_dst tmp
- szs = primRepToSize pks
- opc = case szs of
- B -> MOVSxL B
- Bu -> MOVZxL Bu
- W -> MOVSxL W
- Wu -> MOVZxL Wu
- L -> MOV L
- Lu -> MOV L
-
- code = c_addr `snocOL`
- opc (OpAddr am_addr) (OpReg r_dst)
- in
- returnNat code
-
--- dst is a reg, but src could be anything
-assignReg_IntCode pk reg src
- = getRegisterReg reg `thenNat` \ registerd ->
- getRegister src `thenNat` \ registers ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- r_dst = registerName registerd tmp
- r_src = registerName registers r_dst
- c_src = registerCode registers r_dst
-
- code = c_src `snocOL`
- MOV L (OpReg r_src) (OpReg r_dst)
- in
- returnNat code
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-assignMem_IntCode pk addr src
- = getNewRegNCG IntRep `thenNat` \ tmp ->
- getAmode addr `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
- in
- returnNat code__2
-
-assignReg_IntCode pk reg src
- = getRegister src `thenNat` \ register2 ->
- getRegisterReg reg `thenNat` \ register1 ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- dst__2 = registerName register1 tmp
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code `snocOL` OR False g0 (RIReg src__2) dst__2
- else code
- in
- returnNat code__2
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-assignMem_IntCode pk addr src
- = getNewRegNCG IntRep `thenNat` \ tmp ->
- getAmode addr `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
- in
- returnNat code__2
-
-assignReg_IntCode pk reg src
- = getRegister src `thenNat` \ register2 ->
- getRegisterReg reg `thenNat` \ register1 ->
- let
- dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code `snocOL` MR dst__2 src__2
- else code
- in
- returnNat code__2
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-% --------------------------------
-Floating-point assignments:
-% --------------------------------
-
-\begin{code}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if alpha_TARGET_ARCH
-
-assignFltCode pk (StInd _ dst) src
- = getNewRegNCG pk `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode []
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- returnNat code__2
-
-assignFltCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- dst__2 = registerName register1 zeroh
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code . mkSeqInstr (FMOV src__2 dst__2)
- else code
- in
- returnNat code__2
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
--- Floating point assignment to memory
-assignMem_FltCode pk addr src
- = getRegister src `thenNat` \ reg_src ->
- getRegister addr `thenNat` \ reg_addr ->
- getNewRegNCG pk `thenNat` \ tmp_src ->
- getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
- let r_src = registerName reg_src tmp_src
- c_src = registerCode reg_src tmp_src
- r_addr = registerName reg_addr tmp_addr
- c_addr = registerCode reg_addr tmp_addr
- sz = primRepToSize pk
-
- code = c_src `appOL`
- -- no need to preserve r_src across the addr computation,
- -- since r_src must be a float reg
- -- whilst r_addr is an int reg
- c_addr `snocOL`
- GST sz r_src
- (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
- in
- returnNat code
-
--- Floating point assignment to a register/temporary
-assignReg_FltCode pk reg src
- = getRegisterReg reg `thenNat` \ reg_dst ->
- getRegister src `thenNat` \ reg_src ->
- getNewRegNCG pk `thenNat` \ tmp ->
- let
- r_dst = registerName reg_dst tmp
- r_src = registerName reg_src r_dst
- c_src = registerCode reg_src r_dst
-
- code = if isFixed reg_src
- then c_src `snocOL` GMOV r_src r_dst
- else c_src
- in
- returnNat code
-
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
--- Floating point assignment to memory
-assignMem_FltCode pk addr src
- = getNewRegNCG pk `thenNat` \ tmp1 ->
- getAmode addr `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- sz = primRepToSize pk
- dst__2 = amodeAddr amode
-
- code1 = amodeCode amode
- code2 = registerCode register tmp1
-
- src__2 = registerName register tmp1
- pk__2 = registerRep register
- sz__2 = primRepToSize pk__2
-
- code__2 = code1 `appOL` code2 `appOL`
- if pk == pk__2
- then unitOL (ST sz src__2 dst__2)
- else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
- in
- returnNat code__2
-
--- Floating point assignment to a register/temporary
--- Why is this so bizarrely ugly?
-assignReg_FltCode pk reg src
- = getRegisterReg reg `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- pk__2 = registerRep register2
- sz__2 = primRepToSize pk__2
- in
- getNewRegNCG pk__2 `thenNat` \ tmp ->
- let
- sz = primRepToSize pk
- dst__2 = registerName register1 g0 -- must be Fixed
- reg__2 = if pk /= pk__2 then tmp else dst__2
- code = registerCode register2 reg__2
- src__2 = registerName register2 reg__2
- code__2 =
- if pk /= pk__2 then
- code `snocOL` FxTOy sz__2 sz src__2 dst__2
- else if isFixed register2 then
- code `snocOL` FMOV sz src__2 dst__2
- else
- code
- in
- returnNat code__2
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
--- Floating point assignment to memory
-assignMem_FltCode pk addr src
- = getNewRegNCG pk `thenNat` \ tmp1 ->
- getAmode addr `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- sz = primRepToSize pk
- dst__2 = amodeAddr amode
-
- code1 = amodeCode amode
- code2 = registerCode register tmp1
-
- src__2 = registerName register tmp1
- pk__2 = registerRep register
-
- code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
- in
- returnNat code__2
-
--- Floating point assignment to a register/temporary
-assignReg_FltCode pk reg src
- = getRegisterReg reg `thenNat` \ reg_dst ->
- getRegister src `thenNat` \ reg_src ->
- getNewRegNCG pk `thenNat` \ tmp ->
- let
- r_dst = registerName reg_dst tmp
- r_src = registerName reg_src r_dst
- c_src = registerCode reg_src r_dst
-
- code = if isFixed reg_src
- then c_src `snocOL` MR r_dst r_src
- else c_src
- in
- returnNat code
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating an unconditional branch}
-%* *
-%************************************************************************
-
-We accept two types of targets: an immediate CLabel or a tree that
-gets evaluated into a register. Any CLabels which are AsmTemporaries
-are assumed to be in the local block of code, close enough for a
-branch instruction. Other CLabels are assumed to be far away.
-
-(If applicable) Do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-genJump (StCLbl lbl)
- | isAsmTemp lbl = returnInstr (BR target)
- | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
- where
- target = ImmCLbl lbl
-
-genJump tree
- = getRegister tree `thenNat` \ register ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- dst = registerName register pv
- code = registerCode register pv
- target = registerName register pv
- in
- if isFixed register then
- returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
- else
- returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-genJump dsts (StInd pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- target = amodeAddr amode
- in
- returnNat (code `snocOL` JMP dsts (OpAddr target))
-
-genJump dsts tree
- | maybeToBool imm
- = returnNat (unitOL (JMP dsts (OpImm target)))
-
- | otherwise
- = getRegister tree `thenNat` \ register ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- target = registerName register tmp
- in
- returnNat (code `snocOL` JMP dsts (OpReg target))
- where
- imm = maybeImm tree
- target = case imm of Just x -> x
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-genJump dsts (StCLbl lbl)
- | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
- | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
- | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
- where
- target = ImmCLbl lbl
-
-genJump dsts tree
- = getRegister tree `thenNat` \ register ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- target = registerName register tmp
- in
- returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-genJump dsts (StCLbl lbl)
- | hasDestInfo dsts = panic "genJump(powerpc): CLbl and dsts"
- | otherwise = returnNat (toOL [BCC ALWAYS lbl])
-
-genJump dsts tree
- = getRegister tree `thenNat` \ register ->
- getNewRegNCG PtrRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- target = registerName register tmp
- in
- returnNat (code `snocOL` MTCTR target `snocOL` BCTR dsts)
-#endif /* sparc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Conditional jumps}
-%* *
-%************************************************************************
-
-Conditional jumps are always to local labels, so we can use branch
-instructions. We peek at the arguments to decide what kind of
-comparison to do.
-
-ALPHA: For comparisons with 0, we're laughing, because we can just do
-the desired conditional branch.
-
-I386: First, we have to ensure that the condition
-codes are set according to the supplied comparison operation.
-
-SPARC: First, we have to ensure that the condition codes are set
-according to the supplied comparison operation. We generate slightly
-different code for floating point comparisons, because a floating
-point operation cannot directly precede a @BF@. We assume the worst
-and fill that slot with a @NOP@.
-
-SPARC: Do not fill the delay slots here; you will confuse the register
-allocator.
-
-\begin{code}
-genCondJump
- :: CLabel -- the branch target
- -> StixExpr -- the condition on which to branch
- -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-genCondJump lbl (StPrim op [x, StInt 0])
- = getRegister x `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerRep register
- target = ImmCLbl lbl
- in
- returnSeq code [BI (cmpOp op) value target]
- where
- cmpOp CharGtOp = GTT
- cmpOp CharGeOp = GE
- cmpOp CharEqOp = EQQ
- cmpOp CharNeOp = NE
- cmpOp CharLtOp = LTT
- cmpOp CharLeOp = LE
- cmpOp IntGtOp = GTT
- cmpOp IntGeOp = GE
- cmpOp IntEqOp = EQQ
- cmpOp IntNeOp = NE
- cmpOp IntLtOp = LTT
- cmpOp IntLeOp = LE
- cmpOp WordGtOp = NE
- cmpOp WordGeOp = ALWAYS
- cmpOp WordEqOp = EQQ
- cmpOp WordNeOp = NE
- cmpOp WordLtOp = NEVER
- cmpOp WordLeOp = EQQ
- cmpOp AddrGtOp = NE
- cmpOp AddrGeOp = ALWAYS
- cmpOp AddrEqOp = EQQ
- cmpOp AddrNeOp = NE
- cmpOp AddrLtOp = NEVER
- cmpOp AddrLeOp = EQQ
-
-genCondJump lbl (StPrim op [x, StDouble 0.0])
- = getRegister x `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerRep register
- target = ImmCLbl lbl
- in
- returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
- where
- cmpOp FloatGtOp = GTT
- cmpOp FloatGeOp = GE
- cmpOp FloatEqOp = EQQ
- cmpOp FloatNeOp = NE
- cmpOp FloatLtOp = LTT
- cmpOp FloatLeOp = LE
- cmpOp DoubleGtOp = GTT
- cmpOp DoubleGeOp = GE
- cmpOp DoubleEqOp = EQQ
- cmpOp DoubleNeOp = NE
- cmpOp DoubleLtOp = LTT
- cmpOp DoubleLeOp = LE
-
-genCondJump lbl (StPrim op [x, y])
- | fltCmpOp op
- = trivialFCode pr instr x y `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- returnNat (code . mkSeqInstr (BF cond result target))
- where
- pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
-
- fltCmpOp op = case op of
- FloatGtOp -> True
- FloatGeOp -> True
- FloatEqOp -> True
- FloatNeOp -> True
- FloatLtOp -> True
- FloatLeOp -> True
- DoubleGtOp -> True
- DoubleGeOp -> True
- DoubleEqOp -> True
- DoubleNeOp -> True
- DoubleLtOp -> True
- DoubleLeOp -> True
- _ -> False
- (instr, cond) = case op of
- FloatGtOp -> (FCMP TF LE, EQQ)
- FloatGeOp -> (FCMP TF LTT, EQQ)
- FloatEqOp -> (FCMP TF EQQ, NE)
- FloatNeOp -> (FCMP TF EQQ, EQQ)
- FloatLtOp -> (FCMP TF LTT, NE)
- FloatLeOp -> (FCMP TF LE, NE)
- DoubleGtOp -> (FCMP TF LE, EQQ)
- DoubleGeOp -> (FCMP TF LTT, EQQ)
- DoubleEqOp -> (FCMP TF EQQ, NE)
- DoubleNeOp -> (FCMP TF EQQ, EQQ)
- DoubleLtOp -> (FCMP TF LTT, NE)
- DoubleLeOp -> (FCMP TF LE, NE)
-
-genCondJump lbl (StPrim op [x, y])
- = trivialCode instr x y `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- returnNat (code . mkSeqInstr (BI cond result target))
- where
- (instr, cond) = case op of
- CharGtOp -> (CMP LE, EQQ)
- CharGeOp -> (CMP LTT, EQQ)
- CharEqOp -> (CMP EQQ, NE)
- CharNeOp -> (CMP EQQ, EQQ)
- CharLtOp -> (CMP LTT, NE)
- CharLeOp -> (CMP LE, NE)
- IntGtOp -> (CMP LE, EQQ)
- IntGeOp -> (CMP LTT, EQQ)
- IntEqOp -> (CMP EQQ, NE)
- IntNeOp -> (CMP EQQ, EQQ)
- IntLtOp -> (CMP LTT, NE)
- IntLeOp -> (CMP LE, NE)
- WordGtOp -> (CMP ULE, EQQ)
- WordGeOp -> (CMP ULT, EQQ)
- WordEqOp -> (CMP EQQ, NE)
- WordNeOp -> (CMP EQQ, EQQ)
- WordLtOp -> (CMP ULT, NE)
- WordLeOp -> (CMP ULE, NE)
- AddrGtOp -> (CMP ULE, EQQ)
- AddrGeOp -> (CMP ULT, EQQ)
- AddrEqOp -> (CMP EQQ, NE)
- AddrNeOp -> (CMP EQQ, EQQ)
- AddrLtOp -> (CMP ULT, NE)
- AddrLeOp -> (CMP ULE, NE)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-genCondJump lbl bool
- = getCondCode bool `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- in
- returnNat (code `snocOL` JXX cond lbl)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-genCondJump lbl bool
- = getCondCode bool `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- target = ImmCLbl lbl
- in
- returnNat (
- code `appOL`
- toOL (
- if condFloat condition
- then [NOP, BF cond False target, NOP]
- else [BI cond False target, NOP]
- )
- )
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-genCondJump lbl bool
- = getCondCode bool `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- target = ImmCLbl lbl
- in
- returnNat (
- code `snocOL` BCC cond lbl )
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating C calls}
-%* *
-%************************************************************************
-
-Now the biggest nightmare---calls. Most of the nastiness is buried in
-@get_arg@, which moves the arguments to the correct registers/stack
-locations. Apart from that, the code is easy.
-
-(If applicable) Do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-genCCall
- :: (Either FastString StixExpr) -- function to call
- -> CCallConv
- -> PrimRep -- type of the result
- -> [StixExpr] -- arguments (of mixed type)
- -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-genCCall fn cconv kind args
- = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenNat` \ ((unused,_), argCode) ->
- let
- nRegs = length allArgRegs - length unused
- code = asmSeqThen (map ($ []) argCode)
- in
- returnSeq code [
- LDA pv (AddrImm (ImmLab (ptext fn))),
- JSR ra (AddrReg pv) nRegs,
- LDGP gp (AddrReg ra)]
- where
- ------------------------
- {- Try to get a value into a specific register (or registers) for
- a call. The first 6 arguments go into the appropriate
- argument register (separate registers for integer and floating
- point arguments, but used in lock-step), and the remaining
- arguments are dumped to the stack, beginning at 0(sp). Our
- first argument is a pair of the list of remaining argument
- registers to be assigned for this call and the next stack
- offset to use for overflowing arguments. This way,
- @get_Arg@ can be applied to all of a call's arguments using
- @mapAccumLNat@.
- -}
- get_arg
- :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
- -> StixTree -- Current argument
- -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
-
- -- We have to use up all of our argument registers first...
-
- get_arg ((iDst,fDst):dsts, offset) arg
- = getRegister arg `thenNat` \ register ->
- let
- reg = if isFloatingRep pk then fDst else iDst
- code = registerCode register reg
- src = registerName register reg
- pk = registerRep register
- in
- returnNat (
- if isFloatingRep pk then
- ((dsts, offset), if isFixed register then
- code . mkSeqInstr (FMOV src fDst)
- else code)
- else
- ((dsts, offset), if isFixed register then
- code . mkSeqInstr (OR src (RIReg src) iDst)
- else code))
-
- -- Once we have run out of argument registers, we move to the
- -- stack...
-
- get_arg ([], offset) arg
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
- in
- returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-genCCall fn cconv ret_rep args
- = mapNat push_arg
- (reverse args) `thenNat` \ sizes_n_codes ->
- getDeltaNat `thenNat` \ delta ->
- let (sizes, push_codes) = unzip sizes_n_codes
- tot_arg_size = sum sizes
- in
- -- deal with static vs dynamic call targets
- (case fn of
- Left t_static
- -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
- Right dyn
- -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
- ASSERT(case dyn_rep of { L -> True; _ -> False})
- returnNat (dyn_c `snocOL` CALL (Right dyn_r))
- )
- `thenNat` \ callinsns ->
- let push_code = concatOL push_codes
- call = callinsns `appOL`
- toOL (
- -- Deallocate parameters after call for ccall;
- -- but not for stdcall (callee does it)
- (if cconv == StdCallConv then [] else
- [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
- ++
- [DELTA (delta + tot_arg_size)]
- )
- in
- setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
- returnNat (push_code `appOL` call)
-
- where
- -- function names that begin with '.' are assumed to be special
- -- internally generated names like '.mul,' which don't get an
- -- underscore prefix
- -- ToDo:needed (WDP 96/03) ???
- fn_u = unpackFS (unLeft fn)
- fn__2 tot_arg_size
- | head fn_u == '.'
- = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
- | otherwise -- General case
- = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
-
- stdcallsize tot_arg_size
- | cconv == StdCallConv = '@':show tot_arg_size
- | otherwise = ""
-
- arg_size DF = 8
- arg_size F = 4
- arg_size _ = 4
-
- ------------
- push_arg :: StixExpr{-current argument-}
- -> NatM (Int, InstrBlock) -- argsz, code
-
- push_arg arg
- | is64BitRep arg_rep
- = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
- getDeltaNat `thenNat` \ delta ->
- setDeltaNat (delta - 8) `thenNat` \ _ ->
- let r_lo = VirtualRegI vr_lo
- r_hi = getHiVRegFromLo r_lo
- in returnNat (8,
- code `appOL`
- toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
- PUSH L (OpReg r_lo), DELTA (delta - 8)]
- )
- | otherwise
- = get_op arg `thenNat` \ (code, reg, sz) ->
- getDeltaNat `thenNat` \ delta ->
- arg_size sz `bind` \ size ->
- setDeltaNat (delta-size) `thenNat` \ _ ->
- if (case sz of DF -> True; F -> True; _ -> False)
- then returnNat (size,
- code `appOL`
- toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
- DELTA (delta-size),
- GST sz reg (AddrBaseIndex (Just esp)
- Nothing
- (ImmInt 0))]
- )
- else returnNat (size,
- code `snocOL`
- PUSH L (OpReg reg) `snocOL`
- DELTA (delta-size)
- )
- where
- arg_rep = repOfStixExpr arg
-
- ------------
- get_op
- :: StixExpr
- -> NatM (InstrBlock, Reg, Size) -- code, reg, size
-
- get_op op
- = getRegister op `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
- in
- returnNat (code, reg, sz)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-{-
- The SPARC calling convention is an absolute
- nightmare. The first 6x32 bits of arguments are mapped into
- %o0 through %o5, and the remaining arguments are dumped to the
- stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
-
- If we have to put args on the stack, move %o6==%sp down by
- the number of words to go on the stack, to ensure there's enough space.
-
- According to Fraser and Hanson's lcc book, page 478, fig 17.2,
- 16 words above the stack pointer is a word for the address of
- a structure return value. I use this as a temporary location
- for moving values from float to int regs. Certainly it isn't
- safe to put anything in the 16 words starting at %sp, since
- this area can get trashed at any time due to window overflows
- caused by signal handlers.
-
- A final complication (if the above isn't enough) is that
- we can't blithely calculate the arguments one by one into
- %o0 .. %o5. Consider the following nested calls:
-
- fff a (fff b c)
-
- Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
- the inner call will itself use %o0, which trashes the value put there
- in preparation for the outer call. Upshot: we need to calculate the
- args into temporary regs, and move those to arg regs or onto the
- stack only immediately prior to the call proper. Sigh.
--}
-
-genCCall fn cconv kind args
- = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
- let
- (argcodes, vregss) = unzip argcode_and_vregs
- n_argRegs = length allArgRegs
- n_argRegs_used = min (length vregs) n_argRegs
- vregs = concat vregss
- in
- -- deal with static vs dynamic call targets
- (case fn of
- Left t_static
- -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
- Right dyn
- -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
- returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
- )
- `thenNat` \ callinsns ->
- let
- argcode = concatOL argcodes
- (move_sp_down, move_sp_up)
- = let diff = length vregs - n_argRegs
- nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
- in if nn <= 0
- then (nilOL, nilOL)
- else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
- transfer_code
- = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
- in
- returnNat (argcode `appOL`
- move_sp_down `appOL`
- transfer_code `appOL`
- callinsns `appOL`
- unitOL NOP `appOL`
- move_sp_up)
- where
- -- function names that begin with '.' are assumed to be special
- -- internally generated names like '.mul,' which don't get an
- -- underscore prefix
- -- ToDo:needed (WDP 96/03) ???
- fn_static = unLeft fn
- fn__2 = case (headFS fn_static) of
- '.' -> ImmLit (ftext fn_static)
- _ -> ImmLab False (ftext fn_static)
-
- -- move args from the integer vregs into which they have been
- -- marshalled, into %o0 .. %o5, and the rest onto the stack.
- move_final :: [Reg] -> [Reg] -> Int -> [Instr]
-
- move_final [] _ offset -- all args done
- = []
-
- move_final (v:vs) [] offset -- out of aregs; move to stack
- = ST W v (spRel offset)
- : move_final vs [] (offset+1)
-
- move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
- = OR False g0 (RIReg v) a
- : move_final vs az offset
-
- -- generate code to calculate an argument, and move it into one
- -- or two integer vregs.
- arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
- arg_to_int_vregs arg
- | is64BitRep (repOfStixExpr arg)
- = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
- let r_lo = VirtualRegI vr_lo
- r_hi = getHiVRegFromLo r_lo
- in returnNat (code, [r_hi, r_lo])
- | otherwise
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register) `thenNat` \ tmp ->
- let code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
- in
- -- the value is in src. Get it into 1 or 2 int vregs.
- case pk of
- DoubleRep ->
- getNewRegNCG WordRep `thenNat` \ v1 ->
- getNewRegNCG WordRep `thenNat` \ v2 ->
- returnNat (
- code `snocOL`
- FMOV DF src f0 `snocOL`
- ST F f0 (spRel 16) `snocOL`
- LD W (spRel 16) v1 `snocOL`
- ST F (fPair f0) (spRel 16) `snocOL`
- LD W (spRel 16) v2
- ,
- [v1,v2]
- )
- FloatRep ->
- getNewRegNCG WordRep `thenNat` \ v1 ->
- returnNat (
- code `snocOL`
- ST F src (spRel 16) `snocOL`
- LD W (spRel 16) v1
- ,
- [v1]
- )
- other ->
- getNewRegNCG WordRep `thenNat` \ v1 ->
- returnNat (
- code `snocOL` OR False g0 (RIReg src) v1
- ,
- [v1]
- )
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-
-#if darwin_TARGET_OS
-{-
- The PowerPC calling convention for Darwin/Mac OS X
- is described in Apple's document
- "Inside Mac OS X - Mach-O Runtime Architecture".
- Parameters may be passed in general-purpose registers, in
- floating point registers, or on the stack. Stack space is
- always reserved for parameters, even if they are passed in registers.
- The called routine may choose to save parameters from registers
- to the corresponding space on the stack.
- The parameter area should be part of the caller's stack frame,
- allocated in the caller's prologue code (large enough to hold
- the parameter lists for all called routines). The NCG already
- uses the space that we should use as a parameter area for register
- spilling, so we allocate a new stack frame just before ccalling.
- That way we don't need to decide beforehand how much space to
- reserve for parameters.
--}
-
-genCCall fn cconv kind args
- = mapNat prepArg args `thenNat` \ preppedArgs ->
- let
- (argReps,argCodes,vregs) = unzip3 preppedArgs
-
- -- size of linkage area + size of arguments, in bytes
- stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
- roundTo16 x | x `mod` 16 == 0 = x
- | otherwise = x + 16 - (x `mod` 16)
-
- move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
- move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
-
- (moveFinalCode,usedRegs) = move_final
- (zip vregs argReps)
- allArgRegs allFPArgRegs
- eXTRA_STK_ARGS_HERE
- (toOL []) []
-
- passArguments = concatOL argCodes
- `appOL` move_sp_down
- `appOL` moveFinalCode
- in
- case fn of
- Left lbl ->
- addImportNat lbl `thenNat` \ _ ->
- returnNat (passArguments
- `snocOL` BL (ImmLit $ ftext
- (FSLIT("L_")
- `appendFS` lbl
- `appendFS` FSLIT("$stub")))
- usedRegs
- `appOL` move_sp_up)
- Right dyn ->
- getRegister dyn `thenNat` \ dynReg ->
- getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
- returnNat (registerCode dynReg tmp
- `appOL` passArguments
- `snocOL` MTCTR (registerName dynReg tmp)
- `snocOL` BCTRL usedRegs
- `appOL` move_sp_up)
- where
- prepArg arg
- | is64BitRep (repOfStixExpr arg)
- = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
- let r_lo = VirtualRegI vr_lo
- r_hi = getHiVRegFromLo r_lo
- in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
- | otherwise
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register) `thenNat` \ tmp ->
- returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
- move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
- move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
- | not (is64BitRep rep) =
- case rep of
- FloatRep ->
- move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
- (accumCode `snocOL`
- (case fprs of
- fpr : fprs -> MR fpr vr
- [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
- ((take 1 fprs) ++ accumUsed)
- DoubleRep ->
- move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
- (accumCode `snocOL`
- (case fprs of
- fpr : fprs -> MR fpr vr
- [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
- ((take 1 fprs) ++ accumUsed)
- VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
- _ ->
- move_final vregs (drop 1 gprs) fprs (stackOffset+4)
- (accumCode `snocOL`
- (case gprs of
- gpr : gprs -> MR gpr vr
- [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
- ((take 1 gprs) ++ accumUsed)
-
- move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
- | is64BitRep rep =
- let
- storeWord vr (gpr:_) offset = MR gpr vr
- storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
- in
- move_final vregs (drop 2 gprs) fprs (stackOffset+8)
- (accumCode
- `snocOL` storeWord vr_hi gprs stackOffset
- `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
- ((take 2 gprs) ++ accumUsed)
-#else
-
-{-
- PowerPC Linux uses the System V Release 4 Calling Convention
- for PowerPC. It is described in the
- "System V Application Binary Interface PowerPC Processor Supplement".
-
- Like the Darwin/Mac OS X code above, this allocates a new stack frame
- so that the parameter area doesn't conflict with the spill slots.
--}
-
-genCCall fn cconv kind args
- = mapNat prepArg args `thenNat` \ preppedArgs ->
- let
- (argReps,argCodes,vregs) = unzip3 preppedArgs
-
- -- size of linkage area + size of arguments, in bytes
- stackDelta = roundTo16 finalStack
- roundTo16 x | x `mod` 16 == 0 = x
- | otherwise = x + 16 - (x `mod` 16)
-
- move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
- move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
-
- (moveFinalCode,usedRegs,finalStack) =
- move_final (zip vregs argReps)
- allArgRegs allFPArgRegs
- eXTRA_STK_ARGS_HERE
- (toOL []) []
-
- passArguments = concatOL argCodes
- `appOL` move_sp_down
- `appOL` moveFinalCode
- in
- case fn of
- Left lbl ->
- addImportNat lbl `thenNat` \ _ ->
- returnNat (passArguments
- `snocOL` BL (ImmLit $ ftext lbl)
- usedRegs
- `appOL` move_sp_up)
- Right dyn ->
- getRegister dyn `thenNat` \ dynReg ->
- getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
- returnNat (registerCode dynReg tmp
- `appOL` passArguments
- `snocOL` MTCTR (registerName dynReg tmp)
- `snocOL` BCTRL usedRegs
- `appOL` move_sp_up)
- where
- prepArg arg
- | is64BitRep (repOfStixExpr arg)
- = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
- let r_lo = VirtualRegI vr_lo
- r_hi = getHiVRegFromLo r_lo
- in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
- | otherwise
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register) `thenNat` \ tmp ->
- returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
- move_final [] _ _ stackOffset accumCode accumUsed = (accumCode, accumUsed, stackOffset)
- move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
- | not (is64BitRep rep) =
- case rep of
- FloatRep ->
- case fprs of
- fpr : fprs' -> move_final vregs gprs fprs' stackOffset
- (accumCode `snocOL` MR fpr vr)
- (fpr : accumUsed)
- [] -> move_final vregs gprs fprs (stackOffset+4)
- (accumCode `snocOL`
- ST F vr (AddrRegImm sp (ImmInt stackOffset)))
- accumUsed
- DoubleRep ->
- case fprs of
- fpr : fprs' -> move_final vregs gprs fprs' stackOffset
- (accumCode `snocOL` MR fpr vr)
- (fpr : accumUsed)
- [] -> move_final vregs gprs fprs (stackOffset+8)
- (accumCode `snocOL`
- ST DF vr (AddrRegImm sp (ImmInt stackOffset)))
- accumUsed
- VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
- _ ->
- case gprs of
- gpr : gprs' -> move_final vregs gprs' fprs stackOffset
- (accumCode `snocOL` MR gpr vr)
- (gpr : accumUsed)
- [] -> move_final vregs gprs fprs (stackOffset+4)
- (accumCode `snocOL`
- ST W vr (AddrRegImm sp (ImmInt stackOffset)))
- accumUsed
-
- move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
- | is64BitRep rep =
- case gprs of
- hireg : loreg : regs | even (length gprs) ->
- move_final vregs regs fprs stackOffset
- (regCode hireg loreg) accumUsed
- _skipped : hireg : loreg : regs ->
- move_final vregs regs fprs stackOffset
- (regCode hireg loreg) accumUsed
- _ -> -- only one or no regs left
- move_final vregs [] fprs (stackOffset+8)
- stackCode accumUsed
- where
- stackCode =
- accumCode
- `snocOL` ST W vr_hi (AddrRegImm sp (ImmInt stackOffset))
- `snocOL` ST W vr_lo (AddrRegImm sp (ImmInt (stackOffset+4)))
- regCode hireg loreg =
- accumCode
- `snocOL` MR hireg vr_hi
- `snocOL` MR loreg vr_lo
-
-#endif
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Support bits}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
-%* *
-%************************************************************************
-
-Turn those condition codes into integers now (when they appear on
-the right hand side of an assignment).
-
-(If applicable) Do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-condIntReg = panic "MachCode.condIntReg (not on Alpha)"
-condFltReg = panic "MachCode.condFltReg (not on Alpha)"
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-condIntReg cond x y
- = condIntCode cond x y `thenNat` \ condition ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code `appOL` toOL [
- SETCC cond (OpReg tmp),
- AND L (OpImm (ImmInt 1)) (OpReg tmp),
- MOV L (OpReg tmp) (OpReg dst)]
- in
- returnNat (Any IntRep code__2)
-
-condFltReg cond x y
- = getNatLabelNCG `thenNat` \ lbl1 ->
- getNatLabelNCG `thenNat` \ lbl2 ->
- condFltCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code `appOL` toOL [
- JXX cond lbl1,
- MOV L (OpImm (ImmInt 0)) (OpReg dst),
- JXX ALWAYS lbl2,
- LABEL lbl1,
- MOV L (OpImm (ImmInt 1)) (OpReg dst),
- LABEL lbl2]
- in
- returnNat (Any IntRep code__2)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-condIntReg EQQ x (StInt 0)
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `appOL` toOL [
- SUB False True g0 (RIReg src) g0,
- SUB True False g0 (RIImm (ImmInt (-1))) dst]
- in
- returnNat (Any IntRep code__2)
-
-condIntReg EQQ x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `appOL` toOL [
- XOR False src1 (RIReg src2) dst,
- SUB False True g0 (RIReg dst) g0,
- SUB True False g0 (RIImm (ImmInt (-1))) dst]
- in
- returnNat (Any IntRep code__2)
-
-condIntReg NE x (StInt 0)
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `appOL` toOL [
- SUB False True g0 (RIReg src) g0,
- ADD True False g0 (RIImm (ImmInt 0)) dst]
- in
- returnNat (Any IntRep code__2)
-
-condIntReg NE x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `appOL` toOL [
- XOR False src1 (RIReg src2) dst,
- SUB False True g0 (RIReg dst) g0,
- ADD True False g0 (RIImm (ImmInt 0)) dst]
- in
- returnNat (Any IntRep code__2)
-
-condIntReg cond x y
- = getNatLabelNCG `thenNat` \ lbl1 ->
- getNatLabelNCG `thenNat` \ lbl2 ->
- condIntCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code `appOL` toOL [
- BI cond False (ImmCLbl lbl1), NOP,
- OR False g0 (RIImm (ImmInt 0)) dst,
- BI ALWAYS False (ImmCLbl lbl2), NOP,
- LABEL lbl1,
- OR False g0 (RIImm (ImmInt 1)) dst,
- LABEL lbl2]
- in
- returnNat (Any IntRep code__2)
-
-condFltReg cond x y
- = getNatLabelNCG `thenNat` \ lbl1 ->
- getNatLabelNCG `thenNat` \ lbl2 ->
- condFltCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code `appOL` toOL [
- NOP,
- BF cond False (ImmCLbl lbl1), NOP,
- OR False g0 (RIImm (ImmInt 0)) dst,
- BI ALWAYS False (ImmCLbl lbl2), NOP,
- LABEL lbl1,
- OR False g0 (RIImm (ImmInt 1)) dst,
- LABEL lbl2]
- in
- returnNat (Any IntRep code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-condIntReg cond x y
- = getNatLabelNCG `thenNat` \ lbl ->
- condIntCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
- BCC cond lbl,
- LI dst (ImmInt 0),
- LABEL lbl]
- in
- returnNat (Any IntRep code__2)
-
-condFltReg cond x y
- = getNatLabelNCG `thenNat` \ lbl ->
- condFltCode cond x y `thenNat` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
- BCC cond lbl,
- LI dst (ImmInt 0),
- LABEL lbl]
- in
- returnNat (Any IntRep code__2)
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{@trivial*Code@: deal with trivial instructions}
-%* *
-%************************************************************************
-
-Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
-@trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
-for constants on the right hand side, because that's where the generic
-optimizer will have put them.
-
-Similarly, for unary instructions, we don't have to worry about
-matching an StInt as the argument, because genericOpt will already
-have handled the constant-folding.
-
-\begin{code}
-trivialCode
- :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
- ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
- -> Maybe (Operand -> Operand -> Instr)
- ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
- ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
- ,))))
- -> StixExpr -> StixExpr -- the two arguments
- -> NatM Register
-
-trivialFCode
- :: PrimRep
- -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
- ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
- ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
- ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
- ,))))
- -> StixExpr -> StixExpr -- the two arguments
- -> NatM Register
-
-trivialUCode
- :: IF_ARCH_alpha((RI -> Reg -> Instr)
- ,IF_ARCH_i386 ((Operand -> Instr)
- ,IF_ARCH_sparc((RI -> Reg -> Instr)
- ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
- ,))))
- -> StixExpr -- the one argument
- -> NatM Register
-
-trivialUFCode
- :: PrimRep
- -> IF_ARCH_alpha((Reg -> Reg -> Instr)
- ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
- ,IF_ARCH_sparc((Reg -> Reg -> Instr)
- ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
- ,))))
- -> StixExpr -- the one argument
- -> NatM Register
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-trivialCode instr x (StInt y)
- | fits8Bits y
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
- in
- returnNat (Any IntRep code__2)
-
-trivialCode instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 []
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
- src2 = registerName register2 tmp2
- code__2 dst = asmSeqThen [code1, code2] .
- mkSeqInstr (instr src1 (RIReg src2) dst)
- in
- returnNat (Any IntRep code__2)
-
-------------
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
- in
- returnNat (Any IntRep code__2)
-
-------------
-trivialFCode _ instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 dst = asmSeqThen [code1 [], code2 []] .
- mkSeqInstr (instr src1 src2 dst)
- in
- returnNat (Any DoubleRep code__2)
-
-trivialUFCode _ instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr src dst)
- in
- returnNat (Any DoubleRep code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-\end{code}
-The Rules of the Game are:
-
-* You cannot assume anything about the destination register dst;
- it may be anything, including a fixed reg.
-
-* You may compute an operand into a fixed reg, but you may not
- subsequently change the contents of that fixed reg. If you
- want to do so, first copy the value either to a temporary
- or into dst. You are free to modify dst even if it happens
- to be a fixed reg -- that's not your problem.
-
-* You cannot assume that a fixed reg will stay live over an
- arbitrary computation. The same applies to the dst reg.
-
-* Temporary regs obtained from getNewRegNCG are distinct from
- each other and from all other regs, and stay live over
- arbitrary computations.
-
-\begin{code}
-
-trivialCode instr maybe_revinstr a b
-
- | is_imm_b
- = getRegister a `thenNat` \ rega ->
- let mkcode dst
- = if isAny rega
- then registerCode rega dst `bind` \ code_a ->
- code_a `snocOL`
- instr (OpImm imm_b) (OpReg dst)
- else registerCodeF rega `bind` \ code_a ->
- registerNameF rega `bind` \ r_a ->
- code_a `snocOL`
- MOV L (OpReg r_a) (OpReg dst) `snocOL`
- instr (OpImm imm_b) (OpReg dst)
- in
- returnNat (Any IntRep mkcode)
-
- | is_imm_a
- = getRegister b `thenNat` \ regb ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let revinstr_avail = maybeToBool maybe_revinstr
- revinstr = case maybe_revinstr of Just ri -> ri
- mkcode dst
- | revinstr_avail
- = if isAny regb
- then registerCode regb dst `bind` \ code_b ->
- code_b `snocOL`
- revinstr (OpImm imm_a) (OpReg dst)
- else registerCodeF regb `bind` \ code_b ->
- registerNameF regb `bind` \ r_b ->
- code_b `snocOL`
- MOV L (OpReg r_b) (OpReg dst) `snocOL`
- revinstr (OpImm imm_a) (OpReg dst)
-
- | otherwise
- = if isAny regb
- then registerCode regb tmp `bind` \ code_b ->
- code_b `snocOL`
- MOV L (OpImm imm_a) (OpReg dst) `snocOL`
- instr (OpReg tmp) (OpReg dst)
- else registerCodeF regb `bind` \ code_b ->
- registerNameF regb `bind` \ r_b ->
- code_b `snocOL`
- MOV L (OpReg r_b) (OpReg tmp) `snocOL`
- MOV L (OpImm imm_a) (OpReg dst) `snocOL`
- instr (OpReg tmp) (OpReg dst)
- in
- returnNat (Any IntRep mkcode)
-
- | otherwise
- = getRegister a `thenNat` \ rega ->
- getRegister b `thenNat` \ regb ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let mkcode dst
- = case (isAny rega, isAny regb) of
- (True, True)
- -> registerCode regb tmp `bind` \ code_b ->
- registerCode rega dst `bind` \ code_a ->
- code_b `appOL`
- code_a `snocOL`
- instr (OpReg tmp) (OpReg dst)
- (True, False)
- -> registerCode rega tmp `bind` \ code_a ->
- registerCodeF regb `bind` \ code_b ->
- registerNameF regb `bind` \ r_b ->
- code_a `appOL`
- code_b `snocOL`
- instr (OpReg r_b) (OpReg tmp) `snocOL`
- MOV L (OpReg tmp) (OpReg dst)
- (False, True)
- -> registerCode regb tmp `bind` \ code_b ->
- registerCodeF rega `bind` \ code_a ->
- registerNameF rega `bind` \ r_a ->
- code_b `appOL`
- code_a `snocOL`
- MOV L (OpReg r_a) (OpReg dst) `snocOL`
- instr (OpReg tmp) (OpReg dst)
- (False, False)
- -> registerCodeF rega `bind` \ code_a ->
- registerNameF rega `bind` \ r_a ->
- registerCodeF regb `bind` \ code_b ->
- registerNameF regb `bind` \ r_b ->
- code_a `snocOL`
- MOV L (OpReg r_a) (OpReg tmp) `appOL`
- code_b `snocOL`
- instr (OpReg r_b) (OpReg tmp) `snocOL`
- MOV L (OpReg tmp) (OpReg dst)
- in
- returnNat (Any IntRep mkcode)
-
- where
- maybe_imm_a = maybeImm a
- is_imm_a = maybeToBool maybe_imm_a
- imm_a = case maybe_imm_a of Just imm -> imm
-
- maybe_imm_b = maybeImm b
- is_imm_b = maybeToBool maybe_imm_b
- imm_b = case maybe_imm_b of Just imm -> imm
-
-
------------
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- let
- code__2 dst = let code = registerCode register dst
- src = registerName register dst
- in code `appOL`
- if isFixed register && dst /= src
- then toOL [MOV L (OpReg src) (OpReg dst),
- instr (OpReg dst)]
- else unitOL (instr (OpReg src))
- in
- returnNat (Any IntRep code__2)
-
------------
-trivialFCode pk instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 dst
- -- treat the common case specially: both operands in
- -- non-fixed regs.
- | isAny register1 && isAny register2
- = code1 `appOL`
- code2 `snocOL`
- instr (primRepToSize pk) src1 src2 dst
-
- -- be paranoid (and inefficient)
- | otherwise
- = code1 `snocOL` GMOV src1 tmp1 `appOL`
- code2 `snocOL`
- instr (primRepToSize pk) tmp1 src2 dst
- in
- returnNat (Any pk code__2)
-
-
--------------
-trivialUFCode pk instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG pk `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr src dst
- in
- returnNat (Any pk code__2)
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-trivialCode instr x (StInt y)
- | fits13Bits y
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
- in
- returnNat (Any IntRep code__2)
-
-trivialCode instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `snocOL`
- instr src1 (RIReg src2) dst
- in
- returnNat (Any IntRep code__2)
-
-------------
-trivialFCode pk instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- promote x = FxTOy F DF x tmp
-
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- pk2 = registerRep register2
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 dst =
- if pk1 == pk2 then
- code1 `appOL` code2 `snocOL`
- instr (primRepToSize pk) src1 src2 dst
- else if pk1 == FloatRep then
- code1 `snocOL` promote src1 `appOL` code2 `snocOL`
- instr DF tmp src2 dst
- else
- code1 `appOL` code2 `snocOL` promote src2 `snocOL`
- instr DF src1 tmp dst
- in
- returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
-
-------------
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr (RIReg src) dst
- in
- returnNat (Any IntRep code__2)
-
--------------
-trivialUFCode pk instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG pk `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr src dst
- in
- returnNat (Any pk code__2)
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-trivialCode instr x (StInt y)
- | fits16Bits y
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
- in
- returnNat (Any IntRep code__2)
-
-trivialCode instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `snocOL`
- instr dst src1 (RIReg src2)
- in
- returnNat (Any IntRep code__2)
-
-trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
- -> StixExpr -> StixExpr -> NatM Register
-trivialCode2 instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `snocOL`
- instr dst src1 src2
- in
- returnNat (Any IntRep code__2)
-
-trivialFCode pk instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG (registerRep register1)
- `thenNat` \ tmp1 ->
- getNewRegNCG (registerRep register2)
- `thenNat` \ tmp2 ->
- -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- -- promote x = FxTOy F DF x tmp
-
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- pk2 = registerRep register2
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
-
- code__2 dst =
- code1 `appOL` code2 `snocOL`
- instr (primRepToSize dstRep) dst src1 src2
- in
- returnNat (Any dstRep code__2)
-
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr dst src
- in
- returnNat (Any IntRep code__2)
-trivialUFCode pk instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code `snocOL` instr dst src
- in
- returnNat (Any pk code__2)
-
--- There is no "remainder" instruction on the PPC, so we have to do
--- it the hard way.
--- The "div" parameter is the division instruction to use (DIVW or DIVWU)
-
-remainderCode :: (Reg -> Reg -> Reg -> Instr)
- -> StixExpr -> StixExpr -> NatM Register
-remainderCode div x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp1 ->
- getNewRegNCG IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
- code__2 dst = code1 `appOL` code2 `appOL` toOL [
- div dst src1 src2,
- MULLW dst dst (RIReg src2),
- SUBF dst dst src1
- ]
- in
- returnNat (Any IntRep code__2)
-
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Coercing to/from integer/floating-point...}
-%* *
-%************************************************************************
-
-@coerce(Int2FP|FP2Int)@ are more complicated integer/float
-conversions. We have to store temporaries in memory to move
-between the integer and the floating point register sets.
-
-@coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
-pretend, on sparc at least, that double and float regs are seperate
-kinds, so the value has to be computed into one kind before being
-explicitly "converted" to live in the other kind.
-
-\begin{code}
-coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
-coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
-
-coerceDbl2Flt :: StixExpr -> NatM Register
-coerceFlt2Dbl :: StixExpr -> NatM Register
-\end{code}
-
-\begin{code}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-coerceInt2FP _ x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
-
- code__2 dst = code . mkSeqInstrs [
- ST Q src (spRel 0),
- LD TF dst (spRel 0),
- CVTxy Q TF dst dst]
- in
- returnNat (Any DoubleRep code__2)
-
--------------
-coerceFP2Int x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
-
- code__2 dst = code . mkSeqInstrs [
- CVTxy TF Q src tmp,
- ST TF tmp (spRel 0),
- LD Q dst (spRel 0)]
- in
- returnNat (Any IntRep code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if i386_TARGET_ARCH
-
-coerceInt2FP pk x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
- opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
- code__2 dst = code `snocOL` opc src dst
- in
- returnNat (Any pk code__2)
-
-------------
-coerceFP2Int fprep x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
-
- opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
- code__2 dst = code `snocOL` opc src dst
- in
- returnNat (Any IntRep code__2)
-
-------------
-coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
-coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
-
-#endif /* i386_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if sparc_TARGET_ARCH
-
-coerceInt2FP pk x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
-
- code__2 dst = code `appOL` toOL [
- ST W src (spRel (-2)),
- LD W (spRel (-2)) dst,
- FxTOy W (primRepToSize pk) dst dst]
- in
- returnNat (Any pk code__2)
-
-------------
-coerceFP2Int fprep x
- = ASSERT(fprep == DoubleRep || fprep == FloatRep)
- getRegister x `thenNat` \ register ->
- getNewRegNCG fprep `thenNat` \ reg ->
- getNewRegNCG FloatRep `thenNat` \ tmp ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code `appOL` toOL [
- FxTOy (primRepToSize fprep) W src tmp,
- ST W tmp (spRel (-2)),
- LD W (spRel (-2)) dst]
- in
- returnNat (Any IntRep code__2)
-
-------------
-coerceDbl2Flt x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let code = registerCode register tmp
- src = registerName register tmp
- in
- returnNat (Any FloatRep
- (\dst -> code `snocOL` FxTOy DF F src dst))
-
-------------
-coerceFlt2Dbl x
- = getRegister x `thenNat` \ register ->
- getNewRegNCG FloatRep `thenNat` \ tmp ->
- let code = registerCode register tmp
- src = registerName register tmp
- in
- returnNat (Any DoubleRep
- (\dst -> code `snocOL` FxTOy F DF src dst))
-
-#endif /* sparc_TARGET_ARCH */
-
-#if powerpc_TARGET_ARCH
-coerceInt2FP pk x
- = ASSERT(pk == DoubleRep)
- getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- getNatLabelNCG `thenNat` \ lbl ->
- getNewRegNCG PtrRep `thenNat` \ itmp ->
- getNewRegNCG DoubleRep `thenNat` \ ftmp ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code `appOL` toOL [
- SEGMENT RoDataSegment,
- LABEL lbl,
- DATA W [ImmInt 0x43300000, ImmInt 0x80000000],
- SEGMENT TextSegment,
- XORIS itmp src (ImmInt 0x8000),
- ST W itmp (spRel (-1)),
- LIS itmp (ImmInt 0x4330),
- ST W itmp (spRel (-2)),
- LD DF ftmp (spRel (-2)),
- LIS itmp (HA (ImmCLbl lbl)),
- LD DF dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
- FSUB DF dst ftmp dst
- ]
- in
- returnNat (Any DoubleRep code__2)
-
-coerceFP2Int fprep x
- = ASSERT(fprep == DoubleRep || fprep == FloatRep)
- getRegister x `thenNat` \ register ->
- getNewRegNCG fprep `thenNat` \ reg ->
- getNewRegNCG DoubleRep `thenNat` \ tmp ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code `appOL` toOL [
- -- convert to int in FP reg
- FCTIWZ tmp src,
- -- store value (64bit) from FP to stack
- ST DF tmp (spRel (-2)),
- -- read low word of value (high word is undefined)
- LD W dst (spRel (-1))]
- in
- returnNat (Any IntRep code__2)
-coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
-coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
-#endif /* powerpc_TARGET_ARCH */
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Generating machine code (instruction selection)
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
+
+-- This is a big module, but, if you pay attention to
+-- (a) the sectioning, (b) the type signatures, and
+-- (c) the #if blah_TARGET_ARCH} things, the
+-- structure should not be too overwhelming.
+
+module MachCodeGen ( cmmTopCodeGen, InstrBlock ) where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+-- NCG stuff:
+import MachInstrs
+import MachRegs
+import NCGMonad
+
+-- Our intermediate code:
+import PprCmm ( pprExpr )
+import Cmm
+import MachOp
+import CLabel
+
+-- The rest:
+import CmdLineOpts ( opt_Static )
+import ForeignCall ( CCallConv(..) )
+import OrdList
+import Pretty
+import Outputable
+import qualified Outputable
+import FastString
+import FastTypes ( isFastTrue )
+
+#ifdef DEBUG
+import Outputable ( assertPanic )
+import TRACE ( trace )
+#endif
+
+import Control.Monad ( mapAndUnzipM )
+import Maybe ( fromJust )
+import DATA_BITS
+import DATA_WORD
+
+-- -----------------------------------------------------------------------------
+-- Top-level of the instruction selector
+
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+-- They are really trees of insns to facilitate fast appending, where a
+-- left-to-right traversal (pre-order?) yields the insns in the correct
+-- order.
+
+type InstrBlock = OrdList Instr
+
+cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop]
+cmmTopCodeGen (CmmProc info lab params blocks) = do
+ (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+ return (CmmProc info lab params (concat nat_blocks) : concat statics)
+cmmTopCodeGen (CmmData sec dat) = do
+ return [CmmData sec dat] -- no translation, we just use CmmStatic
+
+basicBlockCodeGen :: CmmBasicBlock -> NatM ([NatBasicBlock],[NatCmmTop])
+basicBlockCodeGen (BasicBlock id stmts) = do
+ instrs <- stmtsToInstrs stmts
+ -- code generation may introduce new basic block boundaries, which
+ -- are indicated by the NEWBLOCK instruction. We must split up the
+ -- instruction stream into basic blocks again. Also, we extract
+ -- LDATAs here too.
+ let
+ (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+
+ mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+ = ([], BasicBlock id instrs : blocks, statics)
+ mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+ = (instrs, blocks, CmmData sec dat:statics)
+ mkBlocks instr (instrs,blocks,statics)
+ = (instr:instrs, blocks, statics)
+ -- in
+ return (BasicBlock id top : other_blocks, statics)
+
+stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
+stmtsToInstrs stmts
+ = do instrss <- mapM stmtToInstrs stmts
+ return (concatOL instrss)
+
+stmtToInstrs :: CmmStmt -> NatM InstrBlock
+stmtToInstrs stmt = case stmt of
+ CmmNop -> return nilOL
+ CmmComment s -> return (unitOL (COMMENT s))
+
+ CmmAssign reg src
+ | isFloatingRep kind -> assignReg_FltCode kind reg src
+ | wordRep == I32 && kind == I64
+ -> assignReg_I64Code reg src
+ | otherwise -> assignReg_IntCode kind reg src
+ where kind = cmmRegRep reg
+
+ CmmStore addr src
+ | isFloatingRep kind -> assignMem_FltCode kind addr src
+ | wordRep == I32 && kind == I64
+ -> assignMem_I64Code addr src
+ | otherwise -> assignMem_IntCode kind addr src
+ where kind = cmmExprRep src
+
+ CmmCall target result_regs args vols
+ -> genCCall target result_regs args vols
+
+ CmmBranch id -> genBranch id
+ CmmCondBranch arg id -> genCondJump id arg
+ CmmSwitch arg ids -> genSwitch arg ids
+ CmmJump arg params -> genJump arg
+
+-- -----------------------------------------------------------------------------
+-- General things for putting together code sequences
+
+-- Expand CmmRegOff. ToDo: should we do it this way around, or convert
+-- CmmExprs into CmmRegOff?
+mangleIndexTree :: CmmExpr -> CmmExpr
+mangleIndexTree (CmmRegOff reg off)
+ = CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) rep)]
+ where rep = cmmRegRep reg
+
+-- -----------------------------------------------------------------------------
+-- Code gen for 64-bit arithmetic on 32-bit platforms
+
+{-
+Simple support for generating 64-bit code (ie, 64 bit values and 64
+bit assignments) on 32-bit platforms. Unlike the main code generator
+we merely shoot for generating working code as simply as possible, and
+pay little attention to code quality. Specifically, there is no
+attempt to deal cleverly with the fixed-vs-floating register
+distinction; all values are generated into (pairs of) floating
+registers, even if this would mean some redundant reg-reg moves as a
+result. Only one of the VRegUniques is returned, since it will be
+of the VRegUniqueLo form, and the upper-half VReg can be determined
+by applying getHiVRegFromLo to it.
+-}
+
+data ChildCode64 -- a.k.a "Register64"
+ = ChildCode64
+ InstrBlock -- code
+ Reg -- the lower 32-bit temporary which contains the
+ -- result; use getHiVRegFromLo to find the other
+ -- VRegUnique. Rules of this simplified insn
+ -- selection game are therefore that the returned
+ -- Reg may be modified
+
+assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
+iselExpr64 :: CmmExpr -> NatM ChildCode64
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+assignMem_I64Code addrTree valueTree = do
+ Amode addr addr_code <- getAmode addrTree
+ ChildCode64 vcode rlo <- iselExpr64 valueTree
+ let
+ rhi = getHiVRegFromLo rlo
+
+ -- Little-endian store
+ mov_lo = MOV I32 (OpReg rlo) (OpAddr addr)
+ mov_hi = MOV I32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))
+ -- in
+ return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
+
+
+assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
+ ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+ let
+ r_dst_lo = mkVReg u_dst I32
+ r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = MOV I32 (OpReg r_src_lo) (OpReg r_dst_lo)
+ mov_hi = MOV I32 (OpReg r_src_hi) (OpReg r_dst_hi)
+ -- in
+ return (
+ vcode `snocOL` mov_lo `snocOL` mov_hi
+ )
+
+assignReg_I64Code lvalue valueTree
+ = panic "assignReg_I64Code(i386): invalid lvalue"
+
+------------
+
+iselExpr64 (CmmLit (CmmInt i _)) = do
+ (rlo,rhi) <- getNewRegPairNat I32
+ let
+ r = fromIntegral (fromIntegral i :: Word32)
+ q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32)
+ code = toOL [
+ MOV I32 (OpImm (ImmInteger r)) (OpReg rlo),
+ MOV I32 (OpImm (ImmInteger q)) (OpReg rhi)
+ ]
+ -- in
+ return (ChildCode64 code rlo)
+
+iselExpr64 (CmmLoad addrTree I64) = do
+ Amode addr addr_code <- getAmode addrTree
+ (rlo,rhi) <- getNewRegPairNat I32
+ let
+ mov_lo = MOV I32 (OpAddr addr) (OpReg rlo)
+ mov_hi = MOV I32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)
+ -- in
+ return (
+ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
+ rlo
+ )
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64)))
+ = return (ChildCode64 nilOL (mkVReg vu I32))
+
+-- we handle addition, but rather badly
+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do
+ ChildCode64 code1 r1lo <- iselExpr64 e1
+ (rlo,rhi) <- getNewRegPairNat I32
+ let
+ r = fromIntegral (fromIntegral i :: Word32)
+ q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32)
+ r1hi = getHiVRegFromLo r1lo
+ code = code1 `appOL`
+ toOL [ MOV I32 (OpReg r1lo) (OpReg rlo),
+ ADD I32 (OpImm (ImmInteger r)) (OpReg rlo),
+ MOV I32 (OpReg r1hi) (OpReg rhi),
+ ADC I32 (OpImm (ImmInteger q)) (OpReg rhi) ]
+ -- in
+ return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
+ ChildCode64 code1 r1lo <- iselExpr64 e1
+ ChildCode64 code2 r2lo <- iselExpr64 e2
+ (rlo,rhi) <- getNewRegPairNat I32
+ let
+ r1hi = getHiVRegFromLo r1lo
+ r2hi = getHiVRegFromLo r2lo
+ code = code1 `appOL`
+ code2 `appOL`
+ toOL [ MOV I32 (OpReg r1lo) (OpReg rlo),
+ ADD I32 (OpReg r2lo) (OpReg rlo),
+ MOV I32 (OpReg r1hi) (OpReg rhi),
+ ADC I32 (OpReg r2hi) (OpReg rhi) ]
+ -- in
+ return (ChildCode64 code rlo)
+
+iselExpr64 expr
+ = pprPanic "iselExpr64(i386)" (ppr expr)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+assignMem_I64Code addrTree valueTree
+ = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
+ getRegister addrTree `thenNat` \ register_addr ->
+ getNewRegNat IntRep `thenNat` \ t_addr ->
+ let rlo = VirtualRegI vrlo
+ rhi = getHiVRegFromLo rlo
+ code_addr = registerCode register_addr t_addr
+ reg_addr = registerName register_addr t_addr
+ -- Big-endian store
+ mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
+ mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
+ in
+ return (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
+
+
+assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
+ = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
+ let
+ r_dst_lo = mkVReg u_dst IntRep
+ r_src_lo = VirtualRegI vr_src_lo
+ r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = mkMOV r_src_lo r_dst_lo
+ mov_hi = mkMOV r_src_hi r_dst_hi
+ mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+ in
+ return (
+ vcode `snocOL` mov_hi `snocOL` mov_lo
+ )
+assignReg_I64Code lvalue valueTree
+ = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
+ (pprStixReg lvalue)
+
+
+-- Don't delete this -- it's very handy for debugging.
+--iselExpr64 expr
+-- | trace ("iselExpr64: " ++ showSDoc (pprCmmExpr expr)) False
+-- = panic "iselExpr64(???)"
+
+iselExpr64 (CmmLoad I64 addrTree)
+ = getRegister addrTree `thenNat` \ register_addr ->
+ getNewRegNat IntRep `thenNat` \ t_addr ->
+ getNewRegNat IntRep `thenNat` \ rlo ->
+ let rhi = getHiVRegFromLo rlo
+ code_addr = registerCode register_addr t_addr
+ reg_addr = registerName register_addr t_addr
+ mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
+ mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
+ in
+ return (
+ ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
+ (getVRegUnique rlo)
+ )
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64)))
+ = getNewRegNat IntRep `thenNat` \ r_dst_lo ->
+ let r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_lo = mkVReg vu IntRep
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = mkMOV r_src_lo r_dst_lo
+ mov_hi = mkMOV r_src_hi r_dst_hi
+ mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+ in
+ return (
+ ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
+ )
+
+iselExpr64 (StCall fn cconv I64 args)
+ = genCCall fn cconv kind args `thenNat` \ call ->
+ getNewRegNat IntRep `thenNat` \ r_dst_lo ->
+ let r_dst_hi = getHiVRegFromLo r_dst_lo
+ mov_lo = mkMOV o0 r_dst_lo
+ mov_hi = mkMOV o1 r_dst_hi
+ mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+ in
+ return (
+ ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
+ (getVRegUnique r_dst_lo)
+ )
+
+iselExpr64 expr
+ = pprPanic "iselExpr64(sparc)" (pprCmmExpr expr)
+
+#endif /* sparc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if powerpc_TARGET_ARCH
+
+getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
+getI64Amodes addrTree = do
+ Amode hi_addr addr_code <- getAmode addrTree
+ case addrOffset hi_addr 4 of
+ Just lo_addr -> return (hi_addr, lo_addr, addr_code)
+ Nothing -> do (hi_ptr, code) <- getSomeReg addrTree
+ return (AddrRegImm hi_ptr (ImmInt 0),
+ AddrRegImm hi_ptr (ImmInt 4),
+ code)
+
+assignMem_I64Code addrTree valueTree = do
+ (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
+ ChildCode64 vcode rlo <- iselExpr64 valueTree
+ let
+ rhi = getHiVRegFromLo rlo
+
+ -- Big-endian store
+ mov_hi = ST I32 rhi hi_addr
+ mov_lo = ST I32 rlo lo_addr
+ -- in
+ return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
+
+assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
+ ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+ let
+ r_dst_lo = mkVReg u_dst I32
+ r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = MR r_dst_lo r_src_lo
+ mov_hi = MR r_dst_hi r_src_hi
+ -- in
+ return (
+ vcode `snocOL` mov_lo `snocOL` mov_hi
+ )
+
+assignReg_I64Code lvalue valueTree
+ = panic "assignReg_I64Code(powerpc): invalid lvalue"
+
+
+-- Don't delete this -- it's very handy for debugging.
+--iselExpr64 expr
+-- | trace ("iselExpr64: " ++ showSDoc (pprCmmExpr expr)) False
+-- = panic "iselExpr64(???)"
+
+iselExpr64 (CmmLoad addrTree I64) = do
+ (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
+ (rlo, rhi) <- getNewRegPairNat I32
+ let mov_hi = LD I32 rhi hi_addr
+ mov_lo = LD I32 rlo lo_addr
+ return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
+ rlo
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64)))
+ = return (ChildCode64 nilOL (mkVReg vu I32))
+
+iselExpr64 (CmmLit (CmmInt i _)) = do
+ (rlo,rhi) <- getNewRegPairNat I32
+ let
+ half0 = fromIntegral (fromIntegral i :: Word16)
+ half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16)
+ half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16)
+ half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16)
+
+ code = toOL [
+ LIS rlo (ImmInt half1),
+ OR rlo rlo (RIImm $ ImmInt half0),
+ LIS rhi (ImmInt half3),
+ OR rlo rlo (RIImm $ ImmInt half2)
+ ]
+ -- in
+ return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
+ ChildCode64 code1 r1lo <- iselExpr64 e1
+ ChildCode64 code2 r2lo <- iselExpr64 e2
+ (rlo,rhi) <- getNewRegPairNat I32
+ let
+ r1hi = getHiVRegFromLo r1lo
+ r2hi = getHiVRegFromLo r2lo
+ code = code1 `appOL`
+ code2 `appOL`
+ toOL [ ADDC rlo r1lo r2lo,
+ ADDE rhi r1hi r2hi ]
+ -- in
+ return (ChildCode64 code rlo)
+
+iselExpr64 expr
+ = pprPanic "iselExpr64(powerpc)" (ppr expr)
+
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- The 'Register' type
+
+-- 'Register's passed up the tree. If the stix code forces the register
+-- to live in a pre-decided machine register, it comes out as @Fixed@;
+-- otherwise, it comes out as @Any@, and the parent can decide which
+-- register to put it in.
+
+data Register
+ = Fixed MachRep Reg InstrBlock
+ | Any MachRep (Reg -> InstrBlock)
+
+swizzleRegisterRep :: Register -> MachRep -> Register
+swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
+swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
+
+
+-- -----------------------------------------------------------------------------
+-- Grab the Reg for a CmmReg
+
+getRegisterReg :: CmmReg -> Reg
+
+getRegisterReg (CmmLocal (LocalReg u pk))
+ = mkVReg u pk
+
+getRegisterReg (CmmGlobal mid)
+ = case get_GlobalReg_reg_or_addr mid of
+ Left (RealReg rrno) -> RealReg rrno
+ _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+ -- By this stage, the only MagicIds remaining should be the
+ -- ones which map to a real machine register on this
+ -- platform. Hence ...
+
+
+-- -----------------------------------------------------------------------------
+-- Generate code to get a subtree into a Register
+
+-- Don't delete this -- it's very handy for debugging.
+--getRegister expr
+-- | trace ("getRegister: " ++ showSDoc (pprCmmExpr expr)) False
+-- = panic "getRegister(???)"
+
+getRegister :: CmmExpr -> NatM Register
+
+getRegister (CmmReg reg)
+ = return (Fixed (cmmRegRep reg) (getRegisterReg reg) nilOL)
+
+getRegister tree@(CmmRegOff _ _)
+ = getRegister (mangleIndexTree tree)
+
+-- end of machine-"independent" bit; here we go on the rest...
+
+#if alpha_TARGET_ARCH
+
+getRegister (StDouble d)
+ = getBlockIdNat `thenNat` \ lbl ->
+ getNewRegNat PtrRep `thenNat` \ tmp ->
+ let code dst = mkSeqInstrs [
+ LDATA RoDataSegment lbl [
+ DATA TF [ImmLab (rational d)]
+ ],
+ LDA tmp (AddrImm (ImmCLbl lbl)),
+ LD TF dst (AddrReg tmp)]
+ in
+ return (Any F64 code)
+
+getRegister (StPrim primop [x]) -- unary PrimOps
+ = case primop of
+ IntNegOp -> trivialUCode (NEG Q False) x
+
+ NotOp -> trivialUCode NOT x
+
+ FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
+ DoubleNegOp -> trivialUFCode F64 (FNEG TF) x
+
+ OrdOp -> coerceIntCode IntRep x
+ ChrOp -> chrCode x
+
+ Float2IntOp -> coerceFP2Int x
+ Int2FloatOp -> coerceInt2FP pr x
+ Double2IntOp -> coerceFP2Int x
+ Int2DoubleOp -> coerceInt2FP pr x
+
+ Double2FloatOp -> coerceFltCode x
+ Float2DoubleOp -> coerceFltCode x
+
+ other_op -> getRegister (StCall fn CCallConv F64 [x])
+ where
+ fn = case other_op of
+ FloatExpOp -> FSLIT("exp")
+ FloatLogOp -> FSLIT("log")
+ FloatSqrtOp -> FSLIT("sqrt")
+ FloatSinOp -> FSLIT("sin")
+ FloatCosOp -> FSLIT("cos")
+ FloatTanOp -> FSLIT("tan")
+ FloatAsinOp -> FSLIT("asin")
+ FloatAcosOp -> FSLIT("acos")
+ FloatAtanOp -> FSLIT("atan")
+ FloatSinhOp -> FSLIT("sinh")
+ FloatCoshOp -> FSLIT("cosh")
+ FloatTanhOp -> FSLIT("tanh")
+ DoubleExpOp -> FSLIT("exp")
+ DoubleLogOp -> FSLIT("log")
+ DoubleSqrtOp -> FSLIT("sqrt")
+ DoubleSinOp -> FSLIT("sin")
+ DoubleCosOp -> FSLIT("cos")
+ DoubleTanOp -> FSLIT("tan")
+ DoubleAsinOp -> FSLIT("asin")
+ DoubleAcosOp -> FSLIT("acos")
+ DoubleAtanOp -> FSLIT("atan")
+ DoubleSinhOp -> FSLIT("sinh")
+ DoubleCoshOp -> FSLIT("cosh")
+ DoubleTanhOp -> FSLIT("tanh")
+ where
+ pr = panic "MachCode.getRegister: no primrep needed for Alpha"
+
+getRegister (StPrim primop [x, y]) -- dyadic PrimOps
+ = case primop of
+ CharGtOp -> trivialCode (CMP LTT) y x
+ CharGeOp -> trivialCode (CMP LE) y x
+ CharEqOp -> trivialCode (CMP EQQ) x y
+ CharNeOp -> int_NE_code x y
+ CharLtOp -> trivialCode (CMP LTT) x y
+ CharLeOp -> trivialCode (CMP LE) x y
+
+ IntGtOp -> trivialCode (CMP LTT) y x
+ IntGeOp -> trivialCode (CMP LE) y x
+ IntEqOp -> trivialCode (CMP EQQ) x y
+ IntNeOp -> int_NE_code x y
+ IntLtOp -> trivialCode (CMP LTT) x y
+ IntLeOp -> trivialCode (CMP LE) x y
+
+ WordGtOp -> trivialCode (CMP ULT) y x
+ WordGeOp -> trivialCode (CMP ULE) x y
+ WordEqOp -> trivialCode (CMP EQQ) x y
+ WordNeOp -> int_NE_code x y
+ WordLtOp -> trivialCode (CMP ULT) x y
+ WordLeOp -> trivialCode (CMP ULE) x y
+
+ AddrGtOp -> trivialCode (CMP ULT) y x
+ AddrGeOp -> trivialCode (CMP ULE) y x
+ AddrEqOp -> trivialCode (CMP EQQ) x y
+ AddrNeOp -> int_NE_code x y
+ AddrLtOp -> trivialCode (CMP ULT) x y
+ AddrLeOp -> trivialCode (CMP ULE) x y
+
+ FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+ FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+ FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+ FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+ FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
+ FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
+
+ DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+ DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+ DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+ DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+ DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
+ DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
+
+ IntAddOp -> trivialCode (ADD Q False) x y
+ IntSubOp -> trivialCode (SUB Q False) x y
+ IntMulOp -> trivialCode (MUL Q False) x y
+ IntQuotOp -> trivialCode (DIV Q False) x y
+ IntRemOp -> trivialCode (REM Q False) x y
+
+ WordAddOp -> trivialCode (ADD Q False) x y
+ WordSubOp -> trivialCode (SUB Q False) x y
+ WordMulOp -> trivialCode (MUL Q False) x y
+ WordQuotOp -> trivialCode (DIV Q True) x y
+ WordRemOp -> trivialCode (REM Q True) x y
+
+ FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
+ FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
+ FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
+ FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
+
+ DoubleAddOp -> trivialFCode F64 (FADD TF) x y
+ DoubleSubOp -> trivialFCode F64 (FSUB TF) x y
+ DoubleMulOp -> trivialFCode F64 (FMUL TF) x y
+ DoubleDivOp -> trivialFCode F64 (FDIV TF) x y
+
+ AddrAddOp -> trivialCode (ADD Q False) x y
+ AddrSubOp -> trivialCode (SUB Q False) x y
+ AddrRemOp -> trivialCode (REM Q True) x y
+
+ AndOp -> trivialCode AND x y
+ OrOp -> trivialCode OR x y
+ XorOp -> trivialCode XOR x y
+ SllOp -> trivialCode SLL x y
+ SrlOp -> trivialCode SRL x y
+
+ ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
+ ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
+ ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
+
+ FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv F64 [x,y])
+ DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv F64 [x,y])
+ where
+ {- ------------------------------------------------------------
+ Some bizarre special code for getting condition codes into
+ registers. Integer non-equality is a test for equality
+ followed by an XOR with 1. (Integer comparisons always set
+ the result register to 0 or 1.) Floating point comparisons of
+ any kind leave the result in a floating point register, so we
+ need to wrangle an integer register out of things.
+ -}
+ int_NE_code :: StixTree -> StixTree -> NatM Register
+
+ int_NE_code x y
+ = trivialCode (CMP EQQ) x y `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
+ in
+ return (Any IntRep code__2)
+
+ {- ------------------------------------------------------------
+ Comments for int_NE_code also apply to cmpF_code
+ -}
+ cmpF_code
+ :: (Reg -> Reg -> Reg -> Instr)
+ -> Cond
+ -> StixTree -> StixTree
+ -> NatM Register
+
+ cmpF_code instr cond x y
+ = trivialFCode pr instr x y `thenNat` \ register ->
+ getNewRegNat F64 `thenNat` \ tmp ->
+ getBlockIdNat `thenNat` \ lbl ->
+ let
+ code = registerCode register tmp
+ result = registerName register tmp
+
+ code__2 dst = code . mkSeqInstrs [
+ OR zeroh (RIImm (ImmInt 1)) dst,
+ BF cond result (ImmCLbl lbl),
+ OR zeroh (RIReg zeroh) dst,
+ NEWBLOCK lbl]
+ in
+ return (Any IntRep code__2)
+ where
+ pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
+ ------------------------------------------------------------
+
+getRegister (CmmLoad pk mem)
+ = getAmode mem `thenNat` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ size = primRepToSize pk
+ code__2 dst = code . mkSeqInstr (LD size dst src)
+ in
+ return (Any pk code__2)
+
+getRegister (StInt i)
+ | fits8Bits i
+ = let
+ code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
+ in
+ return (Any IntRep code)
+ | otherwise
+ = let
+ code dst = mkSeqInstr (LDI Q dst src)
+ in
+ return (Any IntRep code)
+ where
+ src = ImmInt (fromInteger i)
+
+getRegister leaf
+ | isJust imm
+ = let
+ code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
+ in
+ return (Any PtrRep code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+getRegister (CmmLit (CmmFloat f F32)) = do
+ lbl <- getNewLabelNat
+ let code dst = toOL [
+ LDATA ReadOnlyData
+ [CmmDataLabel lbl,
+ CmmStaticLit (CmmFloat f F32)],
+ GLD F32 (ImmAddr (ImmCLbl lbl) 0) dst
+ ]
+ -- in
+ return (Any F32 code)
+
+
+getRegister (CmmLit (CmmFloat d F64))
+ | d == 0.0
+ = let code dst = unitOL (GLDZ dst)
+ in return (Any F64 code)
+
+ | d == 1.0
+ = let code dst = unitOL (GLD1 dst)
+ in return (Any F64 code)
+
+ | otherwise = do
+ lbl <- getNewLabelNat
+ let code dst = toOL [
+ LDATA ReadOnlyData
+ [CmmDataLabel lbl,
+ CmmStaticLit (CmmFloat d F64)],
+ GLD F64 (ImmAddr (ImmCLbl lbl) 0) dst
+ ]
+ -- in
+ return (Any F64 code)
+
+
+-- catch simple cases of zero- or sign-extended load
+getRegister (CmmMachOp (MO_U_Conv I8 I32) [CmmLoad addr _]) = do
+ code <- intLoadCode (MOVZxL I8) addr
+ return (Any I32 code)
+
+getRegister (CmmMachOp (MO_S_Conv I8 I32) [CmmLoad addr _]) = do
+ code <- intLoadCode (MOVSxL I8) addr
+ return (Any I32 code)
+
+getRegister (CmmMachOp (MO_U_Conv I16 I32) [CmmLoad addr _]) = do
+ code <- intLoadCode (MOVZxL I16) addr
+ return (Any I32 code)
+
+getRegister (CmmMachOp (MO_S_Conv I16 I32) [CmmLoad addr _]) = do
+ code <- intLoadCode (MOVSxL I16) addr
+ return (Any I32 code)
+
+
+getRegister (CmmMachOp mop [x]) -- unary MachOps
+ = case mop of
+ MO_S_Neg F32 -> trivialUFCode F32 (GNEG F32) x
+ MO_S_Neg F64 -> trivialUFCode F64 (GNEG F64) x
+
+ MO_S_Neg rep -> trivialUCode rep (NEGI rep) x
+ MO_Not rep -> trivialUCode rep (NOT rep) x
+
+ -- Nop conversions
+ -- TODO: these are only nops if the arg is not a fixed register that
+ -- can't be byte-addressed.
+ MO_U_Conv I32 I8 -> conversionNop I32 x
+ MO_S_Conv I32 I8 -> conversionNop I32 x
+ MO_U_Conv I16 I8 -> conversionNop I16 x
+ MO_S_Conv I16 I8 -> conversionNop I16 x
+ MO_U_Conv I32 I16 -> conversionNop I32 x
+ MO_S_Conv I32 I16 -> conversionNop I32 x
+ MO_U_Conv rep1 rep2 | rep1 == rep2 -> conversionNop rep1 x
+ MO_S_Conv rep1 rep2 | rep1 == rep2 -> conversionNop rep1 x
+
+ -- widenings
+ MO_U_Conv I8 I32 -> integerExtend I8 I32 MOVZxL x
+ MO_U_Conv I16 I32 -> integerExtend I16 I32 MOVZxL x
+ MO_U_Conv I8 I16 -> integerExtend I8 I16 MOVZxL x
+
+ MO_S_Conv I8 I32 -> integerExtend I8 I32 MOVSxL x
+ MO_S_Conv I16 I32 -> integerExtend I16 I32 MOVSxL x
+ MO_S_Conv I8 I16 -> integerExtend I8 I16 MOVSxL x
+
+ MO_S_Conv F32 F64 -> conversionNop F64 x
+ MO_S_Conv F64 F32 -> conversionNop F32 x
+ MO_S_Conv from to
+ | isFloatingRep from -> coerceFP2Int from to x
+ | isFloatingRep to -> coerceInt2FP from to x
+
+ where
+ -- signed or unsigned extension.
+ integerExtend from to instr expr = do
+ (reg,e_code) <- if from == I8 then getByteReg expr
+ else getSomeReg expr
+ let
+ code dst =
+ e_code `snocOL`
+ instr from (OpReg reg) (OpReg dst)
+ return (Any to code)
+
+ conversionNop new_rep expr
+ = do e_code <- getRegister expr
+ return (swizzleRegisterRep e_code new_rep)
+
+
+getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps
+ = ASSERT2(cmmExprRep x /= I8, pprExpr e)
+ case mop of
+ MO_Eq F32 -> condFltReg EQQ x y
+ MO_Ne F32 -> condFltReg NE x y
+ MO_S_Gt F32 -> condFltReg GTT x y
+ MO_S_Ge F32 -> condFltReg GE x y
+ MO_S_Lt F32 -> condFltReg LTT x y
+ MO_S_Le F32 -> condFltReg LE x y
+
+ MO_Eq F64 -> condFltReg EQQ x y
+ MO_Ne F64 -> condFltReg NE x y
+ MO_S_Gt F64 -> condFltReg GTT x y
+ MO_S_Ge F64 -> condFltReg GE x y
+ MO_S_Lt F64 -> condFltReg LTT x y
+ MO_S_Le F64 -> condFltReg LE x y
+
+ MO_Eq rep -> condIntReg EQQ x y
+ MO_Ne rep -> condIntReg NE x y
+
+ MO_S_Gt rep -> condIntReg GTT x y
+ MO_S_Ge rep -> condIntReg GE x y
+ MO_S_Lt rep -> condIntReg LTT x y
+ MO_S_Le rep -> condIntReg LE x y
+
+ MO_U_Gt rep -> condIntReg GU x y
+ MO_U_Ge rep -> condIntReg GEU x y
+ MO_U_Lt rep -> condIntReg LU x y
+ MO_U_Le rep -> condIntReg LEU x y
+
+ MO_Add F32 -> trivialFCode F32 GADD x y
+ MO_Sub F32 -> trivialFCode F32 GSUB x y
+
+ MO_Add F64 -> trivialFCode F64 GADD x y
+ MO_Sub F64 -> trivialFCode F64 GSUB x y
+
+ MO_S_Quot F32 -> trivialFCode F32 GDIV x y
+ MO_S_Quot F64 -> trivialFCode F64 GDIV x y
+
+ MO_Add rep -> add_code rep x y
+ MO_Sub rep -> sub_code rep x y
+
+ MO_S_Quot rep -> div_code rep True True x y
+ MO_S_Rem rep -> div_code rep True False x y
+ MO_U_Quot rep -> div_code rep False True x y
+ MO_U_Rem rep -> div_code rep False False x y
+
+ MO_Mul F32 -> trivialFCode F32 GMUL x y
+ MO_Mul F64 -> trivialFCode F64 GMUL x y
+ MO_Mul rep -> let op = IMUL rep in
+ trivialCode rep op (Just op) x y
+
+ MO_S_MulMayOflo rep -> imulMayOflo rep x y
+
+ MO_And rep -> let op = AND rep in
+ trivialCode rep op (Just op) x y
+ MO_Or rep -> let op = OR rep in
+ trivialCode rep op (Just op) x y
+ MO_Xor rep -> let op = XOR rep in
+ trivialCode rep op (Just op) x y
+
+ {- Shift ops on x86s have constraints on their source, it
+ either has to be Imm, CL or 1
+ => trivialCode is not restrictive enough (sigh.)
+ -}
+ MO_Shl rep -> shift_code rep (SHL rep) x y {-False-}
+ MO_U_Shr rep -> shift_code rep (SHR rep) x y {-False-}
+ MO_S_Shr rep -> shift_code rep (SAR rep) x y {-False-}
+
+ other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
+ where
+ --------------------
+ imulMayOflo :: MachRep -> CmmExpr -> CmmExpr -> NatM Register
+ imulMayOflo I32 a b = do
+ res_lo <- getNewRegNat I32
+ res_hi <- getNewRegNat I32
+ (a_reg, a_code) <- getNonClobberedReg a
+ (b_reg, b_code) <- getSomeReg b
+ let
+ code dst = a_code `appOL` b_code `appOL`
+ toOL [
+ MOV I32 (OpReg a_reg) (OpReg res_hi),
+ MOV I32 (OpReg b_reg) (OpReg res_lo),
+ IMUL64 res_hi res_lo, -- result in res_hi:res_lo
+ SAR I32 (OpImm (ImmInt 31)) (OpReg res_lo), -- sign extend lower part
+ SUB I32 (OpReg res_hi) (OpReg res_lo), -- compare against upper
+ MOV I32 (OpReg res_lo) (OpReg dst)
+ -- dst==0 if high part == sign extended low part
+ ]
+ -- in
+ return (Any I32 code)
+
+ --------------------
+ shift_code :: MachRep
+ -> (Operand -> Operand -> Instr)
+ -> CmmExpr
+ -> CmmExpr
+ -> NatM Register
+
+ {- Case1: shift length as immediate -}
+ shift_code rep instr x y@(CmmLit lit) = do
+ x_code <- getAnyReg x
+ let
+ code dst
+ = x_code dst `snocOL`
+ instr (OpImm (litToImm lit)) (OpReg dst)
+ -- in
+ return (Any rep code)
+
+ {- Case2: shift length is complex (non-immediate) -}
+ shift_code rep instr x y{-amount-} = do
+ (x_reg, x_code) <- getNonClobberedReg x
+ y_code <- getAnyReg y
+ let
+ code = x_code `appOL`
+ y_code ecx `snocOL`
+ instr (OpReg ecx) (OpReg x_reg)
+ -- in
+ return (Fixed rep x_reg code)
+
+ --------------------
+ add_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register
+ add_code rep x (CmmLit (CmmInt y _)) = add_int rep x y
+ add_code rep x y = trivialCode rep (ADD rep) (Just (ADD rep)) x y
+
+ --------------------
+ sub_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register
+ sub_code rep x (CmmLit (CmmInt y _)) = add_int rep x (-y)
+ sub_code rep x y = trivialCode rep (SUB rep) Nothing x y
+
+ -- our three-operand add instruction:
+ add_int rep x y = do
+ (x_reg, x_code) <- getSomeReg x
+ let
+ imm = ImmInt (fromInteger y)
+ code dst
+ = x_code `snocOL`
+ LEA rep
+ (OpAddr (AddrBaseIndex (Just x_reg) Nothing imm))
+ (OpReg dst)
+ --
+ return (Any rep code)
+
+ ----------------------
+ div_code rep signed quotient x y = do
+ (y_op, y_code) <- getOperand y -- cannot be clobbered
+ x_code <- getAnyReg x
+ let
+ widen | signed = CLTD
+ | otherwise = XOR rep (OpReg edx) (OpReg edx)
+
+ instr | signed = IDIV
+ | otherwise = DIV
+
+ code = y_code `appOL`
+ x_code eax `appOL`
+ toOL [widen, instr rep y_op]
+
+ result | quotient = eax
+ | otherwise = edx
+
+ -- in
+ return (Fixed rep result code)
+
+
+
+getRegister (CmmLoad mem pk)
+ | isFloatingRep pk
+ = do
+ Amode src mem_code <- getAmode mem
+ let
+ code dst = mem_code `snocOL`
+ GLD pk src dst
+ --
+ return (Any pk code)
+
+getRegister (CmmLoad mem pk)
+ | pk /= I64
+ = do
+ code <- intLoadCode (instr pk) mem
+ return (Any pk code)
+ where
+ instr I8 = MOVZxL pk
+ instr I16 = MOV I16
+ instr I32 = MOV I32
+ -- we always zero-extend 8-bit loads, if we
+ -- can't think of anything better. This is because
+ -- we can't guarantee access to an 8-bit variant of every register
+ -- (esi and edi don't have 8-bit variants), so to make things
+ -- simpler we do our 8-bit arithmetic with full 32-bit registers.
+
+getRegister (CmmLit (CmmInt 0 rep))
+ = let
+ code dst
+ = unitOL (XOR rep (OpReg dst) (OpReg dst))
+ in
+ return (Any rep code)
+
+getRegister (CmmLit lit)
+ = let
+ rep = cmmLitRep lit
+ imm = litToImm lit
+ code dst = unitOL (MOV rep (OpImm imm) (OpReg dst))
+ in
+ return (Any rep code)
+
+getRegister other = panic "getRegister(x86)"
+
+
+intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
+ -> NatM (Reg -> InstrBlock)
+intLoadCode instr mem = do
+ Amode src mem_code <- getAmode mem
+ return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))
+
+-- Compute an expression into *any* register, adding the appropriate
+-- move instruction if necessary.
+getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
+getAnyReg expr = do
+ r <- getRegister expr
+ anyReg r
+
+anyReg :: Register -> NatM (Reg -> InstrBlock)
+anyReg (Any _ code) = return code
+anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
+
+-- The dual to getAnyReg: compute an expression into a register, but
+-- we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+ r <- getRegister expr
+ case r of
+ Any rep code -> do
+ tmp <- getNewRegNat rep
+ return (tmp, code tmp)
+ Fixed _ reg code ->
+ return (reg, code)
+
+-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
+-- Fixed registers might not be byte-addressable, so we make sure we've
+-- got a temporary, inserting an extra reg copy if necessary.
+getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getByteReg expr = do
+ r <- getRegister expr
+ case r of
+ Any rep code -> do
+ tmp <- getNewRegNat rep
+ return (tmp, code tmp)
+ Fixed rep reg code
+ | isVirtualReg reg -> return (reg,code)
+ | otherwise -> do
+ tmp <- getNewRegNat rep
+ return (tmp, code `snocOL` reg2reg rep reg tmp)
+ -- ToDo: could optimise slightly by checking for byte-addressable
+ -- real registers, but that will happen very rarely if at all.
+
+-- Another variant: this time we want the result in a register that cannot
+-- be modified by code to evaluate an arbitrary expression.
+getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getNonClobberedReg expr = do
+ r <- getRegister expr
+ case r of
+ Any rep code -> do
+ tmp <- getNewRegNat rep
+ return (tmp, code tmp)
+ Fixed rep reg code
+ -- only free regs can be clobbered
+ | RealReg rr <- reg, isFastTrue (freeReg rr) -> do
+ tmp <- getNewRegNat rep
+ return (tmp, code `snocOL` reg2reg rep reg tmp)
+ | otherwise ->
+ return (reg, code)
+
+reg2reg :: MachRep -> Reg -> Reg -> Instr
+reg2reg rep src dst
+ | isFloatingRep rep = GMOV src dst
+ | otherwise = MOV rep (OpReg src) (OpReg dst)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+getRegister (StFloat d)
+ = getBlockIdNat `thenNat` \ lbl ->
+ getNewRegNat PtrRep `thenNat` \ tmp ->
+ let code dst = toOL [
+ SEGMENT DataSegment,
+ NEWBLOCK lbl,
+ DATA F [ImmFloat d],
+ SEGMENT TextSegment,
+ SETHI (HI (ImmCLbl lbl)) tmp,
+ LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+ in
+ return (Any F32 code)
+
+getRegister (StDouble d)
+ = getBlockIdNat `thenNat` \ lbl ->
+ getNewRegNat PtrRep `thenNat` \ tmp ->
+ let code dst = toOL [
+ SEGMENT DataSegment,
+ NEWBLOCK lbl,
+ DATA DF [ImmDouble d],
+ SEGMENT TextSegment,
+ SETHI (HI (ImmCLbl lbl)) tmp,
+ LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+ in
+ return (Any F64 code)
+
+
+getRegister (CmmMachOp mop [x]) -- unary PrimOps
+ = case mop of
+ MO_NatS_Neg -> trivialUCode (SUB False False g0) x
+ MO_Nat_Not -> trivialUCode (XNOR False g0) x
+ MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
+
+ MO_F32_Neg -> trivialUFCode F32 (FNEG F) x
+ MO_F64_Neg -> trivialUFCode F64 (FNEG DF) x
+
+ MO_F64_to_Flt -> coerceDbl2Flt x
+ MO_F32_to_Dbl -> coerceFlt2Dbl x
+
+ MO_F32_to_NatS -> coerceFP2Int F32 x
+ MO_NatS_to_Flt -> coerceInt2FP F32 x
+ MO_F64_to_NatS -> coerceFP2Int F64 x
+ MO_NatS_to_Dbl -> coerceInt2FP F64 x
+
+ -- Conversions which are a nop on sparc
+ MO_32U_to_NatS -> conversionNop IntRep x
+ MO_32S_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_32U -> conversionNop WordRep x
+ MO_32U_to_NatU -> conversionNop WordRep x
+
+ MO_NatU_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_NatU -> conversionNop WordRep x
+ MO_NatP_to_NatU -> conversionNop WordRep x
+ MO_NatU_to_NatP -> conversionNop PtrRep x
+ MO_NatS_to_NatP -> conversionNop PtrRep x
+ MO_NatP_to_NatS -> conversionNop IntRep x
+
+ -- sign-extending widenings
+ MO_8U_to_32U -> integerExtend False 24 x
+ MO_8U_to_NatU -> integerExtend False 24 x
+ MO_8S_to_NatS -> integerExtend True 24 x
+ MO_16U_to_NatU -> integerExtend False 16 x
+ MO_16S_to_NatS -> integerExtend True 16 x
+
+ other_op ->
+ let fixed_x = if is_float_op -- promote to double
+ then CmmMachOp MO_F32_to_Dbl [x]
+ else x
+ in
+ getRegister (StCall (Left fn) CCallConv F64 [fixed_x])
+ where
+ integerExtend signed nBits x
+ = getRegister (
+ CmmMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
+ [CmmMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
+ )
+ conversionNop new_rep expr
+ = getRegister expr `thenNat` \ e_code ->
+ return (swizzleRegisterRep e_code new_rep)
+
+ (is_float_op, fn)
+ = case mop of
+ MO_F32_Exp -> (True, FSLIT("exp"))
+ MO_F32_Log -> (True, FSLIT("log"))
+ MO_F32_Sqrt -> (True, FSLIT("sqrt"))
+
+ MO_F32_Sin -> (True, FSLIT("sin"))
+ MO_F32_Cos -> (True, FSLIT("cos"))
+ MO_F32_Tan -> (True, FSLIT("tan"))
+
+ MO_F32_Asin -> (True, FSLIT("asin"))
+ MO_F32_Acos -> (True, FSLIT("acos"))
+ MO_F32_Atan -> (True, FSLIT("atan"))
+
+ MO_F32_Sinh -> (True, FSLIT("sinh"))
+ MO_F32_Cosh -> (True, FSLIT("cosh"))
+ MO_F32_Tanh -> (True, FSLIT("tanh"))
+
+ MO_F64_Exp -> (False, FSLIT("exp"))
+ MO_F64_Log -> (False, FSLIT("log"))
+ MO_F64_Sqrt -> (False, FSLIT("sqrt"))
+
+ MO_F64_Sin -> (False, FSLIT("sin"))
+ MO_F64_Cos -> (False, FSLIT("cos"))
+ MO_F64_Tan -> (False, FSLIT("tan"))
+
+ MO_F64_Asin -> (False, FSLIT("asin"))
+ MO_F64_Acos -> (False, FSLIT("acos"))
+ MO_F64_Atan -> (False, FSLIT("atan"))
+
+ MO_F64_Sinh -> (False, FSLIT("sinh"))
+ MO_F64_Cosh -> (False, FSLIT("cosh"))
+ MO_F64_Tanh -> (False, FSLIT("tanh"))
+
+ other -> pprPanic "getRegister(sparc) - binary CmmMachOp (2)"
+ (pprMachOp mop)
+
+
+getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
+ = case mop of
+ MO_32U_Gt -> condIntReg GTT x y
+ MO_32U_Ge -> condIntReg GE x y
+ MO_32U_Eq -> condIntReg EQQ x y
+ MO_32U_Ne -> condIntReg NE x y
+ MO_32U_Lt -> condIntReg LTT x y
+ MO_32U_Le -> condIntReg LE x y
+
+ MO_Nat_Eq -> condIntReg EQQ x y
+ MO_Nat_Ne -> condIntReg NE x y
+
+ MO_NatS_Gt -> condIntReg GTT x y
+ MO_NatS_Ge -> condIntReg GE x y
+ MO_NatS_Lt -> condIntReg LTT x y
+ MO_NatS_Le -> condIntReg LE x y
+
+ MO_NatU_Gt -> condIntReg GU x y
+ MO_NatU_Ge -> condIntReg GEU x y
+ MO_NatU_Lt -> condIntReg LU x y
+ MO_NatU_Le -> condIntReg LEU x y
+
+ MO_F32_Gt -> condFltReg GTT x y
+ MO_F32_Ge -> condFltReg GE x y
+ MO_F32_Eq -> condFltReg EQQ x y
+ MO_F32_Ne -> condFltReg NE x y
+ MO_F32_Lt -> condFltReg LTT x y
+ MO_F32_Le -> condFltReg LE x y
+
+ MO_F64_Gt -> condFltReg GTT x y
+ MO_F64_Ge -> condFltReg GE x y
+ MO_F64_Eq -> condFltReg EQQ x y
+ MO_F64_Ne -> condFltReg NE x y
+ MO_F64_Lt -> condFltReg LTT x y
+ MO_F64_Le -> condFltReg LE x y
+
+ MO_Nat_Add -> trivialCode (ADD False False) x y
+ MO_Nat_Sub -> trivialCode (SUB False False) x y
+
+ MO_NatS_Mul -> trivialCode (SMUL False) x y
+ MO_NatU_Mul -> trivialCode (UMUL False) x y
+ MO_NatS_MulMayOflo -> imulMayOflo x y
+
+ -- ToDo: teach about V8+ SPARC div instructions
+ MO_NatS_Quot -> idiv FSLIT(".div") x y
+ MO_NatS_Rem -> idiv FSLIT(".rem") x y
+ MO_NatU_Quot -> idiv FSLIT(".udiv") x y
+ MO_NatU_Rem -> idiv FSLIT(".urem") x y
+
+ MO_F32_Add -> trivialFCode F32 FADD x y
+ MO_F32_Sub -> trivialFCode F32 FSUB x y
+ MO_F32_Mul -> trivialFCode F32 FMUL x y
+ MO_F32_Div -> trivialFCode F32 FDIV x y
+
+ MO_F64_Add -> trivialFCode F64 FADD x y
+ MO_F64_Sub -> trivialFCode F64 FSUB x y
+ MO_F64_Mul -> trivialFCode F64 FMUL x y
+ MO_F64_Div -> trivialFCode F64 FDIV x y
+
+ MO_Nat_And -> trivialCode (AND False) x y
+ MO_Nat_Or -> trivialCode (OR False) x y
+ MO_Nat_Xor -> trivialCode (XOR False) x y
+
+ MO_Nat_Shl -> trivialCode SLL x y
+ MO_Nat_Shr -> trivialCode SRL x y
+ MO_Nat_Sar -> trivialCode SRA x y
+
+ MO_F32_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64
+ [promote x, promote y])
+ where promote x = CmmMachOp MO_F32_to_Dbl [x]
+ MO_F64_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64
+ [x, y])
+
+ other -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)
+ where
+ idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
+
+ --------------------
+ imulMayOflo :: CmmExpr -> CmmExpr -> NatM Register
+ imulMayOflo a1 a2
+ = getNewRegNat IntRep `thenNat` \ t1 ->
+ getNewRegNat IntRep `thenNat` \ t2 ->
+ getNewRegNat IntRep `thenNat` \ res_lo ->
+ getNewRegNat IntRep `thenNat` \ res_hi ->
+ getRegister a1 `thenNat` \ reg1 ->
+ getRegister a2 `thenNat` \ reg2 ->
+ let code1 = registerCode reg1 t1
+ code2 = registerCode reg2 t2
+ src1 = registerName reg1 t1
+ src2 = registerName reg2 t2
+ code dst = code1 `appOL` code2 `appOL`
+ toOL [
+ SMUL False src1 (RIReg src2) res_lo,
+ RDY res_hi,
+ SRA res_lo (RIImm (ImmInt 31)) res_lo,
+ SUB False False res_lo (RIReg res_hi) dst
+ ]
+ in
+ return (Any IntRep code)
+
+getRegister (CmmLoad pk mem) = do
+ Amode src code <- getAmode mem
+ let
+ size = primRepToSize pk
+ code__2 dst = code `snocOL` LD size src dst
+ --
+ return (Any pk code__2)
+
+getRegister (StInt i)
+ | fits13Bits i
+ = let
+ src = ImmInt (fromInteger i)
+ code dst = unitOL (OR False g0 (RIImm src) dst)
+ in
+ return (Any IntRep code)
+
+getRegister leaf
+ | isJust imm
+ = let
+ code dst = toOL [
+ SETHI (HI imm__2) dst,
+ OR False dst (RIImm (LO imm__2)) dst]
+ in
+ return (Any PtrRep code)
+ | otherwise
+ = ncgPrimopMoan "getRegister(sparc)" (pprCmmExpr leaf)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+getRegister (CmmLoad mem pk)
+ | pk /= I64
+ = do
+ Amode addr addr_code <- getAmode mem
+ let code dst = ASSERT((regClass dst == RcDouble) == isFloatingRep pk)
+ addr_code `snocOL` LD pk dst addr
+ return (Any pk code)
+
+-- catch simple cases of zero- or sign-extended load
+getRegister (CmmMachOp (MO_U_Conv I8 I32) [CmmLoad mem _]) = do
+ Amode addr addr_code <- getAmode mem
+ return (Any I32 (\dst -> addr_code `snocOL` LD I8 dst addr))
+
+-- Note: there is no Load Byte Arithmetic instruction, so no signed case here
+
+getRegister (CmmMachOp (MO_U_Conv I16 I32) [CmmLoad mem _]) = do
+ Amode addr addr_code <- getAmode mem
+ return (Any I32 (\dst -> addr_code `snocOL` LD I16 dst addr))
+
+getRegister (CmmMachOp (MO_S_Conv I16 I32) [CmmLoad mem _]) = do
+ Amode addr addr_code <- getAmode mem
+ return (Any I32 (\dst -> addr_code `snocOL` LA I16 dst addr))
+
+getRegister (CmmMachOp mop [x]) -- unary MachOps
+ = case mop of
+ MO_Not rep -> trivialUCode rep NOT x
+
+ MO_S_Conv F64 F32 -> trivialUCode F32 FRSP x
+ MO_S_Conv F32 F64 -> conversionNop F64 x
+
+ MO_S_Conv from to
+ | from == to -> conversionNop to x
+ | isFloatingRep from -> coerceFP2Int from to x
+ | isFloatingRep to -> coerceInt2FP from to x
+
+ -- narrowing is a nop: we treat the high bits as undefined
+ MO_S_Conv I32 to -> conversionNop to x
+ MO_S_Conv I16 I8 -> conversionNop I8 x
+ MO_S_Conv I8 to -> trivialUCode to (EXTS I8) x
+ MO_S_Conv I16 to -> trivialUCode to (EXTS I16) x
+
+ MO_U_Conv from to
+ | from == to -> conversionNop to x
+ -- narrowing is a nop: we treat the high bits as undefined
+ MO_U_Conv I32 to -> conversionNop to x
+ MO_U_Conv I16 I8 -> conversionNop I8 x
+ MO_U_Conv I8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 I32))
+ MO_U_Conv I16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 I32))
+
+ MO_S_Neg F32 -> trivialUCode F32 FNEG x
+ MO_S_Neg F64 -> trivialUCode F64 FNEG x
+ MO_S_Neg rep -> trivialUCode rep NEG x
+
+ where
+ conversionNop new_rep expr
+ = do e_code <- getRegister expr
+ return (swizzleRegisterRep e_code new_rep)
+
+getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
+ = case mop of
+ MO_Eq F32 -> condFltReg EQQ x y
+ MO_Ne F32 -> condFltReg NE x y
+
+ MO_S_Gt F32 -> condFltReg GTT x y
+ MO_S_Ge F32 -> condFltReg GE x y
+ MO_S_Lt F32 -> condFltReg LTT x y
+ MO_S_Le F32 -> condFltReg LE x y
+
+ MO_Eq F64 -> condFltReg EQQ x y
+ MO_Ne F64 -> condFltReg NE x y
+
+ MO_S_Gt F64 -> condFltReg GTT x y
+ MO_S_Ge F64 -> condFltReg GE x y
+ MO_S_Lt F64 -> condFltReg LTT x y
+ MO_S_Le F64 -> condFltReg LE x y
+
+ MO_Eq rep -> condIntReg EQQ (extendUExpr rep x) (extendUExpr rep y)
+ MO_Ne rep -> condIntReg NE (extendUExpr rep x) (extendUExpr rep y)
+
+ MO_S_Gt rep -> condIntReg GTT (extendSExpr rep x) (extendSExpr rep y)
+ MO_S_Ge rep -> condIntReg GE (extendSExpr rep x) (extendSExpr rep y)
+ MO_S_Lt rep -> condIntReg LTT (extendSExpr rep x) (extendSExpr rep y)
+ MO_S_Le rep -> condIntReg LE (extendSExpr rep x) (extendSExpr rep y)
+
+ MO_U_Gt rep -> condIntReg GU (extendUExpr rep x) (extendUExpr rep y)
+ MO_U_Ge rep -> condIntReg GEU (extendUExpr rep x) (extendUExpr rep y)
+ MO_U_Lt rep -> condIntReg LU (extendUExpr rep x) (extendUExpr rep y)
+ MO_U_Le rep -> condIntReg LEU (extendUExpr rep x) (extendUExpr rep y)
+
+ MO_Add F32 -> trivialCodeNoImm F32 (FADD F32) x y
+ MO_Sub F32 -> trivialCodeNoImm F32 (FSUB F32) x y
+ MO_Mul F32 -> trivialCodeNoImm F32 (FMUL F32) x y
+ MO_S_Quot F32 -> trivialCodeNoImm F32 (FDIV F32) x y
+
+ MO_Add F64 -> trivialCodeNoImm F64 (FADD F64) x y
+ MO_Sub F64 -> trivialCodeNoImm F64 (FSUB F64) x y
+ MO_Mul F64 -> trivialCodeNoImm F64 (FMUL F64) x y
+ MO_S_Quot F64 -> trivialCodeNoImm F64 (FDIV F64) x y
+
+ MO_Add rep -> trivialCode rep True ADD x y
+ MO_Sub rep ->
+ case y of -- subfi ('substract from' with immediate) doesn't exist
+ CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)
+ -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)
+ _ -> trivialCodeNoImm rep SUBF y x
+
+ MO_Mul rep -> trivialCode rep True MULLW x y
+
+ MO_S_MulMayOflo I32 -> trivialCodeNoImm I32 MULLW_MayOflo x y
+
+ MO_S_MulMayOflo rep -> panic "S_MulMayOflo (rep /= I32): not implemented"
+ MO_U_MulMayOflo rep -> panic "U_MulMayOflo: not implemented"
+
+ MO_S_Quot rep -> trivialCodeNoImm rep DIVW (extendSExpr rep x) (extendSExpr rep y)
+ MO_U_Quot rep -> trivialCodeNoImm rep DIVWU (extendUExpr rep x) (extendUExpr rep y)
+
+ MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y)
+ MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y)
+
+ MO_And rep -> trivialCode rep False AND x y
+ MO_Or rep -> trivialCode rep False OR x y
+ MO_Xor rep -> trivialCode rep False XOR x y
+
+ MO_Shl rep -> trivialCode rep False SLW x y
+ MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y
+ MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y
+
+getRegister (CmmLit (CmmInt i rep))
+ | Just imm <- makeImmediate rep True i
+ = let
+ code dst = unitOL (LI dst imm)
+ in
+ return (Any rep code)
+
+getRegister (CmmLit (CmmFloat f F32)) = do
+ lbl <- getNewLabelNat
+ tmp <- getNewRegNat I32
+ let code dst = toOL [
+ LDATA ReadOnlyData [CmmDataLabel lbl,
+ CmmStaticLit (CmmFloat f F32)],
+ LIS tmp (HA (ImmCLbl lbl)),
+ LD F32 dst (AddrRegImm tmp (LO (ImmCLbl lbl)))
+ ]
+ -- in
+ return (Any F32 code)
+
+getRegister (CmmLit (CmmFloat d F64)) = do
+ lbl <- getNewLabelNat
+ tmp <- getNewRegNat I32
+ let code dst = toOL [
+ LDATA ReadOnlyData [CmmDataLabel lbl,
+ CmmStaticLit (CmmFloat d F64)],
+ LIS tmp (HA (ImmCLbl lbl)),
+ LD F64 dst (AddrRegImm tmp (LO (ImmCLbl lbl)))
+ ]
+ -- in
+ return (Any F32 code)
+
+#if darwin_TARGET_OS
+getRegister (CmmLit (CmmLabel lbl))
+ | labelCouldBeDynamic lbl
+ = do
+ addImportNat False lbl
+ let imm = ImmDyldNonLazyPtr lbl
+ code dst = toOL [
+ LIS dst (HA imm),
+ LD I32 dst (AddrRegImm dst (LO imm))
+ ]
+ return (Any I32 code)
+#endif
+
+getRegister (CmmLit lit)
+ = let
+ rep = cmmLitRep lit
+ imm = litToImm lit
+ code dst = toOL [
+ LIS dst (HI imm),
+ OR dst dst (RIImm (LO imm))
+ ]
+ in
+ return (Any rep code)
+getRegister other = pprPanic "getRegister(ppc)" (pprExpr other)
+
+ -- extend?Rep: wrap integer expression of type rep
+ -- in a conversion to I32
+extendSExpr I32 x = x
+extendSExpr rep x = CmmMachOp (MO_S_Conv rep I32) [x]
+extendUExpr I32 x = x
+extendUExpr rep x = CmmMachOp (MO_U_Conv rep I32) [x]
+
+-- ###FIXME: exact code duplication from x86 case
+-- The dual to getAnyReg: compute an expression into a register, but
+-- we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+ r <- getRegister expr
+ case r of
+ Any rep code -> do
+ tmp <- getNewRegNat rep
+ return (tmp, code tmp)
+ Fixed _ reg code ->
+ return (reg, code)
+
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- The 'Amode' type: Memory addressing modes passed up the tree.
+
+data Amode = Amode AddrMode InstrBlock
+
+{-
+Now, given a tree (the argument to an CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to. So you can't put
+anything in between, lest it overwrite some of those registers. If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+ code
+ LEA amode, tmp
+ ... other computation ...
+ ... (tmp) ...
+-}
+
+getAmode :: CmmExpr -> NatM Amode
+getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+
+getAmode (StPrim IntSubOp [x, StInt i])
+ = getNewRegNat PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (-(fromInteger i))
+ in
+ return (Amode (AddrRegImm reg off) code)
+
+getAmode (StPrim IntAddOp [x, StInt i])
+ = getNewRegNat PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (fromInteger i)
+ in
+ return (Amode (AddrRegImm reg off) code)
+
+getAmode leaf
+ | isJust imm
+ = return (Amode (AddrImm imm__2) id)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+getAmode other
+ = getNewRegNat PtrRep `thenNat` \ tmp ->
+ getRegister other `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ in
+ return (Amode (AddrReg reg) code)
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+-- This is all just ridiculous, since it carefully undoes
+-- what mangleIndexTree has just done.
+getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit (CmmInt i _)])
+ -- ASSERT(rep == I32)???
+ = do (x_reg, x_code) <- getSomeReg x
+ let off = ImmInt (-(fromInteger i))
+ return (Amode (AddrBaseIndex (Just x_reg) Nothing off) x_code)
+
+getAmode (CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt i _)])
+ -- ASSERT(rep == I32)???
+ = do (x_reg, x_code) <- getSomeReg x
+ let off = ImmInt (fromInteger i)
+ return (Amode (AddrBaseIndex (Just x_reg) Nothing off) x_code)
+
+-- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be
+-- recognised by the next rule.
+getAmode (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),
+ b@(CmmLit _)])
+ = getAmode (CmmMachOp (MO_Add rep) [b,a])
+
+getAmode (CmmMachOp (MO_Add rep) [x, CmmMachOp (MO_Shl _)
+ [y, CmmLit (CmmInt shift _)]])
+ | shift == 0 || shift == 1 || shift == 2 || shift == 3
+ = do (x_reg, x_code) <- getNonClobberedReg x
+ -- x must be in a temp, because it has to stay live over y_code
+ -- we could compre x_reg and y_reg and do something better here...
+ (y_reg, y_code) <- getSomeReg y
+ let
+ code = x_code `appOL` y_code
+ base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8
+ return (Amode (AddrBaseIndex (Just x_reg) (Just (y_reg,base)) (ImmInt 0))
+ code)
+
+getAmode (CmmLit lit)
+ = return (Amode (ImmAddr (litToImm lit) 0) nilOL)
+
+getAmode expr = do
+ (reg,code) <- getSomeReg expr
+ return (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+getAmode (CmmMachOp MO_Nat_Sub [x, StInt i])
+ | fits13Bits (-i)
+ = getNewRegNat PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (-(fromInteger i))
+ in
+ return (Amode (AddrRegImm reg off) code)
+
+
+getAmode (CmmMachOp MO_Nat_Add [x, StInt i])
+ | fits13Bits i
+ = getNewRegNat PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (fromInteger i)
+ in
+ return (Amode (AddrRegImm reg off) code)
+
+getAmode (CmmMachOp MO_Nat_Add [x, y])
+ = getNewRegNat PtrRep `thenNat` \ tmp1 ->
+ getNewRegNat IntRep `thenNat` \ tmp2 ->
+ getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ let
+ code1 = registerCode register1 tmp1
+ reg1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ reg2 = registerName register2 tmp2
+ code__2 = code1 `appOL` code2
+ in
+ return (Amode (AddrRegReg reg1 reg2) code__2)
+
+getAmode leaf
+ | isJust imm
+ = getNewRegNat PtrRep `thenNat` \ tmp ->
+ let
+ code = unitOL (SETHI (HI imm__2) tmp)
+ in
+ return (Amode (AddrRegImm tmp (LO imm__2)) code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+getAmode other
+ = getNewRegNat PtrRep `thenNat` \ tmp ->
+ getRegister other `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt 0
+ in
+ return (Amode (AddrRegImm reg off) code)
+
+#endif /* sparc_TARGET_ARCH */
+
+#ifdef powerpc_TARGET_ARCH
+getAmode (CmmMachOp (MO_Sub I32) [x, CmmLit (CmmInt i _)])
+ | Just off <- makeImmediate I32 True (-i)
+ = do
+ (reg, code) <- getSomeReg x
+ return (Amode (AddrRegImm reg off) code)
+
+
+getAmode (CmmMachOp (MO_Add I32) [x, CmmLit (CmmInt i _)])
+ | Just off <- makeImmediate I32 True i
+ = do
+ (reg, code) <- getSomeReg x
+ return (Amode (AddrRegImm reg off) code)
+
+getAmode (CmmLit lit)
+ = do
+ tmp <- getNewRegNat I32
+ let
+ code = unitOL (LIS tmp (HA imm))
+ return (Amode (AddrRegImm tmp (LO imm)) code)
+ where
+ imm = litToImm lit
+
+getAmode (CmmMachOp (MO_Add I32) [x, y])
+ = do
+ (regX, codeX) <- getSomeReg x
+ (regY, codeY) <- getSomeReg y
+ return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+
+getAmode other
+ = do
+ (reg, code) <- getSomeReg other
+ let
+ off = ImmInt 0
+ return (Amode (AddrRegImm reg off) code)
+#endif /* powerpc_TARGET_ARCH */
+
+-- -----------------------------------------------------------------------------
+-- getOperand: sometimes any operand will do.
+
+-- getOperand gets a *safe* operand; that is, the value of the operand
+-- will remain valid across the computation of an arbitrary expression,
+-- unless the expression is computed directly into a register which
+-- the operand refers to (see trivialCode where this function is used
+-- for an example).
+
+#ifdef i386_TARGET_ARCH
+
+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)
+getOperand (CmmLoad mem pk)
+ | not (isFloatingRep pk) && pk /= I64 = do
+ Amode src mem_code <- getAmode mem
+ (src',save_code) <-
+ if (amodeCouldBeClobbered src)
+ then do
+ tmp <- getNewRegNat wordRep
+ return (AddrBaseIndex (Just tmp) Nothing (ImmInt 0),
+ unitOL (LEA I32 (OpAddr src) (OpReg tmp)))
+ else
+ return (src, nilOL)
+ return (OpAddr src', save_code `appOL` mem_code)
+
+getOperand e = do
+ (reg, code) <- getNonClobberedReg e
+ return (OpReg reg, code)
+
+amodeCouldBeClobbered :: AddrMode -> Bool
+amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode)
+
+regClobbered (RealReg rr) = isFastTrue (freeReg rr)
+regClobbered _ = False
+
+#endif
+
+-- -----------------------------------------------------------------------------
+-- The 'CondCode' type: Condition codes passed up the tree.
+
+data CondCode = CondCode Bool Cond InstrBlock
+
+-- Set up a condition code for a conditional branch.
+
+getCondCode :: CmmExpr -> NatM CondCode
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+getCondCode = panic "MachCode.getCondCode: not on Alphas"
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH || sparc_TARGET_ARCH
+-- yes, they really do seem to want exactly the same!
+
+getCondCode (CmmMachOp mop [x, y])
+ = ASSERT (cmmExprRep x /= I8) -- tmp, not set up to handle 8-bit comparisons
+ case mop of
+ MO_Eq F32 -> condFltCode EQQ x y
+ MO_Ne F32 -> condFltCode NE x y
+
+ MO_S_Gt F32 -> condFltCode GTT x y
+ MO_S_Ge F32 -> condFltCode GE x y
+ MO_S_Lt F32 -> condFltCode LTT x y
+ MO_S_Le F32 -> condFltCode LE x y
+
+ MO_Eq F64 -> condFltCode EQQ x y
+ MO_Ne F64 -> condFltCode NE x y
+
+ MO_S_Gt F64 -> condFltCode GTT x y
+ MO_S_Ge F64 -> condFltCode GE x y
+ MO_S_Lt F64 -> condFltCode LTT x y
+ MO_S_Le F64 -> condFltCode LE x y
+
+ MO_Eq rep -> condIntCode EQQ x y
+ MO_Ne rep -> condIntCode NE x y
+
+ MO_S_Gt rep -> condIntCode GTT x y
+ MO_S_Ge rep -> condIntCode GE x y
+ MO_S_Lt rep -> condIntCode LTT x y
+ MO_S_Le rep -> condIntCode LE x y
+
+ MO_U_Gt rep -> condIntCode GU x y
+ MO_U_Ge rep -> condIntCode GEU x y
+ MO_U_Lt rep -> condIntCode LU x y
+ MO_U_Le rep -> condIntCode LEU x y
+
+ other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
+
+getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other)
+
+#elif powerpc_TARGET_ARCH
+
+-- almost the same as everywhere else - but we need to
+-- extend small integers to 32 bit first
+
+getCondCode (CmmMachOp mop [x, y])
+ = case mop of
+ MO_Eq F32 -> condFltCode EQQ x y
+ MO_Ne F32 -> condFltCode NE x y
+
+ MO_S_Gt F32 -> condFltCode GTT x y
+ MO_S_Ge F32 -> condFltCode GE x y
+ MO_S_Lt F32 -> condFltCode LTT x y
+ MO_S_Le F32 -> condFltCode LE x y
+
+ MO_Eq F64 -> condFltCode EQQ x y
+ MO_Ne F64 -> condFltCode NE x y
+
+ MO_S_Gt F64 -> condFltCode GTT x y
+ MO_S_Ge F64 -> condFltCode GE x y
+ MO_S_Lt F64 -> condFltCode LTT x y
+ MO_S_Le F64 -> condFltCode LE x y
+
+ MO_Eq rep -> condIntCode EQQ (extendUExpr rep x) (extendUExpr rep y)
+ MO_Ne rep -> condIntCode NE (extendUExpr rep x) (extendUExpr rep y)
+
+ MO_S_Gt rep -> condIntCode GTT (extendSExpr rep x) (extendSExpr rep y)
+ MO_S_Ge rep -> condIntCode GE (extendSExpr rep x) (extendSExpr rep y)
+ MO_S_Lt rep -> condIntCode LTT (extendSExpr rep x) (extendSExpr rep y)
+ MO_S_Le rep -> condIntCode LE (extendSExpr rep x) (extendSExpr rep y)
+
+ MO_U_Gt rep -> condIntCode GU (extendUExpr rep x) (extendUExpr rep y)
+ MO_U_Ge rep -> condIntCode GEU (extendUExpr rep x) (extendUExpr rep y)
+ MO_U_Lt rep -> condIntCode LU (extendUExpr rep x) (extendUExpr rep y)
+ MO_U_Le rep -> condIntCode LEU (extendUExpr rep x) (extendUExpr rep y)
+
+ other -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
+
+getCondCode other = panic "getCondCode(2)(powerpc)"
+
+
+#endif
+
+
+-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
+-- passed back up the tree.
+
+condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+
+#if alpha_TARGET_ARCH
+condIntCode = panic "MachCode.condIntCode: not on Alphas"
+condFltCode = panic "MachCode.condFltCode: not on Alphas"
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+-- memory vs immediate
+condIntCode cond (CmmLoad x pk) (CmmLit lit) = do
+ Amode x_addr x_code <- getAmode x
+ let
+ imm = litToImm lit
+ code = x_code `snocOL`
+ CMP pk (OpImm imm) (OpAddr x_addr)
+ --
+ return (CondCode False cond code)
+
+-- anything vs zero
+condIntCode cond x (CmmLit (CmmInt 0 pk)) = do
+ (x_reg, x_code) <- getSomeReg x
+ let
+ code = x_code `snocOL`
+ TEST pk (OpReg x_reg) (OpReg x_reg)
+ --
+ return (CondCode False cond code)
+
+-- anything vs immediate
+condIntCode cond x (CmmLit lit) = do
+ (x_reg, x_code) <- getSomeReg x
+ let
+ imm = litToImm lit
+ code = x_code `snocOL`
+ CMP (cmmLitRep lit) (OpImm imm) (OpReg x_reg)
+ -- in
+ return (CondCode False cond code)
+
+-- memory vs anything
+condIntCode cond (CmmLoad x pk) y = do
+ (y_reg, y_code) <- getNonClobberedReg y
+ Amode x_addr x_code <- getAmode x
+ let
+ code = y_code `appOL`
+ x_code `snocOL`
+ CMP pk (OpReg y_reg) (OpAddr x_addr)
+ -- in
+ return (CondCode False cond code)
+
+-- anything vs memory
+condIntCode cond y (CmmLoad x pk) = do
+ (y_reg, y_code) <- getNonClobberedReg y
+ Amode x_addr x_code <- getAmode x
+ let
+ code = y_code `appOL`
+ x_code `snocOL`
+ CMP pk (OpAddr x_addr) (OpReg y_reg)
+ -- in
+ return (CondCode False cond code)
+
+-- anything vs anything
+condIntCode cond x y = do
+ (x_op, x_code) <- getOperand x
+ (y_reg, y_code) <- getSomeReg y
+ let
+ code = x_code `appOL`
+ y_code `snocOL`
+ CMP (cmmExprRep x) (OpReg y_reg) x_op
+ -- in
+ return (CondCode False cond code)
+
+-----------
+condFltCode cond x y
+ = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do
+ (x_reg, x_code) <- getNonClobberedReg x
+ (y_reg, y_code) <- getSomeReg y
+ let
+ code = x_code `appOL` y_code `snocOL`
+ GCMP cond x_reg y_reg
+ -- The GCMP insn does the test and sets the zero flag if comparable
+ -- and true. Hence we always supply EQQ as the condition to test.
+ return (CondCode True EQQ code)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+condIntCode cond x (StInt y)
+ | fits13Bits y
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (fromInteger y)
+ code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
+ in
+ return (CondCode False cond code__2)
+
+condIntCode cond x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNat IntRep `thenNat` \ tmp1 ->
+ getNewRegNat IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 = code1 `appOL` code2 `snocOL`
+ SUB False True src1 (RIReg src2) g0
+ in
+ return (CondCode False cond code__2)
+
+-----------
+condFltCode cond x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNat (registerRep register1)
+ `thenNat` \ tmp1 ->
+ getNewRegNat (registerRep register2)
+ `thenNat` \ tmp2 ->
+ getNewRegNat F64 `thenNat` \ tmp ->
+ let
+ promote x = FxTOy F DF x tmp
+
+ pk1 = registerRep register1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ pk2 = registerRep register2
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ code__2 =
+ if pk1 == pk2 then
+ code1 `appOL` code2 `snocOL`
+ FCMP True (primRepToSize pk1) src1 src2
+ else if pk1 == F32 then
+ code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+ FCMP True DF tmp src2
+ else
+ code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+ FCMP True DF src1 tmp
+ in
+ return (CondCode True cond code__2)
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+-- ###FIXME: I16 and I8!
+condIntCode cond x (CmmLit (CmmInt y rep))
+ | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
+ = do
+ (src1, code) <- getSomeReg x
+ let
+ code' = code `snocOL`
+ (if condUnsigned cond then CMPL else CMP) I32 src1 (RIImm src2)
+ return (CondCode False cond code')
+
+condIntCode cond x y = do
+ (src1, code1) <- getSomeReg x
+ (src2, code2) <- getSomeReg y
+ let
+ code' = code1 `appOL` code2 `snocOL`
+ (if condUnsigned cond then CMPL else CMP) I32 src1 (RIReg src2)
+ return (CondCode False cond code')
+
+condFltCode cond x y = do
+ (src1, code1) <- getSomeReg x
+ (src2, code2) <- getSomeReg y
+ let
+ code' = code1 `appOL` code2 `snocOL` FCMP src1 src2
+ code'' = case cond of -- twiddle CR to handle unordered case
+ GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
+ LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
+ _ -> code'
+ where
+ ltbit = 0 ; eqbit = 2 ; gtbit = 1
+ return (CondCode True cond code'')
+
+#endif /* powerpc_TARGET_ARCH */
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business. Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers. If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side. This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: MachRep -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode :: MachRep -> CmmReg -> CmmExpr -> NatM InstrBlock
+
+assignMem_FltCode :: MachRep -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode :: MachRep -> CmmReg -> CmmExpr -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+
+assignIntCode pk (CmmLoad dst _) src
+ = getNewRegNat IntRep `thenNat` \ tmp ->
+ getAmode dst `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
+ let
+ code1 = amodeCode amode []
+ dst__2 = amodeAddr amode
+ code2 = registerCode register tmp []
+ src__2 = registerName register tmp
+ sz = primRepToSize pk
+ code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ in
+ return code__2
+
+assignIntCode pk dst src
+ = getRegister dst `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
+ let
+ dst__2 = registerName register1 zeroh
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+ code__2 = if isFixed register2
+ then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
+ else code
+ in
+ return code__2
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+-- integer assignment to memory
+assignMem_IntCode pk addr src = do
+ Amode addr code_addr <- getAmode addr
+ (code_src, op_src) <- get_op_RI src
+ let
+ code = code_src `appOL`
+ code_addr `snocOL`
+ MOV pk op_src (OpAddr addr)
+ -- NOTE: op_src is stable, so it will still be valid
+ -- after code_addr. This may involve the introduction
+ -- of an extra MOV to a temporary register, but we hope
+ -- the register allocator will get rid of it.
+ --
+ return code
+ where
+ get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand) -- code, operator
+ get_op_RI (CmmLit lit)
+ = return (nilOL, OpImm (litToImm lit))
+ get_op_RI op
+ = do (reg,code) <- getNonClobberedReg op
+ return (code, OpReg reg)
+
+
+-- Assign; dst is a reg, rhs is mem
+assignReg_IntCode pk reg (CmmLoad src _) = do
+ load_code <- intLoadCode (MOV pk) src
+ return (load_code (getRegisterReg reg))
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode pk reg src = do
+ code <- getAnyReg src
+ return (code (getRegisterReg reg))
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+assignMem_IntCode pk addr src
+ = getNewRegNat IntRep `thenNat` \ tmp ->
+ getAmode addr `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
+ let
+ code1 = amodeCode amode
+ dst__2 = amodeAddr amode
+ code2 = registerCode register tmp
+ src__2 = registerName register tmp
+ sz = primRepToSize pk
+ code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
+ in
+ return code__2
+
+assignReg_IntCode pk reg src
+ = getRegister src `thenNat` \ register2 ->
+ getRegisterReg reg `thenNat` \ register1 ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ dst__2 = registerName register1 tmp
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+ code__2 = if isFixed register2
+ then code `snocOL` OR False g0 (RIReg src__2) dst__2
+ else code
+ in
+ return code__2
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+assignMem_IntCode pk addr src = do
+ (srcReg, code) <- getSomeReg src
+ Amode dstAddr addr_code <- getAmode addr
+ return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode pk reg src
+ = do
+ r <- getRegister src
+ return $ case r of
+ Any _ code -> code dst
+ Fixed _ freg fcode -> fcode `snocOL` MR dst freg
+ where
+ dst = getRegisterReg reg
+
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Floating-point assignments
+
+#if alpha_TARGET_ARCH
+
+assignFltCode pk (CmmLoad dst _) src
+ = getNewRegNat pk `thenNat` \ tmp ->
+ getAmode dst `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
+ let
+ code1 = amodeCode amode []
+ dst__2 = amodeAddr amode
+ code2 = registerCode register tmp []
+ src__2 = registerName register tmp
+ sz = primRepToSize pk
+ code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ in
+ return code__2
+
+assignFltCode pk dst src
+ = getRegister dst `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
+ let
+ dst__2 = registerName register1 zeroh
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+ code__2 = if isFixed register2
+ then code . mkSeqInstr (FMOV src__2 dst__2)
+ else code
+ in
+ return code__2
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src = do
+ (src_reg, src_code) <- getNonClobberedReg src
+ Amode addr addr_code <- getAmode addr
+ let
+ code = src_code `appOL`
+ addr_code `snocOL`
+ GST pk src_reg addr
+ return code
+
+-- Floating point assignment to a register/temporary
+assignReg_FltCode pk reg src = do
+ src_code <- getAnyReg src
+ return (src_code (getRegisterReg reg))
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
+ = getNewRegNat pk `thenNat` \ tmp1 ->
+ getAmode addr `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
+ let
+ sz = primRepToSize pk
+ dst__2 = amodeAddr amode
+
+ code1 = amodeCode amode
+ code2 = registerCode register tmp1
+
+ src__2 = registerName register tmp1
+ pk__2 = registerRep register
+ sz__2 = primRepToSize pk__2
+
+ code__2 = code1 `appOL` code2 `appOL`
+ if pk == pk__2
+ then unitOL (ST sz src__2 dst__2)
+ else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
+ in
+ return code__2
+
+-- Floating point assignment to a register/temporary
+-- Why is this so bizarrely ugly?
+assignReg_FltCode pk reg src
+ = getRegisterReg reg `thenNat` \ register1 ->
+ getRegister src `thenNat` \ register2 ->
+ let
+ pk__2 = registerRep register2
+ sz__2 = primRepToSize pk__2
+ in
+ getNewRegNat pk__2 `thenNat` \ tmp ->
+ let
+ sz = primRepToSize pk
+ dst__2 = registerName register1 g0 -- must be Fixed
+ reg__2 = if pk /= pk__2 then tmp else dst__2
+ code = registerCode register2 reg__2
+ src__2 = registerName register2 reg__2
+ code__2 =
+ if pk /= pk__2 then
+ code `snocOL` FxTOy sz__2 sz src__2 dst__2
+ else if isFixed register2 then
+ code `snocOL` FMOV sz src__2 dst__2
+ else
+ code
+ in
+ return code__2
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+-- Easy, isn't it?
+assignMem_FltCode = assignMem_IntCode
+assignReg_FltCode = assignReg_IntCode
+
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Generating an non-local jump
+
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+
+genJump (CmmLabel lbl)
+ | isAsmTemp lbl = returnInstr (BR target)
+ | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
+ where
+ target = ImmCLbl lbl
+
+genJump tree
+ = getRegister tree `thenNat` \ register ->
+ getNewRegNat PtrRep `thenNat` \ tmp ->
+ let
+ dst = registerName register pv
+ code = registerCode register pv
+ target = registerName register pv
+ in
+ if isFixed register then
+ returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
+ else
+ return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+genJump (CmmLoad mem pk) = do
+ Amode target code <- getAmode mem
+ return (code `snocOL` JMP (OpAddr target))
+
+genJump (CmmLit lit) = do
+ return (unitOL (JMP (OpImm (litToImm lit))))
+
+genJump expr = do
+ (reg,code) <- getSomeReg expr
+ return (code `snocOL` JMP (OpReg reg))
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+genJump (CmmLabel lbl)
+ = return (toOL [CALL (Left target) 0 True, NOP])
+ where
+ target = ImmCLbl lbl
+
+genJump tree
+ = getRegister tree `thenNat` \ register ->
+ getNewRegNat PtrRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ target = registerName register tmp
+ in
+ return (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+genJump (CmmLit (CmmLabel lbl))
+ = return (unitOL $ JMP lbl)
+
+genJump tree
+ = do
+ (target,code) <- getSomeReg tree
+ return (code `snocOL` MTCTR target `snocOL` BCTR [])
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Unconditional branches
+
+genBranch :: BlockId -> NatM InstrBlock
+
+#if alpha_TARGET_ARCH
+genBranch id = return (unitOL (BR id))
+#endif
+
+#if i386_TARGET_ARCH
+genBranch id = return (unitOL (JXX ALWAYS id))
+#endif
+
+#if sparc_TARGET_ARCH
+genBranch id = return (toOL [BI ALWAYS False id, NOP])
+#endif
+
+#if powerpc_TARGET_ARCH
+genBranch id = return (unitOL (BCC ALWAYS id))
+#endif
+
+
+-- -----------------------------------------------------------------------------
+-- Conditional jumps
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions. We peek at the arguments to decide what kind of
+comparison to do.
+
+ALPHA: For comparisons with 0, we're laughing, because we can just do
+the desired conditional branch.
+
+I386: First, we have to ensure that the condition
+codes are set according to the supplied comparison operation.
+
+SPARC: First, we have to ensure that the condition codes are set
+according to the supplied comparison operation. We generate slightly
+different code for floating point comparisons, because a floating
+point operation cannot directly precede a @BF@. We assume the worst
+and fill that slot with a @NOP@.
+
+SPARC: Do not fill the delay slots here; you will confuse the register
+allocator.
+-}
+
+
+genCondJump
+ :: BlockId -- the branch target
+ -> CmmExpr -- the condition on which to branch
+ -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+
+genCondJump id (StPrim op [x, StInt 0])
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat (registerRep register)
+ `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ value = registerName register tmp
+ pk = registerRep register
+ target = ImmCLbl lbl
+ in
+ returnSeq code [BI (cmpOp op) value target]
+ where
+ cmpOp CharGtOp = GTT
+ cmpOp CharGeOp = GE
+ cmpOp CharEqOp = EQQ
+ cmpOp CharNeOp = NE
+ cmpOp CharLtOp = LTT
+ cmpOp CharLeOp = LE
+ cmpOp IntGtOp = GTT
+ cmpOp IntGeOp = GE
+ cmpOp IntEqOp = EQQ
+ cmpOp IntNeOp = NE
+ cmpOp IntLtOp = LTT
+ cmpOp IntLeOp = LE
+ cmpOp WordGtOp = NE
+ cmpOp WordGeOp = ALWAYS
+ cmpOp WordEqOp = EQQ
+ cmpOp WordNeOp = NE
+ cmpOp WordLtOp = NEVER
+ cmpOp WordLeOp = EQQ
+ cmpOp AddrGtOp = NE
+ cmpOp AddrGeOp = ALWAYS
+ cmpOp AddrEqOp = EQQ
+ cmpOp AddrNeOp = NE
+ cmpOp AddrLtOp = NEVER
+ cmpOp AddrLeOp = EQQ
+
+genCondJump lbl (StPrim op [x, StDouble 0.0])
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat (registerRep register)
+ `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ value = registerName register tmp
+ pk = registerRep register
+ target = ImmCLbl lbl
+ in
+ return (code . mkSeqInstr (BF (cmpOp op) value target))
+ where
+ cmpOp FloatGtOp = GTT
+ cmpOp FloatGeOp = GE
+ cmpOp FloatEqOp = EQQ
+ cmpOp FloatNeOp = NE
+ cmpOp FloatLtOp = LTT
+ cmpOp FloatLeOp = LE
+ cmpOp DoubleGtOp = GTT
+ cmpOp DoubleGeOp = GE
+ cmpOp DoubleEqOp = EQQ
+ cmpOp DoubleNeOp = NE
+ cmpOp DoubleLtOp = LTT
+ cmpOp DoubleLeOp = LE
+
+genCondJump lbl (StPrim op [x, y])
+ | fltCmpOp op
+ = trivialFCode pr instr x y `thenNat` \ register ->
+ getNewRegNat F64 `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ result = registerName register tmp
+ target = ImmCLbl lbl
+ in
+ return (code . mkSeqInstr (BF cond result target))
+ where
+ pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
+
+ fltCmpOp op = case op of
+ FloatGtOp -> True
+ FloatGeOp -> True
+ FloatEqOp -> True
+ FloatNeOp -> True
+ FloatLtOp -> True
+ FloatLeOp -> True
+ DoubleGtOp -> True
+ DoubleGeOp -> True
+ DoubleEqOp -> True
+ DoubleNeOp -> True
+ DoubleLtOp -> True
+ DoubleLeOp -> True
+ _ -> False
+ (instr, cond) = case op of
+ FloatGtOp -> (FCMP TF LE, EQQ)
+ FloatGeOp -> (FCMP TF LTT, EQQ)
+ FloatEqOp -> (FCMP TF EQQ, NE)
+ FloatNeOp -> (FCMP TF EQQ, EQQ)
+ FloatLtOp -> (FCMP TF LTT, NE)
+ FloatLeOp -> (FCMP TF LE, NE)
+ DoubleGtOp -> (FCMP TF LE, EQQ)
+ DoubleGeOp -> (FCMP TF LTT, EQQ)
+ DoubleEqOp -> (FCMP TF EQQ, NE)
+ DoubleNeOp -> (FCMP TF EQQ, EQQ)
+ DoubleLtOp -> (FCMP TF LTT, NE)
+ DoubleLeOp -> (FCMP TF LE, NE)
+
+genCondJump lbl (StPrim op [x, y])
+ = trivialCode instr x y `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ result = registerName register tmp
+ target = ImmCLbl lbl
+ in
+ return (code . mkSeqInstr (BI cond result target))
+ where
+ (instr, cond) = case op of
+ CharGtOp -> (CMP LE, EQQ)
+ CharGeOp -> (CMP LTT, EQQ)
+ CharEqOp -> (CMP EQQ, NE)
+ CharNeOp -> (CMP EQQ, EQQ)
+ CharLtOp -> (CMP LTT, NE)
+ CharLeOp -> (CMP LE, NE)
+ IntGtOp -> (CMP LE, EQQ)
+ IntGeOp -> (CMP LTT, EQQ)
+ IntEqOp -> (CMP EQQ, NE)
+ IntNeOp -> (CMP EQQ, EQQ)
+ IntLtOp -> (CMP LTT, NE)
+ IntLeOp -> (CMP LE, NE)
+ WordGtOp -> (CMP ULE, EQQ)
+ WordGeOp -> (CMP ULT, EQQ)
+ WordEqOp -> (CMP EQQ, NE)
+ WordNeOp -> (CMP EQQ, EQQ)
+ WordLtOp -> (CMP ULT, NE)
+ WordLeOp -> (CMP ULE, NE)
+ AddrGtOp -> (CMP ULE, EQQ)
+ AddrGeOp -> (CMP ULT, EQQ)
+ AddrEqOp -> (CMP EQQ, NE)
+ AddrNeOp -> (CMP EQQ, EQQ)
+ AddrLtOp -> (CMP ULT, NE)
+ AddrLeOp -> (CMP ULE, NE)
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+genCondJump id bool = do
+ CondCode _ cond code <- getCondCode bool
+ return (code `snocOL` JXX cond id)
+
+#endif /* i386_TARGET_ARCH */
+
+
+#if sparc_TARGET_ARCH
+
+genCondJump id bool = do
+ CondCode is_float cond code <- getCondCode bool
+ return (
+ code `appOL`
+ toOL (
+ if is_float
+ then [NOP, BF cond False id, NOP]
+ else [BI cond False id, NOP]
+ )
+ )
+
+#endif /* sparc_TARGET_ARCH */
+
+
+#if powerpc_TARGET_ARCH
+
+genCondJump id bool = do
+ CondCode is_float cond code <- getCondCode bool
+ return (code `snocOL` BCC cond id)
+
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Generating C calls
+
+-- Now the biggest nightmare---calls. Most of the nastiness is buried in
+-- @get_arg@, which moves the arguments to the correct registers/stack
+-- locations. Apart from that, the code is easy.
+--
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+genCCall
+ :: CmmCallTarget -- function to call
+ -> [(CmmReg,MachHint)] -- where to put the result
+ -> [(CmmExpr,MachHint)] -- arguments (of mixed type)
+ -> Maybe [GlobalReg] -- volatile regs to save
+ -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+
+ccallResultRegs =
+
+genCCall fn cconv result_regs args
+ = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
+ `thenNat` \ ((unused,_), argCode) ->
+ let
+ nRegs = length allArgRegs - length unused
+ code = asmSeqThen (map ($ []) argCode)
+ in
+ returnSeq code [
+ LDA pv (AddrImm (ImmLab (ptext fn))),
+ JSR ra (AddrReg pv) nRegs,
+ LDGP gp (AddrReg ra)]
+ where
+ ------------------------
+ {- Try to get a value into a specific register (or registers) for
+ a call. The first 6 arguments go into the appropriate
+ argument register (separate registers for integer and floating
+ point arguments, but used in lock-step), and the remaining
+ arguments are dumped to the stack, beginning at 0(sp). Our
+ first argument is a pair of the list of remaining argument
+ registers to be assigned for this call and the next stack
+ offset to use for overflowing arguments. This way,
+ @get_Arg@ can be applied to all of a call's arguments using
+ @mapAccumLNat@.
+ -}
+ get_arg
+ :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
+ -> StixTree -- Current argument
+ -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
+
+ -- We have to use up all of our argument registers first...
+
+ get_arg ((iDst,fDst):dsts, offset) arg
+ = getRegister arg `thenNat` \ register ->
+ let
+ reg = if isFloatingRep pk then fDst else iDst
+ code = registerCode register reg
+ src = registerName register reg
+ pk = registerRep register
+ in
+ return (
+ if isFloatingRep pk then
+ ((dsts, offset), if isFixed register then
+ code . mkSeqInstr (FMOV src fDst)
+ else code)
+ else
+ ((dsts, offset), if isFixed register then
+ code . mkSeqInstr (OR src (RIReg src) iDst)
+ else code))
+
+ -- Once we have run out of argument registers, we move to the
+ -- stack...
+
+ get_arg ([], offset) arg
+ = getRegister arg `thenNat` \ register ->
+ getNewRegNat (registerRep register)
+ `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ pk = registerRep register
+ sz = primRepToSize pk
+ in
+ return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+-- we only cope with a single result for foreign calls
+genCCall (CmmPrim op) [(r,_)] args vols = do
+ case op of
+ MO_F32_Sqrt -> actuallyInlineFloatOp F32 (GSQRT F32) args
+ MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args
+
+ MO_F32_Sin -> actuallyInlineFloatOp F32 (GSIN F32) args
+ MO_F64_Sin -> actuallyInlineFloatOp F64 (GSIN F64) args
+
+ MO_F32_Cos -> actuallyInlineFloatOp F32 (GCOS F32) args
+ MO_F64_Cos -> actuallyInlineFloatOp F64 (GCOS F64) args
+
+ MO_F32_Tan -> actuallyInlineFloatOp F32 (GTAN F32) args
+ MO_F64_Tan -> actuallyInlineFloatOp F64 (GTAN F64) args
+
+ other_op -> outOfLineFloatOp op r args vols
+ where
+ actuallyInlineFloatOp rep instr [(x,_)]
+ = do res <- trivialUFCode rep instr x
+ any <- anyReg res
+ return (any (getRegisterReg r))
+
+genCCall target dest_regs args vols = do
+ sizes_n_codes <- mapM push_arg (reverse args)
+ delta <- getDeltaNat
+ let
+ (sizes, push_codes) = unzip sizes_n_codes
+ tot_arg_size = sum sizes
+ -- in
+ -- deal with static vs dynamic call targets
+ (callinsns,cconv) <-
+ case target of
+ -- CmmPrim -> ...
+ CmmForeignCall (CmmLit (CmmLabel lbl)) conv
+ -> -- ToDo: stdcall arg sizes
+ return (unitOL (CALL (Left fn_imm)), conv)
+ where fn_imm = ImmCLbl lbl
+ CmmForeignCall expr conv
+ -> do (dyn_c, dyn_r, dyn_rep) <- get_op expr
+ ASSERT(dyn_rep == I32)
+ return (dyn_c `snocOL` CALL (Right dyn_r), conv)
+
+ let push_code = concatOL push_codes
+ call = callinsns `appOL`
+ toOL (
+ -- Deallocate parameters after call for ccall;
+ -- but not for stdcall (callee does it)
+ (if cconv == StdCallConv then [] else
+ [ADD I32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
+ ++
+ [DELTA (delta + tot_arg_size)]
+ )
+ -- in
+ setDeltaNat (delta + tot_arg_size)
+
+ let
+ -- assign the results, if necessary
+ assign_code [] = nilOL
+ assign_code [(dest,_hint)] =
+ case rep of
+ I64 -> toOL [MOV I32 (OpReg eax) (OpReg r_dest),
+ MOV I32 (OpReg edx) (OpReg r_dest_hi)]
+ F32 -> unitOL (GMOV fake0 r_dest)
+ F64 -> unitOL (GMOV fake0 r_dest)
+ rep -> unitOL (MOV rep (OpReg eax) (OpReg r_dest))
+ where
+ r_dest_hi = getHiVRegFromLo r_dest
+ rep = cmmRegRep dest
+ r_dest = getRegisterReg dest
+ assign_code many = panic "genCCall.assign_code many"
+
+ return (push_code `appOL`
+ call `appOL`
+ assign_code dest_regs)
+
+ where
+ arg_size F64 = 8
+ arg_size F32 = 4
+ arg_size _ = 4
+
+ push_arg :: (CmmExpr,MachHint){-current argument-}
+ -> NatM (Int, InstrBlock) -- argsz, code
+
+ push_arg (arg,_hint) -- we don't need the hints on x86
+ | arg_rep == I64 = do
+ ChildCode64 code r_lo <- iselExpr64 arg
+ delta <- getDeltaNat
+ setDeltaNat (delta - 8)
+ let
+ r_hi = getHiVRegFromLo r_lo
+ -- in
+ return (8, code `appOL`
+ toOL [PUSH I32 (OpReg r_hi), DELTA (delta - 4),
+ PUSH I32 (OpReg r_lo), DELTA (delta - 8),
+ DELTA (delta-8)]
+ )
+
+ | otherwise = do
+ (code, reg, sz) <- get_op arg
+ delta <- getDeltaNat
+ let size = arg_size sz
+ setDeltaNat (delta-size)
+ if (case sz of F64 -> True; F32 -> True; _ -> False)
+ then return (size,
+ code `appOL`
+ toOL [SUB I32 (OpImm (ImmInt size)) (OpReg esp),
+ DELTA (delta-size),
+ GST sz reg (AddrBaseIndex (Just esp)
+ Nothing
+ (ImmInt 0))]
+ )
+ else return (size,
+ code `snocOL`
+ PUSH I32 (OpReg reg) `snocOL`
+ DELTA (delta-size)
+ )
+ where
+ arg_rep = cmmExprRep arg
+
+ ------------
+ get_op :: CmmExpr -> NatM (InstrBlock, Reg, MachRep) -- code, reg, size
+ get_op op = do
+ (reg,code) <- getSomeReg op
+ return (code, reg, cmmExprRep op)
+
+
+outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)]
+ -> Maybe [GlobalReg] -> NatM InstrBlock
+outOfLineFloatOp mop res args vols
+ | cmmRegRep res == F64
+ = stmtToInstrs (CmmCall target [(res,FloatHint)] args vols)
+
+ | otherwise
+ = do uq <- getUniqueNat
+ let
+ tmp = CmmLocal (LocalReg uq F64)
+ -- in
+ code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] (map promote args) vols)
+ code2 <- stmtToInstrs (CmmAssign res (demote (CmmReg tmp)))
+ return (code1 `appOL` code2)
+ where
+ promote (x,hint) = (CmmMachOp (MO_S_Conv F32 F64) [x], hint)
+ demote x = CmmMachOp (MO_S_Conv F64 F32) [x]
+
+ target = CmmForeignCall (CmmLit lbl) CCallConv
+ lbl = CmmLabel (mkForeignLabel fn Nothing False)
+
+ fn = case mop of
+ MO_F32_Exp -> FSLIT("exp")
+ MO_F32_Log -> FSLIT("log")
+
+ MO_F32_Asin -> FSLIT("asin")
+ MO_F32_Acos -> FSLIT("acos")
+ MO_F32_Atan -> FSLIT("atan")
+
+ MO_F32_Sinh -> FSLIT("sinh")
+ MO_F32_Cosh -> FSLIT("cosh")
+ MO_F32_Tanh -> FSLIT("tanh")
+ MO_F32_Pwr -> FSLIT("pow")
+
+ MO_F64_Exp -> FSLIT("exp")
+ MO_F64_Log -> FSLIT("log")
+
+ MO_F64_Asin -> FSLIT("asin")
+ MO_F64_Acos -> FSLIT("acos")
+ MO_F64_Atan -> FSLIT("atan")
+
+ MO_F64_Sinh -> FSLIT("sinh")
+ MO_F64_Cosh -> FSLIT("cosh")
+ MO_F64_Tanh -> FSLIT("tanh")
+ MO_F64_Pwr -> FSLIT("pow")
+
+ other -> pprPanic "outOfLineFloatOp" (pprCallishMachOp mop)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+{-
+ The SPARC calling convention is an absolute
+ nightmare. The first 6x32 bits of arguments are mapped into
+ %o0 through %o5, and the remaining arguments are dumped to the
+ stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
+
+ If we have to put args on the stack, move %o6==%sp down by
+ the number of words to go on the stack, to ensure there's enough space.
+
+ According to Fraser and Hanson's lcc book, page 478, fig 17.2,
+ 16 words above the stack pointer is a word for the address of
+ a structure return value. I use this as a temporary location
+ for moving values from float to int regs. Certainly it isn't
+ safe to put anything in the 16 words starting at %sp, since
+ this area can get trashed at any time due to window overflows
+ caused by signal handlers.
+
+ A final complication (if the above isn't enough) is that
+ we can't blithely calculate the arguments one by one into
+ %o0 .. %o5. Consider the following nested calls:
+
+ fff a (fff b c)
+
+ Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
+ the inner call will itself use %o0, which trashes the value put there
+ in preparation for the outer call. Upshot: we need to calculate the
+ args into temporary regs, and move those to arg regs or onto the
+ stack only immediately prior to the call proper. Sigh.
+-}
+
+genCCall fn cconv kind args
+ = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
+ let
+ (argcodes, vregss) = unzip argcode_and_vregs
+ n_argRegs = length allArgRegs
+ n_argRegs_used = min (length vregs) n_argRegs
+ vregs = concat vregss
+ in
+ -- deal with static vs dynamic call targets
+ (case fn of
+ Left t_static
+ -> return (unitOL (CALL (Left fn__2) n_argRegs_used False))
+ Right dyn
+ -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
+ return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
+ )
+ `thenNat` \ callinsns ->
+ let
+ argcode = concatOL argcodes
+ (move_sp_down, move_sp_up)
+ = let diff = length vregs - n_argRegs
+ nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
+ in if nn <= 0
+ then (nilOL, nilOL)
+ else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
+ transfer_code
+ = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
+ in
+ return (argcode `appOL`
+ move_sp_down `appOL`
+ transfer_code `appOL`
+ callinsns `appOL`
+ unitOL NOP `appOL`
+ move_sp_up)
+ where
+ -- function names that begin with '.' are assumed to be special
+ -- internally generated names like '.mul,' which don't get an
+ -- underscore prefix
+ -- ToDo:needed (WDP 96/03) ???
+ fn_static = unLeft fn
+ fn__2 = case (headFS fn_static) of
+ '.' -> ImmLit (ftext fn_static)
+ _ -> ImmCLbl (mkForeignLabel fn_static False)
+
+ -- move args from the integer vregs into which they have been
+ -- marshalled, into %o0 .. %o5, and the rest onto the stack.
+ move_final :: [Reg] -> [Reg] -> Int -> [Instr]
+
+ move_final [] _ offset -- all args done
+ = []
+
+ move_final (v:vs) [] offset -- out of aregs; move to stack
+ = ST W v (spRel offset)
+ : move_final vs [] (offset+1)
+
+ move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
+ = OR False g0 (RIReg v) a
+ : move_final vs az offset
+
+ -- generate code to calculate an argument, and move it into one
+ -- or two integer vregs.
+ arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
+ arg_to_int_vregs arg
+ | is64BitRep (repOfCmmExpr arg)
+ = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
+ let r_lo = VirtualRegI vr_lo
+ r_hi = getHiVRegFromLo r_lo
+ in return (code, [r_hi, r_lo])
+ | otherwise
+ = getRegister arg `thenNat` \ register ->
+ getNewRegNat (registerRep register) `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
+ pk = registerRep register
+ in
+ -- the value is in src. Get it into 1 or 2 int vregs.
+ case pk of
+ F64 ->
+ getNewRegNat WordRep `thenNat` \ v1 ->
+ getNewRegNat WordRep `thenNat` \ v2 ->
+ return (
+ code `snocOL`
+ FMOV DF src f0 `snocOL`
+ ST F f0 (spRel 16) `snocOL`
+ LD W (spRel 16) v1 `snocOL`
+ ST F (fPair f0) (spRel 16) `snocOL`
+ LD W (spRel 16) v2
+ ,
+ [v1,v2]
+ )
+ F32 ->
+ getNewRegNat WordRep `thenNat` \ v1 ->
+ return (
+ code `snocOL`
+ ST F src (spRel 16) `snocOL`
+ LD W (spRel 16) v1
+ ,
+ [v1]
+ )
+ other ->
+ getNewRegNat WordRep `thenNat` \ v1 ->
+ return (
+ code `snocOL` OR False g0 (RIReg src) v1
+ ,
+ [v1]
+ )
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+#if darwin_TARGET_OS || linux_TARGET_OS
+{-
+ The PowerPC calling convention for Darwin/Mac OS X
+ is described in Apple's document
+ "Inside Mac OS X - Mach-O Runtime Architecture".
+
+ PowerPC Linux uses the System V Release 4 Calling Convention
+ for PowerPC. It is described in the
+ "System V Application Binary Interface PowerPC Processor Supplement".
+
+ Both conventions are similar:
+ Parameters may be passed in general-purpose registers starting at r3, in
+ floating point registers starting at f1, or on the stack.
+
+ But there are substantial differences:
+ * The number of registers used for parameter passing and the exact set of
+ nonvolatile registers differs (see MachRegs.lhs).
+ * On Darwin, stack space is always reserved for parameters, even if they are
+ passed in registers. The called routine may choose to save parameters from
+ registers to the corresponding space on the stack.
+ * On Darwin, a corresponding amount of GPRs is skipped when a floating point
+ parameter is passed in an FPR.
+ * SysV insists on either passing I64 arguments on the stack, or in two GPRs,
+ starting with an odd-numbered GPR. It may skip a GPR to achieve this.
+ Darwin just treats an I64 like two separate I32s (high word first).
+
+ According to both conventions, The parameter area should be part of the
+ caller's stack frame, allocated in the caller's prologue code (large enough
+ to hold the parameter lists for all called routines). The NCG already
+ uses the stack for register spilling, leaving 64 bytes free at the top.
+ If we need a larger parameter area than that, we just allocate a new stack
+ frame just before ccalling.
+-}
+
+genCCall target dest_regs argsAndHints vols
+ = ASSERT (not $ any (`elem` [I8,I16]) argReps)
+ -- we rely on argument promotion in the codeGen
+ do
+ (finalStack,passArgumentsCode,usedRegs) <- passArguments
+ (zip args argReps)
+ allArgRegs allFPArgRegs
+ initialStackOffset
+ (toOL []) []
+
+ let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
+ codeAfter = move_sp_up finalStack `appOL` moveResult
+
+ case labelOrExpr of
+ Left lbl -> do
+ addImportNat True lbl
+ return ( codeBefore
+ `snocOL` BL lbl usedRegs
+ `appOL` codeAfter)
+ Right dyn -> do
+ (dynReg, dynCode) <- getSomeReg dyn
+ return ( dynCode
+ `snocOL` MTCTR dynReg
+ `appOL` codeBefore
+ `snocOL` BCTRL usedRegs
+ `appOL` codeAfter)
+ where
+#if darwin_TARGET_OS
+ initialStackOffset = 24
+ -- size of linkage area + size of arguments, in bytes
+ stackDelta _finalStack = roundTo16 $ (24 +) $ max 32 $ sum $
+ map machRepByteWidth argReps
+#elif linux_TARGET_OS
+ initialStackOffset = 8
+ stackDelta finalStack = roundTo16 finalStack
+#endif
+ args = map fst argsAndHints
+ argReps = map cmmExprRep args
+
+ roundTo16 x | x `mod` 16 == 0 = x
+ | otherwise = x + 16 - (x `mod` 16)
+
+ move_sp_down finalStack
+ | delta > 64 =
+ toOL [STU I32 sp (AddrRegImm sp (ImmInt (-delta))),
+ DELTA (-delta)]
+ | otherwise = nilOL
+ where delta = stackDelta finalStack
+ move_sp_up finalStack
+ | delta > 64 =
+ toOL [ADD sp sp (RIImm (ImmInt delta)),
+ DELTA 0]
+ | otherwise = nilOL
+ where delta = stackDelta finalStack
+
+
+ passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
+ passArguments ((arg,I64):args) gprs fprs stackOffset
+ accumCode accumUsed =
+ do
+ ChildCode64 code vr_lo <- iselExpr64 arg
+ let vr_hi = getHiVRegFromLo vr_lo
+
+#if darwin_TARGET_OS
+ passArguments args
+ (drop 2 gprs)
+ fprs
+ (stackOffset+8)
+ (accumCode `appOL` code
+ `snocOL` storeWord vr_hi gprs stackOffset
+ `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
+ ((take 2 gprs) ++ accumUsed)
+ where
+ storeWord vr (gpr:_) offset = MR gpr vr
+ storeWord vr [] offset = ST I32 vr (AddrRegImm sp (ImmInt offset))
+
+#elif linux_TARGET_OS
+ let stackCode = accumCode `appOL` code
+ `snocOL` ST I32 vr_hi (AddrRegImm sp (ImmInt stackOffset))
+ `snocOL` ST I32 vr_lo (AddrRegImm sp (ImmInt (stackOffset+4)))
+ regCode hireg loreg =
+ accumCode `appOL` code
+ `snocOL` MR hireg vr_hi
+ `snocOL` MR loreg vr_lo
+
+ case gprs of
+ hireg : loreg : regs | even (length gprs) ->
+ passArguments args regs fprs stackOffset
+ (regCode hireg loreg) (hireg : loreg : accumUsed)
+ _skipped : hireg : loreg : regs ->
+ passArguments args regs fprs stackOffset
+ (regCode hireg loreg) (hireg : loreg : accumUsed)
+ _ -> -- only one or no regs left
+ passArguments args [] fprs (stackOffset+8)
+ stackCode accumUsed
+#endif
+
+ passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed
+ | reg : _ <- regs = do
+ register <- getRegister arg
+ let code = case register of
+ Fixed _ freg fcode -> fcode `snocOL` MR reg freg
+ Any _ acode -> acode reg
+ passArguments args
+ (drop nGprs gprs)
+ (drop nFprs fprs)
+#if darwin_TARGET_OS
+ -- The Darwin ABI requires that we reserve stack slots for register parameters
+ (stackOffset + stackBytes)
+#elif linux_TARGET_OS
+ -- ... the SysV ABI doesn't.
+ stackOffset
+#endif
+ (accumCode `appOL` code)
+ (reg : accumUsed)
+ | otherwise = do
+ (vr, code) <- getSomeReg arg
+ passArguments args
+ (drop nGprs gprs)
+ (drop nFprs fprs)
+ (stackOffset + stackBytes)
+ (accumCode `appOL` code `snocOL` ST rep vr stackSlot)
+ accumUsed
+ where
+ stackSlot = AddrRegImm sp (ImmInt stackOffset)
+ (nGprs, nFprs, stackBytes, regs) = case rep of
+ I32 -> (1, 0, 4, gprs)
+#if darwin_TARGET_OS
+ -- The Darwin ABI requires that we skip a corresponding number of GPRs when
+ -- we use the FPRs.
+ F32 -> (1, 1, 4, fprs)
+ F64 -> (2, 1, 8, fprs)
+#elif linux_TARGET_OS
+ -- ... the SysV ABI doesn't.
+ F32 -> (0, 1, 4, fprs)
+ F64 -> (0, 1, 8, fprs)
+#endif
+
+ moveResult =
+ case dest_regs of
+ [] -> nilOL
+ [(dest, _hint)]
+ | reduceToF32 && rep == F32 -> unitOL (FRSP r_dest f1)
+ | rep == F32 || rep == F64 -> unitOL (MR r_dest f1)
+ | rep == I64 -> toOL [MR (getHiVRegFromLo r_dest) r3,
+ MR r_dest r4]
+ | otherwise -> unitOL (MR r_dest r3)
+ where rep = cmmRegRep dest
+ r_dest = getRegisterReg dest
+
+ (labelOrExpr, reduceToF32) = case target of
+ CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> (Left lbl, False)
+ CmmForeignCall expr conv -> (Right expr, False)
+ CmmPrim mop -> (Left $ mkForeignLabel label Nothing False, reduce)
+ where
+ (label, reduce) = case mop of
+ MO_F32_Exp -> (FSLIT("exp"), True)
+ MO_F32_Log -> (FSLIT("log"), True)
+ MO_F32_Sqrt -> (FSLIT("sqrt"), True)
+
+ MO_F32_Sin -> (FSLIT("sin"), True)
+ MO_F32_Cos -> (FSLIT("cos"), True)
+ MO_F32_Tan -> (FSLIT("tan"), True)
+
+ MO_F32_Asin -> (FSLIT("asin"), True)
+ MO_F32_Acos -> (FSLIT("acos"), True)
+ MO_F32_Atan -> (FSLIT("atan"), True)
+
+ MO_F32_Sinh -> (FSLIT("sinh"), True)
+ MO_F32_Cosh -> (FSLIT("cosh"), True)
+ MO_F32_Tanh -> (FSLIT("tanh"), True)
+ MO_F32_Pwr -> (FSLIT("pow"), True)
+
+ MO_F64_Exp -> (FSLIT("exp"), False)
+ MO_F64_Log -> (FSLIT("log"), False)
+ MO_F64_Sqrt -> (FSLIT("sqrt"), False)
+
+ MO_F64_Sin -> (FSLIT("sin"), False)
+ MO_F64_Cos -> (FSLIT("cos"), False)
+ MO_F64_Tan -> (FSLIT("tan"), False)
+
+ MO_F64_Asin -> (FSLIT("asin"), False)
+ MO_F64_Acos -> (FSLIT("acos"), False)
+ MO_F64_Atan -> (FSLIT("atan"), False)
+
+ MO_F64_Sinh -> (FSLIT("sinh"), False)
+ MO_F64_Cosh -> (FSLIT("cosh"), False)
+ MO_F64_Tanh -> (FSLIT("tanh"), False)
+ MO_F64_Pwr -> (FSLIT("pow"), False)
+ other -> pprPanic "genCCall(ppc): unknown callish op"
+ (pprCallishMachOp other)
+
+#endif /* darwin_TARGET_OS || linux_TARGET_OS */
+
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Generating a table-branch
+
+genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
+
+#if i386_TARGET_ARCH
+genSwitch expr ids = do
+ (reg,e_code) <- getSomeReg expr
+ lbl <- getNewLabelNat
+ let
+ jumpTable = map jumpTableEntry ids
+ op = OpAddr (AddrBaseIndex Nothing (Just (reg,4)) (ImmCLbl lbl))
+ code = e_code `appOL` toOL [
+ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ JMP_TBL op [ id | Just id <- ids ]
+ ]
+ -- in
+ return code
+#elif powerpc_TARGET_ARCH
+genSwitch expr ids = do
+ (reg,e_code) <- getSomeReg expr
+ tmp <- getNewRegNat I32
+ lbl <- getNewLabelNat
+ let
+ jumpTable = map jumpTableEntry ids
+
+ code = e_code `appOL` toOL [
+ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ SLW tmp reg (RIImm (ImmInt 2)),
+ ADDIS tmp tmp (HA (ImmCLbl lbl)),
+ LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
+ MTCTR tmp,
+ BCTR [ id | Just id <- ids ]
+ ]
+ -- in
+ return code
+#else
+genSwitch expr ids = panic "ToDo: genSwitch"
+#endif
+
+jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordRep)
+jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
+ where blockLabel = mkAsmTempLabel id
+
+-- -----------------------------------------------------------------------------
+-- Support bits
+-- -----------------------------------------------------------------------------
+
+
+-- -----------------------------------------------------------------------------
+-- 'condIntReg' and 'condFltReg': condition codes into registers
+
+-- Turn those condition codes into integers now (when they appear on
+-- the right hand side of an assignment).
+--
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+condIntReg = panic "MachCode.condIntReg (not on Alpha)"
+condFltReg = panic "MachCode.condFltReg (not on Alpha)"
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+condIntReg cond x y = do
+ CondCode _ cond cond_code <- condIntCode cond x y
+ tmp <- getNewRegNat I8
+ let
+ code dst = cond_code `appOL` toOL [
+ SETCC cond (OpReg tmp),
+ MOV I32 (OpReg tmp) (OpReg dst),
+ AND I32 (OpImm (ImmInt 1)) (OpReg dst)
+ ]
+ -- NB. (1) Tha AND is needed here because the x86 only
+ -- sets the low byte in the SETCC instruction.
+ -- NB. (2) The extra temporary register is a hack to
+ -- work around the fact that the setcc instructions only
+ -- accept byte registers. dst might not be a byte-able reg,
+ -- but currently all free registers are byte-able, so we're
+ -- guaranteed that a new temporary is byte-able.
+ -- in
+ return (Any I32 code)
+
+
+condFltReg cond x y = do
+ lbl1 <- getBlockIdNat
+ lbl2 <- getBlockIdNat
+ CondCode _ cond cond_code <- condFltCode cond x y
+ let
+ code dst = cond_code `appOL` toOL [
+ JXX cond lbl1,
+ MOV I32 (OpImm (ImmInt 0)) (OpReg dst),
+ JXX ALWAYS lbl2,
+ NEWBLOCK lbl1,
+ MOV I32 (OpImm (ImmInt 1)) (OpReg dst),
+ JXX ALWAYS lbl2,
+ NEWBLOCK lbl2]
+ -- SIGH, have to split up this block somehow...
+ -- in
+ return (Any I32 code)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+condIntReg EQQ x (StInt 0)
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code `appOL` toOL [
+ SUB False True g0 (RIReg src) g0,
+ SUB True False g0 (RIImm (ImmInt (-1))) dst]
+ in
+ return (Any IntRep code__2)
+
+condIntReg EQQ x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNat IntRep `thenNat` \ tmp1 ->
+ getNewRegNat IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 dst = code1 `appOL` code2 `appOL` toOL [
+ XOR False src1 (RIReg src2) dst,
+ SUB False True g0 (RIReg dst) g0,
+ SUB True False g0 (RIImm (ImmInt (-1))) dst]
+ in
+ return (Any IntRep code__2)
+
+condIntReg NE x (StInt 0)
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code `appOL` toOL [
+ SUB False True g0 (RIReg src) g0,
+ ADD True False g0 (RIImm (ImmInt 0)) dst]
+ in
+ return (Any IntRep code__2)
+
+condIntReg NE x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNat IntRep `thenNat` \ tmp1 ->
+ getNewRegNat IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 dst = code1 `appOL` code2 `appOL` toOL [
+ XOR False src1 (RIReg src2) dst,
+ SUB False True g0 (RIReg dst) g0,
+ ADD True False g0 (RIImm (ImmInt 0)) dst]
+ in
+ return (Any IntRep code__2)
+
+condIntReg cond x y
+ = getBlockIdNat `thenNat` \ lbl1 ->
+ getBlockIdNat `thenNat` \ lbl2 ->
+ condIntCode cond x y `thenNat` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = code `appOL` toOL [
+ BI cond False (ImmCLbl lbl1), NOP,
+ OR False g0 (RIImm (ImmInt 0)) dst,
+ BI ALWAYS False (ImmCLbl lbl2), NOP,
+ NEWBLOCK lbl1,
+ OR False g0 (RIImm (ImmInt 1)) dst,
+ NEWBLOCK lbl2]
+ in
+ return (Any IntRep code__2)
+
+condFltReg cond x y
+ = getBlockIdNat `thenNat` \ lbl1 ->
+ getBlockIdNat `thenNat` \ lbl2 ->
+ condFltCode cond x y `thenNat` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = code `appOL` toOL [
+ NOP,
+ BF cond False (ImmCLbl lbl1), NOP,
+ OR False g0 (RIImm (ImmInt 0)) dst,
+ BI ALWAYS False (ImmCLbl lbl2), NOP,
+ NEWBLOCK lbl1,
+ OR False g0 (RIImm (ImmInt 1)) dst,
+ NEWBLOCK lbl2]
+ in
+ return (Any IntRep code__2)
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+condReg getCond = do
+ lbl1 <- getBlockIdNat
+ lbl2 <- getBlockIdNat
+ CondCode _ cond cond_code <- getCond
+ let
+{- code dst = cond_code `appOL` toOL [
+ BCC cond lbl1,
+ LI dst (ImmInt 0),
+ BCC ALWAYS lbl2,
+ NEWBLOCK lbl1,
+ LI dst (ImmInt 1),
+ BCC ALWAYS lbl2,
+ NEWBLOCK lbl2
+ ]-}
+ code dst = cond_code
+ `appOL` negate_code
+ `appOL` toOL [
+ MFCR dst,
+ RLWINM dst dst (bit + 1) 31 31
+ ]
+
+ negate_code | do_negate = unitOL (CRNOR bit bit bit)
+ | otherwise = nilOL
+
+ (bit, do_negate) = case cond of
+ LTT -> (0, False)
+ LE -> (1, True)
+ EQQ -> (2, False)
+ GE -> (0, True)
+ GTT -> (1, False)
+
+ NE -> (2, True)
+
+ LU -> (0, False)
+ LEU -> (1, True)
+ GEU -> (0, True)
+ GU -> (1, False)
+
+ return (Any I32 code)
+
+condIntReg cond x y = condReg (condIntCode cond x y)
+condFltReg cond x y = condReg (condFltCode cond x y)
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- 'trivial*Code': deal with trivial instructions
+
+-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
+-- Only look for constants on the right hand side, because that's
+-- where the generic optimizer will have put them.
+
+-- Similarly, for unary instructions, we don't have to worry about
+-- matching an StInt as the argument, because genericOpt will already
+-- have handled the constant-folding.
+
+trivialCode
+ :: MachRep
+ -> IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
+ ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
+ -> Maybe (Operand -> Operand -> Instr)
+ ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
+ ,IF_ARCH_powerpc(Bool -> (Reg -> Reg -> RI -> Instr)
+ ,))))
+ -> CmmExpr -> CmmExpr -- the two arguments
+ -> NatM Register
+
+#ifndef powerpc_TARGET_ARCH
+trivialFCode
+ :: MachRep
+ -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
+ ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
+ ,IF_ARCH_i386 ((MachRep -> Reg -> Reg -> Reg -> Instr)
+ ,)))
+ -> CmmExpr -> CmmExpr -- the two arguments
+ -> NatM Register
+#endif
+
+trivialUCode
+ :: MachRep
+ -> IF_ARCH_alpha((RI -> Reg -> Instr)
+ ,IF_ARCH_i386 ((Operand -> Instr)
+ ,IF_ARCH_sparc((RI -> Reg -> Instr)
+ ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
+ ,))))
+ -> CmmExpr -- the one argument
+ -> NatM Register
+
+#ifndef powerpc_TARGET_ARCH
+trivialUFCode
+ :: MachRep
+ -> IF_ARCH_alpha((Reg -> Reg -> Instr)
+ ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
+ ,IF_ARCH_sparc((Reg -> Reg -> Instr)
+ ,)))
+ -> CmmExpr -- the one argument
+ -> NatM Register
+#endif
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+
+trivialCode instr x (StInt y)
+ | fits8Bits y
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (fromInteger y)
+ code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
+ in
+ return (Any IntRep code__2)
+
+trivialCode instr x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNat IntRep `thenNat` \ tmp1 ->
+ getNewRegNat IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 []
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 []
+ src2 = registerName register2 tmp2
+ code__2 dst = asmSeqThen [code1, code2] .
+ mkSeqInstr (instr src1 (RIReg src2) dst)
+ in
+ return (Any IntRep code__2)
+
+------------
+trivialUCode instr x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
+ in
+ return (Any IntRep code__2)
+
+------------
+trivialFCode _ instr x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNat F64 `thenNat` \ tmp1 ->
+ getNewRegNat F64 `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ code__2 dst = asmSeqThen [code1 [], code2 []] .
+ mkSeqInstr (instr src1 src2 dst)
+ in
+ return (Any F64 code__2)
+
+trivialUFCode _ instr x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat F64 `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr src dst)
+ in
+ return (Any F64 code__2)
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+{-
+The Rules of the Game are:
+
+* You cannot assume anything about the destination register dst;
+ it may be anything, including a fixed reg.
+
+* You may compute an operand into a fixed reg, but you may not
+ subsequently change the contents of that fixed reg. If you
+ want to do so, first copy the value either to a temporary
+ or into dst. You are free to modify dst even if it happens
+ to be a fixed reg -- that's not your problem.
+
+* You cannot assume that a fixed reg will stay live over an
+ arbitrary computation. The same applies to the dst reg.
+
+* Temporary regs obtained from getNewRegNat are distinct from
+ each other and from all other regs, and stay live over
+ arbitrary computations.
+
+--------------------
+
+SDM's version of The Rules:
+
+* If getRegister returns Any, that means it can generate correct
+ code which places the result in any register, period. Even if that
+ register happens to be read during the computation.
+
+ Corollary #1: this means that if you are generating code for an
+ operation with two arbitrary operands, you cannot assign the result
+ of the first operand into the destination register before computing
+ the second operand. The second operand might require the old value
+ of the destination register.
+
+ Corollary #2: A function might be able to generate more efficient
+ code if it knows the destination register is a new temporary (and
+ therefore not read by any of the sub-computations).
+
+* If getRegister returns Any, then the code it generates may modify only:
+ (a) fresh temporaries
+ (b) the destination register
+ (c) known registers (eg. %ecx is used by shifts)
+ In particular, it may *not* modify global registers, unless the global
+ register happens to be the destination register.
+-}
+
+trivialCode rep instr maybe_revinstr a (CmmLit lit_b) = do
+ a_code <- getAnyReg a
+ let
+ code dst
+ = a_code dst `snocOL`
+ instr (OpImm (litToImm lit_b)) (OpReg dst)
+ -- in
+ return (Any rep code)
+
+trivialCode rep instr (Just revinstr) (CmmLit lit_a) b = do
+ b_code <- getAnyReg b
+ let
+ code dst
+ = b_code dst `snocOL`
+ revinstr (OpImm (litToImm lit_a)) (OpReg dst)
+ -- in
+ return (Any rep code)
+
+trivialCode rep instr maybe_revinstr a b = do
+ (b_op, b_code) <- getOperand b
+ a_code <- getAnyReg a
+ tmp <- getNewRegNat rep
+ let
+ -- We want the value of b to stay alive across the computation of a.
+ -- But, we want to calculate a straight into the destination register,
+ -- because the instruction only has two operands (dst := dst `op` src).
+ -- The troublesome case is when the result of b is in the same register
+ -- as the destination reg. In this case, we have to save b in a
+ -- new temporary across the computation of a.
+ code dst
+ | dst `clashesWith` b_op =
+ b_code `appOL`
+ unitOL (MOV rep b_op (OpReg tmp)) `appOL`
+ a_code dst `snocOL`
+ instr (OpReg tmp) (OpReg dst)
+ | otherwise =
+ b_code `appOL`
+ a_code dst `snocOL`
+ instr b_op (OpReg dst)
+ -- in
+ return (Any rep code)
+ where
+ reg `clashesWith` OpReg reg2 = reg == reg2
+ reg `clashesWith` OpAddr amode = any (==reg) (addrModeRegs amode)
+
+-----------
+
+trivialUCode rep instr x = do
+ x_code <- getAnyReg x
+ let
+ code dst =
+ x_code dst `snocOL`
+ instr (OpReg dst)
+ -- in
+ return (Any rep code)
+
+-----------
+
+trivialFCode pk instr x y = do
+ (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too
+ (y_reg, y_code) <- getSomeReg y
+ let
+ code dst =
+ x_code `appOL`
+ y_code `snocOL`
+ instr pk x_reg y_reg dst
+ -- in
+ return (Any pk code)
+
+-------------
+
+trivialUFCode rep instr x = do
+ (x_reg, x_code) <- getSomeReg x
+ let
+ code dst =
+ x_code `snocOL`
+ instr x_reg dst
+ -- in
+ return (Any rep code)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+trivialCode instr x (StInt y)
+ | fits13Bits y
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (fromInteger y)
+ code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
+ in
+ return (Any IntRep code__2)
+
+trivialCode instr x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNat IntRep `thenNat` \ tmp1 ->
+ getNewRegNat IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 dst = code1 `appOL` code2 `snocOL`
+ instr src1 (RIReg src2) dst
+ in
+ return (Any IntRep code__2)
+
+------------
+trivialFCode pk instr x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNat (registerRep register1)
+ `thenNat` \ tmp1 ->
+ getNewRegNat (registerRep register2)
+ `thenNat` \ tmp2 ->
+ getNewRegNat F64 `thenNat` \ tmp ->
+ let
+ promote x = FxTOy F DF x tmp
+
+ pk1 = registerRep register1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ pk2 = registerRep register2
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ code__2 dst =
+ if pk1 == pk2 then
+ code1 `appOL` code2 `snocOL`
+ instr (primRepToSize pk) src1 src2 dst
+ else if pk1 == F32 then
+ code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+ instr DF tmp src2 dst
+ else
+ code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+ instr DF src1 tmp dst
+ in
+ return (Any (if pk1 == pk2 then pk1 else F64) code__2)
+
+------------
+trivialUCode instr x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code `snocOL` instr (RIReg src) dst
+ in
+ return (Any IntRep code__2)
+
+-------------
+trivialUFCode pk instr x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat pk `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code `snocOL` instr src dst
+ in
+ return (Any pk code__2)
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+{-
+Wolfgang's PowerPC version of The Rules:
+
+A slightly modified version of The Rules to take advantage of the fact
+that PowerPC instructions work on all registers and don't implicitly
+clobber any fixed registers.
+
+* The only expression for which getRegister returns Fixed is (CmmReg reg).
+
+* If getRegister returns Any, then the code it generates may modify only:
+ (a) fresh temporaries
+ (b) the destination register
+ It may *not* modify global registers, unless the global
+ register happens to be the destination register.
+ It may not clobber any other registers. In fact, only ccalls clobber any
+ fixed registers.
+ Also, it may not modify the counter register (used by genCCall).
+
+ Corollary: If a getRegister for a subexpression returns Fixed, you need
+ not move it to a fresh temporary before evaluating the next subexpression.
+ The Fixed register won't be modified.
+ Therefore, we don't need a counterpart for the x86's getStableReg on PPC.
+
+* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on
+ the value of the destination register.
+-}
+
+trivialCode rep signed instr x (CmmLit (CmmInt y _))
+ | Just imm <- makeImmediate rep signed y
+ = do
+ (src1, code1) <- getSomeReg x
+ let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
+ return (Any rep code)
+
+trivialCode rep signed instr x y = do
+ (src1, code1) <- getSomeReg x
+ (src2, code2) <- getSomeReg y
+ let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)
+ return (Any rep code)
+
+trivialCodeNoImm :: MachRep -> (Reg -> Reg -> Reg -> Instr)
+ -> CmmExpr -> CmmExpr -> NatM Register
+trivialCodeNoImm rep instr x y = do
+ (src1, code1) <- getSomeReg x
+ (src2, code2) <- getSomeReg y
+ let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
+ return (Any rep code)
+
+trivialUCode rep instr x = do
+ (src, code) <- getSomeReg x
+ let code' dst = code `snocOL` instr dst src
+ return (Any rep code')
+
+-- There is no "remainder" instruction on the PPC, so we have to do
+-- it the hard way.
+-- The "div" parameter is the division instruction to use (DIVW or DIVWU)
+
+remainderCode :: MachRep -> (Reg -> Reg -> Reg -> Instr)
+ -> CmmExpr -> CmmExpr -> NatM Register
+remainderCode rep div x y = do
+ (src1, code1) <- getSomeReg x
+ (src2, code2) <- getSomeReg y
+ let code dst = code1 `appOL` code2 `appOL` toOL [
+ div dst src1 src2,
+ MULLW dst dst (RIReg src2),
+ SUBF dst dst src1
+ ]
+ return (Any rep code)
+
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Coercing to/from integer/floating-point...
+
+-- @coerce(Int2FP|FP2Int)@ are more complicated integer/float
+-- conversions. We have to store temporaries in memory to move
+-- between the integer and the floating point register sets.
+
+-- @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
+-- pretend, on sparc at least, that double and float regs are seperate
+-- kinds, so the value has to be computed into one kind before being
+-- explicitly "converted" to live in the other kind.
+
+coerceInt2FP :: MachRep -> MachRep -> CmmExpr -> NatM Register
+coerceFP2Int :: MachRep -> MachRep -> CmmExpr -> NatM Register
+
+#ifdef sparc_TARGET_ARCH
+coerceDbl2Flt :: CmmExpr -> NatM Register
+coerceFlt2Dbl :: CmmExpr -> NatM Register
+#endif
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if alpha_TARGET_ARCH
+
+coerceInt2FP _ x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ reg ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+
+ code__2 dst = code . mkSeqInstrs [
+ ST Q src (spRel 0),
+ LD TF dst (spRel 0),
+ CVTxy Q TF dst dst]
+ in
+ return (Any F64 code__2)
+
+-------------
+coerceFP2Int x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat F64 `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+
+ code__2 dst = code . mkSeqInstrs [
+ CVTxy TF Q src tmp,
+ ST TF tmp (spRel 0),
+ LD Q dst (spRel 0)]
+ in
+ return (Any IntRep code__2)
+
+#endif /* alpha_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if i386_TARGET_ARCH
+
+coerceInt2FP from to x = do
+ (x_reg, x_code) <- getSomeReg x
+ let
+ opc = case to of F32 -> GITOF; F64 -> GITOD
+ code dst = x_code `snocOL` opc x_reg dst
+ -- ToDo: works for non-I32 reps?
+ -- in
+ return (Any to code)
+
+------------
+
+coerceFP2Int from to x = do
+ (x_reg, x_code) <- getSomeReg x
+ let
+ opc = case from of F32 -> GFTOI; F64 -> GDTOI
+ code dst = x_code `snocOL` opc x_reg dst
+ -- ToDo: works for non-I32 reps?
+ -- in
+ return (Any to code)
+
+#endif /* i386_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if sparc_TARGET_ARCH
+
+coerceInt2FP pk x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat IntRep `thenNat` \ reg ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+
+ code__2 dst = code `appOL` toOL [
+ ST W src (spRel (-2)),
+ LD W (spRel (-2)) dst,
+ FxTOy W (primRepToSize pk) dst dst]
+ in
+ return (Any pk code__2)
+
+------------
+coerceFP2Int fprep x
+ = ASSERT(fprep == F64 || fprep == F32)
+ getRegister x `thenNat` \ register ->
+ getNewRegNat fprep `thenNat` \ reg ->
+ getNewRegNat F32 `thenNat` \ tmp ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+ code__2 dst = code `appOL` toOL [
+ FxTOy (primRepToSize fprep) W src tmp,
+ ST W tmp (spRel (-2)),
+ LD W (spRel (-2)) dst]
+ in
+ return (Any IntRep code__2)
+
+------------
+coerceDbl2Flt x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat F64 `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
+ in
+ return (Any F32
+ (\dst -> code `snocOL` FxTOy DF F src dst))
+
+------------
+coerceFlt2Dbl x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNat F32 `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
+ in
+ return (Any F64
+ (\dst -> code `snocOL` FxTOy F DF src dst))
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+coerceInt2FP fromRep toRep x = do
+ (src, code) <- getSomeReg x
+ lbl <- getNewLabelNat
+ itmp <- getNewRegNat I32
+ ftmp <- getNewRegNat F64
+ let
+ code' dst = code `appOL` maybe_exts `appOL` toOL [
+ LDATA ReadOnlyData
+ [CmmDataLabel lbl,
+ CmmStaticLit (CmmInt 0x43300000 I32),
+ CmmStaticLit (CmmInt 0x80000000 I32)],
+ XORIS itmp src (ImmInt 0x8000),
+ ST I32 itmp (spRel 3),
+ LIS itmp (ImmInt 0x4330),
+ ST I32 itmp (spRel 2),
+ LD F64 ftmp (spRel 2),
+ LIS itmp (HA (ImmCLbl lbl)),
+ LD F64 dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
+ FSUB F64 dst ftmp dst
+ ] `appOL` maybe_frsp dst
+
+ maybe_exts = case fromRep of
+ I8 -> unitOL $ EXTS I8 src src
+ I16 -> unitOL $ EXTS I16 src src
+ I32 -> nilOL
+ maybe_frsp dst = case toRep of
+ F32 -> unitOL $ FRSP dst dst
+ F64 -> nilOL
+ return (Any toRep code')
+
+coerceFP2Int fromRep toRep x = do
+ -- the reps don't really matter: F*->F64 and I32->I* are no-ops
+ (src, code) <- getSomeReg x
+ tmp <- getNewRegNat F64
+ let
+ code' dst = code `appOL` toOL [
+ -- convert to int in FP reg
+ FCTIWZ tmp src,
+ -- store value (64bit) from FP to stack
+ ST F64 tmp (spRel 2),
+ -- read low word of value (high word is undefined)
+ LD I32 dst (spRel 3)]
+ return (Any toRep code')
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- eXTRA_STK_ARGS_HERE
+
+-- We (allegedly) put the first six C-call arguments in registers;
+-- where do we start putting the rest of them?
+
+-- Moved from MachInstrs (SDM):
+
+#if alpha_TARGET_ARCH || sparc_TARGET_ARCH
+eXTRA_STK_ARGS_HERE :: Int
+eXTRA_STK_ARGS_HERE
+ = IF_ARCH_alpha(0, IF_ARCH_sparc(23, ???))
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Machine-dependent assembly language
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-----------------------------------------------------------------------------
+
+#include "nativeGen/NCG.h"
+
+module MachInstrs (
+ -- * Cmm instantiations
+ NatCmm, NatCmmTop, NatBasicBlock,
+
+ -- * Machine instructions
+ Instr(..),
+ Cond(..),
+#if !powerpc_TARGET_ARCH && !i386_TARGET_ARCH
+ Size(..), machRepSize,
+#endif
+ RI(..),
+
+#if i386_TARGET_ARCH
+ Operand(..),
+ i386_insert_ffrees,
+#endif
+#if sparc_TARGET_ARCH
+ riZero, fpRelEA, moveSp, fPair,
+#endif
+#if powerpc_TARGET_ARCH
+ condUnsigned, condToSigned,
+#endif
+ DestInfo(..), hasDestInfo, pprDests,
+
+ ) where
+
+#include "HsVersions.h"
+#include "../includes/ghcconfig.h"
+
+import MachRegs
+import Cmm
+import MachOp ( MachRep(..) )
+import CLabel ( CLabel, pprCLabel )
+import Panic ( panic )
+import Outputable
+import Config ( cLeadingUnderscore )
+import FastString
+
+import GLAEXTS
+
+
+-- -----------------------------------------------------------------------------
+-- Our flavours of the Cmm types
+
+-- Type synonyms for Cmm populated with native code
+type NatCmm = GenCmm CmmStatic Instr
+type NatCmmTop = GenCmmTop CmmStatic Instr
+type NatBasicBlock = GenBasicBlock Instr
+
+-- -----------------------------------------------------------------------------
+-- Conditions on this architecture
+
+data Cond
+#if alpha_TARGET_ARCH
+ = ALWAYS -- For BI (same as BR)
+ | EQQ -- For CMP and BI (NB: "EQ" is a 1.3 Prelude name)
+ | GE -- For BI only
+ | GTT -- For BI only (NB: "GT" is a 1.3 Prelude name)
+ | LE -- For CMP and BI
+ | LTT -- For CMP and BI (NB: "LT" is a 1.3 Prelude name)
+ | NE -- For BI only
+ | NEVER -- For BI (null instruction)
+ | ULE -- For CMP only
+ | ULT -- For CMP only
+#endif
+#if i386_TARGET_ARCH
+ = ALWAYS -- What's really used? ToDo
+ | EQQ
+ | GE
+ | GEU
+ | GTT
+ | GU
+ | LE
+ | LEU
+ | LTT
+ | LU
+ | NE
+ | NEG
+ | POS
+ | CARRY
+ | OFLO
+#endif
+#if sparc_TARGET_ARCH
+ = ALWAYS -- What's really used? ToDo
+ | EQQ
+ | GE
+ | GEU
+ | GTT
+ | GU
+ | LE
+ | LEU
+ | LTT
+ | LU
+ | NE
+ | NEG
+ | NEVER
+ | POS
+ | VC
+ | VS
+#endif
+#if powerpc_TARGET_ARCH
+ = ALWAYS
+ | EQQ
+ | GE
+ | GEU
+ | GTT
+ | GU
+ | LE
+ | LEU
+ | LTT
+ | LU
+ | NE
+#endif
+ deriving Eq -- to make an assertion work
+
+
+-- -----------------------------------------------------------------------------
+-- Sizes on this architecture
+
+-- ToDo: it's not clear to me that we need separate signed-vs-unsigned sizes
+-- here. I've removed them from the x86 version, we'll see what happens --SDM
+
+#if !powerpc_TARGET_ARCH && !i386_TARGET_ARCH
+data Size
+#if alpha_TARGET_ARCH
+ = B -- byte
+ | Bu
+-- | W -- word (2 bytes): UNUSED
+-- | Wu -- : UNUSED
+ | L -- longword (4 bytes)
+ | Q -- quadword (8 bytes)
+-- | FF -- VAX F-style floating pt: UNUSED
+-- | GF -- VAX G-style floating pt: UNUSED
+-- | DF -- VAX D-style floating pt: UNUSED
+-- | SF -- IEEE single-precision floating pt: UNUSED
+ | TF -- IEEE double-precision floating pt
+#endif
+#if sparc_TARGET_ARCH || powerpc_TARGET_ARCH
+ = B -- byte (signed)
+ | Bu -- byte (unsigned)
+ | H -- halfword (signed, 2 bytes)
+ | Hu -- halfword (unsigned, 2 bytes)
+ | W -- word (4 bytes)
+ | F -- IEEE single-precision floating pt
+ | DF -- IEEE single-precision floating pt
+#endif
+ deriving Eq
+
+machRepSize :: MachRep -> Size
+machRepSize I8 = IF_ARCH_alpha(Bu, IF_ARCH_sparc(Bu, ))
+machRepSize I16 = IF_ARCH_alpha(err,IF_ARCH_sparc(Hu, ))
+machRepSize I32 = IF_ARCH_alpha(L, IF_ARCH_sparc(W, ))
+machRepSize I64 = panic "machRepSize: I64"
+machRepSize I128 = panic "machRepSize: I128"
+machRepSize F32 = IF_ARCH_alpha(TF, IF_ARCH_sparc(F, ))
+machRepSize F64 = IF_ARCH_alpha(TF, IF_ARCH_sparc(DF,))
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Register or immediate (a handy type on some platforms)
+
+data RI = RIReg Reg
+ | RIImm Imm
+
+
+-- -----------------------------------------------------------------------------
+-- Machine's assembly language
+
+-- We have a few common "instructions" (nearly all the pseudo-ops) but
+-- mostly all of 'Instr' is machine-specific.
+
+data Instr
+ = COMMENT FastString -- comment pseudo-op
+
+ | LDATA Section [CmmStatic] -- some static data spat out during code
+ -- generation. Will be extracted before
+ -- pretty-printing.
+
+ | NEWBLOCK BlockId -- start a new basic block. Useful during
+ -- codegen, removed later. Preceding
+ -- instruction should be a jump, as per the
+ -- invariants for a BasicBlock (see Cmm).
+
+ | DELTA Int -- specify current stack offset for
+ -- benefit of subsequent passes
+
+-- -----------------------------------------------------------------------------
+-- Alpha instructions
+
+#if alpha_TARGET_ARCH
+
+-- data Instr continues...
+
+-- Loads and stores.
+ | LD Size Reg AddrMode -- size, dst, src
+ | LDA Reg AddrMode -- dst, src
+ | LDAH Reg AddrMode -- dst, src
+ | LDGP Reg AddrMode -- dst, src
+ | LDI Size Reg Imm -- size, dst, src
+ | ST Size Reg AddrMode -- size, src, dst
+
+-- Int Arithmetic.
+ | CLR Reg -- dst
+ | ABS Size RI Reg -- size, src, dst
+ | NEG Size Bool RI Reg -- size, overflow, src, dst
+ | ADD Size Bool Reg RI Reg -- size, overflow, src, src, dst
+ | SADD Size Size Reg RI Reg -- size, scale, src, src, dst
+ | SUB Size Bool Reg RI Reg -- size, overflow, src, src, dst
+ | SSUB Size Size Reg RI Reg -- size, scale, src, src, dst
+ | MUL Size Bool Reg RI Reg -- size, overflow, src, src, dst
+ | DIV Size Bool Reg RI Reg -- size, unsigned, src, src, dst
+ | REM Size Bool Reg RI Reg -- size, unsigned, src, src, dst
+
+-- Simple bit-twiddling.
+ | NOT RI Reg
+ | AND Reg RI Reg
+ | ANDNOT Reg RI Reg
+ | OR Reg RI Reg
+ | ORNOT Reg RI Reg
+ | XOR Reg RI Reg
+ | XORNOT Reg RI Reg
+ | SLL Reg RI Reg
+ | SRL Reg RI Reg
+ | SRA Reg RI Reg
+
+ | ZAP Reg RI Reg
+ | ZAPNOT Reg RI Reg
+
+ | NOP
+
+-- Comparison
+ | CMP Cond Reg RI Reg
+
+-- Float Arithmetic.
+ | FCLR Reg
+ | FABS Reg Reg
+ | FNEG Size Reg Reg
+ | FADD Size Reg Reg Reg
+ | FDIV Size Reg Reg Reg
+ | FMUL Size Reg Reg Reg
+ | FSUB Size Reg Reg Reg
+ | CVTxy Size Size Reg Reg
+ | FCMP Size Cond Reg Reg Reg
+ | FMOV Reg Reg
+
+-- Jumping around.
+ | BI Cond Reg Imm
+ | BF Cond Reg Imm
+ | BR Imm
+ | JMP Reg AddrMode Int
+ | BSR Imm Int
+ | JSR Reg AddrMode Int
+
+-- Alpha-specific pseudo-ops.
+ | FUNBEGIN CLabel
+ | FUNEND CLabel
+
+data RI
+ = RIReg Reg
+ | RIImm Imm
+
+#endif /* alpha_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Intel x86 instructions
+
+{-
+Intel, in their infinite wisdom, selected a stack model for floating
+point registers on x86. That might have made sense back in 1979 --
+nowadays we can see it for the nonsense it really is. A stack model
+fits poorly with the existing nativeGen infrastructure, which assumes
+flat integer and FP register sets. Prior to this commit, nativeGen
+could not generate correct x86 FP code -- to do so would have meant
+somehow working the register-stack paradigm into the register
+allocator and spiller, which sounds very difficult.
+
+We have decided to cheat, and go for a simple fix which requires no
+infrastructure modifications, at the expense of generating ropey but
+correct FP code. All notions of the x86 FP stack and its insns have
+been removed. Instead, we pretend (to the instruction selector and
+register allocator) that x86 has six floating point registers, %fake0
+.. %fake5, which can be used in the usual flat manner. We further
+claim that x86 has floating point instructions very similar to SPARC
+and Alpha, that is, a simple 3-operand register-register arrangement.
+Code generation and register allocation proceed on this basis.
+
+When we come to print out the final assembly, our convenient fiction
+is converted to dismal reality. Each fake instruction is
+independently converted to a series of real x86 instructions.
+%fake0 .. %fake5 are mapped to %st(0) .. %st(5). To do reg-reg
+arithmetic operations, the two operands are pushed onto the top of the
+FP stack, the operation done, and the result copied back into the
+relevant register. There are only six %fake registers because 2 are
+needed for the translation, and x86 has 8 in total.
+
+The translation is inefficient but is simple and it works. A cleverer
+translation would handle a sequence of insns, simulating the FP stack
+contents, would not impose a fixed mapping from %fake to %st regs, and
+hopefully could avoid most of the redundant reg-reg moves of the
+current translation.
+
+We might as well make use of whatever unique FP facilities Intel have
+chosen to bless us with (let's not be churlish, after all).
+Hence GLDZ and GLD1. Bwahahahahahahaha!
+-}
+
+{-
+MORE FLOATING POINT MUSINGS...
+
+Intel's internal floating point registers are by default 80 bit
+extended precision. This means that all operations done on values in
+registers are done at 80 bits, and unless the intermediate values are
+truncated to the appropriate size (32 or 64 bits) by storing in
+memory, calculations in registers will give different results from
+calculations which pass intermediate values in memory (eg. via
+function calls).
+
+One solution is to set the FPU into 64 bit precision mode. Some OSs
+do this (eg. FreeBSD) and some don't (eg. Linux). The problem here is
+that this will only affect 64-bit precision arithmetic; 32-bit
+calculations will still be done at 64-bit precision in registers. So
+it doesn't solve the whole problem.
+
+There's also the issue of what the C library is expecting in terms of
+precision. It seems to be the case that glibc on Linux expects the
+FPU to be set to 80 bit precision, so setting it to 64 bit could have
+unexpected effects. Changing the default could have undesirable
+effects on other 3rd-party library code too, so the right thing would
+be to save/restore the FPU control word across Haskell code if we were
+to do this.
+
+gcc's -ffloat-store gives consistent results by always storing the
+results of floating-point calculations in memory, which works for both
+32 and 64-bit precision. However, it only affects the values of
+user-declared floating point variables in C, not intermediate results.
+GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision
+flag).
+
+Another problem is how to spill floating point registers in the
+register allocator. Should we spill the whole 80 bits, or just 64?
+On an OS which is set to 64 bit precision, spilling 64 is fine. On
+Linux, spilling 64 bits will round the results of some operations.
+This is what gcc does. Spilling at 80 bits requires taking up a full
+128 bit slot (so we get alignment). We spill at 80-bits and ignore
+the alignment problems.
+
+In the future, we'll use the SSE registers for floating point. This
+requires a CPU that supports SSE2 (ordinary SSE only supports 32 bit
+precision float ops), which means P4 or Xeon and above. Using SSE
+will solve all these problems, because the SSE registers use fixed 32
+bit or 64 bit precision.
+
+--SDM 1/2003
+-}
+
+#if i386_TARGET_ARCH
+
+-- data Instr continues...
+
+-- Moves.
+ | MOV MachRep Operand Operand
+ | MOVZxL MachRep Operand Operand -- size is the size of operand 1
+ | MOVSxL MachRep Operand Operand -- size is the size of operand 1
+
+-- Load effective address (also a very useful three-operand add instruction :-)
+ | LEA MachRep Operand Operand
+
+-- Int Arithmetic.
+ | ADD MachRep Operand Operand
+ | ADC MachRep Operand Operand
+ | SUB MachRep Operand Operand
+ | IMUL MachRep Operand Operand -- signed int mul
+ | MUL MachRep Operand Operand -- unsigned int mul
+
+ | IMUL64 Reg Reg
+ -- operand1:operand2 := (operand1[31:0] *signed operand2[31:0])
+
+ | DIV MachRep Operand -- eax := eax:edx/op, edx := eax:edx%op
+ | IDIV MachRep Operand -- ditto, but signed
+
+-- Simple bit-twiddling.
+ | AND MachRep Operand Operand
+ | OR MachRep Operand Operand
+ | XOR MachRep Operand Operand
+ | NOT MachRep Operand
+ | NEGI MachRep Operand -- NEG instruction (name clash with Cond)
+
+-- Shifts (amount may be immediate or %cl only)
+ | SHL MachRep Operand{-amount-} Operand
+ | SAR MachRep Operand{-amount-} Operand
+ | SHR MachRep Operand{-amount-} Operand
+
+ | BT MachRep Imm Operand
+ | NOP
+
+-- Float Arithmetic.
+
+-- Note that we cheat by treating G{ABS,MOV,NEG} of doubles
+-- as single instructions right up until we spit them out.
+ -- all the 3-operand fake fp insns are src1 src2 dst
+ -- and furthermore are constrained to be fp regs only.
+ -- IMPORTANT: keep is_G_insn up to date with any changes here
+ | GMOV Reg Reg -- src(fpreg), dst(fpreg)
+ | GLD MachRep AddrMode Reg -- src, dst(fpreg)
+ | GST MachRep Reg AddrMode -- src(fpreg), dst
+
+ | GLDZ Reg -- dst(fpreg)
+ | GLD1 Reg -- dst(fpreg)
+
+ | GFTOI Reg Reg -- src(fpreg), dst(intreg)
+ | GDTOI Reg Reg -- src(fpreg), dst(intreg)
+
+ | GITOF Reg Reg -- src(intreg), dst(fpreg)
+ | GITOD Reg Reg -- src(intreg), dst(fpreg)
+
+ | GADD MachRep Reg Reg Reg -- src1, src2, dst
+ | GDIV MachRep Reg Reg Reg -- src1, src2, dst
+ | GSUB MachRep Reg Reg Reg -- src1, src2, dst
+ | GMUL MachRep Reg Reg Reg -- src1, src2, dst
+
+ -- FP compare. Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT]
+ -- Compare src1 with src2; set the Zero flag iff the numbers are
+ -- comparable and the comparison is True. Subsequent code must
+ -- test the %eflags zero flag regardless of the supplied Cond.
+ | GCMP Cond Reg Reg -- src1, src2
+
+ | GABS MachRep Reg Reg -- src, dst
+ | GNEG MachRep Reg Reg -- src, dst
+ | GSQRT MachRep Reg Reg -- src, dst
+ | GSIN MachRep Reg Reg -- src, dst
+ | GCOS MachRep Reg Reg -- src, dst
+ | GTAN MachRep Reg Reg -- src, dst
+
+ | GFREE -- do ffree on all x86 regs; an ugly hack
+
+-- Comparison
+ | TEST MachRep Operand Operand
+ | CMP MachRep Operand Operand
+ | SETCC Cond Operand
+
+-- Stack Operations.
+ | PUSH MachRep Operand
+ | POP MachRep Operand
+ -- both unused (SDM):
+ -- | PUSHA
+ -- | POPA
+
+-- Jumping around.
+ | JMP Operand
+ | JXX Cond BlockId -- includes unconditional branches
+ | JMP_TBL Operand [BlockId] -- table jump
+ | CALL (Either Imm Reg)
+
+-- Other things.
+ | CLTD -- sign extend %eax into %edx:%eax
+
+data Operand
+ = OpReg Reg -- register
+ | OpImm Imm -- immediate value
+ | OpAddr AddrMode -- memory reference
+
+
+i386_insert_ffrees :: [Instr] -> [Instr]
+i386_insert_ffrees insns
+ | any is_G_instr insns
+ = concatMap ffree_before_nonlocal_transfers insns
+ | otherwise
+ = insns
+
+ffree_before_nonlocal_transfers insn
+ = case insn of
+ CALL _ -> [GFREE, insn]
+ JMP _ -> [GFREE, insn]
+ other -> [insn]
+
+
+-- if you ever add a new FP insn to the fake x86 FP insn set,
+-- you must update this too
+is_G_instr :: Instr -> Bool
+is_G_instr instr
+ = case instr of
+ GMOV _ _ -> True; GLD _ _ _ -> True; GST _ _ _ -> True;
+ GLDZ _ -> True; GLD1 _ -> True;
+ GFTOI _ _ -> True; GDTOI _ _ -> True;
+ GITOF _ _ -> True; GITOD _ _ -> True;
+ GADD _ _ _ _ -> True; GDIV _ _ _ _ -> True
+ GSUB _ _ _ _ -> True; GMUL _ _ _ _ -> True
+ GCMP _ _ _ -> True; GABS _ _ _ -> True
+ GNEG _ _ _ -> True; GSQRT _ _ _ -> True
+ GSIN _ _ _ -> True; GCOS _ _ _ -> True; GTAN _ _ _ -> True;
+ GFREE -> panic "is_G_instr: GFREE (!)"
+ other -> False
+
+#endif /* i386_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- Sparc instructions
+
+#if sparc_TARGET_ARCH
+
+-- data Instr continues...
+
+-- Loads and stores.
+ | LD MachRep AddrMode Reg -- size, src, dst
+ | ST MachRep Reg AddrMode -- size, src, dst
+
+-- Int Arithmetic.
+ | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
+ | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
+ | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst
+ | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst
+ | RDY Reg -- move contents of Y register to reg
+
+-- Simple bit-twiddling.
+ | AND Bool Reg RI Reg -- cc?, src1, src2, dst
+ | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst
+ | OR Bool Reg RI Reg -- cc?, src1, src2, dst
+ | ORN Bool Reg RI Reg -- cc?, src1, src2, dst
+ | XOR Bool Reg RI Reg -- cc?, src1, src2, dst
+ | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst
+ | SLL Reg RI Reg -- src1, src2, dst
+ | SRL Reg RI Reg -- src1, src2, dst
+ | SRA Reg RI Reg -- src1, src2, dst
+ | SETHI Imm Reg -- src, dst
+ | NOP -- Really SETHI 0, %g0, but worth an alias
+
+-- Float Arithmetic.
+
+-- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single
+-- instructions right up until we spit them out.
+ | FABS MachRep Reg Reg -- src dst
+ | FADD MachRep Reg Reg Reg -- src1, src2, dst
+ | FCMP Bool MachRep Reg Reg -- exception?, src1, src2, dst
+ | FDIV MachRep Reg Reg Reg -- src1, src2, dst
+ | FMOV MachRep Reg Reg -- src, dst
+ | FMUL MachRep Reg Reg Reg -- src1, src2, dst
+ | FNEG MachRep Reg Reg -- src, dst
+ | FSQRT MachRep Reg Reg -- src, dst
+ | FSUB MachRep Reg Reg Reg -- src1, src2, dst
+ | FxTOy MachRep MachRep Reg Reg -- src, dst
+
+-- Jumping around.
+ | BI Cond Bool Imm -- cond, annul?, target
+ | BF Cond Bool Imm -- cond, annul?, target
+
+ | JMP DestInfo AddrMode -- target
+ | CALL (Either Imm Reg) Int Bool -- target, args, terminal
+
+data RI = RIReg Reg
+ | RIImm Imm
+
+riZero :: RI -> Bool
+
+riZero (RIImm (ImmInt 0)) = True
+riZero (RIImm (ImmInteger 0)) = True
+riZero (RIReg (RealReg 0)) = True
+riZero _ = False
+
+-- Calculate the effective address which would be used by the
+-- corresponding fpRel sequence. fpRel is in MachRegs.lhs,
+-- alas -- can't have fpRelEA here because of module dependencies.
+fpRelEA :: Int -> Reg -> Instr
+fpRelEA n dst
+ = ADD False False fp (RIImm (ImmInt (n * BYTES_PER_WORD))) dst
+
+-- Code to shift the stack pointer by n words.
+moveSp :: Int -> Instr
+moveSp n
+ = ADD False False sp (RIImm (ImmInt (n * BYTES_PER_WORD))) sp
+
+-- Produce the second-half-of-a-double register given the first half.
+fPair :: Reg -> Reg
+fPair (RealReg n) | n >= 32 && n `mod` 2 == 0 = RealReg (n+1)
+fPair other = pprPanic "fPair(sparc NCG)" (ppr other)
+#endif /* sparc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- PowerPC instructions
+
+#ifdef powerpc_TARGET_ARCH
+-- data Instr continues...
+
+-- Loads and stores.
+ | LD MachRep Reg AddrMode -- Load size, dst, src
+ | LA MachRep Reg AddrMode -- Load arithmetic size, dst, src
+ | ST MachRep Reg AddrMode -- Store size, src, dst
+ | STU MachRep Reg AddrMode -- Store with Update size, src, dst
+ | LIS Reg Imm -- Load Immediate Shifted dst, src
+ | LI Reg Imm -- Load Immediate dst, src
+ | MR Reg Reg -- Move Register dst, src -- also for fmr
+
+ | CMP MachRep Reg RI --- size, src1, src2
+ | CMPL MachRep Reg RI --- size, src1, src2
+
+ | BCC Cond BlockId
+ | JMP CLabel -- same as branch,
+ -- but with CLabel instead of block ID
+ | MTCTR Reg
+ | BCTR [BlockId] -- with list of local destinations
+ | BL CLabel [Reg] -- with list of argument regs
+ | BCTRL [Reg]
+
+ | ADD Reg Reg RI -- dst, src1, src2
+ | ADDC Reg Reg Reg -- (carrying) dst, src1, src2
+ | ADDE Reg Reg Reg -- (extend) dst, src1, src2
+ | ADDIS Reg Reg Imm -- Add Immediate Shifted dst, src1, src2
+ | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1
+ | MULLW Reg Reg RI
+ | DIVW Reg Reg Reg
+ | DIVWU Reg Reg Reg
+
+ | MULLW_MayOflo Reg Reg Reg
+ -- dst = 1 if src1 * src2 overflows
+ -- pseudo-instruction; pretty-printed as:
+ -- mullwo. dst, src1, src2
+ -- mfxer dst
+ -- rlwinm dst, dst, 2, 31,31
+
+ | AND Reg Reg RI -- dst, src1, src2
+ | OR Reg Reg RI -- dst, src1, src2
+ | XOR Reg Reg RI -- dst, src1, src2
+ | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2
+
+ | EXTS MachRep Reg Reg
+
+ | NEG Reg Reg
+ | NOT Reg Reg
+
+ | SLW Reg Reg RI -- shift left word
+ | SRW Reg Reg RI -- shift right word
+ | SRAW Reg Reg RI -- shift right arithmetic word
+
+ -- Rotate Left Word Immediate then AND with Mask
+ | RLWINM Reg Reg Int Int Int
+
+ | FADD MachRep Reg Reg Reg
+ | FSUB MachRep Reg Reg Reg
+ | FMUL MachRep Reg Reg Reg
+ | FDIV MachRep Reg Reg Reg
+ | FNEG Reg Reg -- negate is the same for single and double prec.
+
+ | FCMP Reg Reg
+
+ | FCTIWZ Reg Reg -- convert to integer word
+ | FRSP Reg Reg -- reduce to single precision
+ -- (but destination is a FP register)
+
+ | CRNOR Int Int Int -- condition register nor
+ | MFCR Reg -- move from condition register
+
+condUnsigned GU = True
+condUnsigned LU = True
+condUnsigned GEU = True
+condUnsigned LEU = True
+condUnsigned _ = False
+
+condToSigned GU = GTT
+condToSigned LU = LTT
+condToSigned GEU = GE
+condToSigned LEU = LE
+condToSigned x = x
+#endif /* powerpc_TARGET_ARCH */
+
+
+-- -----------------------------------------------------------------------------
+-- DestInfo
+
+-- ToDo: might not be needed anymore --SDM
+
+-- used by insnFuture in RegAllocInfo.lhs
+data DestInfo
+ = NoDestInfo -- no supplied dests; infer from context
+ | DestInfo [CLabel] -- precisely these dests and no others
+
+hasDestInfo NoDestInfo = False
+hasDestInfo (DestInfo _) = True
+
+pprDests :: DestInfo -> SDoc
+pprDests NoDestInfo = text "NoDestInfo"
+pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
+++ /dev/null
-_interface_ MachMisc 1
-_exports_
-MachMisc Instr fixedHdrSize fmtAsmLbl underscorePrefix;
-_declarations_
-1 fixedHdrSize _:_ PrelBase.Int ;;
-2 fmtAsmLbl _:_ PrelBase.String -> PrelBase.String ;;
-1 underscorePrefix _:_ PrelBase.Bool ;;
-1 data Instr ;;
\ No newline at end of file
+++ /dev/null
-__interface MachMisc 1 0 where
-__export MachMisc Instr fixedHdrSize fmtAsmLbl underscorePrefix;
-1 fixedHdrSize :: PrelBase.Int ;
-2 fmtAsmLbl :: PrelBase.String -> PrelBase.String ;
-1 underscorePrefix :: PrelBase.Bool ;
-1 data Instr ;
+++ /dev/null
-module MachMisc where
-
-data Instr
-
-fixedHdrSize :: GHC.Base.Int
-fmtAsmLbl :: GHC.Base.String -> GHC.Base.String
-underscorePrefix :: GHC.Base.Bool
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-\section[MachMisc]{Description of various machine-specific things}
-
-\begin{code}
-#include "nativeGen/NCG.h"
-
-module MachMisc (
-
- primRepToSize,
-
- eXTRA_STK_ARGS_HERE,
-
- volatileSaves, volatileRestores,
-
- targetMaxDouble, targetMaxInt, targetMinDouble, targetMinInt,
-
- underscorePrefix,
- fmtAsmLbl,
- exactLog2,
-
- Instr(..), IF_ARCH_i386(Operand(..) COMMA,)
- Cond(..),
- Size(..),
- IF_ARCH_i386(i386_insert_ffrees COMMA,)
-
-#if alpha_TARGET_ARCH
- , RI(..)
-#endif
-#if i386_TARGET_ARCH
-#endif
-#if sparc_TARGET_ARCH
- RI(..), riZero, fpRelEA, moveSp, fPair
-#endif
-#if powerpc_TARGET_ARCH
- , RI(..)
- , condUnsigned, condToSigned
-#endif
- ) where
-
-#include "HsVersions.h"
-#include "../includes/config.h"
-
-import AbsCSyn ( MagicId(..) )
-import AbsCUtils ( magicIdPrimRep )
-import CLabel ( CLabel, isAsmTemp )
-import Literal ( mkMachInt, Literal(..) )
-import MachRegs ( callerSaves,
- get_MagicId_addr, get_MagicId_reg_or_addr,
- Imm(..), Reg(..), MachRegsAddr(..)
-# if sparc_TARGET_ARCH
- ,fp, sp
-# endif
- )
-import PrimRep ( PrimRep(..) )
-import Stix ( StixStmt(..), StixExpr(..), StixReg(..),
- CodeSegment, DestInfo(..) )
-import Panic ( panic )
-import Outputable ( pprPanic, ppr, showSDoc )
-import Config ( cLeadingUnderscore )
-import FastTypes
-import FastString
-
-import GLAEXTS
-import TRACE ( trace )
-
-import Maybes ( mapCatMaybes )
-\end{code}
-
-\begin{code}
-underscorePrefix :: Bool -- leading underscore on assembler labels?
-underscorePrefix = (cLeadingUnderscore == "YES")
-
----------------------------
-fmtAsmLbl :: String -> String -- for formatting labels
-
-fmtAsmLbl s
- {- The alpha assembler likes temporary labels to look like $L123
- instead of L123. (Don't toss the L, because then Lf28
- turns into $f28.)
- -}
- = IF_ARCH_alpha(
- '$' : s
- ,{-otherwise-}
- '.':'L':s
- )
-\end{code}
-
-% ----------------------------------------------------------------
-
-We (allegedly) put the first six C-call arguments in registers;
-where do we start putting the rest of them?
-\begin{code}
-eXTRA_STK_ARGS_HERE :: Int
-eXTRA_STK_ARGS_HERE
- = IF_ARCH_alpha(0, IF_ARCH_i386(23{-6x4bytes-}, IF_ARCH_sparc(23,
- IF_ARCH_powerpc( IF_OS_darwin(24,8{-SVR4 ABI: Linux-}), ???))))
-\end{code}
-
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-Now the volatile saves and restores. We add the basic guys to the
-list of ``user'' registers provided. Note that there are more basic
-registers on the restore list, because some are reloaded from
-constants.
-
-(@volatileRestores@ used only for wrapper-hungry PrimOps.)
-
-\begin{code}
-volatileSaves, volatileRestores :: [MagicId] -> [StixStmt]
-
-volatileSaves = volatileSavesOrRestores True
-volatileRestores = volatileSavesOrRestores False
-
-save_cands = [BaseReg,Sp,SpLim,Hp,HpLim]
-restore_cands = save_cands
-
-volatileSavesOrRestores do_saves vols
- = mapCatMaybes mkCode vols
- where
- mkCode mid
- | case mid of { BaseReg -> True; _ -> False }
- = panic "volatileSavesOrRestores:BaseReg"
- | not (callerSaves mid)
- = Nothing
- | otherwise -- must be callee-saves ...
- = case get_MagicId_reg_or_addr mid of
- -- If stored in BaseReg, we ain't interested
- Right baseRegAddr
- -> Nothing
- Left (RealReg rrno)
- -- OK, it's callee-saves, and in a real reg (rrno).
- -- We have to cook up some transfer code.
- {- Note that the use of (StixMagicId mid) here is a bit subtle.
- Here, we only create those for MagicIds which are stored in
- a real reg on this arch -- the preceding case on the result
- of get_MagicId_reg_or_addr guarantees this. Later, when
- selecting insns, that means these assignments are sure to turn
- into real reg-to-mem or mem-to-reg moves, rather than being
- pointless moves from some address in the reg-table
- back to itself.-}
- | do_saves
- -> Just (StAssignMem rep addr
- (StReg (StixMagicId mid)))
- | otherwise
- -> Just (StAssignReg rep (StixMagicId mid)
- (StInd rep addr))
- where
- rep = magicIdPrimRep mid
- addr = get_MagicId_addr mid
-\end{code}
-
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-Obviously slightly weedy
-(Note that the floating point values aren't terribly important.)
-ToDo: Fix!(JSM)
-\begin{code}
-targetMinDouble = MachDouble (-1.7976931348623157e+308)
-targetMaxDouble = MachDouble (1.7976931348623157e+308)
-targetMinInt = mkMachInt (-2147483648)
-targetMaxInt = mkMachInt 2147483647
-\end{code}
-
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-This algorithm for determining the $\log_2$ of exact powers of 2 comes
-from GCC. It requires bit manipulation primitives, and we use GHC
-extensions. Tough.
-
-\begin{code}
-w2i x = word2Int# x
-i2w x = int2Word# x
-
-exactLog2 :: Integer -> Maybe Integer
-exactLog2 x
- = if (x <= 0 || x >= 2147483648) then
- Nothing
- else
- case iUnbox (fromInteger x) of { x# ->
- if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
- Nothing
- else
- Just (toInteger (iBox (pow2 x#)))
- }
- where
- pow2 x# | x# ==# 1# = 0#
- | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#))
-\end{code}
-
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-\begin{code}
-data Cond
-#if alpha_TARGET_ARCH
- = ALWAYS -- For BI (same as BR)
- | EQQ -- For CMP and BI (NB: "EQ" is a 1.3 Prelude name)
- | GE -- For BI only
- | GTT -- For BI only (NB: "GT" is a 1.3 Prelude name)
- | LE -- For CMP and BI
- | LTT -- For CMP and BI (NB: "LT" is a 1.3 Prelude name)
- | NE -- For BI only
- | NEVER -- For BI (null instruction)
- | ULE -- For CMP only
- | ULT -- For CMP only
-#endif
-#if i386_TARGET_ARCH
- = ALWAYS -- What's really used? ToDo
- | EQQ
- | GE
- | GEU
- | GTT
- | GU
- | LE
- | LEU
- | LTT
- | LU
- | NE
- | NEG
- | POS
- | CARRY
- | OFLO
-#endif
-#if sparc_TARGET_ARCH
- = ALWAYS -- What's really used? ToDo
- | EQQ
- | GE
- | GEU
- | GTT
- | GU
- | LE
- | LEU
- | LTT
- | LU
- | NE
- | NEG
- | NEVER
- | POS
- | VC
- | VS
-#endif
-#if powerpc_TARGET_ARCH
- = ALWAYS
- | EQQ
- | GE
- | GEU
- | GTT
- | GU
- | LE
- | LEU
- | LTT
- | LU
- | NE
-#endif
- deriving Eq -- to make an assertion work
-\end{code}
-
-\begin{code}
-data Size
-#if alpha_TARGET_ARCH
- = B -- byte
- | Bu
--- | W -- word (2 bytes): UNUSED
--- | Wu -- : UNUSED
- | L -- longword (4 bytes)
- | Q -- quadword (8 bytes)
--- | FF -- VAX F-style floating pt: UNUSED
--- | GF -- VAX G-style floating pt: UNUSED
--- | DF -- VAX D-style floating pt: UNUSED
--- | SF -- IEEE single-precision floating pt: UNUSED
- | TF -- IEEE double-precision floating pt
-#endif
-#if i386_TARGET_ARCH
- = B -- byte (signed)
- | Bu -- byte (unsigned)
- | W -- word (signed)
- | Wu -- word (unsigned)
- | L -- longword (signed)
- | Lu -- longword (unsigned)
- | F -- IEEE single-precision floating pt
- | DF -- IEEE single-precision floating pt
- | F80 -- Intel 80-bit internal FP format; only used for spilling
-#endif
-#if sparc_TARGET_ARCH || powerpc_TARGET_ARCH
- = B -- byte (signed)
- | Bu -- byte (unsigned)
- | H -- halfword (signed, 2 bytes)
- | Hu -- halfword (unsigned, 2 bytes)
- | W -- word (4 bytes)
- | F -- IEEE single-precision floating pt
- | DF -- IEEE single-precision floating pt
-#endif
-
-primRepToSize :: PrimRep -> Size
-
-primRepToSize PtrRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize CodePtrRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize DataPtrRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize RetRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize CostCentreRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize CharRep = IF_ARCH_alpha(L, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-
-primRepToSize Int8Rep = IF_ARCH_alpha(B, IF_ARCH_i386(B, IF_ARCH_sparc(B, IF_ARCH_powerpc(B, ))))
-primRepToSize Int16Rep = IF_ARCH_alpha(err,IF_ARCH_i386(W, IF_ARCH_sparc(H, IF_ARCH_powerpc(H, ))))
- where err = primRepToSize_fail "Int16Rep"
-primRepToSize Int32Rep = IF_ARCH_alpha(L, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize Word8Rep = IF_ARCH_alpha(Bu, IF_ARCH_i386(Bu, IF_ARCH_sparc(Bu, IF_ARCH_powerpc(Bu, ))))
-primRepToSize Word16Rep = IF_ARCH_alpha(err,IF_ARCH_i386(Wu, IF_ARCH_sparc(Hu, IF_ARCH_powerpc(Hu, ))))
- where err = primRepToSize_fail "Word16Rep"
-primRepToSize Word32Rep = IF_ARCH_alpha(L, IF_ARCH_i386(Lu, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-
-primRepToSize IntRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize WordRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize AddrRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-primRepToSize FloatRep = IF_ARCH_alpha(TF, IF_ARCH_i386(F, IF_ARCH_sparc(F, IF_ARCH_powerpc(F, ))))
-primRepToSize DoubleRep = IF_ARCH_alpha(TF, IF_ARCH_i386(DF, IF_ARCH_sparc(DF, IF_ARCH_powerpc(DF, ))))
-primRepToSize StablePtrRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, IF_ARCH_powerpc(W, ))))
-
-primRepToSize Word64Rep = primRepToSize_fail "Word64Rep"
-primRepToSize Int64Rep = primRepToSize_fail "Int64Rep"
-primRepToSize other = primRepToSize_fail (showSDoc (ppr other))
-
-primRepToSize_fail str
- = error ("ERROR: MachMisc.primRepToSize: cannot handle `" ++ str ++ "'.\n\t"
- ++ "Workaround: use -fvia-C.\n\t"
- ++ "Perhaps you should report it as a GHC bug,\n\t"
- ++ "to glasgow-haskell-bugs@haskell.org.")
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Machine's assembly language}
-%* *
-%************************************************************************
-
-We have a few common ``instructions'' (nearly all the pseudo-ops) but
-mostly all of @Instr@ is machine-specific.
-
-\begin{code}
-data Instr
- = COMMENT FastString -- comment pseudo-op
- | SEGMENT CodeSegment -- {data,text} segment pseudo-op
- | LABEL CLabel -- global label pseudo-op
- | ASCII Bool -- True <=> needs backslash conversion
- String -- the literal string
- | DATA Size
- [Imm]
- | DELTA Int -- specify current stack offset for
- -- benefit of subsequent passes
-\end{code}
-
-\begin{code}
-#if alpha_TARGET_ARCH
-
--- data Instr continues...
-
--- Loads and stores.
-
- | LD Size Reg MachRegsAddr -- size, dst, src
- | LDA Reg MachRegsAddr -- dst, src
- | LDAH Reg MachRegsAddr -- dst, src
- | LDGP Reg MachRegsAddr -- dst, src
- | LDI Size Reg Imm -- size, dst, src
- | ST Size Reg MachRegsAddr -- size, src, dst
-
--- Int Arithmetic.
-
- | CLR Reg -- dst
- | ABS Size RI Reg -- size, src, dst
- | NEG Size Bool RI Reg -- size, overflow, src, dst
- | ADD Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | SADD Size Size Reg RI Reg -- size, scale, src, src, dst
- | SUB Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | SSUB Size Size Reg RI Reg -- size, scale, src, src, dst
- | MUL Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | DIV Size Bool Reg RI Reg -- size, unsigned, src, src, dst
- | REM Size Bool Reg RI Reg -- size, unsigned, src, src, dst
-
--- Simple bit-twiddling.
-
- | NOT RI Reg
- | AND Reg RI Reg
- | ANDNOT Reg RI Reg
- | OR Reg RI Reg
- | ORNOT Reg RI Reg
- | XOR Reg RI Reg
- | XORNOT Reg RI Reg
- | SLL Reg RI Reg
- | SRL Reg RI Reg
- | SRA Reg RI Reg
-
- | ZAP Reg RI Reg
- | ZAPNOT Reg RI Reg
-
- | NOP
-
--- Comparison
-
- | CMP Cond Reg RI Reg
-
--- Float Arithmetic.
-
- | FCLR Reg
- | FABS Reg Reg
- | FNEG Size Reg Reg
- | FADD Size Reg Reg Reg
- | FDIV Size Reg Reg Reg
- | FMUL Size Reg Reg Reg
- | FSUB Size Reg Reg Reg
- | CVTxy Size Size Reg Reg
- | FCMP Size Cond Reg Reg Reg
- | FMOV Reg Reg
-
--- Jumping around.
-
- | BI Cond Reg Imm
- | BF Cond Reg Imm
- | BR Imm
- | JMP Reg MachRegsAddr Int
- | BSR Imm Int
- | JSR Reg MachRegsAddr Int
-
--- Alpha-specific pseudo-ops.
-
- | FUNBEGIN CLabel
- | FUNEND CLabel
-
-data RI
- = RIReg Reg
- | RIImm Imm
-
-#endif /* alpha_TARGET_ARCH */
-\end{code}
-
-Intel, in their infinite wisdom, selected a stack model for floating
-point registers on x86. That might have made sense back in 1979 --
-nowadays we can see it for the nonsense it really is. A stack model
-fits poorly with the existing nativeGen infrastructure, which assumes
-flat integer and FP register sets. Prior to this commit, nativeGen
-could not generate correct x86 FP code -- to do so would have meant
-somehow working the register-stack paradigm into the register
-allocator and spiller, which sounds very difficult.
-
-We have decided to cheat, and go for a simple fix which requires no
-infrastructure modifications, at the expense of generating ropey but
-correct FP code. All notions of the x86 FP stack and its insns have
-been removed. Instead, we pretend (to the instruction selector and
-register allocator) that x86 has six floating point registers, %fake0
-.. %fake5, which can be used in the usual flat manner. We further
-claim that x86 has floating point instructions very similar to SPARC
-and Alpha, that is, a simple 3-operand register-register arrangement.
-Code generation and register allocation proceed on this basis.
-
-When we come to print out the final assembly, our convenient fiction
-is converted to dismal reality. Each fake instruction is
-independently converted to a series of real x86 instructions.
-%fake0 .. %fake5 are mapped to %st(0) .. %st(5). To do reg-reg
-arithmetic operations, the two operands are pushed onto the top of the
-FP stack, the operation done, and the result copied back into the
-relevant register. There are only six %fake registers because 2 are
-needed for the translation, and x86 has 8 in total.
-
-The translation is inefficient but is simple and it works. A cleverer
-translation would handle a sequence of insns, simulating the FP stack
-contents, would not impose a fixed mapping from %fake to %st regs, and
-hopefully could avoid most of the redundant reg-reg moves of the
-current translation.
-
-We might as well make use of whatever unique FP facilities Intel have
-chosen to bless us with (let's not be churlish, after all).
-Hence GLDZ and GLD1. Bwahahahahahahaha!
-
-LATER (10 Nov 2000): idiv gives problems with the register spiller,
-because the spiller is simpleminded and because idiv has fixed uses of
-%eax and %edx. Rather than make the spiller cleverer, we do away with
-idiv, and instead have iquot and irem fake (integer) insns, which have
-no operand register constraints -- ie, they behave like add, sub, mul.
-The printer-outer transforms them to a sequence of real insns which does
-the Right Thing (tm). As with the FP stuff, this gives ropey code,
-but we don't care, since it doesn't get used much. We hope.
-
-\begin{code}
-#if i386_TARGET_ARCH
-
--- data Instr continues...
-
--- Moves.
-
- | MOV Size Operand Operand
- | MOVZxL Size Operand Operand -- size is the size of operand 1
- | MOVSxL Size Operand Operand -- size is the size of operand 1
-
--- Load effective address (also a very useful three-operand add instruction :-)
-
- | LEA Size Operand Operand
-
--- Int Arithmetic.
-
- | ADD Size Operand Operand
- | SUB Size Operand Operand
- | IMUL Size Operand Operand -- signed int mul
- | MUL Size Operand Operand -- unsigned int mul
- | IMUL64 Reg Reg -- 32 x 32 -> 64 signed mul
- -- operand1:operand2 := (operand1[31:0] *signed operand2[31:0])
-
--- Quotient and remainder. SEE comment above -- these are not
--- real x86 insns; instead they are expanded when printed
--- into a sequence of real insns.
-
- | IQUOT Size Operand Operand -- signed quotient
- | IREM Size Operand Operand -- signed remainder
- | QUOT Size Operand Operand -- unsigned quotient
- | REM Size Operand Operand -- unsigned remainder
-
--- Simple bit-twiddling.
-
- | AND Size Operand Operand
- | OR Size Operand Operand
- | XOR Size Operand Operand
- | NOT Size Operand
- | NEGI Size Operand -- NEG instruction (name clash with Cond)
- | SHL Size Imm Operand -- Only immediate shifts allowed
- | SAR Size Imm Operand -- Only immediate shifts allowed
- | SHR Size Imm Operand -- Only immediate shifts allowed
- | BT Size Imm Operand
- | NOP
-
--- Float Arithmetic.
-
--- Note that we cheat by treating G{ABS,MOV,NEG} of doubles
--- as single instructions right up until we spit them out.
-
- -- all the 3-operand fake fp insns are src1 src2 dst
- -- and furthermore are constrained to be fp regs only.
- -- IMPORTANT: keep is_G_insn up to date with any changes here
- | GMOV Reg Reg -- src(fpreg), dst(fpreg)
- | GLD Size MachRegsAddr Reg -- src, dst(fpreg)
- | GST Size Reg MachRegsAddr -- src(fpreg), dst
-
- | GLDZ Reg -- dst(fpreg)
- | GLD1 Reg -- dst(fpreg)
-
- | GFTOI Reg Reg -- src(fpreg), dst(intreg)
- | GDTOI Reg Reg -- src(fpreg), dst(intreg)
-
- | GITOF Reg Reg -- src(intreg), dst(fpreg)
- | GITOD Reg Reg -- src(intreg), dst(fpreg)
-
- | GADD Size Reg Reg Reg -- src1, src2, dst
- | GDIV Size Reg Reg Reg -- src1, src2, dst
- | GSUB Size Reg Reg Reg -- src1, src2, dst
- | GMUL Size Reg Reg Reg -- src1, src2, dst
-
- -- FP compare. Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT]
- -- Compare src1 with src2; set the Zero flag iff the numbers are
- -- comparable and the comparison is True. Subsequent code must
- -- test the %eflags zero flag regardless of the supplied Cond.
- | GCMP Cond Reg Reg -- src1, src2
-
- | GABS Size Reg Reg -- src, dst
- | GNEG Size Reg Reg -- src, dst
- | GSQRT Size Reg Reg -- src, dst
- | GSIN Size Reg Reg -- src, dst
- | GCOS Size Reg Reg -- src, dst
- | GTAN Size Reg Reg -- src, dst
-
- | GFREE -- do ffree on all x86 regs; an ugly hack
--- Comparison
-
- | TEST Size Operand Operand
- | CMP Size Operand Operand
- | SETCC Cond Operand
-
--- Stack Operations.
-
- | PUSH Size Operand
- | POP Size Operand
- | PUSHA
- | POPA
-
--- Jumping around.
-
- | JMP DestInfo Operand -- possible dests, target
- | JXX Cond CLabel -- target
- | CALL (Either Imm Reg)
-
--- Other things.
-
- | CLTD -- sign extend %eax into %edx:%eax
-
-data Operand
- = OpReg Reg -- register
- | OpImm Imm -- immediate value
- | OpAddr MachRegsAddr -- memory reference
-
-
-i386_insert_ffrees :: [Instr] -> [Instr]
-i386_insert_ffrees insns
- | any is_G_instr insns
- = concatMap ffree_before_nonlocal_transfers insns
- | otherwise
- = insns
-
-ffree_before_nonlocal_transfers insn
- = case insn of
- CALL _ -> [GFREE, insn]
- -- Jumps to immediate labels are local
- JMP _ (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> [insn]
- -- If a jump mentions dests, it is a local jump thru
- -- a case table.
- JMP (DestInfo _) _ -> [insn]
- JMP _ _ -> [GFREE, insn]
- other -> [insn]
-
-
--- if you ever add a new FP insn to the fake x86 FP insn set,
--- you must update this too
-is_G_instr :: Instr -> Bool
-is_G_instr instr
- = case instr of
- GMOV _ _ -> True; GLD _ _ _ -> True; GST _ _ _ -> True;
- GLDZ _ -> True; GLD1 _ -> True;
- GFTOI _ _ -> True; GDTOI _ _ -> True;
- GITOF _ _ -> True; GITOD _ _ -> True;
- GADD _ _ _ _ -> True; GDIV _ _ _ _ -> True
- GSUB _ _ _ _ -> True; GMUL _ _ _ _ -> True
- GCMP _ _ _ -> True; GABS _ _ _ -> True
- GNEG _ _ _ -> True; GSQRT _ _ _ -> True
- GSIN _ _ _ -> True; GCOS _ _ _ -> True; GTAN _ _ _ -> True;
- GFREE -> panic "is_G_instr: GFREE (!)"
- other -> False
-
-#endif /* i386_TARGET_ARCH */
-\end{code}
-
-\begin{code}
-#if sparc_TARGET_ARCH
-
--- data Instr continues...
-
--- Loads and stores.
-
- | LD Size MachRegsAddr Reg -- size, src, dst
- | ST Size Reg MachRegsAddr -- size, src, dst
-
--- Int Arithmetic.
-
- | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
- | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
- | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst
- | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst
- | RDY Reg -- move contents of Y register to reg
-
--- Simple bit-twiddling.
-
- | AND Bool Reg RI Reg -- cc?, src1, src2, dst
- | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst
- | OR Bool Reg RI Reg -- cc?, src1, src2, dst
- | ORN Bool Reg RI Reg -- cc?, src1, src2, dst
- | XOR Bool Reg RI Reg -- cc?, src1, src2, dst
- | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst
- | SLL Reg RI Reg -- src1, src2, dst
- | SRL Reg RI Reg -- src1, src2, dst
- | SRA Reg RI Reg -- src1, src2, dst
- | SETHI Imm Reg -- src, dst
- | NOP -- Really SETHI 0, %g0, but worth an alias
-
--- Float Arithmetic.
-
--- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
--- right up until we spit them out.
-
- | FABS Size Reg Reg -- src dst
- | FADD Size Reg Reg Reg -- src1, src2, dst
- | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst
- | FDIV Size Reg Reg Reg -- src1, src2, dst
- | FMOV Size Reg Reg -- src, dst
- | FMUL Size Reg Reg Reg -- src1, src2, dst
- | FNEG Size Reg Reg -- src, dst
- | FSQRT Size Reg Reg -- src, dst
- | FSUB Size Reg Reg Reg -- src1, src2, dst
- | FxTOy Size Size Reg Reg -- src, dst
-
--- Jumping around.
-
- | BI Cond Bool Imm -- cond, annul?, target
- | BF Cond Bool Imm -- cond, annul?, target
-
- | JMP DestInfo MachRegsAddr -- target
- | CALL (Either Imm Reg) Int Bool -- target, args, terminal
-
-data RI = RIReg Reg
- | RIImm Imm
-
-riZero :: RI -> Bool
-
-riZero (RIImm (ImmInt 0)) = True
-riZero (RIImm (ImmInteger 0)) = True
-riZero (RIReg (RealReg 0)) = True
-riZero _ = False
-
--- Calculate the effective address which would be used by the
--- corresponding fpRel sequence. fpRel is in MachRegs.lhs,
--- alas -- can't have fpRelEA here because of module dependencies.
-fpRelEA :: Int -> Reg -> Instr
-fpRelEA n dst
- = ADD False False fp (RIImm (ImmInt (n * BYTES_PER_WORD))) dst
-
--- Code to shift the stack pointer by n words.
-moveSp :: Int -> Instr
-moveSp n
- = ADD False False sp (RIImm (ImmInt (n * BYTES_PER_WORD))) sp
-
--- Produce the second-half-of-a-double register given the first half.
-fPair :: Reg -> Reg
-fPair (RealReg n) | n >= 32 && n `mod` 2 == 0 = RealReg (n+1)
-fPair other = pprPanic "fPair(sparc NCG)" (ppr other)
-#endif /* sparc_TARGET_ARCH */
-\end{code}
-
-\begin{code}
-#ifdef powerpc_TARGET_ARCH
--- data Instr continues...
-
--- Loads and stores.
-
- | LD Size Reg MachRegsAddr -- Load size, dst, src
- | ST Size Reg MachRegsAddr -- Store size, src, dst
- | STU Size Reg MachRegsAddr -- Store with Update size, src, dst
- | LIS Reg Imm -- Load Immediate Shifted dst, src
- | LI Reg Imm -- Load Immediate dst, src
- | MR Reg Reg -- Move Register dst, src -- also for fmr
-
- | CMP Size Reg RI --- size, src1, src2
- | CMPL Size Reg RI --- size, src1, src2
-
- | BCC Cond CLabel
- | MTCTR Reg
- | BCTR DestInfo
- | BL Imm [Reg] -- with list of argument regs
- | BCTRL [Reg]
-
- | ADD Reg Reg RI -- dst, src1, src2
- | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1
- | MULLW Reg Reg RI
- | DIVW Reg Reg Reg
- | DIVWU Reg Reg Reg
-
- | AND Reg Reg RI -- dst, src1, src2
- | OR Reg Reg RI -- dst, src1, src2
- | XOR Reg Reg RI -- dst, src1, src2
- | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2
-
- | NEG Reg Reg
- | NOT Reg Reg
-
- | SLW Reg Reg RI -- shift left word
- | SRW Reg Reg RI -- shift right word
- | SRAW Reg Reg RI -- shift right arithmetic word
-
- | FADD Size Reg Reg Reg
- | FSUB Size Reg Reg Reg
- | FMUL Size Reg Reg Reg
- | FDIV Size Reg Reg Reg
- | FNEG Reg Reg -- negate is the same for single and double prec.
-
- | FCMP Reg Reg
-
- | FCTIWZ Reg Reg -- convert to integer word
- -- (but destination is a FP register)
-
-data RI = RIReg Reg
- | RIImm Imm
-
-condUnsigned GU = True
-condUnsigned LU = True
-condUnsigned GEU = True
-condUnsigned LEU = True
-condUnsigned _ = False
-
-condToSigned GU = GTT
-condToSigned LU = LTT
-condToSigned GEU = GE
-condToSigned LEU = LE
-condToSigned x = x
-#endif /* powerpc_TARGET_ARCH */
-\end{code}
-
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[MachRegs]{Machine-specific info about registers}
-
-Also includes stuff about immediate operands, which are
-often/usually quite entangled with registers.
-
-(Immediates could be untangled from registers at some cost in tangled
-modules --- the pleasure has been foregone.)
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1994-2004
+--
+-- Machine-specific info about registers.
+--
+-- Also includes stuff about immediate operands, which are
+-- often/usually quite entangled with registers.
+--
+-- (Immediates could be untangled from registers at some cost in tangled
+-- modules --- the pleasure has been foregone.)
+--
+-- -----------------------------------------------------------------------------
\begin{code}
#include "nativeGen/NCG.h"
module MachRegs (
- RegClass(..), regClass,
- VRegUnique(..), pprVRegUnique, getHiVRegFromLo,
- Reg(..), isRealReg, isVirtualReg, getVRegUnique,
- allocatableRegs, argRegs, allArgRegs, callClobberedRegs,
-
- Imm(..),
- MachRegsAddr(..),
+ -- * Immediate values
+ Imm(..), strImmLit, litToImm,
+ -- * Addressing modes
+ AddrMode(..),
addrOffset,
- baseRegOffset,
+
+ -- * The 'Reg' type
+ RegNo,
+ Reg(..), isRealReg, isVirtualReg,
+ RegClass(..), regClass,
+ getHiVRegFromLo,
+ mkVReg,
+
+ -- * Global registers
+ get_GlobalReg_reg_or_addr,
callerSaves,
+
+ -- * Machine-dependent register-related stuff
+ allocatableRegs, argRegs, allArgRegs, callClobberedRegs,
freeReg,
- getNewRegNCG,
- mkVReg,
- get_MagicId_reg_or_addr,
- get_MagicId_addr,
- get_Regtable_addr_from_offset,
spRel,
- strImmLit
#if alpha_TARGET_ARCH
- , allArgRegs
- , fits8Bits
- , fReg
- , gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh
+ allArgRegs,
+ fits8Bits,
+ fReg,
+ gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh,
#endif
#if i386_TARGET_ARCH
- , eax, ebx, ecx, edx, esi, esp
- , fake0, fake1, fake2, fake3, fake4, fake5
+ eax, ebx, ecx, edx, esi, edi, ebp, esp,
+ fake0, fake1, fake2, fake3, fake4, fake5,
+ addrModeRegs,
#endif
#if sparc_TARGET_ARCH
- , fits13Bits
- , fpRel, gReg, iReg, lReg, oReg, largeOffsetError
- , fp, sp, g0, g1, g2, o0, o1, f0, f6, f8, f26, f27
-
+ fits13Bits,
+ fpRel, gReg, iReg, lReg, oReg, largeOffsetError,
+ fp, sp, g0, g1, g2, o0, o1, f0, f6, f8, f26, f27,
#endif
#if powerpc_TARGET_ARCH
- , allFPArgRegs
- , fits16Bits
- , sp
- , r3, r4, r27, r28
- , f1, f20, f21
+ allFPArgRegs,
+ makeImmediate,
+ sp,
+ r3, r4, r27, r28,
+ f1, f20, f21,
#endif
) where
#include "HsVersions.h"
-import AbsCSyn ( MagicId(..) )
+#if i386_TARGET_ARCH
+# define STOLEN_X86_REGS 4
+-- HACK: go for the max
+#endif
+
+#include "../includes/MachRegs.h"
+
+import Cmm
+import MachOp ( MachRep(..) )
+
import CLabel ( CLabel, mkMainCapabilityLabel )
-import PrimRep ( PrimRep(..), isFloatingRep )
-import Stix ( StixExpr(..), StixReg(..),
- getUniqueNat, returnNat, thenNat, NatM )
import Unique ( Unique )
import Pretty
import Outputable ( Outputable(..), pprPanic, panic )
import qualified Outputable
+import Unique
+import Constants
import FastTypes
-\end{code}
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if powerpc_TARGET_ARCH
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Word ( Word8, Word16, Word32 )
+import Data.Int ( Int8, Int16, Int32 )
+#else
+import Word ( Word8, Word16, Word32 )
+import Int ( Int8, Int16, Int32 )
+#endif
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Immediates
-\begin{code}
data Imm
= ImmInt Int
| ImmInteger Integer -- Sigh.
| ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLab Bool Doc -- Simple string label (underscore-able)
- -- Bool==True ==> in a different DLL
- | ImmLit Doc -- Simple string
+ | ImmLit Doc -- Simple string
| ImmIndex CLabel Int
| ImmFloat Rational
| ImmDouble Rational
- IF_ARCH_sparc(
+#if sparc_TARGET_ARCH
| LO Imm {- Possible restrictions... -}
| HI Imm
- ,IF_ARCH_powerpc(
+#endif
+#if powerpc_TARGET_ARCH
| LO Imm
| HI Imm
| HA Imm {- high halfword adjusted -}
- ,))
+#if darwin_TARGET_OS
+ -- special dyld (dynamic linker) things
+ | ImmDyldNonLazyPtr CLabel -- Llabel$non_lazy_ptr
+#endif
+#endif
strImmLit s = ImmLit (text s)
-\end{code}
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+litToImm :: CmmLit -> Imm
+litToImm (CmmInt i _) = ImmInteger i
+litToImm (CmmFloat f F32) = ImmFloat f
+litToImm (CmmFloat f F64) = ImmDouble f
+litToImm (CmmLabel l) = ImmCLbl l
+litToImm (CmmLabelOff l off) = ImmIndex l off
-\begin{code}
-data MachRegsAddr
+-- -----------------------------------------------------------------------------
+-- Addressing modes
+
+data AddrMode
#if alpha_TARGET_ARCH
= AddrImm Imm
| AddrReg Reg
| AddrRegImm Reg Imm
#endif
-addrOffset :: MachRegsAddr -> Int -> Maybe MachRegsAddr
+#if i386_TARGET_ARCH
+addrModeRegs :: AddrMode -> [Reg]
+addrModeRegs (AddrBaseIndex b i _) = b_regs ++ i_regs
+ where
+ b_regs = case b of { Just r -> [r]; _ -> [] }
+ i_regs = case i of { Just (r,_) -> [r]; _ -> [] }
+addrModeRegs _ = []
+#endif
+
+
+addrOffset :: AddrMode -> Int -> Maybe AddrMode
addrOffset addr off
= case addr of
#endif
#if i386_TARGET_ARCH
ImmAddr i off0 -> Just (ImmAddr i (off0 + off))
+
AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off)))
AddrBaseIndex r i (ImmInteger n)
-> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off))))
- _ -> Nothing
+
+ AddrBaseIndex r i (ImmCLbl lbl)
+ -> Just (AddrBaseIndex r i (ImmIndex lbl off))
+
+ AddrBaseIndex r i (ImmIndex lbl ix)
+ -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off)))
+
+ _ -> Nothing -- in theory, shouldn't happen
#endif
#if sparc_TARGET_ARCH
AddrRegImm r (ImmInt n)
| otherwise -> Nothing
_ -> Nothing
-
#endif /* sparc */
#if powerpc_TARGET_ARCH
AddrRegImm r (ImmInt n)
| fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))
| otherwise -> Nothing
where n2 = n + toInteger off
-
- AddrRegReg r (RealReg 0)
- | fits16Bits off -> Just (AddrRegImm r (ImmInt off))
- | otherwise -> Nothing
_ -> Nothing
#endif /* powerpc */
#if powerpc_TARGET_ARCH
fits16Bits :: Integral a => a -> Bool
fits16Bits x = x >= -32768 && x < 32768
-#endif
-\end{code}
-
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-@stgReg@: we map STG registers onto appropriate Stix Trees. Either
-they map to real machine registers or stored as offsets from BaseReg.
-Given a MagicId, get_MagicId_reg_or_addr produces either the real
-register it is in, on this platform, or a StixExpr denoting the
-address in the register table holding it. get_MagicId_addr always
-produces the register table address for it.
-
-\begin{code}
-get_MagicId_reg_or_addr :: MagicId -> Either Reg StixExpr
-get_MagicId_addr :: MagicId -> StixExpr
-get_Regtable_addr_from_offset :: Int -> StixExpr
-
-get_MagicId_reg_or_addr mid
- = case magicIdRegMaybe mid of
- Just rr -> Left rr
- Nothing -> Right (get_MagicId_addr mid)
-
-get_MagicId_addr BaseReg
- = -- This arch doesn't have BaseReg in a register, so we have to
- -- use &MainRegTable.r instead.
- StIndex PtrRep (StCLbl mkMainCapabilityLabel)
- (StInt (toInteger OFFW_Capability_r))
-get_MagicId_addr mid
- = get_Regtable_addr_from_offset (baseRegOffset mid)
-
-get_Regtable_addr_from_offset offset_in_words
- = let ptr_to_RegTable
- = case magicIdRegMaybe BaseReg of
- Nothing
- -> -- This arch doesn't have BaseReg in a register, so we have to
- -- use &MainRegTable.r instead.
- StIndex PtrRep (StCLbl mkMainCapabilityLabel)
- (StInt (toInteger OFFW_Capability_r))
- Just _
- -> -- It's in a reg, so leave it as it is
- StReg (StixMagicId BaseReg)
- in
- StIndex PtrRep ptr_to_RegTable (StInt (toInteger offset_in_words))
-\end{code}
-
-% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-@spRel@ gives us a stack relative addressing mode for volatile
-temporaries and for excess call arguments. @fpRel@, where
-applicable, is the same but for the frame pointer.
+makeImmediate :: Integral a => MachRep -> Bool -> a -> Maybe Imm
+
+makeImmediate rep signed x = fmap ImmInt (toI16 rep signed)
+ where
+ narrow I32 False = fromIntegral (fromIntegral x :: Word32)
+ narrow I16 False = fromIntegral (fromIntegral x :: Word16)
+ narrow I8 False = fromIntegral (fromIntegral x :: Word8)
+ narrow I32 True = fromIntegral (fromIntegral x :: Int32)
+ narrow I16 True = fromIntegral (fromIntegral x :: Int16)
+ narrow I8 True = fromIntegral (fromIntegral x :: Int8)
+
+ narrowed = narrow rep signed
+
+ toI16 I32 True
+ | narrowed >= -32768 && narrowed < 32768 = Just narrowed
+ | otherwise = Nothing
+ toI16 I32 False
+ | narrowed >= 0 && narrowed < 65536 = Just narrowed
+ | otherwise = Nothing
+ toI16 _ _ = Just narrowed
+#endif
+
+
+-- @spRel@ gives us a stack relative addressing mode for volatile
+-- temporaries and for excess call arguments. @fpRel@, where
+-- applicable, is the same but for the frame pointer.
-\begin{code}
spRel :: Int -- desired stack offset in words, positive or negative
- -> MachRegsAddr
+ -> AddrMode
spRel n
#if i386_TARGET_ARCH
- = AddrBaseIndex (Just esp) Nothing (ImmInt (n * BYTES_PER_WORD))
+ = AddrBaseIndex (Just esp) Nothing (ImmInt (n * wORD_SIZE))
#else
- = AddrRegImm sp (ImmInt (n * BYTES_PER_WORD))
+ = AddrRegImm sp (ImmInt (n * wORD_SIZE))
#endif
#if sparc_TARGET_ARCH
-fpRel :: Int -> MachRegsAddr
+fpRel :: Int -> AddrMode
-- Duznae work for offsets greater than 13 bits; we just hope for
-- the best
fpRel n
- = AddrRegImm fp (ImmInt (n * BYTES_PER_WORD))
+ = AddrRegImm fp (ImmInt (n * wORD_SIZE))
#endif
-\end{code}
-%************************************************************************
-%* *
-\subsection[Reg]{Real registers}
-%* *
-%************************************************************************
-RealRegs are machine regs which are available for allocation, in the
-usual way. We know what class they are, because that's part of the
-processor's architecture.
+-- -----------------------------------------------------------------------------
+-- Global registers
-VirtualRegs are virtual registers. The register allocator will
-eventually have to map them into RealRegs, or into spill slots.
-VirtualRegs are allocated on the fly, usually to represent a single
-value in the abstract assembly code (i.e. dynamic registers are
-usually single assignment). With the new register allocator, the
-single assignment restriction isn't necessary to get correct code,
-although a better register allocation will result if single assignment
-is used -- because the allocator maps a VirtualReg into a single
-RealReg, even if the VirtualReg has multiple live ranges.
+-- We map STG registers onto appropriate CmmExprs. Either they map
+-- to real machine registers or stored as offsets from BaseReg. Given
+-- a GlobalReg, get_GlobalReg_reg_or_addr produces either the real
+-- register it is in, on this platform, or a StixExpr denoting the
+-- address in the register table holding it. get_MagicId_addr always
+-- produces the register table address for it.
-Virtual regs can be of either class, so that info is attached.
+get_GlobalReg_reg_or_addr :: GlobalReg -> Either Reg CmmExpr
+get_GlobalReg_addr :: GlobalReg -> CmmExpr
+get_Regtable_addr_from_offset :: MachRep -> Int -> CmmExpr
-\begin{code}
+get_GlobalReg_reg_or_addr mid
+ = case globalRegMaybe mid of
+ Just rr -> Left rr
+ Nothing -> Right (get_GlobalReg_addr mid)
+
+get_GlobalReg_addr BaseReg = regTableOffset 0
+get_GlobalReg_addr mid = get_Regtable_addr_from_offset
+ (globalRegRep mid) (baseRegOffset mid)
+
+-- Calculate a literal representing an offset into the register table.
+-- Used when we don't have an actual BaseReg to offset from.
+regTableOffset n =
+ CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
-data VRegUnique
- = VRegUniqueLo Unique -- lower part of a split quantity
- | VRegUniqueHi Unique -- upper part thereof
- deriving (Eq, Ord)
+get_Regtable_addr_from_offset rep offset
+ = case globalRegMaybe BaseReg of
+ Nothing -> regTableOffset offset
+ Just _ -> CmmRegOff (CmmGlobal BaseReg) offset
-instance Show VRegUnique where
- show (VRegUniqueLo u) = show u
- show (VRegUniqueHi u) = "_hi_" ++ show u
+-- ---------------------------------------------------------------------------
+-- Registers
-pprVRegUnique :: VRegUnique -> Outputable.SDoc
-pprVRegUnique
- = Outputable.text . show
+-- RealRegs are machine regs which are available for allocation, in
+-- the usual way. We know what class they are, because that's part of
+-- the processor's architecture.
+
+-- VirtualRegs are virtual registers. The register allocator will
+-- eventually have to map them into RealRegs, or into spill slots.
+-- VirtualRegs are allocated on the fly, usually to represent a single
+-- value in the abstract assembly code (i.e. dynamic registers are
+-- usually single assignment). With the new register allocator, the
+-- single assignment restriction isn't necessary to get correct code,
+-- although a better register allocation will result if single
+-- assignment is used -- because the allocator maps a VirtualReg into
+-- a single RealReg, even if the VirtualReg has multiple live ranges.
+
+-- Virtual regs can be of either class, so that info is attached.
-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform
-- when supplied with the vreg for the lower-half of the quantity.
-getHiVRegFromLo (VirtualRegI (VRegUniqueLo u))
- = VirtualRegI (VRegUniqueHi u)
+-- (NB. Not reversible).
+getHiVRegFromLo (VirtualRegI u)
+ = VirtualRegHi (newTagUnique u 'H') -- makes a pseudo-unique with tag 'H'
getHiVRegFromLo other
= pprPanic "getHiVRegFromLo" (ppr other)
| RcDouble
deriving Eq
+type RegNo = Int
+
data Reg
- = RealReg Int
- | VirtualRegI VRegUnique
- | VirtualRegF VRegUnique
- | VirtualRegD VRegUnique
-
-unRealReg (RealReg i) = i
-unRealReg vreg = pprPanic "unRealReg on VirtualReg" (ppr vreg)
-
-getVRegUnique :: Reg -> VRegUnique
-getVRegUnique (VirtualRegI vu) = vu
-getVRegUnique (VirtualRegF vu) = vu
-getVRegUnique (VirtualRegD vu) = vu
-getVRegUnique rreg = pprPanic "getVRegUnique on RealReg" (ppr rreg)
-
-mkVReg :: Unique -> PrimRep -> Reg
-mkVReg u pk
+ = RealReg {-# UNPACK #-} !RegNo
+ | VirtualRegI {-# UNPACK #-} !Unique
+ | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register
+ | VirtualRegF {-# UNPACK #-} !Unique
+ | VirtualRegD {-# UNPACK #-} !Unique
+ deriving (Eq,Ord)
+
+-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets
+-- in the register allocator.
+instance Uniquable Reg where
+ getUnique (RealReg i) = mkUnique 'C' i
+ getUnique (VirtualRegI u) = u
+ getUnique (VirtualRegHi u) = u
+ getUnique (VirtualRegF u) = u
+ getUnique (VirtualRegD u) = u
+
+mkVReg :: Unique -> MachRep -> Reg
+mkVReg u rep
+ = case rep of
#if sparc_TARGET_ARCH
- = case pk of
- FloatRep -> VirtualRegF (VRegUniqueLo u)
- DoubleRep -> VirtualRegD (VRegUniqueLo u)
- other -> VirtualRegI (VRegUniqueLo u)
+ F32 -> VirtualRegF u
#else
- = if isFloatingRep pk then VirtualRegD (VRegUniqueLo u)
- else VirtualRegI (VRegUniqueLo u)
+ F32 -> VirtualRegD u
#endif
+ F64 -> VirtualRegD u
+ other -> VirtualRegI u
-isVirtualReg (RealReg _) = False
-isVirtualReg (VirtualRegI _) = True
-isVirtualReg (VirtualRegF _) = True
-isVirtualReg (VirtualRegD _) = True
-isRealReg = not . isVirtualReg
-
-getNewRegNCG :: PrimRep -> NatM Reg
-getNewRegNCG pk
- = getUniqueNat `thenNat` \ u -> returnNat (mkVReg u pk)
-
-instance Eq Reg where
- (==) (RealReg i1) (RealReg i2) = i1 == i2
- (==) (VirtualRegI u1) (VirtualRegI u2) = u1 == u2
- (==) (VirtualRegF u1) (VirtualRegF u2) = u1 == u2
- (==) (VirtualRegD u1) (VirtualRegD u2) = u1 == u2
- (==) reg1 reg2 = False
-
-instance Ord Reg where
- compare (RealReg i1) (RealReg i2) = compare i1 i2
- compare (RealReg _) (VirtualRegI _) = LT
- compare (RealReg _) (VirtualRegF _) = LT
- compare (RealReg _) (VirtualRegD _) = LT
-
- compare (VirtualRegI _) (RealReg _) = GT
- compare (VirtualRegI u1) (VirtualRegI u2) = compare u1 u2
- compare (VirtualRegI _) (VirtualRegF _) = LT
- compare (VirtualRegI _) (VirtualRegD _) = LT
-
- compare (VirtualRegF _) (RealReg _) = GT
- compare (VirtualRegF _) (VirtualRegI _) = GT
- compare (VirtualRegF u1) (VirtualRegF u2) = compare u1 u2
- compare (VirtualRegF _) (VirtualRegD _) = LT
-
- compare (VirtualRegD _) (RealReg _) = GT
- compare (VirtualRegD _) (VirtualRegI _) = GT
- compare (VirtualRegD _) (VirtualRegF _) = GT
- compare (VirtualRegD u1) (VirtualRegD u2) = compare u1 u2
+isVirtualReg :: Reg -> Bool
+isVirtualReg (RealReg _) = False
+isVirtualReg (VirtualRegI _) = True
+isVirtualReg (VirtualRegHi _) = True
+isVirtualReg (VirtualRegF _) = True
+isVirtualReg (VirtualRegD _) = True
+isRealReg :: Reg -> Bool
+isRealReg = not . isVirtualReg
instance Show Reg where
- show (RealReg i) = showReg i
- show (VirtualRegI u) = "%vI_" ++ show u
- show (VirtualRegF u) = "%vF_" ++ show u
- show (VirtualRegD u) = "%vD_" ++ show u
+ show (RealReg i) = showReg i
+ show (VirtualRegI u) = "%vI_" ++ show u
+ show (VirtualRegHi u) = "%vHi_" ++ show u
+ show (VirtualRegF u) = "%vF_" ++ show u
+ show (VirtualRegD u) = "%vD_" ++ show u
instance Outputable Reg where
ppr r = Outputable.text (show r)
-\end{code}
-** Machine-specific Reg stuff: **
-The Alpha has 64 registers of interest; 32 integer registers and 32 floating
-point registers. The mapping of STG registers to alpha machine registers
-is defined in StgRegs.h. We are, of course, prepared for any eventuality.
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- Machine-specific register stuff
+
+-- The Alpha has 64 registers of interest; 32 integer registers and 32 floating
+-- point registers. The mapping of STG registers to alpha machine registers
+-- is defined in StgRegs.h. We are, of course, prepared for any eventuality.
+
#if alpha_TARGET_ARCH
-fReg :: Int -> Int
+fReg :: Int -> RegNo
fReg x = (32 + x)
v0, f0, ra, pv, gp, sp, zeroh :: Reg
t11 = realReg 25
t12 = realReg 27
#endif
-\end{code}
+{-
Intel x86 architecture:
- All registers except 7 (esp) are available for use.
- Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
The fp registers are all Double registers; we don't have any RcFloat class
regs. @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should
never generate them.
+-}
-\begin{code}
#if i386_TARGET_ARCH
fake0, fake1, fake2, fake3, fake4, fake5,
fake4 = RealReg 12
fake5 = RealReg 13
+-- On x86, we might want to have an 8-bit RegClass, which would
+-- contain just regs 1-4 (the others don't have 8-bit versions).
+-- However, we can get away without this at the moment because the
+-- only allocatable integer regs are also 8-bit compatible (1, 3, 4).
regClass (RealReg i) = if i < 8 then RcInteger else RcDouble
-regClass (VirtualRegI u) = RcInteger
-regClass (VirtualRegD u) = RcDouble
-regClass (VirtualRegF u) = pprPanic "regClass(x86):VirtualRegF"
+regClass (VirtualRegI u) = RcInteger
+regClass (VirtualRegHi u) = RcInteger
+regClass (VirtualRegD u) = RcDouble
+regClass (VirtualRegF u) = pprPanic "regClass(x86):VirtualRegF"
(ppr (VirtualRegF u))
regNames
= ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp",
"%fake0", "%fake1", "%fake2", "%fake3", "%fake4", "%fake5", "%fake6"]
-showReg :: Int -> String
+showReg :: RegNo -> String
showReg n
= if n >= 0 && n < 14
then regNames !! n
else "%unknown_x86_real_reg_" ++ show n
#endif
-\end{code}
+{-
The SPARC has 64 registers of interest; 32 integer registers and 32
floating point registers. The mapping of STG registers to SPARC
machine registers is defined in StgRegs.h. We are, of course,
The whole fp-register pairing thing on sparcs is a huge nuisance. See
fptools/ghc/includes/MachRegs.h for a description of what's going on
here.
+-}
-\begin{code}
#if sparc_TARGET_ARCH
-gReg,lReg,iReg,oReg,fReg :: Int -> Int
+gReg,lReg,iReg,oReg,fReg :: Int -> RegNo
gReg x = x
oReg x = (8 + x)
lReg x = (16 + x)
iReg x = (24 + x)
fReg x = (32 + x)
-nCG_FirstFloatReg :: Int
+nCG_FirstFloatReg :: RegNo
nCG_FirstFloatReg = unRealReg NCG_FirstFloatReg
regClass (VirtualRegI u) = RcInteger
| i < nCG_FirstFloatReg = RcDouble
| otherwise = RcFloat
-showReg :: Int -> String
+showReg :: RegNo -> String
showReg n
| n >= 0 && n < 8 = "%g" ++ show n
| n >= 8 && n < 16 = "%o" ++ show (n-8)
f1 = RealReg (fReg 1)
#endif
-\end{code}
+{-
The PowerPC has 64 registers of interest; 32 integer registers and 32 floating
point registers.
-\begin{code}
+-}
+
#if powerpc_TARGET_ARCH
-fReg :: Int -> Int
+fReg :: Int -> RegNo
fReg x = (32 + x)
-regClass (VirtualRegI u) = RcInteger
-regClass (VirtualRegF u) = RcFloat
+regClass (VirtualRegI u) = RcInteger
+regClass (VirtualRegHi u) = RcInteger
+regClass (VirtualRegF u) = pprPanic "regClass(ppc):VirtualRegF"
+ (ppr (VirtualRegF u))
regClass (VirtualRegD u) = RcDouble
regClass (RealReg i) | i < 32 = RcInteger
| otherwise = RcDouble
- -- | i < nCG_FirstFloatReg = RcDouble
- -- | otherwise = RcFloat
-showReg :: Int -> String
+showReg :: RegNo -> String
showReg n
| n >= 0 && n <= 31 = "%r" ++ show n
| n >= 32 && n <= 63 = "%f" ++ show (n - 32)
f20 = RealReg $ fReg 20
f21 = RealReg $ fReg 21
#endif
-\end{code}
+{-
Redefine the literals used for machine-registers with non-numeric
names in the header files. Gag me with a spoon, eh?
-\begin{code}
+-}
+
#if alpha_TARGET_ARCH
#define f0 32
#define f1 33
#define fr31 63
#endif
#endif
-\end{code}
-
-\begin{code}
-baseRegOffset :: MagicId -> Int
-
-baseRegOffset (VanillaReg _ 1#) = OFFSET_R1
-baseRegOffset (VanillaReg _ 2#) = OFFSET_R2
-baseRegOffset (VanillaReg _ 3#) = OFFSET_R3
-baseRegOffset (VanillaReg _ 4#) = OFFSET_R4
-baseRegOffset (VanillaReg _ 5#) = OFFSET_R5
-baseRegOffset (VanillaReg _ 6#) = OFFSET_R6
-baseRegOffset (VanillaReg _ 7#) = OFFSET_R7
-baseRegOffset (VanillaReg _ 8#) = OFFSET_R8
-baseRegOffset (VanillaReg _ 9#) = OFFSET_R9
-baseRegOffset (VanillaReg _ 10#) = OFFSET_R10
-baseRegOffset (FloatReg 1#) = OFFSET_F1
-baseRegOffset (FloatReg 2#) = OFFSET_F2
-baseRegOffset (FloatReg 3#) = OFFSET_F3
-baseRegOffset (FloatReg 4#) = OFFSET_F4
-baseRegOffset (DoubleReg 1#) = OFFSET_D1
-baseRegOffset (DoubleReg 2#) = OFFSET_D2
-baseRegOffset Sp = OFFSET_Sp
-baseRegOffset SpLim = OFFSET_SpLim
-#ifdef OFFSET_L1
-baseRegOffset (LongReg _ 1#) = OFFSET_L1
-#endif
-baseRegOffset Hp = OFFSET_Hp
-baseRegOffset HpLim = OFFSET_HpLim
-baseRegOffset CurrentTSO = OFFSET_CurrentTSO
-baseRegOffset CurrentNursery = OFFSET_CurrentNursery
-baseRegOffset HpAlloc = OFFSET_HpAlloc
-#ifdef NCG_DEBUG
-baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
-baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre"
-baseRegOffset VoidReg = panic "baseRegOffset:VoidReg"
-#endif
-\end{code}
-
-\begin{code}
-callerSaves :: MagicId -> Bool
-
-#ifdef CALLER_SAVES_Base
-callerSaves BaseReg = True
-#endif
-#ifdef CALLER_SAVES_R1
-callerSaves (VanillaReg _ ILIT(1)) = True
-#endif
-#ifdef CALLER_SAVES_R2
-callerSaves (VanillaReg _ ILIT(2)) = True
-#endif
-#ifdef CALLER_SAVES_R3
-callerSaves (VanillaReg _ ILIT(3)) = True
-#endif
-#ifdef CALLER_SAVES_R4
-callerSaves (VanillaReg _ ILIT(4)) = True
-#endif
-#ifdef CALLER_SAVES_R5
-callerSaves (VanillaReg _ ILIT(5)) = True
-#endif
-#ifdef CALLER_SAVES_R6
-callerSaves (VanillaReg _ ILIT(6)) = True
-#endif
-#ifdef CALLER_SAVES_R7
-callerSaves (VanillaReg _ ILIT(7)) = True
-#endif
-#ifdef CALLER_SAVES_R8
-callerSaves (VanillaReg _ ILIT(8)) = True
-#endif
-#ifdef CALLER_SAVES_F1
-callerSaves (FloatReg 1#) = True
-#endif
-#ifdef CALLER_SAVES_F2
-callerSaves (FloatReg 2#) = True
-#endif
-#ifdef CALLER_SAVES_F3
-callerSaves (FloatReg 3#) = True
-#endif
-#ifdef CALLER_SAVES_F4
-callerSaves (FloatReg 4#) = True
-#endif
-#ifdef CALLER_SAVES_D1
-callerSaves (DoubleReg 1#) = True
-#endif
-#ifdef CALLER_SAVES_D2
-callerSaves (DoubleReg 2#) = True
-#endif
-#ifdef CALLER_SAVES_L1
-callerSaves (LongReg _ ILIT(1)) = True
-#endif
-#ifdef CALLER_SAVES_Sp
-callerSaves Sp = True
-#endif
-#ifdef CALLER_SAVES_SpLim
-callerSaves SpLim = True
-#endif
-#ifdef CALLER_SAVES_Hp
-callerSaves Hp = True
-#endif
-#ifdef CALLER_SAVES_HpLim
-callerSaves HpLim = True
-#endif
-#ifdef CALLER_SAVES_CurrentTSO
-callerSaves CurrentTSO = True
-#endif
-#ifdef CALLER_SAVES_CurrentNursery
-callerSaves CurrentNursery = True
-#endif
-callerSaves _ = False
-\end{code}
-
-\begin{code}
-magicIdRegMaybe :: MagicId -> Maybe Reg
-#ifdef REG_Base
-magicIdRegMaybe BaseReg = Just (RealReg REG_Base)
-#endif
-#ifdef REG_R1
-magicIdRegMaybe (VanillaReg _ 1#) = Just (RealReg REG_R1)
-#endif
-#ifdef REG_R2
-magicIdRegMaybe (VanillaReg _ 2#) = Just (RealReg REG_R2)
-#endif
-#ifdef REG_R3
-magicIdRegMaybe (VanillaReg _ 3#) = Just (RealReg REG_R3)
-#endif
-#ifdef REG_R4
-magicIdRegMaybe (VanillaReg _ 4#) = Just (RealReg REG_R4)
-#endif
-#ifdef REG_R5
-magicIdRegMaybe (VanillaReg _ 5#) = Just (RealReg REG_R5)
-#endif
-#ifdef REG_R6
-magicIdRegMaybe (VanillaReg _ 6#) = Just (RealReg REG_R6)
-#endif
-#ifdef REG_R7
-magicIdRegMaybe (VanillaReg _ 7#) = Just (RealReg REG_R7)
-#endif
-#ifdef REG_R8
-magicIdRegMaybe (VanillaReg _ 8#) = Just (RealReg REG_R8)
-#endif
-#ifdef REG_R9
-magicIdRegMaybe (VanillaReg _ 9#) = Just (RealReg REG_R9)
-#endif
-#ifdef REG_R10
-magicIdRegMaybe (VanillaReg _ 10#) = Just (RealReg REG_R10)
-#endif
-#ifdef REG_F1
-magicIdRegMaybe (FloatReg 1#) = Just (RealReg REG_F1)
-#endif
-#ifdef REG_F2
-magicIdRegMaybe (FloatReg 2#) = Just (RealReg REG_F2)
-#endif
-#ifdef REG_F3
-magicIdRegMaybe (FloatReg 3#) = Just (RealReg REG_F3)
-#endif
-#ifdef REG_F4
-magicIdRegMaybe (FloatReg 4#) = Just (RealReg REG_F4)
-#endif
-#ifdef REG_D1
-magicIdRegMaybe (DoubleReg 1#) = Just (RealReg REG_D1)
-#endif
-#ifdef REG_D2
-magicIdRegMaybe (DoubleReg 2#) = Just (RealReg REG_D2)
-#endif
-#ifdef REG_Sp
-magicIdRegMaybe Sp = Just (RealReg REG_Sp)
-#endif
-#ifdef REG_Lng1
-magicIdRegMaybe (LongReg _ ILIT(1)) = Just (RealReg REG_Lng1)
-#endif
-#ifdef REG_Lng2
-magicIdRegMaybe (LongReg _ ILIT(2)) = Just (RealReg REG_Lng2)
-#endif
-#ifdef REG_SpLim
-magicIdRegMaybe SpLim = Just (RealReg REG_SpLim)
-#endif
-#ifdef REG_Hp
-magicIdRegMaybe Hp = Just (RealReg REG_Hp)
-#endif
-#ifdef REG_HpLim
-magicIdRegMaybe HpLim = Just (RealReg REG_HpLim)
-#endif
-#ifdef REG_CurrentTSO
-magicIdRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO)
-#endif
-#ifdef REG_CurrentNursery
-magicIdRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery)
-#endif
-magicIdRegMaybe _ = Nothing
-\end{code}
-\begin{code}
--------------------------------
-- allMachRegs is the complete set of machine regs.
-allMachRegNos :: [Int]
+allMachRegNos :: [RegNo]
allMachRegNos
= IF_ARCH_alpha( [0..63],
IF_ARCH_i386( [0..13],
++ [nCG_FirstFloatReg .. f31]),
IF_ARCH_powerpc([0..63],
))))
+
-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
-- i.e., these are the regs for which we are prepared to allow the
-- register allocator to attempt to map VRegs to.
-allocatableRegs :: [Reg]
+allocatableRegs :: [RegNo]
allocatableRegs
= let isFree i = isFastTrue (freeReg i)
- in map RealReg (filter isFree allMachRegNos)
+ in filter isFree allMachRegNos
--------------------------------
-- these are the regs which we cannot assume stay alive over a
-- C call.
callClobberedRegs :: [Reg]
[fReg i | i <- [0..31]] )
#endif /* sparc_TARGET_ARCH */
#if powerpc_TARGET_ARCH
- map RealReg ([0..12] ++ map fReg [0..13])
+#if darwin_TARGET_OS
+ map RealReg (0:[2..12] ++ map fReg [0..13])
+#elif linux_TARGET_OS
+ map RealReg (0:[2..13] ++ map fReg [0..13])
+#endif
#endif /* powerpc_TARGET_ARCH */
--------------------------------
+
-- argRegs is the set of regs which are read for an n-argument call to C.
-- For archs which pass all args on the stack (x86), is empty.
-- Sparc passes up to the first 6 args in regs.
-- Dunno about Alpha.
-argRegs :: Int -> [Reg]
+argRegs :: RegNo -> [Reg]
#if i386_TARGET_ARCH
argRegs _ = panic "MachRegs.argRegs(x86): should not be used!"
argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!"
#endif /* powerpc_TARGET_ARCH */
--------------------------------
+
-- all of the arg regs ??
#if alpha_TARGET_ARCH
allArgRegs :: [(Reg, Reg)]
allArgRegs :: [Reg]
allArgRegs = map RealReg [3..10]
allFPArgRegs :: [Reg]
+#if darwin_TARGET_OS
allFPArgRegs = map (RealReg . fReg) [1..13]
+#elif linux_TARGET_OS
+allFPArgRegs = map (RealReg . fReg) [1..8]
+#endif
#endif /* powerpc_TARGET_ARCH */
\end{code}
\begin{code}
-freeReg :: Int -> FastBool
+freeReg :: RegNo -> FastBool
#if alpha_TARGET_ARCH
freeReg 26 = fastBool False -- return address (ra)
freeReg REG_HpLim = fastBool False
#endif
freeReg n = fastBool True
+
+
+-- -----------------------------------------------------------------------------
+-- Information about global registers
+
+baseRegOffset :: GlobalReg -> Int
+
+baseRegOffset (VanillaReg 1) = oFFSET_StgRegTable_rR1
+baseRegOffset (VanillaReg 2) = oFFSET_StgRegTable_rR2
+baseRegOffset (VanillaReg 3) = oFFSET_StgRegTable_rR3
+baseRegOffset (VanillaReg 4) = oFFSET_StgRegTable_rR4
+baseRegOffset (VanillaReg 5) = oFFSET_StgRegTable_rR5
+baseRegOffset (VanillaReg 6) = oFFSET_StgRegTable_rR6
+baseRegOffset (VanillaReg 7) = oFFSET_StgRegTable_rR7
+baseRegOffset (VanillaReg 8) = oFFSET_StgRegTable_rR8
+baseRegOffset (VanillaReg 9) = oFFSET_StgRegTable_rR9
+baseRegOffset (VanillaReg 10) = oFFSET_StgRegTable_rR10
+baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1
+baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2
+baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3
+baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4
+baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1
+baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2
+baseRegOffset Sp = oFFSET_StgRegTable_rSp
+baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
+baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
+baseRegOffset Hp = oFFSET_StgRegTable_rHp
+baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
+baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
+baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
+baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
+baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
+baseRegOffset GCFun = oFFSET_stgGCFun
+#ifdef DEBUG
+baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
+baseRegOffset _ = panic "baseRegOffset:other"
+#endif
+
+
+-- | Returns 'True' if this global register is stored in a caller-saves
+-- machine register.
+
+callerSaves :: GlobalReg -> Bool
+
+#ifdef CALLER_SAVES_Base
+callerSaves BaseReg = True
+#endif
+#ifdef CALLER_SAVES_R1
+callerSaves (VanillaReg _ ILIT(1)) = True
+#endif
+#ifdef CALLER_SAVES_R2
+callerSaves (VanillaReg _ ILIT(2)) = True
+#endif
+#ifdef CALLER_SAVES_R3
+callerSaves (VanillaReg _ ILIT(3)) = True
+#endif
+#ifdef CALLER_SAVES_R4
+callerSaves (VanillaReg _ ILIT(4)) = True
+#endif
+#ifdef CALLER_SAVES_R5
+callerSaves (VanillaReg _ ILIT(5)) = True
+#endif
+#ifdef CALLER_SAVES_R6
+callerSaves (VanillaReg _ ILIT(6)) = True
+#endif
+#ifdef CALLER_SAVES_R7
+callerSaves (VanillaReg _ ILIT(7)) = True
+#endif
+#ifdef CALLER_SAVES_R8
+callerSaves (VanillaReg _ ILIT(8)) = True
+#endif
+#ifdef CALLER_SAVES_F1
+callerSaves (FloatReg 1#) = True
+#endif
+#ifdef CALLER_SAVES_F2
+callerSaves (FloatReg 2#) = True
+#endif
+#ifdef CALLER_SAVES_F3
+callerSaves (FloatReg 3#) = True
+#endif
+#ifdef CALLER_SAVES_F4
+callerSaves (FloatReg 4#) = True
+#endif
+#ifdef CALLER_SAVES_D1
+callerSaves (DoubleReg 1#) = True
+#endif
+#ifdef CALLER_SAVES_D2
+callerSaves (DoubleReg 2#) = True
+#endif
+#ifdef CALLER_SAVES_L1
+callerSaves (LongReg _ ILIT(1)) = True
+#endif
+#ifdef CALLER_SAVES_Sp
+callerSaves Sp = True
+#endif
+#ifdef CALLER_SAVES_SpLim
+callerSaves SpLim = True
+#endif
+#ifdef CALLER_SAVES_Hp
+callerSaves Hp = True
+#endif
+#ifdef CALLER_SAVES_HpLim
+callerSaves HpLim = True
+#endif
+#ifdef CALLER_SAVES_CurrentTSO
+callerSaves CurrentTSO = True
+#endif
+#ifdef CALLER_SAVES_CurrentNursery
+callerSaves CurrentNursery = True
+#endif
+callerSaves _ = False
+
+
+-- | Returns 'Nothing' if this global register is not stored
+-- in a real machine register, otherwise returns @'Just' reg@, where
+-- reg is the machine register it is stored in.
+
+globalRegMaybe :: GlobalReg -> Maybe Reg
+
+#ifdef REG_Base
+globalRegMaybe BaseReg = Just (RealReg REG_Base)
+#endif
+#ifdef REG_R1
+globalRegMaybe (VanillaReg 1) = Just (RealReg REG_R1)
+#endif
+#ifdef REG_R2
+globalRegMaybe (VanillaReg 2) = Just (RealReg REG_R2)
+#endif
+#ifdef REG_R3
+globalRegMaybe (VanillaReg 3) = Just (RealReg REG_R3)
+#endif
+#ifdef REG_R4
+globalRegMaybe (VanillaReg 4) = Just (RealReg REG_R4)
+#endif
+#ifdef REG_R5
+globalRegMaybe (VanillaReg 5) = Just (RealReg REG_R5)
+#endif
+#ifdef REG_R6
+globalRegMaybe (VanillaReg 6) = Just (RealReg REG_R6)
+#endif
+#ifdef REG_R7
+globalRegMaybe (VanillaReg 7) = Just (RealReg REG_R7)
+#endif
+#ifdef REG_R8
+globalRegMaybe (VanillaReg 8) = Just (RealReg REG_R8)
+#endif
+#ifdef REG_R9
+globalRegMaybe (VanillaReg 9) = Just (RealReg REG_R9)
+#endif
+#ifdef REG_R10
+globalRegMaybe (VanillaReg 10) = Just (RealReg REG_R10)
+#endif
+#ifdef REG_F1
+globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1)
+#endif
+#ifdef REG_F2
+globalRegMaybe (FloatReg 2) = Just (RealReg REG_F2)
+#endif
+#ifdef REG_F3
+globalRegMaybe (FloatReg 3) = Just (RealReg REG_F3)
+#endif
+#ifdef REG_F4
+globalRegMaybe (FloatReg 4) = Just (RealReg REG_F4)
+#endif
+#ifdef REG_D1
+globalRegMaybe (DoubleReg 1) = Just (RealReg REG_D1)
+#endif
+#ifdef REG_D2
+globalRegMaybe (DoubleReg 2) = Just (RealReg REG_D2)
+#endif
+#ifdef REG_Sp
+globalRegMaybe Sp = Just (RealReg REG_Sp)
+#endif
+#ifdef REG_Lng1
+globalRegMaybe (LongReg 1) = Just (RealReg REG_Lng1)
+#endif
+#ifdef REG_Lng2
+globalRegMaybe (LongReg 2) = Just (RealReg REG_Lng2)
+#endif
+#ifdef REG_SpLim
+globalRegMaybe SpLim = Just (RealReg REG_SpLim)
+#endif
+#ifdef REG_Hp
+globalRegMaybe Hp = Just (RealReg REG_Hp)
+#endif
+#ifdef REG_HpLim
+globalRegMaybe HpLim = Just (RealReg REG_HpLim)
+#endif
+#ifdef REG_CurrentTSO
+globalRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO)
+#endif
+#ifdef REG_CurrentNursery
+globalRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery)
+#endif
+globalRegMaybe _ = Nothing
+
+
\end{code}
-#define COMMA ,
-
-#ifndef NCG_H
-#define NCG_H
-#if 0
- COMPILING_NCG is used to control the visibility of
- relevant information from the GHC header files when
- compiling the native code generator modules.
-#endif
+/* -----------------------------------------------------------------------------
-#ifndef COMPILING_NCG
-#define COMPILING_NCG
-#endif
+ (c) The University of Glasgow, 1994-2004
-#if 0
-
-IMPORTANT! If you put extra tabs/spaces in these macro definitions,
-you will screw up the layout where they are used in case expressions!
-
-(This is cpp-dependent, of course)
-
-** Convenience macros for writing the native-code generator **
-
-#endif
+ Native-code generator header file - just useful macros for now.
-#include "../includes/config.h"
-
-#if 0
-{-testing only-}
-#undef sparc_TARGET_ARCH
-#undef sunos4_TARGET_OS
-#undef i386_TARGET_ARCH
-#define i386_TARGET_ARCH 1
-#undef linuxaout_TARGET_OS
-#define linuxaout_TARGET_OS 1
-#endif
-#if 0
-{-testing only-}
-#undef sparc_TARGET_ARCH
-#undef sunos4_TARGET_OS
-#undef alpha_TARGET_ARCH
-#define alpha_TARGET_ARCH 1
-#endif
-
-#if i386_TARGET_ARCH
-# define STOLEN_X86_REGS 4
--- HACK: go for the max
-#endif
-
-#include "../includes/MachRegs.h"
-#include "../includes/NativeDefs.h"
-
-#if alpha_TARGET_ARCH
-# define BYTES_PER_WORD 8
-# define BYTES_PER_WORD_STR "8"
-#endif
+ -------------------------------------------------------------------------- */
-#if i386_TARGET_ARCH
-# define BYTES_PER_WORD 4
-# define BYTES_PER_WORD_STR "4"
-#endif
-
-#if sparc_TARGET_ARCH
-# define BYTES_PER_WORD 4
-# define BYTES_PER_WORD_STR "4"
-#endif
+#ifndef NCG_H
+#define NCG_H
-#if powerpc_TARGET_ARCH
-# define BYTES_PER_WORD 4
-# define BYTES_PER_WORD_STR "4"
-#endif
+#include "../includes/ghcconfig.h"
----------------------------------------------
+#define COMMA ,
+-- - - - - - - - - - - - - - - - - - - - - -
#if alpha_TARGET_ARCH
# define IF_ARCH_alpha(x,y) x
#else
# define IF_ARCH_alpha(x,y) y
#endif
-
----------------------------------------------
-
+-- - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
# define IF_ARCH_i386(x,y) x
#else
#else
# define IF_OS_cygwin32(x,y) y
#endif
----------------------------------------------
+-- - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
# define IF_ARCH_sparc(x,y) x
#else
#else
# define IF_OS_solaris2(x,y) y
#endif
----------------------------------------------
+-- - - - - - - - - - - - - - - - - - - - - -
#if powerpc_TARGET_ARCH
# define IF_ARCH_powerpc(x,y) x
#else
--- /dev/null
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-- The native code generator's monad.
+--
+-- -----------------------------------------------------------------------------
+
+module NCGMonad (
+ NatM_State(..), mkNatM_State,
+
+ NatM, -- instance Monad
+ initNat, addImportNat, getUniqueNat,
+ mapAccumLNat, setDeltaNat, getDeltaNat,
+ getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
+ ) where
+
+#include "HsVersions.h"
+
+import Cmm ( BlockId(..) )
+import CLabel ( CLabel, mkAsmTempLabel )
+import MachRegs
+import MachOp ( MachRep )
+import UniqSupply
+import Unique ( Unique )
+
+
+data NatM_State = NatM_State {
+ natm_us :: UniqSupply,
+ natm_delta :: Int,
+ natm_imports :: [(Bool,CLabel)]
+ }
+
+newtype NatM result = NatM (NatM_State -> (result, NatM_State))
+
+unNat (NatM a) = a
+
+mkNatM_State :: UniqSupply -> Int -> NatM_State
+mkNatM_State us delta = NatM_State us delta []
+
+initNat :: NatM_State -> NatM a -> (a, NatM_State)
+initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
+
+instance Monad NatM where
+ (>>=) = thenNat
+ return = returnNat
+
+thenNat :: NatM a -> (a -> NatM b) -> NatM b
+thenNat expr cont
+ = NatM $ \st -> case unNat expr st of
+ (result, st') -> unNat (cont result) st'
+
+returnNat :: a -> NatM a
+returnNat result = NatM $ \st -> (result, st)
+
+mapAccumLNat :: (acc -> x -> NatM (acc, y))
+ -> acc
+ -> [x]
+ -> NatM (acc, [y])
+
+mapAccumLNat f b []
+ = return (b, [])
+mapAccumLNat f b (x:xs)
+ = do (b__2, x__2) <- f b x
+ (b__3, xs__2) <- mapAccumLNat f b__2 xs
+ return (b__3, x__2:xs__2)
+
+getUniqueNat :: NatM Unique
+getUniqueNat = NatM $ \ (NatM_State us delta imports) ->
+ case splitUniqSupply us of
+ (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports))
+
+getDeltaNat :: NatM Int
+getDeltaNat = NatM $ \ st -> (natm_delta st, st)
+
+setDeltaNat :: Int -> NatM ()
+setDeltaNat delta = NatM $ \ (NatM_State us _ imports) ->
+ ((), NatM_State us delta imports)
+
+addImportNat :: Bool -> CLabel -> NatM ()
+addImportNat is_code imp = NatM $ \ (NatM_State us delta imports) ->
+ ((), NatM_State us delta ((is_code,imp):imports))
+
+getBlockIdNat :: NatM BlockId
+getBlockIdNat = do u <- getUniqueNat; return (BlockId u)
+
+getNewLabelNat :: NatM CLabel
+getNewLabelNat = do u <- getUniqueNat; return (mkAsmTempLabel u)
+
+getNewRegNat :: MachRep -> NatM Reg
+getNewRegNat rep = do u <- getUniqueNat; return (mkVReg u rep)
+
+getNewRegPairNat :: MachRep -> NatM (Reg,Reg)
+getNewRegPairNat rep = do
+ u <- getUniqueNat
+ let lo = mkVReg u rep; hi = getHiVRegFromLo lo
+ return (lo,hi)
+
+TODO in new NCG
+~~~~~~~~~~~~~~~
-Known bugs/issues in nativeGen, 000228 (JRS)
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+- Are we being careful enough about narrowing those out-of-range CmmInts?
--- absC -> stix translation for GET_TAG and in fact anything
- to do with the packed-halfword layout info itbl field is
- pretty dubious. I think I have it fixed for big and little
- endian 32-bit, but it won't work at all on a 64 bit platform.
+- Register allocator:
+ - fixup code
+ - keep track of free stack slots
--- There may or may not be bugs in some of the x86 insn selector
- code in MachCode.lhs. I have checked all of it against the
- Rules of the Game (+ Rules of the game for Amodes) recorded in
- that file, but am not 100% convinced that it is all correct.
- I think most of it is, tho.
+ Optimisations:
--- It won't compile on Solaris or Alphas because the insn selectors
- are not up-to-date.
+ - picking the assignment on entry to a block: better to defer this
+ until we know all the assignments. In a loop, we should pick
+ the assignment from the looping jump (fixpointing?), so that any
+ fixup code ends up *outside* the loop. Otherwise, we should
+ pick the assignment that results in the least fixup code.
+
+- splitting?
+
+-- -----------------------------------------------------------------------------
+-- x86 ToDos
+
+- x86 genCCall needs to tack on the @size for stdcalls (might not be in the
+ foreignlabel).
+
+- x86: should really clean up that IMUL64 stuff, and tell the code gen about
+ Intel imul instructions.
+
+- x86: we're not careful enough about making sure that we only use
+ byte-addressable registers in byte instructions. Should we do it this
+ way, or stick to using 32-bit registers everywhere?
+
+- Use SSE for floating point, optionally.
+
+------------------------------------------------------------------------------
+-- Further optimisations:
+
+- We might be able to extend the scope of the inlining phase so it can
+ skip over more statements that don't affect the value of the inlined
+ expr.
--- NCG introduces a massive space leak; I think it generates all the
- assembly code before printing any of it out (a depressingly
- familiar story ...). Fixing this will await a working heap profiler.
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[PprMach]{Pretty-printing assembly language}
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+ -- (c) The University of Glasgow 1993-2004
+ --
+-----------------------------------------------------------------------------
-We start with the @pprXXX@s with some cross-platform commonality
-(e.g., @pprReg@); we conclude with the no-commonality monster,
-@pprInstr@.
+-- We start with the @pprXXX@s with some cross-platform commonality
+-- (e.g., 'pprReg'); we conclude with the no-commonality monster,
+-- 'pprInstr'.
-\begin{code}
#include "nativeGen/NCG.h"
-module PprMach ( pprInstr, pprSize, pprUserReg IF_OS_darwin(COMMA pprDyldSymbolStub, ) ) where
+module PprMach (
+ pprNatCmmTop, pprBasicBlock,
+ pprInstr, pprSize, pprUserReg,
+#if darwin_TARGET_OS
+ pprDyldSymbolStub,
+#endif
+ ) where
+
#include "HsVersions.h"
+import Cmm
+import MachOp ( MachRep(..) )
import MachRegs -- may differ per-platform
-import MachMisc
+import MachInstrs
+
+import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
+ labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
-import CLabel ( pprCLabel, externallyVisibleCLabel, labelDynamic )
-import Stix ( CodeSegment(..) )
import Panic ( panic )
+import Unique ( pprUnique )
import Pretty
import FastString
import qualified Outputable
#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
-import Data.Word ( Word8, Word16 )
+import Data.Word ( Word8 )
#else
import MutableArray
-import Word ( Word16 )
#endif
import MONAD_ST
-
import Char ( chr, ord )
-import Maybe ( isJust )
+
+#if powerpc_TARGET_ARCH
+import DATA_WORD(Word32)
+import DATA_BITS
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Printing this stuff out
asmSDoc d = Outputable.withPprStyleDoc (
Outputable.mkCodeStyle Outputable.AsmStyle) d
pprCLabel_asm l = asmSDoc (pprCLabel l)
-\end{code}
-%************************************************************************
-%* *
-\subsection{@pprReg@: print a @Reg@}
-%* *
-%************************************************************************
+pprNatCmmTop :: NatCmmTop -> Doc
+pprNatCmmTop (CmmData section dats) =
+ pprSectionHeader section $$ vcat (map pprData dats)
+
+ -- special case for split markers:
+pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
+
+pprNatCmmTop (CmmProc info lbl params blocks) =
+ pprSectionHeader Text $$
+ (if not (null info)
+ then vcat (map pprData info)
+ $$ pprLabel (entryLblToInfoLbl lbl)
+ else empty) $$
+ (case blocks of
+ [] -> empty
+ (BasicBlock _ instrs : rest) ->
+ (if null info then pprLabel lbl else empty) $$
+ -- the first block doesn't get a label:
+ vcat (map pprInstr instrs) $$
+ vcat (map pprBasicBlock rest))
+
+
+pprBasicBlock :: NatBasicBlock -> Doc
+pprBasicBlock (BasicBlock (BlockId id) instrs) =
+ pprLabel (mkAsmTempLabel id) $$
+ vcat (map pprInstr instrs)
+
+-- -----------------------------------------------------------------------------
+-- pprReg: print a 'Reg'
+
+-- For x86, the way we print a register name depends
+-- on which bit of it we care about. Yurgh.
-For x86, the way we print a register name depends
-on which bit of it we care about. Yurgh.
-\begin{code}
pprUserReg :: Reg -> Doc
-pprUserReg = pprReg IF_ARCH_i386(L,)
+pprUserReg = pprReg IF_ARCH_i386(I32,)
-pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc
+pprReg :: IF_ARCH_i386(MachRep ->,) Reg -> Doc
pprReg IF_ARCH_i386(s,) r
= case r of
RealReg i -> ppr_reg_no IF_ARCH_i386(s,) i
- VirtualRegI u -> text "%vI_" <> asmSDoc (pprVRegUnique u)
- VirtualRegF u -> text "%vF_" <> asmSDoc (pprVRegUnique u)
+ VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
+ VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
+ VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
+ VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
where
#if alpha_TARGET_ARCH
ppr_reg_no :: Int -> Doc
})
#endif
#if i386_TARGET_ARCH
- ppr_reg_no :: Size -> Int -> Doc
- ppr_reg_no B = ppr_reg_byte
- ppr_reg_no Bu = ppr_reg_byte
- ppr_reg_no W = ppr_reg_word
- ppr_reg_no Wu = ppr_reg_word
- ppr_reg_no _ = ppr_reg_long
+ ppr_reg_no :: MachRep -> Int -> Doc
+ ppr_reg_no I8 = ppr_reg_byte
+ ppr_reg_no I16 = ppr_reg_word
+ ppr_reg_no _ = ppr_reg_long
ppr_reg_byte i = ptext
(case i of {
| otherwise = ptext SLIT("very naughty powerpc register")
#endif
#endif
-\end{code}
-%************************************************************************
-%* *
-\subsection{@pprSize@: print a @Size@}
-%* *
-%************************************************************************
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- pprSize: print a 'Size'
+
+#if powerpc_TARGET_ARCH || i386_TARGET_ARCH
+pprSize :: MachRep -> Doc
+#else
pprSize :: Size -> Doc
+#endif
pprSize x = ptext (case x of
#if alpha_TARGET_ARCH
TF -> SLIT("t")
#endif
#if i386_TARGET_ARCH
- B -> SLIT("b")
- Bu -> SLIT("b")
- W -> SLIT("w")
- Wu -> SLIT("w")
- L -> SLIT("l")
- Lu -> SLIT("l")
- F -> SLIT("s")
- DF -> SLIT("l")
- F80 -> SLIT("t")
+ I8 -> SLIT("b")
+ I16 -> SLIT("w")
+ I32 -> SLIT("l")
+ F32 -> SLIT("s")
+ F64 -> SLIT("l")
+ F80 -> SLIT("t")
#endif
#if sparc_TARGET_ARCH
B -> SLIT("sb")
DF -> SLIT("d")
#endif
#if powerpc_TARGET_ARCH
- B -> SLIT("b")
- Bu -> SLIT("b")
- H -> SLIT("h")
- Hu -> SLIT("h")
- W -> SLIT("w")
- F -> SLIT("fs")
- DF -> SLIT("fd")
+ I8 -> SLIT("b")
+ I16 -> SLIT("h")
+ I32 -> SLIT("w")
+ F32 -> SLIT("fs")
+ F64 -> SLIT("fd")
#endif
)
-\end{code}
-%************************************************************************
-%* *
-\subsection{@pprCond@: print a @Cond@}
-%* *
-%************************************************************************
+-- -----------------------------------------------------------------------------
+-- pprCond: print a 'Cond'
-\begin{code}
pprCond :: Cond -> Doc
pprCond c = ptext (case c of {
GU -> SLIT("gt"); LEU -> SLIT("le");
#endif
})
-\end{code}
-%************************************************************************
-%* *
-\subsection{@pprImm@: print an @Imm@}
-%* *
-%************************************************************************
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- pprImm: print an 'Imm'
+
pprImm :: Imm -> Doc
pprImm (ImmInt i) = int i
<> pprCLabel_asm l <> char '+' <> int i
pprImm (ImmLit s) = s
-pprImm (ImmLab dll s) = (if underscorePrefix then char '_' else empty)
- <> (if dll then text "_imp__" else empty)
- <> s
+pprImm (ImmFloat _) = panic "pprImm:ImmFloat"
+pprImm (ImmDouble _) = panic "pprImm:ImmDouble"
#if sparc_TARGET_ARCH
pprImm (LO i)
= hcat [ pp_ha, pprImm i, rparen ]
where
pp_ha = text "ha16("
+
+pprImm (ImmDyldNonLazyPtr lbl)
+ = ptext SLIT("L") <> pprCLabel_asm lbl <> ptext SLIT("$non_lazy_ptr")
+
#else
pprImm (LO i)
= pprImm i <> text "@l"
= pprImm i <> text "@ha"
#endif
#endif
-\end{code}
-%************************************************************************
-%* *
-\subsection{@pprAddr@: print an @Addr@}
-%* *
-%************************************************************************
-\begin{code}
-pprAddr :: MachRegsAddr -> Doc
+-- -----------------------------------------------------------------------------
+-- @pprAddr: print an 'AddrMode'
+
+pprAddr :: AddrMode -> Doc
#if alpha_TARGET_ARCH
pprAddr (AddrReg r) = parens (pprReg r)
= let
pp_disp = ppr_disp displacement
pp_off p = pp_disp <> char '(' <> p <> char ')'
- pp_reg r = pprReg L r
+ pp_reg r = pprReg I32 r
in
case (base,index) of
(Nothing, Nothing) -> pp_disp
(Just b, Nothing) -> pp_off (pp_reg b)
- (Nothing, Just (r,i)) -> pp_off (pp_reg r <> comma <> int i)
+ (Nothing, Just (r,i)) -> pp_off (comma <> pp_reg r <> comma <> int i)
(Just b, Just (r,i)) -> pp_off (pp_reg b <> comma <> pp_reg r
<> comma <> int i)
where
pprAddr (AddrRegImm r1 (ImmInteger i))
| i == 0 = pprReg r1
| not (fits13Bits i) = largeOffsetError i
--------------------
-
| otherwise = hcat [ pprReg r1, pp_sign, integer i ]
where
pp_sign = if i > 0 then char '+' else empty
pprAddr (AddrRegImm r1 imm)
= hcat [ pprReg r1, char '+', pprImm imm ]
#endif
+
+-------------------
+
#if powerpc_TARGET_ARCH
pprAddr (AddrRegReg r1 r2)
- = error "PprMach.pprAddr (AddrRegReg) unimplemented"
+ = pprReg r1 <+> ptext SLIT(", ") <+> pprReg r2
pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
#endif
-\end{code}
-%************************************************************************
-%* *
-\subsection{@pprInstr@: print an @Instr@}
-%* *
-%************************************************************************
-
-\begin{code}
-pprInstr :: Instr -> Doc
-
---pprInstr (COMMENT s) = empty -- nuke 'em
-pprInstr (COMMENT s)
- = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
- ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
- ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
- ,IF_ARCH_powerpc( ((<>) (ptext SLIT("; ")) (ftext s))
- ,))))
-
-pprInstr (DELTA d)
- = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
-pprInstr (SEGMENT TextSegment)
- = IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-}
- ,IF_ARCH_sparc(ptext SLIT(".text\n\t.align 4") {-word boundary-}
- ,IF_ARCH_i386((text ".text\n\t.align 4,0x90") {-needs per-OS variation!-}
- ,IF_ARCH_powerpc(ptext SLIT(".text\n.align 2")
- ,))))
+-- -----------------------------------------------------------------------------
+-- pprData: print a 'CmmStatic'
-pprInstr (SEGMENT DataSegment)
+pprSectionHeader Text
+ = ptext
+ IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
+ ,IF_ARCH_sparc(SLIT(".text\n\t.align 4") {-word boundary-}
+ ,IF_ARCH_i386(SLIT(".text\n\t.align 4,0x90") {-needs per-OS variation!-}
+ ,IF_ARCH_powerpc(SLIT(".text\n.align 2")
+ ,))))
+pprSectionHeader Data
= ptext
IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
,IF_ARCH_i386(SLIT(".data\n\t.align 4")
,IF_ARCH_powerpc(SLIT(".data\n.align 2")
,))))
-
-pprInstr (SEGMENT RoDataSegment)
+pprSectionHeader ReadOnlyData
= ptext
IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
SLIT(".section .rodata\n\t.align 2"))
,))))
-
-pprInstr (LABEL clab)
- = let
- pp_lab = pprCLabel_asm clab
- in
- hcat [
- if not (externallyVisibleCLabel clab) then
- empty
- else
- hcat [ptext
- IF_ARCH_alpha(SLIT("\t.globl\t")
+pprSectionHeader UninitialisedData
+ = ptext
+ IF_ARCH_alpha(SLIT("\t.bss\n\t.align 3")
+ ,IF_ARCH_sparc(SLIT(".bss\n\t.align 8") {-<8 will break double constants -}
+ ,IF_ARCH_i386(SLIT(".section .bss\n\t.align 4")
+ ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
+ SLIT(".section .bss\n\t.align 2"))
+ ,))))
+pprSectionHeader (OtherSection sec)
+ = panic "PprMach.pprSectionHeader: unknown section"
+
+pprData :: CmmStatic -> Doc
+pprData (CmmAlign bytes) = pprAlign bytes
+pprData (CmmDataLabel lbl) = pprLabel lbl
+pprData (CmmString str) = pprASCII str
+pprData (CmmUninitialised bytes) = ptext SLIT(".space ") <> int bytes
+pprData (CmmStaticLit lit) = pprDataItem lit
+
+pprGloblDecl :: CLabel -> Doc
+pprGloblDecl lbl
+ | not (externallyVisibleCLabel lbl) = empty
+ | otherwise = ptext IF_ARCH_alpha(SLIT(".globl ")
,IF_ARCH_i386(SLIT(".globl ")
- ,IF_ARCH_sparc(SLIT(".global\t")
+ ,IF_ARCH_sparc(SLIT(".global ")
,IF_ARCH_powerpc(SLIT(".globl ")
- ,))))
- , pp_lab, char '\n'],
- pp_lab,
- char ':'
- ]
+ ,)))) <>
+ pprCLabel_asm lbl
-pprInstr (ASCII False{-no backslash conversion-} str)
- = hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ]
+pprLabel :: CLabel -> Doc
+pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
-pprInstr (ASCII True str)
+
+-- Assume we want to backslash-convert the string
+pprASCII str
= vcat (map do1 (str ++ [chr 0]))
where
do1 :: Char -> Doc
= char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
tab = "0123456789ABCDEF"
+pprAlign bytes =
+ IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
+ IF_ARCH_i386(ptext SLIT(".align ") <> int bytes,
+ IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
+ IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,))))
+ where
+ pow2 = log2 bytes
+
+ log2 :: Int -> Int -- cache the common ones
+ log2 1 = 0
+ log2 2 = 1
+ log2 4 = 2
+ log2 8 = 3
+ log2 n = 1 + log2 (n `quot` 2)
-pprInstr (DATA s xs)
- = vcat (concatMap (ppr_item s) xs)
+
+pprDataItem :: CmmLit -> Doc
+pprDataItem lit
+ = vcat (ppr_item (cmmLitRep lit) lit)
where
+ imm = litToImm lit
-#if alpha_TARGET_ARCH
- ppr_item = error "ppr_item on Alpha"
-#endif
-#if sparc_TARGET_ARCH
- -- copy n paste of x86 version
- ppr_item B x = [ptext SLIT("\t.byte\t") <> pprImm x]
- ppr_item W x = [ptext SLIT("\t.long\t") <> pprImm x]
- ppr_item F (ImmFloat r)
+ -- These seem to be common:
+ ppr_item I8 x = [ptext SLIT("\t.byte\t") <> pprImm imm]
+ ppr_item I32 x = [ptext SLIT("\t.long\t") <> pprImm imm]
+ ppr_item F32 (CmmFloat r _)
= let bs = floatToBytes (fromRational r)
in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
- ppr_item DF (ImmDouble r)
+ ppr_item F64 (CmmFloat r _)
= let bs = doubleToBytes (fromRational r)
in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
+
+#if sparc_TARGET_ARCH
+ -- copy n paste of x86 version
+ ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
+ ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
#endif
#if i386_TARGET_ARCH
- ppr_item B x = [ptext SLIT("\t.byte\t") <> pprImm x]
- ppr_item L x = [ptext SLIT("\t.long\t") <> pprImm x]
- ppr_item F (ImmFloat r)
- = let bs = floatToBytes (fromRational r)
- in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
- ppr_item DF (ImmDouble r)
- = let bs = doubleToBytes (fromRational r)
- in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
+ ppr_item I16 x = [ptext SLIT("\t.word\t") <> pprImm imm]
+ ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
#endif
#if powerpc_TARGET_ARCH
- ppr_item B x = [ptext SLIT("\t.byte\t") <> pprImm x]
- ppr_item Bu x = [ptext SLIT("\t.byte\t") <> pprImm x]
- ppr_item H x = [ptext SLIT("\t.short\t") <> pprImm x]
- ppr_item Hu x = [ptext SLIT("\t.short\t") <> pprImm x]
- ppr_item W x = [ptext SLIT("\t.long\t") <> pprImm x]
- ppr_item F (ImmFloat r)
- = let bs = floatToBytes (fromRational r)
- in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
- ppr_item DF (ImmDouble r)
- = let bs = doubleToBytes (fromRational r)
- in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
+ ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
+ ppr_item I64 (CmmInt x _) =
+ [ptext SLIT("\t.long\t")
+ <> int (fromIntegral
+ (fromIntegral (x `shiftR` 32) :: Word32)),
+ ptext SLIT("\t.long\t")
+ <> int (fromIntegral (fromIntegral x :: Word32))]
#endif
-- fall through to rest of (machine-specific) pprInstr...
-\end{code}
-%************************************************************************
-%* *
-\subsubsection{@pprInstr@ for an Alpha}
-%* *
-%************************************************************************
+-- -----------------------------------------------------------------------------
+-- pprInstr: print an 'Instr'
+
+pprInstr :: Instr -> Doc
+
+--pprInstr (COMMENT s) = empty -- nuke 'em
+pprInstr (COMMENT s)
+ = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
+ ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
+ ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
+ ,IF_ARCH_powerpc( ((<>) (ptext SLIT("; ")) (ftext s))
+ ,))))
+
+pprInstr (DELTA d)
+ = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+pprInstr (NEWBLOCK _)
+ = panic "PprMach.pprInstr: NEWBLOCK"
+
+pprInstr (LDATA _ _)
+ = panic "PprMach.pprInstr: LDATA"
+
+-- -----------------------------------------------------------------------------
+-- pprInstr for an Alpha
-\begin{code}
#if alpha_TARGET_ARCH
pprInstr (LD size reg addr)
]
#endif /* alpha_TARGET_ARCH */
-\end{code}
-%************************************************************************
-%* *
-\subsubsection{@pprInstr@ for an I386}
-%* *
-%************************************************************************
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- pprInstr for an x86
+
#if i386_TARGET_ARCH
pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
#endif
pprInstr (MOV size src dst)
= pprSizeOpOp SLIT("mov") size src dst
-pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes L src dst
-pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes L src dst
+pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
+pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes I32 src dst
-- here we do some patching, since the physical registers are only set late
-- in the code generation.
= pprSizeOp SLIT("inc") size dst
pprInstr (ADD size src dst)
= pprSizeOpOp SLIT("add") size src dst
+pprInstr (ADC size src dst)
+ = pprSizeOpOp SLIT("adc") size src dst
pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
-pprInstr (SHL size imm dst) = pprSizeImmOp SLIT("shl") size imm dst
-pprInstr (SAR size imm dst) = pprSizeImmOp SLIT("sar") size imm dst
-pprInstr (SHR size imm dst) = pprSizeImmOp SLIT("shr") size imm dst
-pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
+pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
+pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
+pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
+
+pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp") size src dst
pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
-pprInstr PUSHA = ptext SLIT("\tpushal")
-pprInstr POPA = ptext SLIT("\tpopal")
+
+-- both unused (SDM):
+-- pprInstr PUSHA = ptext SLIT("\tpushal")
+-- pprInstr POPA = ptext SLIT("\tpopal")
pprInstr NOP = ptext SLIT("\tnop")
pprInstr CLTD = ptext SLIT("\tcltd")
-pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
+pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
-pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
+pprInstr (JXX cond (BlockId id))
+ = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
+ where lab = mkAsmTempLabel id
-pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
-pprInstr (JMP dsts op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
+pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
+pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand I32 op)
+pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
pprInstr (CALL (Left imm)) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
-pprInstr (CALL (Right reg)) = (<>) (ptext SLIT("\tcall *")) (pprReg L reg)
-
--- First bool indicates signedness; second whether quot or rem
-pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst
-pprInstr (IREM sz src dst) = pprInstr_quotRem True False sz src dst
+pprInstr (CALL (Right reg)) = (<>) (ptext SLIT("\tcall *")) (pprReg I32 reg)
-pprInstr (QUOT sz src dst) = pprInstr_quotRem False True sz src dst
-pprInstr (REM sz src dst) = pprInstr_quotRem False False sz src dst
+pprInstr (IDIV sz op) = pprSizeOp SLIT("idiv") sz op
+pprInstr (DIV sz op) = pprSizeOp SLIT("div") sz op
pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo
pprInstr g@(GDTOI src dst)
= pprG g (hcat [gtab, text "subl $4, %esp ; ",
gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
- pprReg L dst])
+ pprReg I32 dst])
pprInstr g@(GITOF src dst)
= pprInstr (GITOD src dst)
pprInstr g@(GITOD src dst)
- = pprG g (hcat [gtab, text "pushl ", pprReg L src,
+ = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
text " ; ffree %st(7); fildl (%esp) ; ",
gpop dst 1, text " ; addl $4,%esp"])
]
-pprInstr_quotRem signed isQuot sz src dst
- | case sz of L -> False; _ -> True
- = panic "pprInstr_quotRem: dunno how to do non-32bit operands"
- | otherwise
- = vcat [
- (text "\t# BEGIN " <> fakeInsn),
- (text "\tpushl $0; pushl %eax; pushl %edx; pushl " <> pprOperand sz src),
- (text "\tmovl " <> pprOperand sz dst <> text ",%eax; " <> widen_to_64),
- (x86op <> text " 0(%esp); movl " <> text resReg <> text ",12(%esp)"),
- (text "\tpopl %edx; popl %edx; popl %eax; popl " <> pprOperand sz dst),
- (text "\t# END " <> fakeInsn)
- ]
- where
- widen_to_64 | signed = text "cltd"
- | not signed = text "xorl %edx,%edx"
- x86op = if signed then text "\tidivl" else text "\tdivl"
- resReg = if isQuot then "%eax" else "%edx"
- opStr | signed = if isQuot then "IQUOT" else "IREM"
- | not signed = if isQuot then "QUOT" else "REM"
- fakeInsn = text opStr <+> pprOperand sz src
- <> char ',' <+> pprOperand sz dst
-
-- Emit code to make hi_reg:lo_reg be the 64-bit product of hi_reg and lo_reg
pprInstr_imul64 hi_reg lo_reg
= let fakeInsn = text "imul64" <+> pp_hi_reg <> comma <+> pp_lo_reg
- pp_hi_reg = pprReg L hi_reg
- pp_lo_reg = pprReg L lo_reg
+ pp_hi_reg = pprReg I32 hi_reg
+ pp_lo_reg = pprReg I32 lo_reg
in
vcat [
text "\t# BEGIN " <> fakeInsn,
--------------------------
-- coerce %st(0) to the specified size
-gcoerceto DF = empty
-gcoerceto F = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
+gcoerceto F64 = empty
+gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
gpush reg offset
= hcat [text "ffree %st(7) ; fld ", greg reg offset]
gpop reg offset
= hcat [text "fstp ", greg reg offset]
-bogus = text "\tbogus"
greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
gsemi = text " ; "
gtab = char '\t'
pprG fake actual
= (char '#' <> pprGInstr fake) $$ actual
-pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") DF src dst
+pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") F64 src dst
pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
-pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") DF dst
-pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") DF dst
+pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
+pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
-pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L src dst
-pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst
+pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32 src dst
+pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
-pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F src dst
-pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst
+pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32 src dst
+pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
-pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") DF co src dst
+pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
-\end{code}
-Continue with I386-only printing bits and bobs:
-\begin{code}
+-- Continue with I386-only printing bits and bobs:
+
pprDollImm :: Imm -> Doc
pprDollImm i = ptext SLIT("$") <> pprImm i
-pprOperand :: Size -> Operand -> Doc
+pprOperand :: MachRep -> Operand -> Doc
pprOperand s (OpReg r) = pprReg s r
pprOperand s (OpImm i) = pprDollImm i
pprOperand s (OpAddr ea) = pprAddr ea
-pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
+pprMnemonic :: LitString -> MachRep -> Doc
+pprMnemonic name size =
+ char '\t' <> ptext name <> pprSize size <> space
+
+pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
pprSizeImmOp name size imm op1
= hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
+ pprMnemonic name size,
char '$',
pprImm imm,
comma,
pprOperand size op1
]
-pprSizeOp :: LitString -> Size -> Operand -> Doc
+pprSizeOp :: LitString -> MachRep -> Operand -> Doc
pprSizeOp name size op1
= hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
+ pprMnemonic name size,
pprOperand size op1
]
-pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
+pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
pprSizeOpOp name size op1 op2
= hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
+ pprMnemonic name size,
pprOperand size op1,
comma,
pprOperand size op2
]
-pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc
-pprSizeByteOpOp name size op1 op2
- = hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
- pprOperand B op1,
- comma,
- pprOperand size op2
- ]
-
-pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
-pprSizeOpReg name size op1 reg
- = hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
- pprOperand size op1,
- comma,
- pprReg size reg
- ]
-
-pprSizeReg :: LitString -> Size -> Reg -> Doc
+pprSizeReg :: LitString -> MachRep -> Reg -> Doc
pprSizeReg name size reg1
= hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
+ pprMnemonic name size,
pprReg size reg1
]
-pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
+pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
pprSizeRegReg name size reg1 reg2
= hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
+ pprMnemonic name size,
pprReg size reg1,
comma,
pprReg size reg2
]
-pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
+pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
pprCondRegReg name size cond reg1 reg2
= hcat [
char '\t',
pprReg size reg2
]
-pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
+pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
pprSizeSizeRegReg name size1 size2 reg1 reg2
= hcat [
char '\t',
pprReg size2 reg2
]
-pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
+pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
= hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
+ pprMnemonic name size,
pprReg size reg1,
comma,
pprReg size reg2,
pprReg size reg3
]
-pprSizeAddr :: LitString -> Size -> MachRegsAddr -> Doc
-pprSizeAddr name size op
- = hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
- pprAddr op
- ]
-
-pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc
+pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
pprSizeAddrReg name size op dst
= hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
+ pprMnemonic name size,
pprAddr op,
comma,
pprReg size dst
]
-pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc
+pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
pprSizeRegAddr name size src op
= hcat [
- char '\t',
- ptext name,
- pprSize size,
- space,
+ pprMnemonic name size,
pprReg size src,
comma,
pprAddr op
]
-pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
-pprOpOp name size op1 op2
+pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
+pprShift name size src dest
= hcat [
- char '\t',
- ptext name, space,
- pprOperand size op1,
+ pprMnemonic name size,
+ pprOperand I8 src, -- src is 8-bit sized
comma,
- pprOperand size op2
+ pprOperand size dest
]
-pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
+pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
pprSizeOpOpCoerce name size1 size2 op1 op2
= hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
pprOperand size1 op1,
= hcat [ char '\t', ptext name, pprCond cond, space, arg]
#endif /* i386_TARGET_ARCH */
-\end{code}
-%************************************************************************
-%* *
-\subsubsection{@pprInstr@ for a SPARC}
-%* *
-%************************************************************************
-\begin{code}
+-- ------------------------------------------------------------------------------- pprInstr for a SPARC
+
#if sparc_TARGET_ARCH
-- a clumsy hack for now, to handle possible double alignment problems
pp_comma_a = text ",a"
#endif /* sparc_TARGET_ARCH */
-\end{code}
-%************************************************************************
-%* *
-\subsubsection{@pprInstr@ for PowerPC}
-%* *
-%************************************************************************
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- pprInstr for PowerPC
+
#if powerpc_TARGET_ARCH
pprInstr (LD sz reg addr) = hcat [
char '\t',
ptext SLIT("l"),
ptext (case sz of
- B -> SLIT("ba")
- Bu -> SLIT("bz")
- H -> SLIT("ha")
- Hu -> SLIT("hz")
- W -> SLIT("wz")
- F -> SLIT("fs")
- DF -> SLIT("fd")),
+ I8 -> SLIT("bz")
+ I16 -> SLIT("hz")
+ I32 -> SLIT("wz")
+ F32 -> SLIT("fs")
+ F64 -> SLIT("fd")),
+ case addr of AddrRegImm _ _ -> empty
+ AddrRegReg _ _ -> char 'x',
+ char '\t',
+ pprReg reg,
+ ptext SLIT(", "),
+ pprAddr addr
+ ]
+pprInstr (LA sz reg addr) = hcat [
+ char '\t',
+ ptext SLIT("l"),
+ ptext (case sz of
+ I8 -> SLIT("ba")
+ I16 -> SLIT("ha")
+ I32 -> SLIT("wa")
+ F32 -> SLIT("fs")
+ F64 -> SLIT("fd")),
+ case addr of AddrRegImm _ _ -> empty
+ AddrRegReg _ _ -> char 'x',
char '\t',
pprReg reg,
ptext SLIT(", "),
char '\t',
ptext SLIT("st"),
pprSize sz,
+ case addr of AddrRegImm _ _ -> empty
+ AddrRegReg _ _ -> char 'x',
char '\t',
pprReg reg,
ptext SLIT(", "),
ptext SLIT("st"),
pprSize sz,
ptext SLIT("u\t"),
+ case addr of AddrRegImm _ _ -> empty
+ AddrRegReg _ _ -> char 'x',
pprReg reg,
ptext SLIT(", "),
pprAddr addr
RIReg _ -> empty
RIImm _ -> char 'i'
]
-pprInstr (BCC cond lbl) = hcat [
+pprInstr (BCC cond (BlockId id)) = hcat [
char '\t',
ptext SLIT("b"),
pprCond cond,
char '\t',
pprCLabel_asm lbl
]
+ where lbl = mkAsmTempLabel id
+
+pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
+ char '\t',
+ ptext SLIT("b"),
+ char '\t',
+ pprCLabel_asm lbl
+ ]
pprInstr (MTCTR reg) = hcat [
char '\t',
char '\t',
ptext SLIT("bctr")
]
-pprInstr (BL imm _) = hcat [
- char '\t',
- ptext SLIT("bl"),
- char '\t',
- pprImm imm
+pprInstr (BL lbl _) = hcat [
+ ptext SLIT("\tbl\tL"),
+ pprCLabel_asm lbl,
+ ptext SLIT("$stub")
]
pprInstr (BCTRL _) = hcat [
char '\t',
ptext SLIT("bctrl")
]
pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
+pprInstr (ADDIS reg1 reg2 imm) = hcat [
+ char '\t',
+ ptext SLIT("addis"),
+ char '\t',
+ pprReg reg1,
+ ptext SLIT(", "),
+ pprReg reg2,
+ ptext SLIT(", "),
+ pprImm imm
+ ]
+
+pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
+pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
+pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
+ hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
+ pprReg reg2, ptext SLIT(", "),
+ pprReg reg3 ],
+ hcat [ ptext SLIT("\tmfxer\t"), pprReg reg1 ],
+ hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
+ pprReg reg1, ptext SLIT(", "),
+ ptext SLIT("2, 31, 31") ]
+ ]
+
-- for some reason, "andi" doesn't exist.
-- we'll use "andi." instead.
pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
ptext SLIT(", "),
pprImm imm
]
-pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 (toUI16 ri)
+pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
-pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 (toUI16 ri)
-pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 (toUI16 ri)
+pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
+pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
pprInstr (XORIS reg1 reg2 imm) = hcat [
char '\t',
pprImm imm
]
-pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 ri
-pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 ri
-pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 ri
+pprInstr (EXTS sz reg1 reg2) = hcat [
+ char '\t',
+ ptext SLIT("exts"),
+ pprSize sz,
+ char '\t',
+ pprReg reg1,
+ ptext SLIT(", "),
+ pprReg reg2
+ ]
+
pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
+pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
+pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
+pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
+pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
+ ptext SLIT("\trlwinm\t"),
+ pprReg reg1,
+ ptext SLIT(", "),
+ pprReg reg2,
+ ptext SLIT(", "),
+ int sh,
+ ptext SLIT(", "),
+ int mb,
+ ptext SLIT(", "),
+ int me
+ ]
+
pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
]
pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
+pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
+
+pprInstr (CRNOR dst src1 src2) = hcat [
+ ptext SLIT("\tcrnor\t"),
+ int dst,
+ ptext SLIT(", "),
+ int src1,
+ ptext SLIT(", "),
+ int src2
+ ]
-pprInstr _ = ptext SLIT("something")
+pprInstr (MFCR reg) = hcat [
+ char '\t',
+ ptext SLIT("mfcr"),
+ char '\t',
+ pprReg reg
+ ]
+
+pprInstr _ = panic "pprInstr (ppc)"
pprLogic op reg1 reg2 ri = hcat [
char '\t',
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
-pprFSize DF = empty
-pprFSize F = char 's'
+pprFSize F64 = empty
+pprFSize F32 = char 's'
--- hack to ensure that negative vals come out in non-negative form
--- (assuming that fromIntegral{Int->Word16} will do a 'c-style'
--- conversion, and not throw a fit/exception.)
-toUI16 :: RI -> RI
-toUI16 (RIImm (ImmInt x))
- | x < 0 = RIImm (ImmInt (fromIntegral ((fromIntegral x) :: Word16)))
-toUI16 (RIImm (ImmInteger x))
- | x < 0 = RIImm (ImmInt (fromIntegral ((fromIntegral x) :: Word16)))
-toUI16 x = x
+ -- limit immediate argument for shift instruction to range 0..32
+ -- (yes, the maximum is really 32, not 31)
+limitShiftRI :: RI -> RI
+limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
+limitShiftRI x = x
{-
The Mach-O object file format used in Darwin/Mac OS X needs a so-called
-}
#if darwin_TARGET_OS
-pprDyldSymbolStub fn =
+pprDyldSymbolStub (True, lbl) =
vcat [
ptext SLIT(".symbol_stub"),
- ptext SLIT("L_") <> ftext fn <> ptext SLIT("$stub:"),
- ptext SLIT("\t.indirect_symbol _") <> ftext fn,
- ptext SLIT("\tlis r11,ha16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)"),
- ptext SLIT("\tlwz r12,lo16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)(r11)"),
+ ptext SLIT("L") <> pprLbl <> ptext SLIT("$stub:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprLbl,
+ ptext SLIT("\tlis r11,ha16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)"),
+ ptext SLIT("\tlwz r12,lo16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)(r11)"),
ptext SLIT("\tmtctr r12"),
- ptext SLIT("\taddi r11,r11,lo16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)"),
+ ptext SLIT("\taddi r11,r11,lo16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)"),
ptext SLIT("\tbctr"),
ptext SLIT(".lazy_symbol_pointer"),
- ptext SLIT("L_") <> ftext fn <> ptext SLIT("$lazy_ptr:"),
- ptext SLIT("\t.indirect_symbol _") <> ftext fn,
+ ptext SLIT("L") <> pprLbl <> ptext SLIT("$lazy_ptr:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprLbl,
ptext SLIT("\t.long dyld_stub_binding_helper")
]
+ where pprLbl = pprCLabel_asm lbl
+
+pprDyldSymbolStub (False, lbl) =
+ vcat [
+ ptext SLIT(".non_lazy_symbol_pointer"),
+ char 'L' <> pprLbl <> ptext SLIT("$non_lazy_ptr:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprLbl,
+ ptext SLIT("\t.long\t0")
+ ]
+ where pprLbl = pprCLabel_asm lbl
#endif
-
#endif /* powerpc_TARGET_ARCH */
-\end{code}
-\begin{code}
+
+-- -----------------------------------------------------------------------------
+-- Converting floating-point literals to integrals for printing
+
#if __GLASGOW_HASKELL__ >= 504
newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
newFloatArray = newArray_
i7 <- readCharArray arr 7
return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
)
-\end{code}
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[RegAllocInfo]{Machine-specific info used for register allocation}
+-----------------------------------------------------------------------------
+--
+-- Machine-specific parts of the register allocator
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
-The (machine-independent) allocator itself is in @AsmRegAlloc@.
-
-\begin{code}
#include "nativeGen/NCG.h"
module RegAllocInfo (
RegUsage(..),
noUsage,
regUsage,
- InsnFuture(..),
- insnFuture,
-
- loadReg,
patchRegs,
- spillReg,
- findReservedRegs,
-
- RegSet,
- regSetFromList,
- regSetToList,
- isEmptyRegSet,
- emptyRegSet,
- eqRegSets,
- filterRegSet,
- unitRegSet,
- elemRegSet,
- unionRegSets,
- minusRegSets,
- intersectionRegSets
+ jumpDests,
+ isRegRegMove,
+
+ maxSpillSlots,
+ mkSpillInstr,
+ mkLoadInstr,
) where
#include "HsVersions.h"
-import List ( sort )
-import MachMisc
+import Cmm ( BlockId )
+#if powerpc_TARGET_ARCH || i386_TARGET_ARCH
+import MachOp ( MachRep(..) )
+#endif
+import MachInstrs
import MachRegs
-import Stix ( DestInfo(..) )
-import CLabel ( isAsmTemp, CLabel{-instance Ord-} )
-import FiniteMap ( addToFM, lookupFM, FiniteMap )
import Outputable
import Constants ( rESERVED_C_STACK_BYTES )
-import Unique ( Unique, Uniquable(..) )
import FastTypes
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Sets of registers}
-%* *
-%************************************************************************
-
-\begin{code}
-
--- Blargh. Use ghc stuff soon! Or: perhaps that's not such a good
--- idea. Most of these sets are either empty or very small, and it
--- might be that the overheads of the FiniteMap based set implementation
--- is a net loss. The same might be true of FeSets.
-
-newtype RegSet = MkRegSet [Reg]
-
-regSetFromList xs
- = MkRegSet (nukeDups (sort xs))
- where nukeDups :: [Reg] -> [Reg]
- nukeDups [] = []
- nukeDups [x] = [x]
- nukeDups (x:y:xys)
- = if x == y then nukeDups (y:xys)
- else x : nukeDups (y:xys)
-
-regSetToList (MkRegSet xs) = xs
-isEmptyRegSet (MkRegSet xs) = null xs
-emptyRegSet = MkRegSet []
-eqRegSets (MkRegSet xs1) (MkRegSet xs2) = xs1 == xs2
-unitRegSet x = MkRegSet [x]
-filterRegSet p (MkRegSet xs) = MkRegSet (filter p xs)
-
-elemRegSet x (MkRegSet xs)
- = f xs
- where
- f [] = False
- f (y:ys) | x == y = True
- | x < y = False
- | otherwise = f ys
-
-unionRegSets (MkRegSet xs1) (MkRegSet xs2)
- = MkRegSet (f xs1 xs2)
- where
- f [] bs = bs
- f as [] = as
- f (a:as) (b:bs)
- | a < b = a : f as (b:bs)
- | a > b = b : f (a:as) bs
- | otherwise = a : f as bs
-
-minusRegSets (MkRegSet xs1) (MkRegSet xs2)
- = MkRegSet (f xs1 xs2)
- where
- f [] bs = []
- f as [] = as
- f (a:as) (b:bs)
- | a < b = a : f as (b:bs)
- | a > b = f (a:as) bs
- | otherwise = f as bs
-
-intersectionRegSets (MkRegSet xs1) (MkRegSet xs2)
- = MkRegSet (f xs1 xs2)
- where
- f [] bs = []
- f as [] = []
- f (a:as) (b:bs)
- | a < b = f as (b:bs)
- | a > b = f (a:as) bs
- | otherwise = a : f as bs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@RegUsage@ type; @noUsage@ and @regUsage@ functions}
-%* *
-%************************************************************************
-
-@regUsage@ returns the sets of src and destination registers used by a
-particular instruction. Machine registers that are pre-allocated to
-stgRegs are filtered out, because they are uninteresting from a
-register allocation standpoint. (We wouldn't want them to end up on
-the free list!) As far as we are concerned, the fixed registers
-simply don't exist (for allocation purposes, anyway).
-
-regUsage doesn't need to do any trickery for jumps and such. Just
-state precisely the regs read and written by that insn. The
-consequences of control flow transfers, as far as register allocation
-goes, are taken care of by @insnFuture@.
-
-\begin{code}
-data RegUsage = RU RegSet RegSet
+-- -----------------------------------------------------------------------------
+-- RegUsage type
+
+-- @regUsage@ returns the sets of src and destination registers used
+-- by a particular instruction. Machine registers that are
+-- pre-allocated to stgRegs are filtered out, because they are
+-- uninteresting from a register allocation standpoint. (We wouldn't
+-- want them to end up on the free list!) As far as we are concerned,
+-- the fixed registers simply don't exist (for allocation purposes,
+-- anyway).
+
+-- regUsage doesn't need to do any trickery for jumps and such. Just
+-- state precisely the regs read and written by that insn. The
+-- consequences of control flow transfers, as far as register
+-- allocation goes, are taken care of by the register allocator.
+
+data RegUsage = RU [Reg] [Reg]
noUsage :: RegUsage
-noUsage = RU emptyRegSet emptyRegSet
+noUsage = RU [] []
regUsage :: Instr -> RegUsage
-interesting (VirtualRegI _) = True
-interesting (VirtualRegF _) = True
-interesting (VirtualRegD _) = True
-interesting (RealReg i) = isFastTrue (freeReg i)
+interesting (VirtualRegI _) = True
+interesting (VirtualRegHi _) = True
+interesting (VirtualRegF _) = True
+interesting (VirtualRegD _) = True
+interesting (RealReg i) = isFastTrue (freeReg i)
-#if alpha_TARGET_ARCH
+#if alpha_TARGET_ARCH
regUsage instr = case instr of
LD B reg addr -> usage (regAddr addr, [reg, t9])
LD Bu reg addr -> usage (regAddr addr, [reg, t9])
MOVSxL sz src dst -> usageRW src dst
LEA sz src dst -> usageRW src dst
ADD sz src dst -> usageRM src dst
+ ADC sz src dst -> usageRM src dst
SUB sz src dst -> usageRM src dst
IMUL sz src dst -> usageRM src dst
IMUL64 sd1 sd2 -> mkRU [sd1,sd2] [sd1,sd2]
MUL sz src dst -> usageRM src dst
- IQUOT sz src dst -> usageRM src dst
- IREM sz src dst -> usageRM src dst
- QUOT sz src dst -> usageRM src dst
- REM sz src dst -> usageRM src dst
+ DIV sz op -> mkRU (eax:edx:use_R op) [eax,edx]
+ IDIV sz op -> mkRU (eax:edx:use_R op) [eax,edx]
AND sz src dst -> usageRM src dst
OR sz src dst -> usageRM src dst
XOR sz src dst -> usageRM src dst
NOT sz op -> usageM op
NEGI sz op -> usageM op
- SHL sz imm dst -> usageM dst
- SAR sz imm dst -> usageM dst
- SHR sz imm dst -> usageM dst
+ SHL sz imm dst -> usageRM imm dst
+ SAR sz imm dst -> usageRM imm dst
+ SHR sz imm dst -> usageRM imm dst
BT sz imm src -> mkRU (use_R src) []
PUSH sz op -> mkRU (use_R op) []
CMP sz src dst -> mkRU (use_R src ++ use_R dst) []
SETCC cond op -> mkRU [] (def_W op)
JXX cond lbl -> mkRU [] []
- JMP dsts op -> mkRU (use_R op) []
+ JMP op -> mkRU (use_R op) []
+ JMP_TBL op ids -> mkRU (use_R op) []
CALL (Left imm) -> mkRU [] callClobberedRegs
CALL (Right reg) -> mkRU [reg] callClobberedRegs
CLTD -> mkRU [eax] [edx]
GTAN sz src dst -> mkRU [src] [dst]
COMMENT _ -> noUsage
- SEGMENT _ -> noUsage
- LABEL _ -> noUsage
- ASCII _ _ -> noUsage
- DATA _ _ -> noUsage
DELTA _ -> noUsage
- _ -> pprPanic "regUsage(x86)" empty
+
+ _other -> panic "regUsage: unrecognised instr"
where
-- 2 operand form; first operand Read; second Written
use_EA (AddrBaseIndex Nothing (Just (i,_)) _) = [i]
use_EA (AddrBaseIndex (Just b) (Just (i,_)) _) = [b,i]
- mkRU src dst = RU (regSetFromList (filter interesting src))
- (regSetFromList (filter interesting dst))
+ mkRU src dst = RU (filter interesting src)
+ (filter interesting dst)
#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
regUsage instr = case instr of
LD sz reg addr -> usage (regAddr addr, [reg])
+ LA sz reg addr -> usage (regAddr addr, [reg])
ST sz reg addr -> usage (reg : regAddr addr, [])
STU sz reg addr -> usage (reg : regAddr addr, [])
LIS reg imm -> usage ([], [reg])
CMPL sz reg ri -> usage (reg : regRI ri,[])
BCC cond lbl -> noUsage
MTCTR reg -> usage ([reg],[])
- BCTR dsts -> noUsage
+ BCTR targets -> noUsage
BL imm params -> usage (params, callClobberedRegs)
BCTRL params -> usage (params, callClobberedRegs)
ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
+ ADDC reg1 reg2 reg3-> usage ([reg2,reg3], [reg1])
+ ADDE reg1 reg2 reg3-> usage ([reg2,reg3], [reg1])
+ ADDIS reg1 reg2 imm -> usage ([reg2], [reg1])
SUBF reg1 reg2 reg3-> usage ([reg2,reg3], [reg1])
MULLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
DIVW reg1 reg2 reg3-> usage ([reg2,reg3], [reg1])
DIVWU reg1 reg2 reg3-> usage ([reg2,reg3], [reg1])
+ MULLW_MayOflo reg1 reg2 reg3
+ -> usage ([reg2,reg3], [reg1])
AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
XORIS reg1 reg2 imm -> usage ([reg2], [reg1])
+ EXTS siz reg1 reg2 -> usage ([reg2], [reg1])
NEG reg1 reg2 -> usage ([reg2], [reg1])
NOT reg1 reg2 -> usage ([reg2], [reg1])
SLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
SRW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
SRAW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
+ RLWINM reg1 reg2 sh mb me
+ -> usage ([reg2], [reg1])
FADD sz r1 r2 r3 -> usage ([r2,r3], [r1])
FSUB sz r1 r2 r3 -> usage ([r2,r3], [r1])
FMUL sz r1 r2 r3 -> usage ([r2,r3], [r1])
FNEG r1 r2 -> usage ([r2], [r1])
FCMP r1 r2 -> usage ([r1,r2], [])
FCTIWZ r1 r2 -> usage ([r2], [r1])
+ FRSP r1 r2 -> usage ([r2], [r1])
+ MFCR reg -> usage ([], [reg])
_ -> noUsage
where
- usage (src, dst) = RU (regSetFromList (filter interesting src))
- (regSetFromList (filter interesting dst))
+ usage (src, dst) = RU (filter interesting src)
+ (filter interesting dst)
regAddr (AddrRegReg r1 r2) = [r1, r2]
regAddr (AddrRegImm r1 _) = [r1]
regRI (RIReg r) = [r]
regRI _ = []
#endif /* powerpc_TARGET_ARCH */
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Free, reserved, call-clobbered, and argument registers}
-%* *
-%************************************************************************
-
-@freeRegs@ is the list of registers we can use in register allocation.
-@freeReg@ (below) says if a particular register is free.
-
-With a per-instruction clobber list, we might be able to get some of
-these back, but it's probably not worth the hassle.
-
-@callClobberedRegs@ ... the obvious.
-
-@argRegs@: assuming a call with N arguments, what registers will be
-used to hold arguments? (NB: it doesn't know whether the arguments
-are integer or floating-point...)
-
-findReservedRegs tells us which regs can be used as spill temporaries.
-The list of instructions for which we are attempting allocation is
-supplied. This is so that we can (at least for x86) examine it to
-discover which registers are being used in a fixed way -- for example,
-%eax and %edx are used by integer division, so they can't be used as
-spill temporaries. However, most instruction lists don't do integer
-division, so we don't want to rule them out altogether.
-
-findReservedRegs returns not a list of spill temporaries, but a list
-of list of them. This is so that the allocator can attempt allocating
-with at first no spill temps, then if that fails, increasing numbers.
-For x86 it is important that we minimise the number of regs reserved
-as spill temporaries, since there are so few. For Alpha and Sparc
-this isn't a concern; we just ignore the supplied code list and return
-a singleton list which we know will satisfy all spill demands.
-
-\begin{code}
-findReservedRegs :: [Instr] -> [[Reg]]
-findReservedRegs instrs
-#if alpha_TARGET_ARCH
- = --[[NCG_Reserved_I1, NCG_Reserved_I2,
- -- NCG_Reserved_F1, NCG_Reserved_F2]]
- error "findReservedRegs: alpha"
-#endif
-#if sparc_TARGET_ARCH
- = [[NCG_SpillTmp_I1, NCG_SpillTmp_I2,
- NCG_SpillTmp_D1, NCG_SpillTmp_D2,
- NCG_SpillTmp_F1, NCG_SpillTmp_F2]]
-#endif
-#if i386_TARGET_ARCH
- -- We can use %fake4 and %fake5 safely for float temps.
- -- Int regs are more troublesome. Only %ecx and %edx are
- -- definitely. At a pinch, we also could bag %eax if there
- -- are no ccalls, but so far we've never encountered
- -- a situation where three integer temporaries are necessary.
- --
- -- Because registers are in short supply on x86, we give the
- -- allocator a whole bunch of possibilities, starting with zero
- -- temporaries and working up to all that are available. This
- -- is inefficient, but spills are pretty rare, so we don't care
- -- if the register allocator has to try half a dozen or so possibilities
- -- before getting to one that works.
- = let f1 = fake5
- f2 = fake4
- intregs_avail
- = [ecx, edx]
- possibilities
- = case intregs_avail of
- [i1] -> [ [], [i1], [f1], [i1,f1], [f1,f2],
- [i1,f1,f2] ]
-
- [i1,i2] -> [ [], [i1], [f1], [i1,i2], [i1,f1], [f1,f2],
- [i1,i2,f1], [i1,f1,f2], [i1,i2,f1,f2] ]
- in
- possibilities
-#endif
-#if powerpc_TARGET_ARCH
- = [[NCG_SpillTmp_I1, NCG_SpillTmp_I2,
- NCG_SpillTmp_D1, NCG_SpillTmp_D2]]
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@InsnFuture@ type; @insnFuture@ function}
-%* *
-%************************************************************************
-@insnFuture@ indicates the places we could get to following the
-current instruction. This is used by the register allocator to
-compute the flow edges between instructions.
-\begin{code}
-data InsnFuture
- = NoFuture -- makes a non-local jump; for the purposes of
- -- register allocation, it exits our domain
- | Next -- falls through to next insn
- | Branch CLabel -- unconditional branch to the label
- | NextOrBranch CLabel -- conditional branch to the label
- | MultiFuture [CLabel] -- multiple specific futures
+-- -----------------------------------------------------------------------------
+-- Determine the possible destinations from the current instruction.
---instance Outputable InsnFuture where
--- ppr NoFuture = text "NoFuture"
--- ppr Next = text "Next"
--- ppr (Branch clbl) = text "(Branch " <> ppr clbl <> char ')'
--- ppr (NextOrBranch clbl) = text "(NextOrBranch " <> ppr clbl <> char ')'
+-- (we always assume that the next instruction is also a valid destination;
+-- if this isn't the case then the jump should be at the end of the basic
+-- block).
-
-insnFuture insn
- = case insn of
-
-#if alpha_TARGET_ARCH
-
- -- We assume that all local jumps will be BI/BF. JMP must be out-of-line.
-
- BR (ImmCLbl lbl) -> RL (lookup lbl) future
- BI _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionRegSets` live) future
- BF _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionRegSets` live) future
- JMP _ _ _ -> RL emptyRegSet future
- BSR _ _ -> RL live future
- JSR _ _ _ -> RL live future
- LABEL lbl -> RL live (FL (all `unionRegSets` live) (addToFM env lbl live))
- _ -> info
-
-#endif /* alpha_TARGET_ARCH */
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+jumpDests :: Instr -> [BlockId] -> [BlockId]
+jumpDests insn acc
+ = case insn of
#if i386_TARGET_ARCH
+ JXX _ id -> id : acc
+ JMP_TBL _ ids -> ids ++ acc
+#elif powerpc_TARGET_ARCH
+ BCC _ id -> id : acc
+ BCTR targets -> targets ++ acc
+#endif
+ _other -> acc
- -- conditional jump
- JXX _ clbl | isAsmTemp clbl -> NextOrBranch clbl
- JXX _ _ -> panic "insnFuture: conditional jump to non-local label"
-
- -- If the insn says what its dests are, use em!
- JMP (DestInfo dsts) _ -> MultiFuture dsts
-
- -- unconditional jump to local label
- JMP NoDestInfo (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> Branch clbl
-
- -- unconditional jump to non-local label
- JMP NoDestInfo lbl -> NoFuture
-
- -- be extra-paranoid
- JMP _ _ -> panic "insnFuture(x86): JMP wierdness"
-
- boring -> Next
-
-#endif /* i386_TARGET_ARCH */
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
-
- -- We assume that all local jumps will be BI/BF.
- BI ALWAYS _ (ImmCLbl clbl) -> Branch clbl
- BI other _ (ImmCLbl clbl) -> NextOrBranch clbl
- BI other _ _ -> panic "nativeGen(sparc):insnFuture(BI)"
-
- BF ALWAYS _ (ImmCLbl clbl) -> Branch clbl
- BF other _ (ImmCLbl clbl) -> NextOrBranch clbl
- BF other _ _ -> panic "nativeGen(sparc):insnFuture(BF)"
-
- -- CALL(terminal) must be out-of-line. JMP is not out-of-line
- -- iff it specifies its destinations.
- JMP NoDestInfo _ -> NoFuture -- n.b. NoFuture == MultiFuture []
- JMP (DestInfo dsts) _ -> MultiFuture dsts
-
- CALL _ _ True -> NoFuture
-
- boring -> Next
-#endif /* sparc_TARGET_ARCH */
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if powerpc_TARGET_ARCH
- BCC ALWAYS clbl | isAsmTemp clbl -> Branch clbl
- | otherwise -> NoFuture
- BCC _ clbl | isAsmTemp clbl -> NextOrBranch clbl
- BCC _ _ -> panic "insnFuture: conditional jump to non-local label"
-
- BCTR (DestInfo dsts) -> MultiFuture dsts
- BCTR NoDestInfo -> NoFuture
- boring -> Next
-#endif /* powerpc_TARGET_ARCH */
-\end{code}
+-- -----------------------------------------------------------------------------
+-- 'patchRegs' function
-%************************************************************************
-%* *
-\subsection{@patchRegs@ function}
-%* *
-%************************************************************************
+-- 'patchRegs' takes an instruction and applies the given mapping to
+-- all the register references.
-@patchRegs@ takes an instruction (possibly with
-MemoryReg/UnmappedReg registers) and changes all register references
-according to the supplied environment.
-
-\begin{code}
patchRegs :: Instr -> (Reg -> Reg) -> Instr
#if alpha_TARGET_ARCH
MOVSxL sz src dst -> patch2 (MOVSxL sz) src dst
LEA sz src dst -> patch2 (LEA sz) src dst
ADD sz src dst -> patch2 (ADD sz) src dst
+ ADC sz src dst -> patch2 (ADC sz) src dst
SUB sz src dst -> patch2 (SUB sz) src dst
IMUL sz src dst -> patch2 (IMUL sz) src dst
IMUL64 sd1 sd2 -> IMUL64 (env sd1) (env sd2)
MUL sz src dst -> patch2 (MUL sz) src dst
- IQUOT sz src dst -> patch2 (IQUOT sz) src dst
- IREM sz src dst -> patch2 (IREM sz) src dst
- QUOT sz src dst -> patch2 (QUOT sz) src dst
- REM sz src dst -> patch2 (REM sz) src dst
+ IDIV sz op -> patch1 (IDIV sz) op
+ DIV sz op -> patch1 (DIV sz) op
AND sz src dst -> patch2 (AND sz) src dst
OR sz src dst -> patch2 (OR sz) src dst
XOR sz src dst -> patch2 (XOR sz) src dst
PUSH sz op -> patch1 (PUSH sz) op
POP sz op -> patch1 (POP sz) op
SETCC cond op -> patch1 (SETCC cond) op
- JMP dsts op -> patch1 (JMP dsts) op
+ JMP op -> patch1 JMP op
+ JMP_TBL op ids -> patch1 JMP_TBL op $ ids
GMOV src dst -> GMOV (env src) (env dst)
GLD sz src dst -> GLD sz (lookupAddr src) (env dst)
CALL (Left imm) -> instr
CALL (Right reg) -> CALL (Right (env reg))
+ NOP -> instr
COMMENT _ -> instr
- SEGMENT _ -> instr
- LABEL _ -> instr
- ASCII _ _ -> instr
- DATA _ _ -> instr
DELTA _ -> instr
JXX _ _ -> instr
CLTD -> instr
- _ -> pprPanic "patchRegs(x86)" empty
+
+ _other -> panic "patchRegs: unrecognised instr"
where
- patch1 insn op = insn (patchOp op)
- patch2 insn src dst = insn (patchOp src) (patchOp dst)
+ patch1 insn op = insn $! patchOp op
+ patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
patchOp (OpReg reg) = OpReg (env reg)
patchOp (OpImm imm) = OpImm imm
patchRegs instr env = case instr of
LD sz reg addr -> LD sz (env reg) (fixAddr addr)
+ LA sz reg addr -> LA sz (env reg) (fixAddr addr)
ST sz reg addr -> ST sz (env reg) (fixAddr addr)
STU sz reg addr -> STU sz (env reg) (fixAddr addr)
LIS reg imm -> LIS (env reg) imm
CMPL sz reg ri -> CMPL sz (env reg) (fixRI ri)
BCC cond lbl -> BCC cond lbl
MTCTR reg -> MTCTR (env reg)
- BCTR dsts -> BCTR dsts
+ BCTR targets -> BCTR targets
BL imm argRegs -> BL imm argRegs -- argument regs
BCTRL argRegs -> BCTRL argRegs -- cannot be remapped
ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri)
+ ADDC reg1 reg2 reg3-> ADDC (env reg1) (env reg2) (env reg3)
+ ADDE reg1 reg2 reg3-> ADDE (env reg1) (env reg2) (env reg3)
+ ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm
SUBF reg1 reg2 reg3-> SUBF (env reg1) (env reg2) (env reg3)
MULLW reg1 reg2 ri -> MULLW (env reg1) (env reg2) (fixRI ri)
DIVW reg1 reg2 reg3-> DIVW (env reg1) (env reg2) (env reg3)
DIVWU reg1 reg2 reg3-> DIVWU (env reg1) (env reg2) (env reg3)
+ MULLW_MayOflo reg1 reg2 reg3
+ -> MULLW_MayOflo (env reg1) (env reg2) (env reg3)
AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri)
OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri)
XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri)
XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm
+ EXTS sz reg1 reg2 -> EXTS sz (env reg1) (env reg2)
NEG reg1 reg2 -> NEG (env reg1) (env reg2)
NOT reg1 reg2 -> NOT (env reg1) (env reg2)
SLW reg1 reg2 ri -> SLW (env reg1) (env reg2) (fixRI ri)
SRW reg1 reg2 ri -> SRW (env reg1) (env reg2) (fixRI ri)
SRAW reg1 reg2 ri -> SRAW (env reg1) (env reg2) (fixRI ri)
+ RLWINM reg1 reg2 sh mb me
+ -> RLWINM (env reg1) (env reg2) sh mb me
FADD sz r1 r2 r3 -> FADD sz (env r1) (env r2) (env r3)
FSUB sz r1 r2 r3 -> FSUB sz (env r1) (env r2) (env r3)
FMUL sz r1 r2 r3 -> FMUL sz (env r1) (env r2) (env r3)
FNEG r1 r2 -> FNEG (env r1) (env r2)
FCMP r1 r2 -> FCMP (env r1) (env r2)
FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2)
+ FRSP r1 r2 -> FRSP (env r1) (env r2)
+ MFCR reg -> MFCR (env reg)
_ -> instr
where
fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
fixRI (RIReg r) = RIReg (env r)
fixRI other = other
#endif /* powerpc_TARGET_ARCH */
-\end{code}
-%************************************************************************
-%* *
-\subsection{@spillReg@ and @loadReg@ functions}
-%* *
-%************************************************************************
+-- -----------------------------------------------------------------------------
+-- Detecting reg->reg moves
+
+-- The register allocator attempts to eliminate reg->reg moves whenever it can,
+-- by assigning the src and dest temporaries to the same real register.
+
+isRegRegMove :: Instr -> Maybe (Reg,Reg)
+#ifdef i386_TARGET_ARCH
+-- TMP:
+isRegRegMove (MOV _ (OpReg r1) (OpReg r2)) = Just (r1,r2)
+#elif powerpc_TARGET_ARCH
+isRegRegMove (MR dst src) = Just (src,dst)
+#else
+#warning ToDo: isRegRegMove
+#endif
+isRegRegMove _ = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Generating spill instructions
+
+mkSpillInstr
+ :: Reg -- register to spill (should be a real)
+ -> Int -- current stack delta
+ -> Int -- spill slot to use
+ -> Instr
+mkSpillInstr reg delta slot
+ = ASSERT(isRealReg reg)
+ let
+ off = spillSlotToOffset slot
+ in
+#ifdef alpha_TARGET_ARCH
+ {-Alpha: spill below the stack pointer (?)-}
+ ST sz dyn (spRel (- (off `div` 8)))
+#endif
+#ifdef i386_TARGET_ARCH
+ let off_w = (off-delta) `div` 4
+ in case regClass reg of
+ RcInteger -> MOV I32 (OpReg reg) (OpAddr (spRel off_w))
+ _ -> GST F80 reg (spRel off_w) {- RcFloat/RcDouble -}
+#endif
+#ifdef sparc_TARGET_ARCH
+ {-SPARC: spill below frame pointer leaving 2 words/spill-}
+ let{off_w = 1 + (off `div` 4);
+ sz = case regClass vreg of {
+ RcInteger -> W;
+ RcFloat -> F;
+ RcDouble -> DF}}
+ in ST sz dyn (fpRel (- off_w))
+#endif
+#ifdef powerpc_TARGET_ARCH
+ let sz = case regClass reg of
+ RcInteger -> I32
+ RcDouble -> F64
+ in ST sz reg (AddrRegImm sp (ImmInt (off-delta)))
+#endif
+
-Spill to memory, and load it back...
+mkLoadInstr
+ :: Reg -- register to load (should be a real)
+ -> Int -- current stack delta
+ -> Int -- spill slot to use
+ -> Instr
+mkLoadInstr reg delta slot
+ = ASSERT(isRealReg reg)
+ let
+ off = spillSlotToOffset slot
+ in
+#ifdef alpha_TARGET_ARCH
+ LD sz dyn (spRel (- (off `div` 8)))
+#endif
+#ifdef i386_TARGET_ARCH
+ let off_w = (off-delta) `div` 4
+ in case regClass reg of {
+ RcInteger -> MOV I32 (OpAddr (spRel off_w)) (OpReg reg);
+ _ -> GLD F80 (spRel off_w) reg} {- RcFloat/RcDouble -}
+#endif
+#ifdef sparc_TARGET_ARCH
+ let{off_w = 1 + (off `div` 4);
+ sz = case regClass vreg of {
+ RcInteger -> W;
+ RcFloat -> F;
+ RcDouble -> DF}}
+ in LD sz (fpRel (- off_w)) dyn
+#endif
+#ifdef powerpc_TARGET_ARCH
+ let sz = case regClass reg of
+ RcInteger -> I32
+ RcDouble -> F64
+ in LD sz reg (AddrRegImm sp (ImmInt (off-delta)))
+#endif
-JRS, 000122: on x86, don't spill directly above the stack pointer,
-since some insn sequences (int <-> conversions) use this as a temp
-location. Leave 8 words (ie, 64 bytes for a 64-bit arch) of slop.
-\begin{code}
spillSlotSize :: Int
-spillSlotSize = IF_ARCH_alpha( 8, IF_ARCH_sparc( 8, IF_ARCH_i386( 12, IF_ARCH_powerpc( 8, ))))
+spillSlotSize = IF_ARCH_i386(12, 8)
maxSpillSlots :: Int
maxSpillSlots = ((rESERVED_C_STACK_BYTES - 64) `div` spillSlotSize) - 1
| otherwise
= pprPanic "spillSlotToOffset:"
(text "invalid spill location: " <> int slot)
-
-vregToSpillSlot :: FiniteMap VRegUnique Int -> VRegUnique -> Int
-vregToSpillSlot vreg_to_slot_map u
- = case lookupFM vreg_to_slot_map u of
- Just xx -> xx
- Nothing -> pprPanic "vregToSpillSlot: unmapped vreg" (pprVRegUnique u)
-
-
-spillReg, loadReg :: FiniteMap VRegUnique Int -> Int -> Reg -> Reg -> Instr
-
-spillReg vreg_to_slot_map delta dyn vreg
- | isVirtualReg vreg
- = let slot_no = vregToSpillSlot vreg_to_slot_map (getVRegUnique vreg)
- off = spillSlotToOffset slot_no
- in
- {-Alpha: spill below the stack pointer (?)-}
- IF_ARCH_alpha( ST sz dyn (spRel (- (off `div` 8)))
-
- {-I386: spill above stack pointer leaving 3 words/spill-}
- ,IF_ARCH_i386 ( let off_w = (off-delta) `div` 4
- in case regClass vreg of {
- RcInteger -> MOV L (OpReg dyn) (OpAddr (spRel off_w));
- _ -> GST F80 dyn (spRel off_w)} {- RcFloat/RcDouble -}
-
- {-SPARC: spill below frame pointer leaving 2 words/spill-}
- ,IF_ARCH_sparc(
- let{off_w = 1 + (off `div` 4);
- sz = case regClass vreg of {
- RcInteger -> W;
- RcFloat -> F;
- RcDouble -> DF}}
- in ST sz dyn (fpRel (- off_w))
- ,IF_ARCH_powerpc(
- let{sz = case regClass vreg of {
- RcInteger -> W;
- RcFloat -> F;
- RcDouble -> DF}}
- in ST sz dyn (AddrRegImm sp (ImmInt (off-delta)))
- ,))))
-
-
-loadReg vreg_to_slot_map delta vreg dyn
- | isVirtualReg vreg
- = let slot_no = vregToSpillSlot vreg_to_slot_map (getVRegUnique vreg)
- off = spillSlotToOffset slot_no
- in
- IF_ARCH_alpha( LD sz dyn (spRel (- (off `div` 8)))
-
- ,IF_ARCH_i386 ( let off_w = (off-delta) `div` 4
- in case regClass vreg of {
- RcInteger -> MOV L (OpAddr (spRel off_w)) (OpReg dyn);
- _ -> GLD F80 (spRel off_w) dyn} {- RcFloat/RcDouble -}
-
- ,IF_ARCH_sparc(
- let{off_w = 1 + (off `div` 4);
- sz = case regClass vreg of {
- RcInteger -> W;
- RcFloat -> F;
- RcDouble -> DF}}
- in LD sz (fpRel (- off_w)) dyn
- ,IF_ARCH_powerpc(
- let{sz = case regClass vreg of {
- RcInteger -> W;
- RcFloat -> F;
- RcDouble -> DF}}
- in LD sz dyn (AddrRegImm sp (ImmInt (off-delta)))
- ,))))
-\end{code}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- The register allocator
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+{-
+The algorithm is roughly:
+
+ 1) Compute strongly connected components of the basic block list.
+
+ 2) Compute liveness (mapping from pseudo register to
+ point(s) of death?).
+
+ 3) Walk instructions in each basic block. We keep track of
+ (a) Free real registers (a bitmap?)
+ (b) Current assignment of temporaries to machine registers and/or
+ spill slots (call this the "assignment").
+ (c) Partial mapping from basic block ids to a virt-to-loc mapping.
+ When we first encounter a branch to a basic block,
+ we fill in its entry in this table with the current mapping.
+
+ For each instruction:
+ (a) For each real register clobbered by this instruction:
+ If a temporary resides in it,
+ If the temporary is live after this instruction,
+ Move the temporary to another (non-clobbered & free) reg,
+ or spill it to memory. Mark the temporary as residing
+ in both memory and a register if it was spilled (it might
+ need to be read by this instruction).
+ (ToDo: this is wrong for jump instructions?)
+
+ (b) For each temporary *read* by the instruction:
+ If the temporary does not have a real register allocation:
+ - Allocate a real register from the free list. If
+ the list is empty:
+ - Find a temporary to spill. Pick one that is
+ not used in this instruction (ToDo: not
+ used for a while...)
+ - generate a spill instruction
+ - If the temporary was previously spilled,
+ generate an instruction to read the temp from its spill loc.
+ (optimisation: if we can see that a real register is going to
+ be used soon, then don't use it for allocation).
+
+ (c) Update the current assignment
+
+ (d) If the intstruction is a branch:
+ if the destination block already has a register assignment,
+ Generate a new block with fixup code and redirect the
+ jump to the new block.
+ else,
+ Update the block id->assignment mapping with the current
+ assignment.
+
+ (e) Delete all register assignments for temps which are read
+ (only) and die here. Update the free register list.
+
+ (f) Mark all registers clobbered by this instruction as not free,
+ and mark temporaries which have been spilled due to clobbering
+ as in memory (step (a) marks then as in both mem & reg).
+
+ (g) For each temporary *written* (only) by this instruction:
+ Allocate a real register as for (b), spilling something
+ else if necessary.
+
+ (h) Delete all register assignments for temps which are
+ written and die here (there should rarely be any). Update
+ the free register list.
+
+ (i) Rewrite the instruction with the new mapping.
+
+ (j) For each spilled reg known to be now dead, re-add its stack slot
+ to the free list.
+
+-}
+
+module RegisterAlloc (
+ regAlloc
+ ) where
+
+#include "HsVersions.h"
+#include "../includes/ghcconfig.h"
+
+import PprMach
+import MachRegs
+import MachInstrs
+import RegAllocInfo
+import Cmm
+
+import Digraph
+import Unique ( Uniquable(..), Unique, getUnique )
+import UniqSet
+import UniqFM
+import Outputable
+
+#ifndef DEBUG
+import Maybe ( fromJust )
+#endif
+import List ( nub, partition )
+import Monad ( when )
+import DATA_WORD
+import DATA_BITS
+
+-- -----------------------------------------------------------------------------
+-- Some useful types
+
+type RegSet = UniqSet Reg
+
+type RegMap a = UniqFM a
+emptyRegMap = emptyUFM
+
+type BlockMap a = UniqFM a
+emptyBlockMap = emptyUFM
+
+-- A basic block where the isntructions are annotated with the registers
+-- which are no longer live in the *next* instruction in this sequence.
+-- (NB. if the instruction is a jump, these registers might still be live
+-- at the jump target(s) - you have to check the liveness at the destination
+-- block to find out).
+type AnnBasicBlock
+ = GenBasicBlock (Instr,
+ [Reg], -- registers read (only) which die
+ [Reg]) -- registers written which die
+
+-- -----------------------------------------------------------------------------
+-- The free register set
+
+-- This needs to be *efficient*
+
+{- Here's an inefficient 'executable specification' of the FreeRegs data type:
+type FreeRegs = [RegNo]
+
+noFreeRegs = 0
+releaseReg n f = if n `elem` f then f else (n : f)
+initFreeRegs = allocatableRegs
+getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
+allocateReg f r = filter (/= r) f
+-}
+
+#if defined(powerpc_TARGET_ARCH)
+
+-- The PowerPC has 32 integer and 32 floating point registers.
+-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
+-- better.
+-- Note that when getFreeRegs scans for free registers, it starts at register
+-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
+-- registers are callee-saves, while the lower regs are caller-saves, so it
+-- makes sense to start at the high end.
+-- Apart from that, the code does nothing PowerPC-specific, so feel free to
+-- add your favourite platform to the #if (if you have 64 registers but only
+-- 32-bit words).
+
+data FreeRegs = FreeRegs !Word32 !Word32
+
+noFreeRegs = FreeRegs 0 0
+releaseReg r (FreeRegs g f)
+ | r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
+ | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
+
+initFreeRegs :: FreeRegs
+initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
+
+getFreeRegs cls (FreeRegs g f)
+ | RcDouble <- cls = go f (0x80000000) 63
+ | RcInteger <- cls = go g (0x80000000) 31
+ where
+ go x 0 i = []
+ go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
+ | otherwise = go x (m `shiftR` 1) $! i-1
+
+allocateReg (FreeRegs g f) r
+ | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
+ | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
+
+#else
+
+-- If we have less than 32 registers, or if we have efficient 64-bit words,
+-- we will just use a single bitfield.
+
+#if defined(alpha_TARGET_ARCH)
+type FreeRegs = Word64
+#else
+type FreeRegs = Word32
+#endif
+
+noFreeRegs :: FreeRegs
+noFreeRegs = 0
+
+releaseReg :: RegNo -> FreeRegs -> FreeRegs
+releaseReg n f = f .|. (1 `shiftL` n)
+
+initFreeRegs :: FreeRegs
+initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
+
+getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
+getFreeRegs cls f = go f 0
+ where go 0 m = []
+ go n m
+ | n .&. 1 /= 0 && regClass (RealReg m) == cls
+ = m : (go (n `shiftR` 1) $! (m+1))
+ | otherwise
+ = go (n `shiftR` 1) $! (m+1)
+ -- ToDo: there's no point looking through all the integer registers
+ -- in order to find a floating-point one.
+
+allocateReg :: FreeRegs -> RegNo -> FreeRegs
+allocateReg f r = f .&. complement (1 `shiftL` fromIntegral r)
+#endif
+
+-- -----------------------------------------------------------------------------
+-- The free list of stack slots
+
+-- This doesn't need to be so efficient. It also doesn't really need to be
+-- maintained as a set, so we just use an ordinary list (lazy, because it
+-- contains all the possible stack slots and there are lots :-).
+
+type StackSlot = Int
+type FreeStack = [StackSlot]
+
+completelyFreeStack :: FreeStack
+completelyFreeStack = [0..maxSpillSlots]
+
+getFreeStackSlot :: FreeStack -> (FreeStack,Int)
+getFreeStackSlot (slot:stack) = (stack,slot)
+
+freeStackSlot :: FreeStack -> Int -> FreeStack
+freeStackSlot stack slot = slot:stack
+
+
+-- -----------------------------------------------------------------------------
+-- Top level of the register allocator
+
+regAlloc :: NatCmmTop -> NatCmmTop
+regAlloc (CmmData sec d) = CmmData sec d
+regAlloc (CmmProc info lbl params [])
+ = CmmProc info lbl params [] -- no blocks to run the regalloc on
+regAlloc (CmmProc info lbl params blocks@(first:rest))
+ = -- pprTrace "Liveness" (ppr block_live) $
+ CmmProc info lbl params (first':rest')
+ where
+ first_id = blockId first
+ sccs = sccBlocks blocks
+ (ann_sccs, block_live) = computeLiveness sccs
+ final_blocks = linearRegAlloc block_live ann_sccs
+ ((first':_),rest') = partition ((== first_id) . blockId) final_blocks
+
+
+sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
+sccBlocks blocks = stronglyConnComp graph
+ where
+ getOutEdges :: [Instr] -> [BlockId]
+ getOutEdges instrs = foldr jumpDests [] instrs
+
+ graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
+ | block@(BasicBlock id instrs) <- blocks ]
+
+
+-- -----------------------------------------------------------------------------
+-- Computing liveness
+
+computeLiveness
+ :: [SCC NatBasicBlock]
+ -> ([SCC AnnBasicBlock], -- instructions annotated with list of registers
+ -- which are "dead after this instruction".
+ BlockMap RegSet) -- blocks annontated with set of live registers
+ -- on entry to the block.
+
+ -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
+ -- control to earlier ones only. The SCCs returned are in the *opposite*
+ -- order, which is exactly what we want for the next pass.
+
+computeLiveness sccs
+ = livenessSCCs emptyBlockMap [] sccs
+ where
+ livenessSCCs
+ :: BlockMap RegSet
+ -> [SCC AnnBasicBlock] -- accum
+ -> [SCC NatBasicBlock]
+ -> ([SCC AnnBasicBlock], BlockMap RegSet)
+
+ livenessSCCs blockmap done [] = (done, blockmap)
+ livenessSCCs blockmap done
+ (AcyclicSCC (BasicBlock block_id instrs) : sccs) =
+ {- pprTrace "live instrs" (ppr (getUnique block_id) $$
+ vcat (map (\(instr,regs) -> docToSDoc (pprInstr instr) $$ ppr regs) instrs')) $
+ -}
+ livenessSCCs blockmap'
+ (AcyclicSCC (BasicBlock block_id instrs'):done) sccs
+ where (live,instrs') = liveness emptyUniqSet blockmap []
+ (reverse instrs)
+ blockmap' = addToUFM blockmap block_id live
+ -- TODO: cope with recursive blocks
+
+ liveness :: RegSet -- live regs
+ -> BlockMap RegSet -- live regs on entry to other BBs
+ -> [(Instr,[Reg],[Reg])] -- instructions (accum)
+ -> [Instr] -- instructions
+ -> (RegSet, [(Instr,[Reg],[Reg])])
+
+ liveness liveregs blockmap done [] = (liveregs, done)
+ liveness liveregs blockmap done (instr:instrs)
+ = liveness liveregs2 blockmap ((instr,r_dying,w_dying):done) instrs
+ where
+ RU read written = regUsage instr
+
+ -- registers that were written here are dead going backwards.
+ -- registers that were read here are live going backwards.
+ liveregs1 = (liveregs `delListFromUniqSet` written)
+ `addListToUniqSet` read
+
+ -- union in the live regs from all the jump destinations of this
+ -- instruction.
+ targets = jumpDests instr [] -- where we go from here
+ liveregs2 = unionManyUniqSets
+ (liveregs1 : map (lookItUp "liveness" blockmap)
+ targets)
+
+ -- registers that are not live beyond this point, are recorded
+ -- as dying here.
+ r_dying = [ reg | reg <- read, reg `notElem` written,
+ not (elementOfUniqSet reg liveregs) ]
+
+ w_dying = [ reg | reg <- written,
+ not (elementOfUniqSet reg liveregs) ]
+
+-- -----------------------------------------------------------------------------
+-- Linear sweep to allocate registers
+
+data Loc = InReg {-# UNPACK #-} !RegNo
+ | InMem {-# UNPACK #-} !Int -- stack slot
+ | InBoth {-# UNPACK #-} !RegNo
+ {-# UNPACK #-} !Int -- stack slot
+ deriving (Eq, Show)
+
+{-
+A temporary can be marked as living in both a register and memory
+(InBoth), for example if it was recently loaded from a spill location.
+This makes it cheap to spill (no save instruction required), but we
+have to be careful to turn this into InReg if the value in the
+register is changed.
+
+This is also useful when a temporary is about to be clobbered. We
+save it in a spill location, but mark it as InBoth because the current
+instruction might still want to read it.
+-}
+
+#ifdef DEBUG
+instance Outputable Loc where
+ ppr l = text (show l)
+#endif
+
+linearRegAlloc
+ :: BlockMap RegSet -- live regs on entry to each basic block
+ -> [SCC AnnBasicBlock] -- instructions annotated with "deaths"
+ -> [NatBasicBlock]
+linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap sccs
+ where
+ linearRA_SCCs
+ :: BlockAssignment
+ -> [SCC AnnBasicBlock]
+ -> [NatBasicBlock]
+ linearRA_SCCs block_assig [] = []
+ linearRA_SCCs block_assig
+ (AcyclicSCC (BasicBlock id instrs) : sccs)
+ = BasicBlock id instrs' : linearRA_SCCs block_assig' sccs
+ where
+ (block_assig',(instrs',fixups)) =
+ case lookupUFM block_assig id of
+ -- no prior info about this block: assume everything is
+ -- free and the assignment is empty.
+ Nothing ->
+ runR block_assig initFreeRegs
+ emptyRegMap completelyFreeStack $
+ linearRA [] [] instrs
+ Just (freeregs,stack,assig) ->
+ runR block_assig freeregs assig stack $
+ linearRA [] [] instrs
+
+ linearRA :: [Instr] -> [NatBasicBlock] -> [(Instr,[Reg],[Reg])]
+ -> RegM ([Instr], [NatBasicBlock])
+ linearRA instr_acc fixups [] =
+ return (reverse instr_acc, fixups)
+ linearRA instr_acc fixups (instr:instrs) = do
+ (instr_acc', new_fixups) <- raInsn block_live instr_acc instr
+ linearRA instr_acc' (new_fixups++fixups) instrs
+
+-- -----------------------------------------------------------------------------
+-- Register allocation for a single instruction
+
+type BlockAssignment = BlockMap (FreeRegs, FreeStack, RegMap Loc)
+
+raInsn :: BlockMap RegSet -- Live temporaries at each basic block
+ -> [Instr] -- new instructions (accum.)
+ -> (Instr,[Reg],[Reg]) -- the instruction (with "deaths")
+ -> RegM (
+ [Instr], -- new instructions
+ [NatBasicBlock] -- extra fixup blocks
+ )
+
+raInsn block_live new_instrs (instr@(DELTA n), _, _) = do
+ setDeltaR n
+ return (new_instrs, [])
+
+raInsn block_live new_instrs (instr, r_dying, w_dying) = do
+ assig <- getAssigR
+
+ -- If we have a reg->reg move between virtual registers, where the
+ -- src register is not live after this instruction, and the dst
+ -- register does not already have an assignment, then we can
+ -- eliminate the instruction.
+ case isRegRegMove instr of
+ Just (src,dst)
+ | src `elem` r_dying,
+ isVirtualReg dst,
+ Just loc <- lookupUFM assig src,
+ not (dst `elemUFM` assig) -> do
+ setAssigR (addToUFM (delFromUFM assig src) dst loc)
+ return (new_instrs, [])
+
+ other -> genRaInsn block_live new_instrs instr r_dying w_dying
+
+
+genRaInsn block_live new_instrs instr r_dying w_dying = do
+ let
+ RU read written = regUsage instr
+
+ -- we're not interested in regs written if they're also read.
+ written' = nub (filter (`notElem` read) written)
+
+ (real_written1,virt_written) = partition isRealReg written'
+
+ real_written = [ r | RealReg r <- real_written1 ]
+
+ -- we don't need to do anything with real registers that are
+ -- only read by this instr. (the list is typically ~2 elements,
+ -- so using nub isn't a problem).
+ virt_read = nub (filter isVirtualReg read)
+ -- in
+
+ -- (a) save any temporaries which will be clobbered by this instruction
+ (clobber_saves, assig_adj) <- saveClobberedTemps real_written r_dying
+
+ -- freeregs <- getFreeRegsR
+ -- assig <- getAssigR
+ -- pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do
+
+ -- (b), (c) allocate real regs for all regs read by this instruction.
+ (r_spills, r_allocd) <-
+ allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
+
+ -- (d) Update block map for new destinations
+ -- NB. do this before removing dead regs from the assignment, because
+ -- these dead regs might in fact be live in the jump targets (they're
+ -- only dead in the code that follows in the current basic block).
+ (fixup_blocks, adjusted_instr)
+ <- joinToTargets block_live [] instr (jumpDests instr [])
+
+ -- (e) Delete all register assignments for temps which are read
+ -- (only) and die here. Update the free register list.
+ releaseRegs r_dying
+
+ -- (f) Mark regs which are clobbered as unallocatable
+ clobberRegs real_written assig_adj
+
+ -- (g) Allocate registers for temporaries *written* (only)
+ (w_spills, w_allocd) <-
+ allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
+
+ -- (h) Release registers for temps which are written here and not
+ -- used again.
+ releaseRegs w_dying
+
+ let
+ -- (i) Patch the instruction
+ patch_map = listToUFM [ (t,RealReg r) |
+ (t,r) <- zip virt_read r_allocd
+ ++ zip virt_written w_allocd ]
+
+ patched_instr = patchRegs adjusted_instr patchLookup
+ patchLookup x = case lookupUFM patch_map x of
+ Nothing -> x
+ Just y -> y
+ -- in
+
+ -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
+
+ -- (j) free up stack slots for dead spilled regs
+ -- TODO (can't be bothered right now)
+
+ return (patched_instr : w_spills ++ reverse r_spills
+ ++ clobber_saves ++ new_instrs,
+ fixup_blocks)
+
+-- -----------------------------------------------------------------------------
+-- releaseRegs
+
+releaseRegs regs = do
+ assig <- getAssigR
+ free <- getFreeRegsR
+ loop assig free regs
+ where
+ loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
+ loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
+ loop assig free (r:rs) =
+ case lookupUFM assig r of
+ Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
+ Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
+ _other -> loop (delFromUFM assig r) free rs
+
+-- -----------------------------------------------------------------------------
+-- Clobber real registers
+
+{-
+For each temp in a register that is going to be clobbered:
+ - if the temp dies after this instruction, do nothing
+ - otherwise, put it somewhere safe (another reg if possible,
+ otherwise spill and record InBoth in the assignment).
+
+for allocateRegs on the temps *read*,
+ - clobbered regs are allocatable.
+
+for allocateRegs on the temps *written*,
+ - clobbered regs are not allocatable.
+-}
+
+saveClobberedTemps
+ :: [RegNo] -- real registers clobbered by this instruction
+ -> [Reg] -- registers which are no longer live after this insn
+ -> RegM (
+ [Instr], -- return: instructions to spill any temps that will
+ [(Unique,Loc)] -- be clobbered, and adjustments to make to the
+ ) -- assignment after reading has taken place.
+
+saveClobberedTemps [] _ = return ([],[]) -- common case
+saveClobberedTemps clobbered dying = do
+ assig <- getAssigR
+ let
+ to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
+ reg `elem` clobbered,
+ temp `notElem` map getUnique dying ]
+ -- in
+ (instrs,assig_adj,assig') <- clobber assig [] [] to_spill
+ setAssigR assig'
+ return (instrs,assig_adj)
+ where
+ clobber assig instrs adj [] = return (instrs,adj,assig)
+ clobber assig instrs adj ((temp,reg):rest)
+ = do
+ (spill,slot) <- spillR (RealReg reg)
+ clobber (addToUFM assig temp (InBoth reg slot))
+ (spill:instrs) ((temp,InMem slot):adj) rest
+ --ToDo: copy it to another register if possible
+
+
+clobberRegs :: [RegNo] -> [(Unique,Loc)] -> RegM ()
+clobberRegs [] _ = return () -- common case
+clobberRegs clobbered assig_adj = do
+ freeregs <- getFreeRegsR
+ setFreeRegsR (foldl allocateReg freeregs clobbered)
+ assig <- getAssigR
+ setAssigR (addListToUFM assig assig_adj)
+
+-- -----------------------------------------------------------------------------
+-- allocateRegsAndSpill
+
+-- This function does several things:
+-- For each temporary referred to by this instruction,
+-- we allocate a real register (spilling another temporary if necessary).
+-- We load the temporary up from memory if necessary.
+-- We also update the register assignment in the process, and
+-- the list of free registers and free stack slots.
+
+allocateRegsAndSpill
+ :: Bool -- True <=> reading (load up spilled regs)
+ -> [Reg] -- don't push these out
+ -> [Instr] -- spill insns
+ -> [RegNo] -- real registers allocated (accum.)
+ -> [Reg] -- temps to allocate
+ -> RegM ([Instr], [RegNo])
+
+allocateRegsAndSpill reading keep spills alloc []
+ = return (spills,reverse alloc)
+
+allocateRegsAndSpill reading keep spills alloc (r:rs) = do
+ assig <- getAssigR
+ case lookupUFM assig r of
+ -- case (1a): already in a register
+ Just (InReg my_reg) ->
+ allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+ -- case (1b): already in a register (and memory)
+ -- NB. if we're writing this register, update its assignemnt to be
+ -- InReg, because the memory value is no longer valid.
+ Just (InBoth my_reg mem) -> do
+ when (not reading) (setAssigR (addToUFM assig my_reg (InReg my_reg)))
+ allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+ -- Not already in a register, so we need to find a free one...
+ loc -> do
+ freeregs <- getFreeRegsR
+
+ case getFreeRegs (regClass r) freeregs of
+
+ -- case (2): we have a free register
+ my_reg:_ -> do
+ spills' <- do_load reading loc my_reg spills
+ let new_loc = case loc of
+ Just (InMem slot) -> InBoth my_reg slot
+ _other -> InReg my_reg
+ setAssigR (addToUFM assig r $! new_loc)
+ setFreeRegsR (allocateReg freeregs my_reg)
+ allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
+
+ -- case (3): we need to push something out to free up a register
+ [] -> do
+ let
+ keep' = map getUnique keep
+ candidates1 = [ (temp,reg,mem)
+ | (temp, InBoth reg mem) <- ufmToList assig,
+ temp `notElem` keep', regClass (RealReg reg) == regClass r ]
+ candidates2 = [ (temp,reg)
+ | (temp, InReg reg) <- ufmToList assig,
+ temp `notElem` keep', regClass (RealReg reg) == regClass r ]
+ -- in
+ ASSERT2(not (null candidates1 && null candidates2), ppr assig) do
+
+ case candidates1 of
+
+ -- we have a temporary that is in both register and mem,
+ -- just free up its register for use.
+ --
+ (temp,my_reg,slot):_ -> do
+ spills' <- do_load reading loc my_reg spills
+ let
+ assig1 = addToUFM assig temp (InMem slot)
+ assig2 = addToUFM assig1 r (InReg my_reg)
+ -- in
+ setAssigR assig2
+ allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
+
+ -- otherwise, we need to spill a temporary that currently
+ -- resides in a register.
+ [] -> do
+ let
+ (temp_to_push_out, my_reg) = head candidates2
+ -- TODO: plenty of room for optimisation in choosing which temp
+ -- to spill. We just pick the first one that isn't used in
+ -- the current instruction for now.
+ -- in
+ (spill_insn,slot) <- spillR (RealReg my_reg)
+ let
+ assig1 = addToUFM assig temp_to_push_out (InMem slot)
+ assig2 = addToUFM assig1 r (InReg my_reg)
+ -- in
+ setAssigR assig2
+ spills' <- do_load reading loc my_reg spills
+ allocateRegsAndSpill reading keep (spill_insn:spills')
+ (my_reg:alloc) rs
+ where
+ -- load up a spilled temporary if we need to
+ do_load True (Just (InMem slot)) reg spills = do
+ insn <- loadR (RealReg reg) slot
+ return (insn : spills)
+ do_load _ _ _ spills =
+ return spills
+
+-- -----------------------------------------------------------------------------
+-- Joining a jump instruction to its targets
+
+-- The first time we encounter a jump to a particular basic block, we
+-- record the assignment of temporaries. The next time we encounter a
+-- jump to the same block, we compare our current assignment to the
+-- stored one. They might be different if spilling has occrred in one
+-- branch; so some fixup code will be required to match up the
+-- assignments.
+
+joinToTargets
+ :: BlockMap RegSet
+ -> [NatBasicBlock]
+ -> Instr
+ -> [BlockId]
+ -> RegM ([NatBasicBlock], Instr)
+
+joinToTargets block_live new_blocks instr []
+ = return (new_blocks, instr)
+joinToTargets block_live new_blocks instr (dest:dests) = do
+ block_assig <- getBlockAssigR
+ assig <- getAssigR
+ let
+ -- adjust the assignment to remove any registers which are not
+ -- live on entry to the destination block.
+ adjusted_assig =
+ listToUFM [ (reg,loc) | reg <- live,
+ Just loc <- [lookupUFM assig reg] ]
+ -- in
+ case lookupUFM block_assig dest of
+ -- Nothing <=> this is the first time we jumped to this
+ -- block.
+ Nothing -> do
+ freeregs <- getFreeRegsR
+ stack <- getStackR
+ setBlockAssigR (addToUFM block_assig dest
+ (freeregs,stack,adjusted_assig))
+ joinToTargets block_live new_blocks instr dests
+
+ Just (freeregs,stack,dest_assig)
+ | ufmToList dest_assig == ufmToList adjusted_assig
+ -> -- ok, the assignments match
+ joinToTargets block_live new_blocks instr dests
+ | otherwise
+ -> -- need fixup code
+ panic "joinToTargets: ToDo: need fixup code"
+ where
+ live = uniqSetToList (lookItUp "joinToTargets" block_live dest)
+
+-- -----------------------------------------------------------------------------
+-- The register allocator's monad.
+
+-- Here we keep all the state that the register allocator keeps track
+-- of as it walks the instructions in a basic block.
+
+data RA_State
+ = RA_State {
+ ra_blockassig :: BlockAssignment,
+ -- The current mapping from basic blocks to
+ -- the register assignments at the beginning of that block.
+ ra_freeregs :: FreeRegs, -- free machine registers
+ ra_assig :: RegMap Loc, -- assignment of temps to locations
+ ra_delta :: Int, -- current stack delta
+ ra_stack :: FreeStack -- free stack slots for spilling
+ }
+
+newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) }
+
+instance Monad RegM where
+ m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
+ return a = RegM $ \s -> (# s, a #)
+
+runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> FreeStack -> RegM a ->
+ (BlockAssignment, a)
+runR block_assig freeregs assig stack thing =
+ case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs,
+ ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack }) of
+ (# RA_State{ ra_blockassig=block_assig }, returned_thing #)
+ -> (block_assig, returned_thing)
+
+spillR :: Reg -> RegM (Instr, Int)
+spillR reg = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
+ let (stack',slot) = getFreeStackSlot stack
+ instr = mkSpillInstr reg delta slot
+ in
+ (# s{ra_stack=stack'}, (instr,slot) #)
+
+loadR :: Reg -> Int -> RegM Instr
+loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
+ (# s, mkLoadInstr reg delta slot #)
+
+freeSlotR :: Int -> RegM ()
+freeSlotR slot = RegM $ \ s@RA_State{ra_stack=stack} ->
+ (# s{ra_stack=freeStackSlot stack slot}, () #)
+
+getFreeRegsR :: RegM FreeRegs
+getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
+ (# s, freeregs #)
+
+setFreeRegsR :: FreeRegs -> RegM ()
+setFreeRegsR regs = RegM $ \ s ->
+ (# s{ra_freeregs = regs}, () #)
+
+getAssigR :: RegM (RegMap Loc)
+getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
+ (# s, assig #)
+
+setAssigR :: RegMap Loc -> RegM ()
+setAssigR assig = RegM $ \ s ->
+ (# s{ra_assig=assig}, () #)
+
+getStackR :: RegM FreeStack
+getStackR = RegM $ \ s@RA_State{ra_stack = stack} ->
+ (# s, stack #)
+
+setStackR :: FreeStack -> RegM ()
+setStackR stack = RegM $ \ s ->
+ (# s{ra_stack=stack}, () #)
+
+getBlockAssigR :: RegM BlockAssignment
+getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
+ (# s, assig #)
+
+setBlockAssigR :: BlockAssignment -> RegM ()
+setBlockAssigR assig = RegM $ \ s ->
+ (# s{ra_blockassig = assig}, () #)
+
+setDeltaR :: Int -> RegM ()
+setDeltaR n = RegM $ \ s ->
+ (# s{ra_delta = n}, () #)
+
+-- -----------------------------------------------------------------------------
+-- Utils
+
+#ifdef DEBUG
+my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
+my_fromJust s p (Just x) = x
+#else
+my_fromJust _ _ = fromJust
+#endif
+
+lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
+lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)
+++ /dev/null
-_interface_ Stix 1
-_exports_
-Stix StixTree;
-_declarations_
-1 data StixTree;
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-
-\begin{code}
-module Stix (
- CodeSegment(..), StixReg(..), StixExpr(..), StixVReg(..),
- StixStmt(..), mkStAssign, StixStmtList,
- pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg,
- stixStmt_CountTempUses, stixStmt_Subst,
- liftStrings, repOfStixExpr,
- DestInfo(..), hasDestInfo,
-
- stgBaseReg, stgNode, stgSp, stgSpLim,
- stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10,
- stgCurrentTSO, stgCurrentNursery,
-
- fixedHS, arrWordsHS, arrPtrsHS,
-
- NatM, initNat, thenNat, returnNat,
- mapNat, mapAndUnzipNat, mapAccumLNat,
- getUniqueNat, getDeltaNat, setDeltaNat,
- NatM_State, mkNatM_State,
- uniqOfNatM_State, deltaOfNatM_State, importsOfNatM_State,
- addImportNat,
-
- getUniqLabelNCG, getNatLabelNCG,
- ncgPrimopMoan,
-
- -- Information about the target arch
- ncg_target_is_32bit
- ) where
-
-#include "HsVersions.h"
-
-import AbsCSyn ( node, tagreg, MagicId(..) )
-import AbsCUtils ( magicIdPrimRep )
-import ForeignCall ( CCallConv )
-import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
-import PrimRep ( PrimRep(..) )
-import MachOp ( MachOp(..), pprMachOp, resultRepOfMachOp )
-import Unique ( Unique )
-import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
-import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
- UniqSM, thenUs, returnUs, getUniqueUs )
-import Constants ( wORD_SIZE )
-import Outputable
-import FastTypes
-import FastString
-
-import UNSAFE_IO ( unsafePerformIO )
-
-import Ratio ( Rational )
-import IO ( hPutStrLn, stderr )
-\end{code}
-
-Two types, StixStmt and StixValue, define Stix.
-
-\begin{code}
-
--- Non-value trees; ones executed for their side-effect.
-data StixStmt
-
- = -- Directive for the assembler to change segment
- StSegment CodeSegment
-
- -- Assembly-language comments
- | StComment FastString
-
- -- Assignments are typed to determine size and register placement.
- -- Assign a value to a StixReg
- | StAssignReg PrimRep StixReg StixExpr
-
- -- Assign a value to memory. First tree indicates the address to be
- -- assigned to, so there is an implicit dereference here.
- | StAssignMem PrimRep StixExpr StixExpr -- dst, src
-
- -- A simple assembly label that we might jump to.
- | StLabel CLabel
-
- -- A function header and footer
- | StFunBegin CLabel
- | StFunEnd CLabel
-
- -- An unconditional jump. This instruction may or may not jump
- -- out of the register allocation domain (basic block, more or
- -- less). For correct register allocation when this insn is used
- -- to jump through a jump table, we optionally allow a list of
- -- the exact targets to be attached, so that the allocator can
- -- easily construct the exact flow edges leaving this insn.
- -- Dynamic targets are allowed.
- | StJump DestInfo StixExpr
-
- -- A fall-through, from slow to fast
- | StFallThrough CLabel
-
- -- A conditional jump. This instruction can be non-terminal :-)
- -- Only static, local, forward labels are allowed
- | StCondJump CLabel StixExpr
-
- -- Raw data (as in an info table).
- | StData PrimRep [StixExpr]
- -- String which has been lifted to the top level (sigh).
- | StDataString FastString
-
- -- A value computed only for its side effects; result is discarded
- -- (A handy trapdoor to allow CCalls with no results to appear as
- -- statements).
- | StVoidable StixExpr
-
-
--- Helper fn to make Stix assignment statements where the
--- lvalue masquerades as a StixExpr. A kludge that should
--- be done away with.
-mkStAssign :: PrimRep -> StixExpr -> StixExpr -> StixStmt
-mkStAssign rep (StReg reg) rhs
- = StAssignReg rep reg rhs
-mkStAssign rep (StInd rep' addr) rhs
- | rep `isCloseEnoughTo` rep'
- = StAssignMem rep addr rhs
- | otherwise
- = --pprPanic "Stix.mkStAssign: mismatched reps" (ppr rep <+> ppr rep')
- --trace ("Stix.mkStAssign: mismatched reps: " ++ showSDoc (ppr rep <+> ppr rep')) (
- StAssignMem rep addr rhs
- --)
- where
- isCloseEnoughTo r1 r2
- = r1 == r2 || (wordIsh r1 && wordIsh r2)
- wordIsh rep
- = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep, RetRep ]
- -- determined by looking at PrimRep.showPrimRep
-
--- Stix trees which denote a value.
-data StixExpr
- = -- Literals
- StInt Integer -- ** add Kind at some point
- | StFloat Rational
- | StDouble Rational
- | StString FastString
- | StCLbl CLabel -- labels that we might index into
-
- -- Abstract registers of various kinds
- | StReg StixReg
-
- -- A typed offset from a base location
- | StIndex PrimRep StixExpr StixExpr -- kind, base, offset
-
- -- An indirection from an address to its contents.
- | StInd PrimRep StixExpr
-
- -- Primitive Operations
- | StMachOp MachOp [StixExpr]
-
- -- Calls to C functions
- | StCall (Either FastString StixExpr) -- Left: static, Right: dynamic
- CCallConv PrimRep [StixExpr]
-
-
--- What's the PrimRep of the value denoted by this StixExpr?
-repOfStixExpr :: StixExpr -> PrimRep
-repOfStixExpr (StInt _) = IntRep
-repOfStixExpr (StFloat _) = FloatRep
-repOfStixExpr (StDouble _) = DoubleRep
-repOfStixExpr (StString _) = PtrRep
-repOfStixExpr (StCLbl _) = PtrRep
-repOfStixExpr (StReg reg) = repOfStixReg reg
-repOfStixExpr (StIndex _ _ _) = PtrRep
-repOfStixExpr (StInd rep _) = rep
-repOfStixExpr (StCall target conv retrep args) = retrep
-repOfStixExpr (StMachOp mop args) = resultRepOfMachOp mop
-
-
--- used by insnFuture in RegAllocInfo.lhs
-data DestInfo
- = NoDestInfo -- no supplied dests; infer from context
- | DestInfo [CLabel] -- precisely these dests and no others
-
-hasDestInfo NoDestInfo = False
-hasDestInfo (DestInfo _) = True
-
-pprDests :: DestInfo -> SDoc
-pprDests NoDestInfo = text "NoDestInfo"
-pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
-
-
-pprStixStmts :: [StixStmt] -> SDoc
-pprStixStmts ts
- = vcat [
- vcat (map pprStixStmt ts),
- char ' ',
- char ' '
- ]
-
-
-pprStixExpr :: StixExpr -> SDoc
-pprStixExpr t
- = case t of
- StCLbl lbl -> pprCLabel lbl
- StInt i -> (if i < 0 then parens else id) (integer i)
- StFloat rat -> parens (text "Float" <+> rational rat)
- StDouble rat -> parens (text "Double" <+> rational rat)
- StString str -> parens (text "Str `" <> ftext str <> char '\'')
- StIndex k b o -> parens (pprStixExpr b <+> char '+' <>
- ppr k <+> pprStixExpr o)
- StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']'
- StReg reg -> pprStixReg reg
- StMachOp op args -> pprMachOp op
- <> parens (hsep (punctuate comma (map pprStixExpr args)))
- StCall fn cc k args
- -> parens (text "Call" <+> targ <+>
- ppr cc <+> ppr k <+>
- hsep (map pprStixExpr args))
- where
- targ = case fn of
- Left t_static -> ftext t_static
- Right t_dyn -> parens (pprStixExpr t_dyn)
-
-pprStixStmt :: StixStmt -> SDoc
-pprStixStmt t
- = case t of
- StSegment cseg -> parens (ppCodeSegment cseg)
- StComment str -> parens (text "Comment" <+> ftext str)
- StAssignReg pr reg rhs
- -> pprStixReg reg <> text " :=" <> ppr pr
- <> text " " <> pprStixExpr rhs
- StAssignMem pr addr rhs
- -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
- <> text " :=" <> ppr pr
- <> text " " <> pprStixExpr rhs
- StLabel ll -> pprCLabel ll <+> char ':'
- StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
- StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
- StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
- StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
- StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
- <+> pprStixExpr t)
- StData k ds -> parens (text "Data" <+> ppr k <+>
- hsep (map pprStixExpr ds))
- StDataString str -> parens (text "DataString" <+> ppr str)
- StVoidable expr -> text "(void)" <+> pprStixExpr expr
-\end{code}
-
-Stix registers can have two forms. They {\em may} or {\em may not}
-map to real, machine-level registers.
-
-\begin{code}
-data StixReg
- = StixMagicId MagicId -- Regs which are part of the abstract machine model
-
- | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in
- -- the abstract C.
-
-pprStixReg (StixMagicId mid) = ppMId mid
-pprStixReg (StixTemp temp) = pprStixVReg temp
-
-repOfStixReg (StixTemp (StixVReg u pr)) = pr
-repOfStixReg (StixMagicId mid) = magicIdPrimRep mid
-
-data StixVReg
- = StixVReg Unique PrimRep
-
-pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
-
-
-
-ppMId BaseReg = text "BaseReg"
-ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
- int (iBox n), char ')']
-ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
-ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')']
-ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
- int (iBox n), char ')']
-ppMId Sp = text "Sp"
-ppMId SpLim = text "SpLim"
-ppMId Hp = text "Hp"
-ppMId HpLim = text "HpLim"
-ppMId CurCostCentre = text "CCC"
-ppMId VoidReg = text "VoidReg"
-\end{code}
-
-We hope that every machine supports the idea of data segment and text
-segment (or that it has no segments at all, and we can lump these
-together).
-
-\begin{code}
-data CodeSegment
- = DataSegment
- | TextSegment
- | RoDataSegment
- deriving (Eq, Show)
-
-ppCodeSegment = text . show
-
-type StixStmtList = [StixStmt] -> [StixStmt]
-\end{code}
-
-Stix Trees for STG registers:
-\begin{code}
-stgBaseReg, stgNode, stgSp, stgSpLim, stgHp, stgHpLim :: StixReg
-
-stgBaseReg = StixMagicId BaseReg
-stgNode = StixMagicId node
-stgTagReg = StixMagicId tagreg
-stgSp = StixMagicId Sp
-stgSpLim = StixMagicId SpLim
-stgHp = StixMagicId Hp
-stgHpLim = StixMagicId HpLim
-stgHpAlloc = StixMagicId HpAlloc
-stgCurrentTSO = StixMagicId CurrentTSO
-stgCurrentNursery = StixMagicId CurrentNursery
-stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9))
-stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10))
-
-getNatLabelNCG :: NatM CLabel
-getNatLabelNCG
- = getUniqueNat `thenNat` \ u ->
- returnNat (mkAsmTempLabel u)
-
-getUniqLabelNCG :: UniqSM CLabel
-getUniqLabelNCG
- = getUniqueUs `thenUs` \ u ->
- returnUs (mkAsmTempLabel u)
-
-fixedHS = StInt (toInteger fixedHdrSize)
-arrWordsHS = StInt (toInteger arrWordsHdrSize)
-arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
-\end{code}
-
-Stix optimisation passes may wish to find out how many times a
-given temporary appears in a tree, so as to be able to decide
-whether or not to inline the assignment's RHS at usage site(s).
-
-\begin{code}
-stixExpr_CountTempUses :: Unique -> StixExpr -> Int
-stixExpr_CountTempUses u t
- = let qs = stixStmt_CountTempUses u
- qe = stixExpr_CountTempUses u
- qr = stixReg_CountTempUses u
- in
- case t of
- StReg reg -> qr reg
- StIndex pk t1 t2 -> qe t1 + qe t2
- StInd pk t1 -> qe t1
- StMachOp mop ts -> sum (map qe ts)
- StCall (Left nm) cconv pk ts -> sum (map qe ts)
- StCall (Right f) cconv pk ts -> sum (map qe ts) + qe f
- StInt _ -> 0
- StFloat _ -> 0
- StDouble _ -> 0
- StString _ -> 0
- StCLbl _ -> 0
-
-stixStmt_CountTempUses :: Unique -> StixStmt -> Int
-stixStmt_CountTempUses u t
- = let qe = stixExpr_CountTempUses u
- qr = stixReg_CountTempUses u
- qv = stixVReg_CountTempUses u
- in
- case t of
- StAssignReg pk reg rhs -> qr reg + qe rhs
- StAssignMem pk addr rhs -> qe addr + qe rhs
- StJump dsts t1 -> qe t1
- StCondJump lbl t1 -> qe t1
- StData pk ts -> sum (map qe ts)
- StVoidable expr -> qe expr
- StSegment _ -> 0
- StFunBegin _ -> 0
- StFunEnd _ -> 0
- StFallThrough _ -> 0
- StComment _ -> 0
- StLabel _ -> 0
- StDataString _ -> 0
-
-stixReg_CountTempUses u reg
- = case reg of
- StixTemp vreg -> stixVReg_CountTempUses u vreg
- StixMagicId mid -> 0
-
-stixVReg_CountTempUses u (StixVReg uu pr)
- = if u == uu then 1 else 0
-\end{code}
-
-If we do decide to inline a temporary binding, the following functions
-do the biz.
-
-\begin{code}
-stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
-stixStmt_Subst u new_u in_this_tree
- = stixStmt_MapUniques f in_this_tree
- where
- f :: Unique -> Maybe StixExpr
- f uu = if uu == u then Just new_u else Nothing
-
-
-stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
-stixExpr_MapUniques f t
- = let qe = stixExpr_MapUniques f
- qs = stixStmt_MapUniques f
- qr = stixReg_MapUniques f
- in
- case t of
- StReg reg -> case qr reg of
- Nothing -> StReg reg
- Just xx -> xx
- StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
- StInd pk t1 -> StInd pk (qe t1)
- StMachOp mop args -> StMachOp mop (map qe args)
- StCall (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
- StCall (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
- StInt _ -> t
- StFloat _ -> t
- StDouble _ -> t
- StString _ -> t
- StCLbl _ -> t
-
-stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
-stixStmt_MapUniques f t
- = let qe = stixExpr_MapUniques f
- qs = stixStmt_MapUniques f
- qr = stixReg_MapUniques f
- qv = stixVReg_MapUniques f
- in
- case t of
- StAssignReg pk reg rhs
- -> case qr reg of
- Nothing -> StAssignReg pk reg (qe rhs)
- Just xx -> panic "stixStmt_MapUniques:StAssignReg"
- StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs)
- StJump dsts t1 -> StJump dsts (qe t1)
- StCondJump lbl t1 -> StCondJump lbl (qe t1)
- StData pk ts -> StData pk (map qe ts)
- StVoidable expr -> StVoidable (qe expr)
- StSegment _ -> t
- StLabel _ -> t
- StFunBegin _ -> t
- StFunEnd _ -> t
- StFallThrough _ -> t
- StComment _ -> t
- StDataString _ -> t
-
-
-stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
-stixReg_MapUniques f reg
- = case reg of
- StixMagicId mid -> Nothing
- StixTemp vreg -> stixVReg_MapUniques f vreg
-
-stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
-stixVReg_MapUniques f (StixVReg uu pr)
- = f uu
-\end{code}
-
-\begin{code}
--- Lift StStrings out of top-level StDatas, putting them at the end of
--- the block, and replacing them with StCLbls which refer to the lifted-out strings.
-{- Motivation for this hackery provided by the following bug:
- Stix:
- (DataSegment)
- Bogon.ping_closure :
- (Data P_ Addr.A#_static_info)
- (Data StgAddr (Str `alalal'))
- (Data P_ (0))
- results in:
- .data
- .align 8
- .global Bogon_ping_closure
- Bogon_ping_closure:
- .long Addr_Azh_static_info
- .long .Ln1a8
- .Ln1a8:
- .byte 0x61
- .byte 0x6C
- .byte 0x61
- .byte 0x6C
- .byte 0x61
- .byte 0x6C
- .byte 0x00
- .long 0
- ie, the Str is planted in-line, when what we really meant was to place
- a _reference_ to the string there. liftStrings will lift out all such
- strings in top-level data and place them at the end of the block.
-
- This is still a rather half-baked solution -- to do the job entirely right
- would mean a complete traversal of all the Stixes, but there's currently no
- real need for it, and it would be slow. Also, potentially there could be
- literal types other than strings which need lifting out?
--}
-
-liftStrings :: [StixStmt] -> UniqSM [StixStmt]
-liftStrings stmts
- = liftStrings_wrk stmts [] []
-
-liftStrings_wrk :: [StixStmt] -- originals
- -> [StixStmt] -- (reverse) originals with strings lifted out
- -> [(CLabel, FastString)] -- lifted strs, and their new labels
- -> UniqSM [StixStmt]
-
--- First, examine the original trees and lift out strings in top-level StDatas.
-liftStrings_wrk (st:sts) acc_stix acc_strs
- = case st of
- StData sz datas
- -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
- liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
- other
- -> liftStrings_wrk sts (other:acc_stix) acc_strs
- where
- -- Handle a top-level StData
- lift [] acc_strs = returnUs ([], acc_strs)
- lift (d:ds) acc_strs
- = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
- case d of
- StString s
- -> getUniqueUs `thenUs` \ unq ->
- let lbl = mkAsmTempLabel unq in
- returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
- other
- -> returnUs (other:ds_done, acc_strs1)
-
--- When we've run out of original trees, emit the lifted strings.
-liftStrings_wrk [] acc_stix acc_strs
- = returnUs (reverse acc_stix ++ concatMap f acc_strs)
- where
- f (lbl,str) = [StSegment RoDataSegment,
- StLabel lbl,
- StDataString str,
- StSegment TextSegment]
-\end{code}
-
-The NCG's monad.
-
-The monad keeps a UniqSupply, the current stack delta and
-a list of imported entities, which is only used for
-Darwin (Mac OS X).
-
-\begin{code}
-data NatM_State = NatM_State UniqSupply Int [FastString]
-type NatM result = NatM_State -> (result, NatM_State)
-
-mkNatM_State :: UniqSupply -> Int -> NatM_State
-mkNatM_State us delta = NatM_State us delta []
-
-uniqOfNatM_State (NatM_State us delta imports) = us
-deltaOfNatM_State (NatM_State us delta imports) = delta
-importsOfNatM_State (NatM_State us delta imports) = imports
-
-initNat :: NatM_State -> NatM a -> (a, NatM_State)
-initNat init_st m = case m init_st of { (r,st) -> (r,st) }
-
-thenNat :: NatM a -> (a -> NatM b) -> NatM b
-thenNat expr cont st
- = case expr st of { (result, st') -> cont result st' }
-
-returnNat :: a -> NatM a
-returnNat result st = (result, st)
-
-mapNat :: (a -> NatM b) -> [a] -> NatM [b]
-mapNat f [] = returnNat []
-mapNat f (x:xs)
- = f x `thenNat` \ r ->
- mapNat f xs `thenNat` \ rs ->
- returnNat (r:rs)
-
-mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
-mapAndUnzipNat f [] = returnNat ([],[])
-mapAndUnzipNat f (x:xs)
- = f x `thenNat` \ (r1, r2) ->
- mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
- returnNat (r1:rs1, r2:rs2)
-
-mapAccumLNat :: (acc -> x -> NatM (acc, y))
- -> acc
- -> [x]
- -> NatM (acc, [y])
-
-mapAccumLNat f b []
- = returnNat (b, [])
-mapAccumLNat f b (x:xs)
- = f b x `thenNat` \ (b__2, x__2) ->
- mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
- returnNat (b__3, x__2:xs__2)
-
-
-getUniqueNat :: NatM Unique
-getUniqueNat (NatM_State us delta imports)
- = case splitUniqSupply us of
- (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports))
-
-getDeltaNat :: NatM Int
-getDeltaNat st@(NatM_State us delta imports)
- = (delta, st)
-
-setDeltaNat :: Int -> NatM ()
-setDeltaNat delta (NatM_State us _ imports)
- = ((), NatM_State us delta imports)
-
-addImportNat :: FastString -> NatM ()
-addImportNat imp (NatM_State us delta imports)
- = ((), NatM_State us delta (imp:imports))
-\end{code}
-
-Giving up in a not-too-inelegant way.
-
-\begin{code}
-ncgPrimopMoan :: String -> SDoc -> a
-ncgPrimopMoan msg pp_rep
- = unsafePerformIO (
- hPutStrLn stderr (
- "\n" ++
- "You've fallen across an unimplemented case in GHC's native code generation\n" ++
- "machinery. You can work around this for the time being by compiling\n" ++
- "this module via the C route, by giving the flag -fvia-C.\n" ++
- "The panic below contains information, intended for the GHC implementors,\n" ++
- "about the exact place where GHC gave up. Please send it to us\n" ++
- "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
- )
- )
- `seq`
- pprPanic msg pp_rep
-\end{code}
-
-Information about the target.
-
-\begin{code}
-
-ncg_target_is_32bit :: Bool
-ncg_target_is_32bit | wORD_SIZE == 4 = True
- | wORD_SIZE == 8 = False
-
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-
-\begin{code}
-module StixMacro ( macroCode, checkCode ) where
-
-#include "HsVersions.h"
-#include "nativeGen/NCG.h"
-
-import {-# SOURCE #-} StixPrim ( amodeToStix )
-
-import MachRegs
-import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) )
-import Constants ( uF_RET, uF_UPDATEE, uF_SIZE )
-import ForeignCall ( CCallConv(..) )
-import MachOp ( MachOp(..) )
-import PrimRep ( PrimRep(..) )
-import Stix
-import Panic ( panic )
-import UniqSupply ( returnUs, thenUs, UniqSM )
-import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
- mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
-\end{code}
---------------------------------------------------------------------------------
-The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
-the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
-not there. The @_LOAD_NODE@ version also loads R1 with an appropriate
-closure address.
-
-\begin{code}
-macroCode
- :: CStmtMacro -- statement macro
- -> [StixExpr] -- args
- -> UniqSM StixStmtList
-\end{code}
-
------------------------------------------------------------------------------
-Updating a CAF
-
-@UPD_CAF@ involves changing the info pointer of the closure, and
-adding an indirection.
-
-\begin{code}
-macroCode UPD_CAF [cafptr,bhptr]
- = let
- new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr])
- a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
- a2 = StAssignMem PtrRep cafptr ind_static_info
- in
- returnUs (\xs -> new_caf : a1 : a2 : xs)
-\end{code}
-
------------------------------------------------------------------------------
-Blackholing
-
-We do lazy blackholing: no need to overwrite thunks with blackholes
-the minute they're entered, as long as we do it before a context
-switch or garbage collection, that's ok.
-
-Don't blackhole single entry closures, for the following reasons:
-
- - if the compiler has decided that they won't be entered again,
- that probably means that nothing has a pointer to it
- (not necessarily true, but...)
-
- - no need to blackhole for concurrency reasons, because nothing
- can block on the result of this computation.
-
-\begin{code}
-macroCode UPD_BH_UPDATABLE args = returnUs id
-
-macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
-{-
- = let
- update = StAssign PtrRep (StInd PtrRep arg) bh_info
- in
- returnUs (\xs -> update : xs)
--}
-\end{code}
-
------------------------------------------------------------------------------
-Update frames
-
-Push an update frame on the stack.
-
-\begin{code}
-macroCode PUSH_UPD_FRAME [bhptr, _{-0-}]
- = let
- frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
-
- -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
- a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info
- a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
- in
- returnUs (\xs -> a1 : a4 : xs)
-\end{code}
-
------------------------------------------------------------------------------
-Setting the tag register
-
-This one only applies if we have a machine register devoted to TagReg.
-
-\begin{code}
-macroCode SET_TAG [tag]
- = case get_MagicId_reg_or_addr tagreg of
- Right baseRegAddr
- -> returnUs id
- Left realreg
- -> let a1 = StAssignReg IntRep (StixMagicId tagreg) tag
- in returnUs ( \xs -> a1 : xs )
-\end{code}
-
------------------------------------------------------------------------------
-
-\begin{code}
-macroCode REGISTER_IMPORT [arg]
- = returnUs (
- \xs -> StAssignMem WordRep (StReg stgSp) arg
- : StAssignReg PtrRep stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
- : xs
- )
-
-macroCode REGISTER_FOREIGN_EXPORT [arg]
- = returnUs (
- \xs -> StVoidable (
- StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep
- [arg]
- )
- : xs
- )
-
-macroCode other args
- = panic "StixMacro.macroCode"
-\end{code}
-
-Do the business for a @HEAP_CHK@, having converted the args to Trees
-of StixOp.
-
------------------------------------------------------------------------------
-Let's make sure that these CAFs are lifted out, shall we?
-
-\begin{code}
--- Some common labels
-
-bh_info, ind_static_info :: StixExpr
-
-bh_info = StCLbl mkBlackHoleInfoTableLabel
-ind_static_info = StCLbl mkIndStaticInfoLabel
-upd_frame_info = StCLbl mkUpdInfoLabel
-
--- Some common call trees
-\end{code}
-
------------------------------------------------------------------------------
-Heap/Stack checks
-
-\begin{code}
-checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
-checkCode macro args assts
- = getUniqLabelNCG `thenUs` \ ulbl_fail ->
- getUniqLabelNCG `thenUs` \ ulbl_pass ->
-
- let args_stix = map amodeToStix args
- newHp wds = StIndex PtrRep (StReg stgHp) wds
- assign_hp wds = StAssignReg PtrRep stgHp (newHp wds)
- hp_alloc wds = StAssignReg IntRep stgHpAlloc wds
- test_hp = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
- cjmp_hp = StCondJump ulbl_pass test_hp
- newSp wds = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
- test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
- test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
- cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
- cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
- assign_ret r ret = mkStAssign CodePtrRep r ret
-
- fail = StLabel ulbl_fail
- join = StLabel ulbl_pass
-
- -- see includes/StgMacros.h for explaination of these magic consts
- aLL_NON_PTRS = 0xff
-
- assign_liveness ptr_regs
- = StAssignReg WordRep stgR9
- (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
- assign_reentry reentry
- = StAssignReg WordRep stgR10 reentry
- in
-
- returnUs (
- case macro of
- HP_CHK_NP ->
- let [words] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_enter : join : xs))
-
- STK_CHK_NP ->
- let [words] = args_stix
- in (\xs -> cjmp_sp_pass words :
- assts (gc_enter : join : xs))
-
- HP_STK_CHK_NP ->
- let [sp_words,hp_words] = args_stix
- in (\xs -> cjmp_sp_fail sp_words :
- assign_hp hp_words : cjmp_hp :
- fail :
- assts (hp_alloc hp_words : gc_enter
- : join : xs))
-
- HP_CHK_FUN ->
- let [words] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_fun : join : xs))
-
- STK_CHK_FUN ->
- let [words] = args_stix
- in (\xs -> cjmp_sp_pass words :
- assts (gc_fun : join : xs))
-
- HP_STK_CHK_FUN ->
- let [sp_words,hp_words] = args_stix
- in (\xs -> cjmp_sp_fail sp_words :
- assign_hp hp_words : cjmp_hp :
- fail :
- assts (hp_alloc hp_words
- : gc_fun : join : xs))
-
- HP_CHK_NOREGS ->
- let [words] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_noregs : join : xs))
-
- HP_CHK_UNPT_R1 ->
- let [words] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_unpt_r1 : join : xs))
-
- HP_CHK_UNBX_R1 ->
- let [words] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_unbx_r1 : join : xs))
-
- HP_CHK_F1 ->
- let [words] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_f1 : join : xs))
-
- HP_CHK_D1 ->
- let [words] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_d1 : join : xs))
-
- HP_CHK_L1 ->
- let [words] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : gc_l1 : join : xs))
-
- HP_CHK_UNBX_TUPLE ->
- let [words,liveness] = args_stix
- in (\xs -> assign_hp words : cjmp_hp :
- assts (hp_alloc words : assign_liveness liveness :
- gc_ut : join : xs))
- )
-
--- Various canned heap-check routines
-
-mkStJump_to_GCentry_name :: String -> StixStmt
-mkStJump_to_GCentry_name gcname
--- | opt_Static
- = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
--- | otherwise -- it's in a different DLL
--- = StJump (StInd PtrRep (StLitLbl True sdoc))
-
-mkStJump_to_RegTable_offw :: Int -> StixStmt
-mkStJump_to_RegTable_offw regtable_offw
--- | opt_Static
- = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
--- | otherwise
--- do something plausible for cross-DLL jump
-
-gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
-gc_fun = mkStJump_to_RegTable_offw OFFSET_stgGCFun
-
-gc_noregs = mkStJump_to_GCentry_name "stg_gc_noregs"
-gc_unpt_r1 = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
-gc_unbx_r1 = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
-gc_f1 = mkStJump_to_GCentry_name "stg_gc_f1"
-gc_d1 = mkStJump_to_GCentry_name "stg_gc_d1"
-gc_l1 = mkStJump_to_GCentry_name "stg_gc_l1"
-gc_ut = mkStJump_to_GCentry_name "stg_gc_ut"
-\end{code}
+++ /dev/null
-_interface_ StixPrim 1
-_exports_
-StixPrim amodeToStix;
-_declarations_
-1 amodeToStix _:_ AbsCSyn.CAddrMode -> Stix.StixExpr ;;
+++ /dev/null
-__interface StixPrim 1 0 where
-__export StixPrim amodeToStix;
-1 amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixExpr ;
+++ /dev/null
-module StixPrim where
-
-amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixExpr
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-
-\begin{code}
-module StixPrim ( amodeToStix, amodeToStix', foreignCallCode )
-where
-
-#include "HsVersions.h"
-
--- import MachMisc
-import Stix
-
-import PprAbsC ( pprAmode )
-import AbsCSyn hiding ( spRel )
-import AbsCUtils ( getAmodeRep, mixedTypeLocn )
-import SMRep ( fixedHdrSize )
-import Literal ( Literal(..), word2IntLit )
-import MachOp ( MachOp(..) )
-import PrimRep ( PrimRep(..), getPrimRepSizeInBytes )
-import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
-import Constants ( mIN_INTLIKE, mIN_CHARLIKE, bLOCK_SIZE,
- rESERVED_STACK_WORDS )
-import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
- mkForeignLabel )
-import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
- CCallConv(..), playSafe, playThreadSafe )
-import Outputable
-import Util ( notNull )
-import FastString
-import FastTypes
-import Char
-
-#include "NCG.h"
-\end{code}
-
-The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts.
-
-\begin{code}
-foreignCallCode
- :: [CAddrMode] -- results
- -> ForeignCall -- op
- -> [CAddrMode] -- args
- -> UniqSM StixStmtList
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Code for foreign calls}
-%* *
-%************************************************************************
-
-First, the dreaded @ccall@.
-
-Usually, this compiles to an assignment, but when the left-hand side
-is empty, we just perform the call and ignore the result.
-
-ToDo: saving/restoring of volatile regs around ccalls.
-
-JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
-rather than inheriting the calling convention of the thing which we're really
-calling.
-
-\begin{code}
-foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
-
- | not (playSafe safety)
- = returnUs (\xs -> ccall : xs)
-
- | otherwise
- = save_thread_state `thenUs` \ save ->
- load_thread_state `thenUs` \ load ->
- getUniqueUs `thenUs` \ uniq ->
- let
- id = StixTemp (StixVReg uniq IntRep)
-
- is_threadSafe
- | playThreadSafe safety = 1
- | otherwise = 0
-
- suspend = StAssignReg IntRep id
- (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv
- IntRep [StReg stgBaseReg, StInt is_threadSafe ])
- resume = StVoidable
- (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv
- VoidRep [StReg id, StInt is_threadSafe ])
- in
- returnUs (\xs -> save (suspend : ccall : resume : load xs))
-
- where
- (cargs, stix_target)
- = case ctarget of
- StaticTarget nm -> (rhs, Left nm)
- DynamicTarget | notNull rhs -- an assertion
- -> (tail rhs, Right (amodeToStix (head rhs)))
-
- stix_args = map amodeToStix' cargs
-
- ccall = case lhs of
- [] -> StVoidable (StCall stix_target cconv VoidRep stix_args)
- [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
- where
- lhs' = amodeToStix lhs
- pk = case getAmodeRep lhs of
- FloatRep -> FloatRep
- DoubleRep -> DoubleRep
- Int64Rep -> Int64Rep
- Word64Rep -> Word64Rep
- other -> IntRep
-
--- a bit late to catch this here..
-foreignCallCode _ DNCall{} _
- = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Code for @CAddrMode@s}
-%* *
-%************************************************************************
-
-When a character is fetched from a mixed type location, we have to do
-an extra cast. This is reflected in amodeCode', which is for rhs
-amodes that might possibly need the extra cast.
-
-\begin{code}
-amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
-
-amodeToStix'{-'-} am@(CVal rr CharRep)
- | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
- | otherwise = amodeToStix am
-amodeToStix' am
- = amodeToStix am
-
------------
-amodeToStix am@(CVal rr CharRep)
- | mixedTypeLocn am
- = StInd IntRep (amodeToStix (CAddr rr))
-
-amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
-
-amodeToStix (CAddr (SpRel off))
- = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
-
-amodeToStix (CAddr (HpRel off))
- = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
-
-amodeToStix (CAddr (NodeRel off))
- = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
-
-amodeToStix (CAddr (CIndex base off pk))
- = StIndex pk (amodeToStix base) (amodeToStix off)
-
-amodeToStix (CReg magic) = StReg (StixMagicId magic)
-amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
-
-amodeToStix (CLbl lbl _) = StCLbl lbl
-
- -- For CharLike and IntLike, we attempt some trivial constant-folding here.
-
-amodeToStix (CCharLike (CLit (MachChar c)))
- = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
- where
- off = charLikeSize * (ord c - mIN_CHARLIKE)
-
-amodeToStix (CCharLike x)
- = panic "amodeToStix.CCharLike"
-
-amodeToStix (CIntLike (CLit (MachInt i)))
- = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
- where
- off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
-
-amodeToStix (CIntLike x)
- = panic "amodeToStix.CIntLike"
-
-amodeToStix (CLit core)
- = case core of
- MachChar c -> StInt (toInteger (ord c))
- MachStr s -> StString s
- MachNullAddr -> StInt 0
- MachInt i -> StInt i
- MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
- -- dreadful, but rare.
- MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
- MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
- MachFloat d -> StFloat d
- MachDouble d -> StDouble d
- _ -> panic "amodeToStix:core literal"
-
-amodeToStix (CMacroExpr _ macro [arg])
- = let
- arg_amode = amodeToStix arg
- in
- case macro of
- ENTRY_CODE -> arg_amode
- ARG_TAG -> arg_amode -- just an integer no. of words
- GET_TAG ->
-#ifdef WORDS_BIGENDIAN
- StMachOp MO_Nat_And
- [StInd WordRep (StIndex PtrRep arg_amode
- (StInt (toInteger (-1)))),
- StInt 65535]
-#else
- StMachOp MO_Nat_Shr
- [StInd WordRep (StIndex PtrRep arg_amode
- (StInt (toInteger (-1)))),
- StInt 16]
-#endif
- BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS
- PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS
- ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS)
-
-
-amodeToStix other
- = pprPanic "StixPrim.amodeToStix" (pprAmode other)
-\end{code}
-
-Sizes of the CharLike and IntLike closures that are arranged as arrays
-in the data segment. (These are in bytes.)
-
-\begin{code}
--- The INTLIKE base pointer
-
-iNTLIKE_closure :: StixExpr
-iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
-
--- The CHARLIKE base
-
-cHARLIKE_closure :: StixExpr
-cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
-
--- these are the sizes of charLike and intLike closures, in _bytes_.
-charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
-intLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
-\end{code}
-
-
-\begin{code}
-save_thread_state
- = getUniqueUs `thenUs` \ tso_uq ->
- let tso = StixTemp (StixVReg tso_uq PtrRep) in
- returnUs (\xs ->
- StAssignReg PtrRep tso (StReg stgCurrentTSO)
- : StAssignMem PtrRep
- (StMachOp MO_Nat_Add
- [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
- (StReg stgSp)
- : StAssignMem PtrRep
- (StMachOp MO_Nat_Add
- [StReg stgCurrentNursery,
- StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
- (StMachOp MO_Nat_Add
- [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
- : xs
- )
-
-load_thread_state
- = getUniqueUs `thenUs` \ tso_uq ->
- let tso = StixTemp (StixVReg tso_uq PtrRep) in
- returnUs (\xs ->
- StAssignReg PtrRep tso (StReg stgCurrentTSO)
- : StAssignReg PtrRep
- stgSp
- (StInd PtrRep
- (StMachOp MO_Nat_Add
- [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
- : StAssignReg PtrRep
- stgSpLim
- (StMachOp MO_Nat_Add
- [StReg tso,
- StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
- *BYTES_PER_WORD))])
- : StAssignReg PtrRep
- stgHp
- (StMachOp MO_Nat_Sub
- [StInd PtrRep
- (StMachOp MO_Nat_Add
- [StReg stgCurrentNursery,
- StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
- StInt (toInteger (1 * BYTES_PER_WORD))
- ])
- : StAssignReg PtrRep
- stgHpLim
- (StIndex Word8Rep
- (StInd PtrRep
- (StIndex PtrRep (StReg stgCurrentNursery)
- (StInt (toInteger BDESCR_START))
- )
- )
- (StMachOp MO_Nat_Sub
- [StMachOp MO_NatU_Mul
- [StInd WordRep
- (StIndex PtrRep (StReg stgCurrentNursery)
- (StInt (toInteger BDESCR_BLOCKS))),
- StInt (toInteger bLOCK_SIZE{-in bytes-})
- ],
- StInt (1 * BYTES_PER_WORD)
- ]
- )
-
- )
-
- : xs
- )
-\end{code}
, is_lower -- Char# -> Bool
, is_upper -- Char# -> Bool
, is_digit -- Char# -> Bool
+
+ , is_hexdigit, is_octdigit
+ , hexDigit, octDecDigit
) where
#include "HsVersions.h"
import DATA_INT ( Int32 )
import DATA_BITS ( Bits((.&.)) )
+import Char ( ord, chr )
\end{code}
Bit masks
is_digit = is_ctype cDigit
\end{code}
+Utils
+
+\begin{code}
+hexDigit :: Char -> Int
+hexDigit c | is_digit c = ord c - ord '0'
+ | otherwise = ord (to_lower c) - ord 'a' + 10
+
+octDecDigit :: Char -> Int
+octDecDigit c = ord c - ord '0'
+
+is_hexdigit c
+ = is_digit c
+ || (c >= 'a' && c <= 'f')
+ || (c >= 'A' && c <= 'F')
+
+is_octdigit c = c >= '0' && c <= '7'
+
+to_lower c
+ | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a'))
+ | otherwise = c
+\end{code}
+
We really mean .|. instead of + below, but GHC currently doesn't do
any constant folding with bitops. *sigh*
{
module Lexer (
- Token(..), lexer, mkPState,
+ Token(..), lexer, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
- failMsgP, failLocMsgP, failSpanMsgP, srcParseFail,
- popContext, pushCurrentContext,
+ failLocMsgP, failSpanMsgP, srcParseFail,
+ popContext, pushCurrentContext, setLastToken, setSrcLoc,
+ getLexState, popLexState, pushLexState
) where
#include "HsVersions.h"
import UniqFM
import CmdLineOpts
import Ctype
-import Util ( maybePrefixMatch )
+import Util ( maybePrefixMatch, readRational )
import DATA_BITS
import Char
-- single-line line pragmas, of the form
-- # <line> "<file>" <extra-stuff> \n
-<line_prag1> $digit+ { set_line line_prag1a }
-<line_prag1a> \" [$graphic \ ]* \" { set_file line_prag1b }
+<line_prag1> $digit+ { setLine line_prag1a }
+<line_prag1a> \" [$graphic \ ]* \" { setFile line_prag1b }
<line_prag1b> .* { pop }
-- Haskell-style line pragmas, of the form
-- {-# LINE <line> "<file>" #-}
-<line_prag2> $digit+ { set_line line_prag2a }
-<line_prag2a> \" [$graphic \ ]* \" { set_file line_prag2b }
+<line_prag2> $digit+ { setLine line_prag2a }
+<line_prag2a> \" [$graphic \ ]* \" { setFile line_prag2b }
<line_prag2b> "#-}"|"-}" { pop }
-- NOTE: accept -} at the end of a LINE pragma, for compatibility
-- with older versions of GHC which generated these.
fs = lexemeToFastString buf len
tok_decimal span buf len
- = return (L span (ITinteger $! parseInteger buf len 10 oct_or_dec))
+ = return (L span (ITinteger $! parseInteger buf len 10 octDecDigit))
tok_octal span buf len
- = return (L span (ITinteger $! parseInteger (stepOnBy 2 buf) (len-2) 8 oct_or_dec))
+ = return (L span (ITinteger $! parseInteger (stepOnBy 2 buf) (len-2) 8 octDecDigit))
tok_hexadecimal span buf len
- = return (L span (ITinteger $! parseInteger (stepOnBy 2 buf) (len-2) 16 hex))
+ = return (L span (ITinteger $! parseInteger (stepOnBy 2 buf) (len-2) 16 hexDigit))
prim_decimal span buf len
- = return (L span (ITprimint $! parseInteger buf (len-1) 10 oct_or_dec))
+ = return (L span (ITprimint $! parseInteger buf (len-1) 10 octDecDigit))
prim_octal span buf len
- = return (L span (ITprimint $! parseInteger (stepOnBy 2 buf) (len-3) 8 oct_or_dec))
+ = return (L span (ITprimint $! parseInteger (stepOnBy 2 buf) (len-3) 8 octDecDigit))
prim_hexadecimal span buf len
- = return (L span (ITprimint $! parseInteger (stepOnBy 2 buf) (len-3) 16 hex))
+ = return (L span (ITprimint $! parseInteger (stepOnBy 2 buf) (len-3) 16 hexDigit))
-tok_float str = ITrational $! readRational__ str
-prim_float str = ITprimfloat $! readRational__ str
-prim_double str = ITprimdouble $! readRational__ str
-
-parseInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer
-parseInteger buf len radix to_int
- = go 0 0
- where go i x | i == len = x
- | otherwise = go (i+1) (x * radix + toInteger (to_int (lookAhead buf i)))
+tok_float str = ITrational $! readRational str
+prim_float str = ITprimfloat $! readRational str
+prim_double str = ITprimdouble $! readRational str
-- -----------------------------------------------------------------------------
-- Layout processing
-- -----------------------------------------------------------------------------
-- LINE pragmas
-set_line :: Int -> Action
-set_line code span buf len = do
- let line = parseInteger buf len 10 oct_or_dec
+setLine :: Int -> Action
+setLine code span buf len = do
+ let line = parseInteger buf len 10 octDecDigit
setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
-- subtract one: the line number refers to the *following* line
popLexState
pushLexState code
lexToken
-set_file :: Int -> Action
-set_file code span buf len = do
+setFile :: Int -> Action
+setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
popLexState
then return (chr (ord c - ord '@'))
else lit_error
- 'x' -> readNum is_hexdigit 16 hex
- 'o' -> readNum is_octdigit 8 oct_or_dec
- x | is_digit x -> readNum2 is_digit 10 oct_or_dec (oct_or_dec x)
+ 'x' -> readNum is_hexdigit 16 hexDigit
+ 'o' -> readNum is_octdigit 8 octDecDigit
+ x | is_digit x -> readNum2 is_digit 10 octDecDigit (octDecDigit x)
c1 -> do
i <- getInput
then return (chr i)
else lit_error
-is_hexdigit c
- = is_digit c
- || (c >= 'a' && c <= 'f')
- || (c >= 'A' && c <= 'F')
-
-hex c | is_digit c = ord c - ord '0'
- | otherwise = ord (to_lower c) - ord 'a' + 10
-
-oct_or_dec c = ord c - ord '0'
-
-is_octdigit c = c >= '0' && c <= '7'
-
-to_lower c
- | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a'))
- | otherwise = c
-
silly_escape_chars = [
("NUL", '\NUL'),
("SOH", '\SOH'),
Just (c,i) -> do setInput i; return c
-- -----------------------------------------------------------------------------
--- Floats
-
-readRational :: ReadS Rational -- NB: doesn't handle leading "-"
-readRational r = do
- (n,d,s) <- readFix r
- (k,t) <- readExp s
- return ((n%1)*10^^(k-d), t)
- where
- readFix r = do
- (ds,s) <- lexDecDigits r
- (ds',t) <- lexDotDigits s
- return (read (ds++ds'), length ds', t)
-
- readExp (e:s) | e `elem` "eE" = readExp' s
- readExp s = return (0,s)
-
- readExp' ('+':s) = readDec s
- readExp' ('-':s) = do
- (k,t) <- readDec s
- return (-k,t)
- readExp' s = readDec s
-
- readDec s = do
- (ds,r) <- nonnull isDigit s
- return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
- r)
-
- lexDecDigits = nonnull isDigit
-
- lexDotDigits ('.':s) = return (span isDigit s)
- lexDotDigits s = return ("",s)
-
- nonnull p s = do (cs@(_:_),t) <- return (span p s)
- return (cs,t)
-
-readRational__ :: String -> Rational -- NB: *does* handle a leading "-"
-readRational__ top_s
- = case top_s of
- '-' : xs -> - (read_me xs)
- xs -> read_me xs
- where
- read_me s
- = case (do { (x,"") <- readRational s ; return x }) of
- [x] -> x
- [] -> error ("readRational__: no parse:" ++ top_s)
- _ -> error ("readRational__: ambiguous parse:" ++ top_s)
-
--- -----------------------------------------------------------------------------
-- The Parse Monad
data LayoutContext
lex_state :: [Int]
}
-- last_loc and last_len are used when generating error messages,
- -- and in pushCurrentContext only.
+ -- and in pushCurrentContext only. Sigh, if only Happy passed the
+ -- current token to happyError, we could at least get rid of last_len.
+ -- Getting rid of last_loc would require finding another way to
+ -- implement pushCurrentContext (which is only called from one place).
newtype P a = P { unP :: PState -> ParseResult a }
-- detected during parsing.
srcParseFail :: P a
srcParseFail = P $ \PState{ buffer = buf, last_len = len,
- last_loc = last_loc, loc = loc } ->
+ last_loc = last_loc } ->
PFailed last_loc (srcParseErr buf len)
-- A lexical error is reported at a particular position in the source file,
import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
import Type ( funTyCon )
-import ForeignCall ( Safety(..), CExportSpec(..),
+import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
CCallConv(..), CCallTarget(..), defaultCCallConv
)
import OccName ( UserFS, varName, dataName, tcClsName, tvName )
import Bag ( emptyBag )
import Panic
-import CStrings ( CLabelString )
import FastString
import Maybes ( orElse )
import Outputable
import HscTypes ( GenAvailInfo(..) )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
- DNCallSpec(..), DNKind(..))
+ DNCallSpec(..), DNKind(..), CLabelString )
import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
occNameUserString, isValOcc )
import BasicTypes ( initialVersion, StrictnessMark(..) )
import Module ( ModuleName )
import SrcLoc
-import CStrings ( CLabelString )
import CmdLineOpts ( opt_InPackage )
import OrdList ( OrdList, fromOL )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
-{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
-{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
ForeignCall(..),
Safety(..), playSafe, playThreadSafe,
- CExportSpec(..),
+ CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
CCallSpec(..),
CCallTarget(..), isDynamicTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
#include "HsVersions.h"
-import CStrings ( CLabelString, pprCLabelString )
-import FastString ( FastString )
+import FastString ( FastString, unpackFS )
+import Char ( isAlphaNum )
import Binary
import Outputable
\end{code}
ccallConvAttribute CCallConv = ""
\end{code}
+\begin{code}
+type CLabelString = FastString -- A C label, completely unencoded
+
+pprCLabelString :: CLabelString -> SDoc
+pprCLabelString lbl = ftext lbl
+
+isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
+isCLabelString lbl
+ = all ok (unpackFS lbl)
+ where
+ ok c = isAlphaNum c || c == '_' || c == '.'
+ -- The '.' appears in e.g. "foo.so" in the
+ -- module part of a ExtName. Maybe it should be separate
+\end{code}
+
+
Printing into C files:
\begin{code}
#include "HsVersions.h"
-import PrimRep -- most of it
import TysPrim
import TysWiredIn
import NewDemand
import Var ( TyVar )
import OccName ( OccName, pprOccName, mkVarOcc )
-import TyCon ( TyCon, isPrimTyCon, tyConPrimRep )
-import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, tyConAppTyCon )
+import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) )
+import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon,
+ typePrimRep )
import BasicTypes ( Arity, Boxity(..) )
import Outputable
import FastTypes
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992-1998
-%
-\section[PrimRep]{Primitive machine-level kinds of things.}
-
-At various places in the back end, we want to be to tag things with a
-``primitive kind''---i.e., the machine-manipulable implementation
-types.
-
-\begin{code}
-module PrimRep (
- PrimRep(..),
- separateByPtrFollowness,
- isFollowableRep,
- isFloatingRep,
- isNonPtrRep,
- is64BitRep,
- getPrimRepSize,
- getPrimRepSizeInBytes,
- retPrimRepSize,
-
- ArgRep(..), primRepToArgRep,
- ) where
-
-#include "HsVersions.h"
-
-import Constants ( dOUBLE_SIZE, iNT64_SIZE, wORD64_SIZE, wORD_SIZE )
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrimRep-datatype]{The @PrimRep@ datatype}
-%* *
-%************************************************************************
-
-These pretty much correspond to the C types declared in StgTypes.h.
-
-\begin{code}
-data PrimRep
- = -- These pointer-kinds are all really the same, but we keep
- -- them separate for documentation purposes.
- PtrRep -- Pointer to a closure; a ``word''.
- | CodePtrRep -- Pointer to code
- | DataPtrRep -- Pointer to data
- | RetRep -- Pointer to code or data (return vector or code pointer)
- | CostCentreRep -- Pointer to a cost centre
-
- | CharRep -- Machine characters
- | IntRep -- signed integers (same size as ptr on this arch)
- | WordRep -- unsigned integers (same size as ptr on this arch)
- | AddrRep -- addresses (C pointers)
- | FloatRep -- floats
- | DoubleRep -- doubles
-
- | Int8Rep -- 8 bit signed integers
- | Int16Rep -- 16 bit signed integers
- | Int32Rep -- 32 bit signed integers
- | Int64Rep -- 64 bit signed integers
- | Word8Rep -- 8 bit unsigned integers
- | Word16Rep -- 16 bit unsigned integers
- | Word32Rep -- 32 bit unsigned integers
- | Word64Rep -- 64 bit unsigned integers
-
- | StablePtrRep -- guaranteed to be represented by a pointer
-
- | VoidRep -- Occupies no space at all!
- -- (Primitive states are mapped onto this)
- deriving (Eq, Ord)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[PrimRep-predicates]{Follow-ness, sizes, and such---on @PrimitiveKinds@}
-%* *
-%************************************************************************
-
-Whether or not the thing is a pointer that the garbage-collector
-should follow. Or, to put it another (less confusing) way, whether
-the object in question is a heap object.
-
-Depending on the outcome, this predicate determines what stack
-the pointer/object possibly will have to be saved onto, and the
-computation of GC liveness info.
-
-\begin{code}
-isFollowableRep :: PrimRep -> Bool -- True <=> points to a heap object
-isFollowableRep PtrRep = True
-isFollowableRep other = False
-
-separateByPtrFollowness :: (a -> PrimRep) -> [a] -> ([a], [a])
-separateByPtrFollowness kind_fun things
- = sep_things kind_fun things [] []
- -- accumulating params for follow-able and don't-follow things...
- where
- sep_things kfun [] bs us = (reverse bs, reverse us)
- sep_things kfun (t:ts) bs us
- = if (isFollowableRep . kfun) t then
- sep_things kfun ts (t:bs) us
- else
- sep_things kfun ts bs (t:us)
-\end{code}
-
-@isFloatingRep@ is used to distinguish @Double@ and @Float@ which
-cause inadvertent numeric conversions if you aren't jolly careful.
-See codeGen/CgCon:cgTopRhsCon.
-
-\begin{code}
-isFloatingRep :: PrimRep -> Bool
-isFloatingRep DoubleRep = True
-isFloatingRep FloatRep = True
-isFloatingRep _ = False
-\end{code}
-
-Identify anything which is one word large and not a pointer.
-
-\begin{code}
-isNonPtrRep :: PrimRep -> Bool
-isNonPtrRep PtrRep = False
-isNonPtrRep VoidRep = False
-isNonPtrRep r = not (isFloatingRep r) && not (is64BitRep r)
-\end{code}
-
-\begin{code}
-is64BitRep :: PrimRep -> Bool
-is64BitRep Int64Rep = True
-is64BitRep Word64Rep = True
-is64BitRep _ = False
-
--- Size in words.
-
-getPrimRepSize :: PrimRep -> Int
-getPrimRepSize DoubleRep = dOUBLE_SIZE
-getPrimRepSize Word64Rep = wORD64_SIZE
-getPrimRepSize Int64Rep = iNT64_SIZE
-getPrimRepSize VoidRep = 0
-getPrimRepSize _ = 1
-
-retPrimRepSize :: Int
-retPrimRepSize = getPrimRepSize RetRep
-
--- Sizes in bytes. (used in some settings to figure out how many
--- bytes we have to push onto the stack when calling external entry
--- points (e.g., stdcalling on win32)
-
--- Note: the "size in bytes" is also the scaling factor used when we
--- have an array of these things. For example, a ByteArray# of
--- Int16Rep will use a scaling factor of 2 when accessing the
--- elements.
-
-getPrimRepSizeInBytes :: PrimRep -> Int
-getPrimRepSizeInBytes PtrRep = wORD_SIZE
-getPrimRepSizeInBytes CodePtrRep = wORD_SIZE
-getPrimRepSizeInBytes DataPtrRep = wORD_SIZE
-getPrimRepSizeInBytes RetRep = wORD_SIZE
-getPrimRepSizeInBytes CostCentreRep = wORD_SIZE
-getPrimRepSizeInBytes CharRep = 4
-getPrimRepSizeInBytes IntRep = wORD_SIZE
-getPrimRepSizeInBytes WordRep = wORD_SIZE
-getPrimRepSizeInBytes AddrRep = wORD_SIZE
-getPrimRepSizeInBytes FloatRep = wORD_SIZE
-getPrimRepSizeInBytes DoubleRep = dOUBLE_SIZE * wORD_SIZE
-getPrimRepSizeInBytes Int8Rep = 1
-getPrimRepSizeInBytes Int16Rep = 2
-getPrimRepSizeInBytes Int32Rep = 4
-getPrimRepSizeInBytes Int64Rep = 8
-getPrimRepSizeInBytes Word8Rep = 1
-getPrimRepSizeInBytes Word16Rep = 2
-getPrimRepSizeInBytes Word32Rep = 4
-getPrimRepSizeInBytes Word64Rep = 8
-getPrimRepSizeInBytes StablePtrRep = wORD_SIZE
-getPrimRepSizeInBytes other = pprPanic "getPrimRepSizeInBytes" (ppr other)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{ArgReps}
-%* *
-%************************************************************************
-
-An ArgRep is similar to a PrimRep, except that it is slightly
-narrower. It corresponds to the distinctions we make between
-different type of function arguments for the purposes of a function's
-calling convention. These reps are used to decide which of the RTS's
-generic apply functions to call when applying an unknown function.
-
-All 64-bit PrimReps map to the same ArgRep, because they're passed in
-the same register, but a PtrRep is still different from an IntRep
-(RepP vs. RepN respectively) because the function's entry convention
-has to take into account the pointer-hood of arguments for the
-purposes of describing the stack on entry to the garbage collector.
-
-\begin{code}
-data ArgRep = RepV | RepP | RepN | RepF | RepD | RepL
-
-primRepToArgRep VoidRep = RepV
-primRepToArgRep FloatRep = RepF
-primRepToArgRep DoubleRep = RepD
-primRepToArgRep r
- | isFollowableRep r = RepP
- | is64BitRep r = RepL
- | otherwise = ASSERT(getPrimRepSize r == 1) RepN
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrimRep-instances]{Boring instance decls for @PrimRep@}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable PrimRep where
- ppr kind = text (showPrimRep kind)
-
-showPrimRep :: PrimRep -> String
-showPrimRep PtrRep = "P_" -- short for StgPtr
-showPrimRep CodePtrRep = "P_" -- DEATH to StgFunPtr! (94/02/22 WDP)
-showPrimRep DataPtrRep = "D_"
-showPrimRep RetRep = "P_"
-showPrimRep CostCentreRep = "CostCentre"
-showPrimRep CharRep = "C_"
-showPrimRep Int8Rep = "StgInt8"
-showPrimRep Int16Rep = "StgInt16"
-showPrimRep Int32Rep = "StgInt32"
-showPrimRep Word8Rep = "StgWord8"
-showPrimRep Word16Rep = "StgWord16"
-showPrimRep Word32Rep = "StgWord32"
-showPrimRep IntRep = "I_" -- short for StgInt
-showPrimRep WordRep = "W_" -- short for StgWord
-showPrimRep Int64Rep = "LI_" -- short for StgLongInt
-showPrimRep Word64Rep = "LW_" -- short for StgLongWord
-showPrimRep AddrRep = "StgAddr"
-showPrimRep FloatRep = "StgFloat"
-showPrimRep DoubleRep = "StgDouble"
-showPrimRep StablePtrRep = "StgStablePtr"
-showPrimRep VoidRep = "!!VOID_KIND!!"
-\end{code}
-
-
import Var ( TyVar, mkTyVar )
import Name ( Name, mkInternalName, mkWiredInName )
import OccName ( mkVarOcc, mkOccFS, tcName )
-import PrimRep ( PrimRep(..) )
-import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon )
+import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon,
+ PrimRep(..) )
import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
unliftedTypeKind, liftedTypeKind, openTypeKind,
Kind, mkArrowKinds,
result_kind = unliftedTypeKind -- all primitive types are unlifted
charPrimTy = mkTyConTy charPrimTyCon
-charPrimTyCon = pcPrimTyCon0 charPrimTyConName CharRep
+charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep
intPrimTy = mkTyConTy intPrimTyCon
intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep
int32PrimTy = mkTyConTy int32PrimTyCon
-int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName Int32Rep
+int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName IntRep
int64PrimTy = mkTyConTy int64PrimTyCon
int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep
wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep
word32PrimTy = mkTyConTy word32PrimTyCon
-word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName Word32Rep
+word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName WordRep
word64PrimTy = mkTyConTy word64PrimTyCon
word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep
\end{code}
RealWorld is deeply magical. It is *primitive*, but it is not
-*unlifted* (hence PtrRep). We never manipulate values of type
+*unlifted* (hence ptrArg). We never manipulate values of type
RealWorld; it's only used in the type system, to parameterise State#.
\begin{code}
%************************************************************************
\begin{code}
-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP StablePtrRep
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP AddrRep
mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
\end{code}
noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
noCostCentre, noCCAttached,
noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
- isDerivedFromCurrentCCS,
+ isDerivedFromCurrentCCS, maybeSingletonCCS,
+ decomposeCCS,
mkUserCC, mkAutoCC, mkAllCafsCC,
mkSingletonCCS, dupifyCC, pushCCOnCCS,
- isCafCCS,
+ isCafCCS, isCafCC,
isSccCountCostCentre,
sccAbleCostCentre,
ccFromThisModule,
- pprCostCentreDecl, pprCostCentreStackDecl, pprCostCentreCore,
+ pprCostCentreCore,
+ costCentreUserName,
cmpCostCentre -- used for removing dups in a list
) where
import Name ( UserFS, EncodedFS, encodeFS, decode,
getOccName, occNameFS
)
-import Module ( Module, ModuleName, moduleName,
- moduleNameUserString
- )
+import Module ( Module, ModuleName, moduleName )
import Outputable
-import CStrings ( pprStringInCStyle )
import FastTypes
import FastString
import Util ( thenCmp )
currentOrSubsumedCCS SubsumedCCS = True
currentOrSubsumedCCS CurrentCCS = True
currentOrSubsumedCCS _ = False
+
+maybeSingletonCCS (PushCC cc NoCCS) = Just cc
+maybeSingletonCCS _ = Nothing
\end{code}
Building cost centres
dupifyCC cc = cc {cc_is_dupd = DupdCC}
-isEmptyCC, isCafCC, isDupdCC :: CostCentre -> Bool
-
-isEmptyCC (NoCostCentre) = True
-isEmptyCC _ = False
+isCafCC, isDupdCC :: CostCentre -> Bool
isCafCC (AllCafsCC {}) = True
isCafCC (NormalCC {cc_is_caf = CafCC}) = True
cmp_caf NotCafCC NotCafCC = EQ
cmp_caf CafCC CafCC = EQ
cmp_caf CafCC NotCafCC = GT
+
+decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack)
+decomposeCCS (PushCC cc ccs) = (cc:more, ccs')
+ where (more,ccs') = decomposeCCS ccs
+decomposeCCS ccs = ([],ccs)
\end{code}
-----------------------------------------------------------------------------
ppr SubsumedCCS = ptext SLIT("CCS_SUBSUMED")
ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
ppr (PushCC cc ccs) = ptext SLIT("PushCostCentre") <>
- parens (ppr ccs <> comma <> ppr cc)
-
--- print the static declaration for a singleton CCS.
-pprCostCentreStackDecl :: CostCentreStack -> SDoc
-pprCostCentreStackDecl ccs@(PushCC cc NoCCS)
- = hcat [ ptext SLIT("CCS_DECLARE"), char '(',
- ppr ccs, comma, -- better be codeStyle
- ppCostCentreLbl cc, comma,
- empty, -- Now always externally visible
- text ");"
- ]
-
-pprCostCentreStackDecl ccs
- = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
+ parens (ppr ccs <> comma <>
+ parens(ptext SLIT("void *")) <> ppr cc)
\end{code}
-----------------------------------------------------------------------------
costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf})
= case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (unpackFS name)
\end{code}
-
-Cost Centre Declarations
-
-\begin{code}
-#ifdef DEBUG
-pprCostCentreDecl is_local (NoCostCentre)
- = panic "pprCostCentreDecl: no cost centre!"
-#endif
-pprCostCentreDecl is_local cc
- = if is_local then
- hcat [
- ptext SLIT("CC_DECLARE"),char '(',
- cc_ident, comma,
- pprStringInCStyle (costCentreUserName cc), comma,
- pprStringInCStyle (moduleNameUserString mod_name), comma,
- is_subsumed, comma,
- empty, -- Now always externally visible
- text ");"]
- else
- hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
- where
- cc_ident = ppCostCentreLbl cc
- mod_name = cc_mod cc
- is_subsumed = ccSubsumed cc
-
-ccSubsumed :: CostCentre -> SDoc -- subsumed value
-ccSubsumed cc | isCafCC cc = ptext SLIT("CC_IS_CAF")
- | otherwise = ptext SLIT("CC_IS_BORING")
-\end{code}
, tcForeignExports
) where
-#include "config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import HsSyn
toDNType
)
import ForeignCall ( CExportSpec(..), CCallTarget(..),
+ CLabelString, isCLabelString,
isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
-import CStrings ( CLabelString, isCLabelString )
+import MachOp ( machRepByteWidth )
import PrelNames ( hasKey, ioTyConKey )
import CmdLineOpts ( dopt_HscLang, HscLang(..) )
import Outputable
#include "nativeGen/NCG.h"
#if alpha_TARGET_ARCH
checkFEDArgs arg_tys
- = check (integral_args <= 4) err
+ = check (integral_args <= 32) err
where
- integral_args = sum (map getPrimRepSize $
- filter (not . isFloatingRep) $
- map typePrimRep arg_tys)
+ integral_args = sum [ machRepByteWidth rep
+ | (rep,hint) <- map typeMachRepRep arg_tys,
+ hint /= FloatHint ]
err = ptext SLIT("On Alpha, I can only handle 4 non-floating-point arguments to foreign export dynamic")
#else
checkFEDArgs arg_tys = returnM ()
import TysWiredIn ( charTy, stringTy, intTy,
mkListTy, mkPArrTy, mkTupleTy, unitTy,
voidTy, listTyCon, tupleTyCon )
-import TyCon ( mkPrimTyCon, tyConKind )
+import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) )
import Kind ( splitKindFunTys )
-import PrimRep ( PrimRep(VoidRep) )
import Name ( getOccName, mkInternalName, mkDerivedTyConOcc )
import Var ( Var, isId, isLocalVar, tyVarKind )
import VarSet
-- accumulated, but never consulted until the end.
-- Nevertheless, it's convenient to accumulate them along
-- with the rest of the info from this module.
- tcg_exports :: NameSet, -- What is exported
- tcg_imports :: ImportAvails, -- Information about what was imported
- -- from where, including things bound
- -- in this module
+ tcg_exports :: NameSet, -- What is exported
+ tcg_imports :: ImportAvails, -- Information about what was imported
+ -- from where, including things bound
+ -- in this module
tcg_dus :: DefUses, -- What is defined in this module and what is used.
-- The latter is used to generate
module TyCon(
TyCon, ArgVrcs,
+ PrimRep(..),
+ tyConPrimRep,
+
AlgTyConRhs(..), visibleDataCons,
isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAbstractTyCon,
algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
tyConSelIds,
tyConTheta,
- tyConPrimRep,
tyConArity,
isClassTyCon, tyConClass_maybe,
getSynTyConDefn,
import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed )
import Name ( Name, nameUnique, NamedThing(getName) )
import PrelNames ( Unique, Uniquable(..) )
-import PrimRep ( PrimRep(..) )
import Maybes ( orElse )
import Outputable
import FastString
| PrimTyCon { -- Primitive types; cannot be defined in Haskell
-- Now includes foreign-imported types
- tyConUnique :: Unique,
- tyConName :: Name,
- tyConKind :: Kind,
- tyConArity :: Arity,
- argVrcs :: ArgVrcs,
- primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are
- -- boxed (represented by pointers). The PrimRep tells.
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind,
+ tyConArity :: Arity,
+ argVrcs :: ArgVrcs,
+
+ primTyConRep :: PrimRep,
+ -- Many primitive tycons are unboxed, but some are
+ -- boxed (represented by pointers). The CgRep tells.
isUnLifted :: Bool, -- Most primitive tycons are unlifted,
-- but foreign-imported ones may not be
visibleDataCons (NewTyCon c _ _) = [c]
\end{code}
+%************************************************************************
+%* *
+\subsection{PrimRep}
+%* *
+%************************************************************************
+
+A PrimRep is an abstraction of a type. It contains information that
+the code generator needs in order to pass arguments, return results,
+and store values of this type.
+
+A PrimRep is somewhat similar to a CgRep (see codeGen/SMRep) and a
+MachRep (see cmm/MachOp), although each of these types has a distinct
+and clearly defined purpose:
+
+ - A PrimRep is a CgRep + information about signedness + information
+ about primitive pointers (AddrRep). Signedness and primitive
+ pointers are required when passing a primitive type to a foreign
+ function, but aren't needed for call/return conventions of Haskell
+ functions.
+
+ - A MachRep is a basic machine type (non-void, doesn't contain
+ information on pointerhood or signedness, but contains some
+ reps that don't have corresponding Haskell types).
+
+\begin{code}
+data PrimRep
+ = VoidRep
+ | PtrRep
+ | IntRep -- signed, word-sized
+ | WordRep -- unsinged, word-sized
+ | Int64Rep -- signed, 64 bit (32-bit words only)
+ | Word64Rep -- unsigned, 64 bit (32-bit words only)
+ | AddrRep -- a pointer, but not to a Haskell value
+ | FloatRep
+ | DoubleRep
+\end{code}
%************************************************************************
%* *
-- as primitive, but *lifted*, TyCons for now. They are lifted
-- because the Haskell type T representing the (foreign) .NET
-- type T is actually implemented (in ILX) as a thunk<T>
--- They have PtrRep
mkForeignTyCon name ext_name kind arity arg_vrcs
= PrimTyCon {
tyConName = name,
tyConKind = kind,
tyConArity = arity,
argVrcs = arg_vrcs,
- primTyConRep = PtrRep,
+ primTyConRep = PtrRep, -- they all do
isUnLifted = False,
tyConExtName = ext_name
}
newTyConRhs :: TyCon -> ([TyVar], Type)
newTyConRhs (AlgTyCon {tyConTyVars = tvs, algRhs = NewTyCon _ rhs _}) = (tvs, rhs)
+\end{code}
+\begin{code}
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
-tyConPrimRep tc = ASSERT( not (isUnboxedTupleTyCon tc) )
- PtrRep
- -- We should not be asking what the representation of an
- -- unboxed tuple is, because it isn't a first class value.
+tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep
\end{code}
\begin{code}
-- Re-exports from Kind
module Kind,
+ -- Re-exports from TyCon
+ PrimRep(..),
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
isAlgTyCon, isSynTyCon, tyConArity,
- tyConKind, getSynTyConDefn,
- tyConPrimRep,
+ tyConKind, getSynTyConDefn, PrimRep(..), tyConPrimRep,
)
-- others
import CmdLineOpts ( opt_DictsStrict )
import SrcLoc ( noSrcLoc )
-import PrimRep ( PrimRep(..) )
import Unique ( Uniquable(..) )
import Util ( mapAccumL, seqList, lengthIs, snocView )
import Outputable
repType ty = ty
+-- ToDo: this could be moved to the code generator, using splitTyConApp instead
+-- of inspecting the type directly.
typePrimRep :: Type -> PrimRep
typePrimRep ty = case repType ty of
TyConApp tc _ -> tyConPrimRep tc
FunTy _ _ -> PtrRep
- AppTy _ _ -> PtrRep -- ??
+ AppTy _ _ -> PtrRep -- See note below
TyVarTy _ -> PtrRep
other -> pprPanic "typePrimRep" (ppr ty)
+ -- Types of the form 'f a' must be of kind *, not *#, so
+ -- we are guaranteed that they are represented by pointers.
+ -- The reason is that f must have kind *->*, not *->*#, because
+ -- (we claim) there is no way to constrain f's kind any other
+ -- way.
-- new_type_rep doesn't ask any questions:
-- it just expands newtype, whether recursive or not
\end{code}
-
---------------------------------------------------------------------
ForAllTy
~~~~~~~~
%
\section{Fast strings}
-Compact representations of character strings with
-unique identifiers (hash-cons'ish).
+FastString: A compact, hash-consed, representation of character strings.
+ Comparison is O(1), and you can get a Unique from them.
+ Generated by the FSLIT macro
+ Turn into SDoc with Outputable.ftext
+
+LitString: Just a wrapper for the Addr# of a C string (Ptr CChar).
+ Practically no operations
+ Outputing them is fast
+ Generated by the SLIT macro
+ Turn into SDoc with Outputable.ptext
+
+Use LitString unless you want the facilities of FastString
\begin{code}
module FastString
-- LitStrings, here for convenience only.
type LitString = Ptr ()
--- ToDo: make it a Ptr when we don't have to support 4.08 any more
mkLitString# :: Addr# -> LitString
mkLitString# a# = Ptr a#
appOL as None = as
appOL as bs = Two as bs
+mapOL :: (a -> b) -> OrdList a -> OrdList b
+mapOL f None = None
+mapOL f (One x) = One (f x)
+mapOL f (Two x y) = Two (mapOL f x) (mapOL f y)
+mapOL f (Many xs) = Many (map f xs)
+
+instance Functor OrdList where
+ fmap = mapOL
+
foldrOL :: (a->b->b) -> b -> OrdList a -> b
foldrOL k z None = z
foldrOL k z (One x) = k x z
) where
#include "HsVersions.h"
-#include "config.h"
+#include "../includes/ghcconfig.h"
import Config
import FastTypes
-- * Conversion
lexemeToString, -- :: StringBuffer -> Int -> String
lexemeToFastString, -- :: StringBuffer -> Int -> FastString
+
+ -- * Parsing integers
+ parseInteger,
) where
#include "HsVersions.h"
lexemeToFastString _ 0 = mkFastString ""
lexemeToFastString (StringBuffer fo _ current#) (I# len) =
mkFastSubStringBA# fo current# len
+
+-- -----------------------------------------------------------------------------
+-- Parsing integer strings in various bases
+
+parseInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer
+parseInteger buf len radix to_int
+ = go 0 0
+ where go i x | i == len = x
+ | otherwise = go (i+1) (x * radix + toInteger (to_int (lookAhead buf i)))
\end{code}
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith,
mapAndUnzip, mapAndUnzip3,
- nOfThem,
+ nOfThem, filterOut,
lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
isSingleton, only,
notNull, snocView,
-- module names
looksLikeModuleName,
- toArgs
+ toArgs,
+
+ -- Floating point stuff
+ readRational,
) where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import Panic ( panic, trace )
import List ( zipWith4 )
#endif
-import Char ( isUpper, isAlphaNum, isSpace )
+import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
+import Ratio ( (%) )
infixr 9 `thenCmp`
\end{code}
%* *
%************************************************************************
+\begin{code}
+filterOut :: (a->Bool) -> [a] -> [a]
+-- Like filter, only reverses the sense of the test
+filterOut p [] = []
+filterOut p (x:xs) | p x = filterOut p xs
+ | otherwise = x : filterOut p xs
+\end{code}
+
A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
are of equal length. Alastair Reid thinks this should only happen if
DEBUGging on; hey, why not?
stripQuotes ('"':xs) = init xs
stripQuotes xs = xs
\end{code}
+
+-- -----------------------------------------------------------------------------
+-- Floats
+
+\begin{code}
+readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
+readRational__ r = do
+ (n,d,s) <- readFix r
+ (k,t) <- readExp s
+ return ((n%1)*10^^(k-d), t)
+ where
+ readFix r = do
+ (ds,s) <- lexDecDigits r
+ (ds',t) <- lexDotDigits s
+ return (read (ds++ds'), length ds', t)
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = return (0,s)
+
+ readExp' ('+':s) = readDec s
+ readExp' ('-':s) = do
+ (k,t) <- readDec s
+ return (-k,t)
+ readExp' s = readDec s
+
+ readDec s = do
+ (ds,r) <- nonnull isDigit s
+ return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
+ r)
+
+ lexDecDigits = nonnull isDigit
+
+ lexDotDigits ('.':s) = return (span isDigit s)
+ lexDotDigits s = return ("",s)
+
+ nonnull p s = do (cs@(_:_),t) <- return (span p s)
+ return (cs,t)
+
+readRational :: String -> Rational -- NB: *does* handle a leading "-"
+readRational top_s
+ = case top_s of
+ '-' : xs -> - (read_me xs)
+ xs -> read_me xs
+ where
+ read_me s
+ = case (do { (x,"") <- readRational__ s ; return x }) of
+ [x] -> x
+ [] -> error ("readRational: no parse:" ++ top_s)
+ _ -> error ("readRational: ambiguous parse:" ++ top_s)
+\end{code}
<p><li>
TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon, loop Generics.GenInfo)
<p><li>
- Type (loop DataCon.DataCon, loop Subst.substTy)
+ TypeRep (loop DataCon.DataCon, loop Subst.substTyWith)
+<p><li>
+ Type (loop PprType.pprType, loop Subst.substTyWith)
<p><li>
FieldLabel(Type) <br>
TysPrim(Type) <br>
<p><li> Some architectures have memory alignment constraints. Others
don't have any constraints but go faster if you align things. These
-macros (from <tt>config.h</tt>) tell you which alignment to use
+macros (from <tt>ghcconfig.h</tt>) tell you which alignment to use
<pre>
/* minimum alignment of unsigned int */
$T_MOVE_DIRVS = '^(\s*(\$.*\.\.ng:|\.align\s+\d+|\.(globl|ent)\s+\S+|\#.*|\.(file|loc)\s+\S+\s+\S+|\.text|\.r?data)\n)';
$T_COPY_DIRVS = '^\s*(\$.*\.\.ng:|\#|\.(file|globl|ent|loc))';
- $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
$T_DOT_WORD = '\.(long|quad|byte|word)';
$T_DOT_GLOBAL = '^\t\.globl';
$T_HDR_literal = "\.rdata\n\t\.align 3\n";
$T_HDR_misc = "\.text\n\t\.align 3\n";
$T_HDR_data = "\.data\n\t\.align 3\n";
- $T_HDR_consist = "\.text\n";
+ $T_HDR_rodata = "\.rdata\n\t\.align 3\n";
$T_HDR_closure = "\.data\n\t\.align 3\n";
- $T_HDR_srt = "\.text\n\t\.align 3\n";
$T_HDR_info = "\.text\n\t\.align 3\n";
$T_HDR_entry = "\.text\n\t\.align 3\n";
$T_HDR_vector = "\.text\n\t\.align 3\n";
- $T_HDR_direct = "\.text\n\t\.align 3\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^hppa/ ) {
$T_MOVE_DIRVS = '^((\s+\.(IMPORT|EXPORT|PARAM).*|\s+\.align\s+\d+|\s+\.(SPACE|SUBSPA)\s+\S+|\s*)\n)';
$T_COPY_DIRVS = '^\s+\.(IMPORT|EXPORT)';
- $T_hsc_cc_PAT = '\.STRING.*\)(hsc|cc) (.*)\\\\x09(.*)\\\\x00"';
$T_DOT_WORD = '\.(blockz|word|half|byte)';
$T_DOT_GLOBAL = '^\s+\.EXPORT';
$T_HDR_literal = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n";
$T_HDR_misc = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
$T_HDR_data = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
- $T_HDR_consist = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n";
+ $T_HDR_rodata = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
$T_HDR_closure = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
- $T_HDR_srt = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
$T_HDR_info = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
$T_HDR_entry = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
$T_HDR_vector = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
- $T_HDR_direct = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd2|nextstep3|cygwin32|mingw32)$/ ) {
$T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,0x90)?|\.globl\s+\S+|\.text|\.data|\.stab[^n].*|\.type\s+.*|\.size\s+.*|\.lcomm.*)\n)';
$T_COPY_DIRVS = '\.(globl|stab|lcomm)';
- $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
$T_DOT_WORD = '\.(long|word|value|byte|space)';
$T_DOT_GLOBAL = '\.globl';
$T_HDR_literal = "\.text\n\t\.align 2\n";
$T_HDR_misc = "\.text\n\t\.align 2,0x90\n";
$T_HDR_data = "\.data\n\t\.align 2\n";
- $T_HDR_consist = "\.text\n";
+ $T_HDR_rodata = "\.text\n\t\.align 2\n";
$T_HDR_closure = "\.data\n\t\.align 2\n";
- $T_HDR_srt = "\.text\n\t\.align 2\n";
$T_HDR_info = "\.text\n\t\.align 2\n"; # NB: requires padding
$T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
$T_HDR_vector = "\.text\n\t\.align 2\n"; # NB: requires padding
- $T_HDR_direct = "\.text\n\t\.align 2,0x90\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux|freebsd|netbsd|openbsd)$/ ) {
$T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)';
$T_COPY_DIRVS = '^\s*\.(globl|type|size|local)';
- if ( $TargetPlatform =~ /freebsd|netbsd/ ) {
- $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
- } else {
- $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
- }
-
$T_DOT_WORD = '\.(long|value|word|byte|zero)';
$T_DOT_GLOBAL = '\.globl';
$T_HDR_literal = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11)
$T_HDR_misc = "\.text\n\t\.align 4\n";
- $T_HDR_data = "\.data\n\t\.align 4\n"; # ToDo: change align??
- $T_HDR_consist = "\.text\n";
- $T_HDR_closure = "\.data\n\t\.align 4\n"; # ToDo: change align?
- $T_HDR_srt = "\.text\n\t\.align 4\n"; # ToDo: change align?
- $T_HDR_info = "\.text\n\t\.align 4\n"; # NB: requires padding
+ $T_HDR_data = "\.data\n\t\.align 4\n";
+ $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 4\n";
+ $T_HDR_closure = "\.data\n\t\.align 4\n";
+ $T_HDR_info = "\.text\n\t\.align 4\n";
$T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
$T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding
- $T_HDR_direct = "\.text\n\t\.align 4\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^ia64-.*-linux$/ ) {
$T_MOVE_DIRVS = '^(\s*\.(global|proc|pred\.safe_across_calls|text|data|section|subsection|align|size|type|ident)\s+.*\n)';
$T_COPY_DIRVS = '\.(global|proc)';
- $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
$T_DOT_WORD = '\.(long|value|byte|zero)';
$T_DOT_GLOBAL = '\.global';
$T_HDR_literal = "\.section\t\.rodata\n";
$T_HDR_misc = "\.text\n\t\.align 8\n";
$T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_consist = "\.text\n";
+ $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 8\n";
$T_HDR_closure = "\.data\n\t\.align 8\n";
- $T_HDR_srt = "\.text\n\t\.align 8\n";
$T_HDR_info = "\.text\n\t\.align 8\n";
$T_HDR_entry = "\.text\n\t\.align 16\n";
$T_HDR_vector = "\.text\n\t\.align 8\n";
- $T_HDR_direct = "\.text\n\t\.align 8\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^x86_64-.*-(linux|openbsd)$/ ) {
$T_MOVE_DIRVS = '^(\s*\.(globl|text|data|section|align|size|type|ident|local)\s+.*\n)';
$T_COPY_DIRVS = '\.(globl|local)';
- $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
$T_DOT_WORD = '\.(quad|long|value|byte|zero)';
$T_DOT_GLOBAL = '\.global';
$T_HDR_literal = "\.section\t\.rodata\n";
$T_HDR_misc = "\.text\n\t\.align 8\n";
$T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_consist = "\.text\n";
+ $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 8\n";
$T_HDR_closure = "\.data\n\t\.align 8\n";
- $T_HDR_srt = "\.text\n\t\.align 8\n";
$T_HDR_info = "\.text\n\t\.align 8\n";
$T_HDR_entry = "\.text\n\t\.align 8\n";
$T_HDR_vector = "\.text\n\t\.align 8\n";
- $T_HDR_direct = "\.text\n\t\.align 8\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^m68k-.*-sunos4/ ) {
$T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.proc\s+\d+|\.const|\.cstring|\.globl\s+\S+|\.text|\.data|\.even|\.stab[^n].*)\n)';
$T_COPY_DIRVS = '\.(globl|proc|stab)';
- $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
$T_DOT_WORD = '\.long';
$T_DOT_GLOBAL = '\.globl';
$T_HDR_literal = "\.text\n\t\.even\n";
$T_HDR_misc = "\.text\n\t\.even\n";
$T_HDR_data = "\.data\n\t\.even\n";
- $T_HDR_consist = "\.text\n";
+ $T_HDR_rodata = "\.text\n\t\.even\n";
$T_HDR_closure = "\.data\n\t\.even\n";
- $T_HDR_srt = "\.text\n\t\.even\n";
$T_HDR_info = "\.text\n\t\.even\n";
$T_HDR_entry = "\.text\n\t\.even\n";
$T_HDR_vector = "\.text\n\t\.even\n";
- $T_HDR_direct = "\.text\n\t\.even\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^mips-.*/ ) {
$T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\.text|\.r?data)\n)';
$T_COPY_DIRVS = '\.(globl|ent)';
- $T_hsc_cc_PAT = 'I WAS TOO LAZY TO DO THIS BIT (WDP 95/05)';
$T_DOT_WORD = '\.word';
$T_DOT_GLOBAL = '^\t\.globl';
$T_HDR_literal = "\t\.rdata\n\t\.align 2\n";
$T_HDR_misc = "\t\.text\n\t\.align 2\n";
$T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_consist = 'TOO LAZY TO DO THIS TOO';
+ $T_HDR_rodata = "\t\.rdata\n\t\.align 2\n";
$T_HDR_closure = "\t\.data\n\t\.align 2\n";
- $T_HDR_srt = "\t\.text\n\t\.align 2\n";
$T_HDR_info = "\t\.text\n\t\.align 2\n";
$T_HDR_entry = "\t\.text\n\t\.align 2\n";
$T_HDR_vector = "\t\.text\n\t\.align 2\n";
- $T_HDR_direct = "\t\.text\n\t\.align 2\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^powerpc-apple-.*/ ) {
$T_MOVE_DIRVS = '^(\s*(\.align \d+|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)';
$T_COPY_DIRVS = '\.(globl|lcomm)';
- $T_hsc_cc_PAT = '\.byte.*\)(hsc|cc) (.*)"\n\t\.byte \d+\n\t\.byte "(.*)"\n\t\.byte \d+';
$T_DOT_WORD = '\.(long|short|byte|fill|space)';
$T_DOT_GLOBAL = '\.globl';
$T_HDR_toc = "\.toc\n";
$T_HDR_literal = "\t\.const_data\n\t\.align 2\n";
$T_HDR_misc = "\t\.text\n\t\.align 2\n";
$T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_consist = "\t\.text\n\t\.align 2\n";
+ $T_HDR_rodata = "\t\.const_data\n\t\.align 2\n";
$T_HDR_closure = "\t\.const_data\n\t\.align 2\n";
- $T_HDR_srt = "\t\.text\n\t\.align 2\n";
$T_HDR_info = "\t\.text\n\t\.align 2\n";
$T_HDR_entry = "\t\.text\n\t\.align 2\n";
$T_HDR_vector = "\t\.text\n\t\.align 2\n";
- $T_HDR_direct = "\t\.text\n\t\.align 2\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^powerpc-.*-linux/ ) {
$T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)';
$T_COPY_DIRVS = '^\s*\.(globl|type|size|local)';
- $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
$T_DOT_WORD = '\.(long|short|byte|fill|space)';
$T_DOT_GLOBAL = '\.globl';
$T_HDR_toc = "\.toc\n";
$T_HDR_literal = "\t\.section\t.rodata\n\t\.align 2\n";
$T_HDR_misc = "\t\.text\n\t\.align 2\n";
$T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_consist = "\t\.text\n\t\.align 2\n";
+ $T_HDR_rodata = "\t\.section\t.rodata\n\t\.align 2\n";
$T_HDR_closure = "\t\.data\n\t\.align 2\n";
- $T_HDR_srt = "\t\.text\n\t\.align 2\n";
$T_HDR_info = "\t\.text\n\t\.align 2\n";
$T_HDR_entry = "\t\.text\n\t\.align 2\n";
$T_HDR_vector = "\t\.text\n\t\.align 2\n";
- $T_HDR_direct = "\t\.text\n\t\.align 2\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^sparc-.*-(solaris2|openbsd)/ ) {
$T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*|\.section.*|\s+\.type.*|\s+\.size.*)\n)';
$T_COPY_DIRVS = '\.(global|proc|stab)';
- $T_hsc_cc_PAT = '\.asciz.*\)(hsc|cc) (.*)\\\\t(.*)"';
$T_DOT_WORD = '\.(long|word|byte|half|skip|uahalf|uaword)';
$T_DOT_GLOBAL = '^\t\.global';
$T_HDR_literal = "\.text\n\t\.align 8\n";
$T_HDR_misc = "\.text\n\t\.align 4\n";
$T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_consist = "\.text\n";
+ $T_HDR_rodata = "\.text\n\t\.align 4\n";
$T_HDR_closure = "\.data\n\t\.align 4\n";
- $T_HDR_srt = "\.data\n\t\.align 4\n";
- $T_HDR_info = "\.text\n\t\.align 4\n";
$T_HDR_entry = "\.text\n\t\.align 4\n";
$T_HDR_vector = "\.text\n\t\.align 4\n";
- $T_HDR_direct = "\.text\n\t\.align 4\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^sparc-.*-sunos4/ ) {
$T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*)\n)';
$T_COPY_DIRVS = '\.(global|proc|stab)';
- $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
$T_DOT_WORD = '\.word';
$T_DOT_GLOBAL = '^\t\.global';
$T_HDR_literal = "\.text\n\t\.align 8\n";
$T_HDR_misc = "\.text\n\t\.align 4\n";
$T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_consist = "\.text\n";
+ $T_HDR_rodata = "\.text\n\t\.align 4\n";
$T_HDR_closure = "\.data\n\t\.align 4\n";
- $T_HDR_srt = "\.data\n\t\.align 4\n";
$T_HDR_info = "\.text\n\t\.align 4\n";
$T_HDR_entry = "\.text\n\t\.align 4\n";
$T_HDR_vector = "\.text\n\t\.align 4\n";
- $T_HDR_direct = "\.text\n\t\.align 4\n";
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^sparc-.*-linux/ ) {
$T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.seg|\.stab.*|\t?\.section.*|\s+\.type.*|\s+\.size.*)\n)';
$T_COPY_DIRVS = '\.(global|globl|proc|stab)';
- $T_hsc_cc_PAT = '\.asciz.*\)(hsc|cc) (.*)\\\\t(.*)"';
$T_DOT_WORD = '\.(long|word|nword|xword|byte|half|short|skip|uahalf|uaword)';
$T_DOT_GLOBAL = '^\t\.global';
$T_HDR_literal = "\.text\n\t\.align 8\n";
$T_HDR_misc = "\.text\n\t\.align 4\n";
$T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_consist = "\.text\n";
+ $T_HDR_rodata = "\.text\n\t\.align 4\n";
$T_HDR_closure = "\.data\n\t\.align 4\n";
- $T_HDR_srt = "\.data\n\t\.align 4\n";
$T_HDR_info = "\.text\n\t\.align 4\n";
$T_HDR_entry = "\.text\n\t\.align 4\n";
$T_HDR_vector = "\.text\n\t\.align 4\n";
- $T_HDR_direct = "\.text\n\t\.align 4\n";
#--------------------------------------------------------#
} else {
}
print STDERR "T_MOVE_DIRVS: $T_MOVE_DIRVS\n";
print STDERR "T_COPY_DIRVS: $T_COPY_DIRVS\n";
-print STDERR "T_hsc_cc_PAT: $T_hsc_cc_PAT\n";
print STDERR "T_DOT_WORD: $T_DOT_WORD\n";
print STDERR "T_HDR_literal: $T_HDR_literal\n";
print STDERR "T_HDR_misc: $T_HDR_misc\n";
print STDERR "T_HDR_data: $T_HDR_data\n";
-print STDERR "T_HDR_consist: $T_HDR_consist\n";
+print STDERR "T_HDR_rodata: $T_HDR_rodata\n";
print STDERR "T_HDR_closure: $T_HDR_closure\n";
print STDERR "T_HDR_info: $T_HDR_info\n";
print STDERR "T_HDR_entry: $T_HDR_entry\n";
print STDERR "T_HDR_vector: $T_HDR_vector\n";
-print STDERR "T_HDR_direct: $T_HDR_direct\n";
}
}
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ # Labels beginning "_c": these are literal strings.
+ } elsif ( /^${T_US}_c.*$/ ) {
+ $chk[++$i] = $_;
+ $chkcat[$i] = 'rodata';
+ $chksymb[$i] = '';
+
} elsif ( /^\s+/ ) { # most common case first -- a simple line!
# duplicated from the bottom
$e =~ s/^\tlw?z? r\d+,\d+\(r1\)\n//;
$e =~ s/^\tmtlr r0\n//;
$e =~ s/^\tblr\n//;
+ $e =~ s/^\tb restFP ;.*\n//;
} else {
print STDERR "$Pgm: unknown epilogue mangling? $TargetPlatform\n";
}
print OUTASM $chk[$i];
}
- } elsif ( $chkcat[$i] eq 'consist' ) {
- if ( $chk[$i] =~ /$T_hsc_cc_PAT/o ) {
- local($consist) = "$1.$2.$3";
- $consist =~ s/,/./g;
- $consist =~ s/\//./g;
- $consist =~ s/-/_/g;
- $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
- #
- # Using a cygnus-2.7-96q4 gcc build on hppas, the
- # consistency chunk for ghc_cc_ID often (but not always!)
- # gets lumped with a bunch of .IMPORT directives containing info on
- # the code or data space nature of external symbols. We can't
- # toss these, so once the consistency ID has been turned into
- # a representable symbol, we substitute it for the symbol
- # that the string was attached to in the first place (ghc_cc_ID.)
- # (The original string is also substituted away.)
- #
- # This change may affect the code output on other platforms in
- # adverse ways, hence we restrict this hack hppa targets only.
- #
- # -- 2/98 SOF
- if ( $TargetPlatform =~ /^hppa/ ) {
- $chk[$i] =~ s/^${T_US}ghc.*c_ID$TPOSTLBL/$consist/o;
- $chk[$i] =~ s/\t$T_hsc_cc_PAT/$T_HDR_misc/o;
- $consist = $chk[$i]; #clumsily
- }
- print OUTASM $T_HDR_consist, "${consist}${T_POST_LBL}\n";
-
- } elsif ( $TargetPlatform !~ /^(mips)-/ ) { # we just don't try in those case (ToDo)
- # on mips: consistency string is just a v
- # horrible bunch of .bytes,
- # which I am too lazy to sort out (WDP 95/05)
-
- print STDERR "Couldn't grok consistency: ", $chk[$i];
- }
-
} elsif ( $chkcat[$i] eq 'splitmarker' ) {
# we can just re-constitute this one...
# NB: we emit _three_ underscores no matter what,
# SRT
if ( defined($srtchk{$symb}) ) {
- print OUTASM $T_HDR_srt;
+ print OUTASM $T_HDR_rodata;
print OUTASM $chk[$srtchk{$symb}];
$chkcat[$srtchk{$symb}] = 'DONE ALREADY';
}
$chkcat[$infochk{$symb}] = 'DONE ALREADY';
}
- # STD ENTRY POINT
+ # ENTRY POINT
if ( defined($entrychk{$symb}) ) {
$c = $chk[$entrychk{$symb}];
+ # If this is an entry point with an info table,
+ # eliminate the entry symbol and all directives involving it.
+ if (defined($infochk{$symb}) && $TargetPlatform !~ /^ia64-/) {
+ $c =~ s/^.*$symb_(entry|ret)${T_POST_LBL}\n//;
+ $c =~ s/^\s*\..*$symb.*\n//g;
+ }
+
print OUTASM $T_HDR_entry;
&print_doctored($c, 1); # NB: the 1!!!
$chkcat[$entrychk{$symb}] = 'DONE ALREADY';
}
- } elsif ( $chkcat[$i] eq 'vector'
- || $chkcat[$i] eq 'direct' ) { # do them in that order
+ } elsif ( $chkcat[$i] eq 'vector' ) {
$symb = $chksymb[$i];
# VECTOR TABLE
print OUTASM "\t# nop\n";
}
+ } elsif ( $chkcat[$i] eq 'rodata' ) {
+ print OUTASM $T_HDR_rodata;
+ print OUTASM $chk[$i];
+ $chkcat[$i] = 'DONE ALREADY';
+
} elsif ( $chkcat[$i] eq 'toc' ) {
# silly optimisation to print tocs, since they come in groups...
print OUTASM $T_HDR_toc;
/* -----------------------------------------------------------------------------
- * $Id: Block.h,v 1.16 2003/11/26 12:14:26 simonmar Exp $
+ * $Id: Block.h,v 1.17 2004/08/13 13:09:09 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
* on a 32-bit machine.
*/
-typedef struct _bdescr {
+#ifndef CMINUSMINUS
+typedef struct bdescr_ {
StgPtr start; /* start addr of memory */
StgPtr free; /* first free byte of memory */
- struct _bdescr *link; /* used for chaining blocks together */
+ struct bdescr_ *link; /* used for chaining blocks together */
union {
- struct _bdescr *back; /* used (occasionally) for doubly-linked lists*/
+ struct bdescr_ *back; /* used (occasionally) for doubly-linked lists*/
StgWord *bitmap;
} u;
unsigned int gen_no; /* generation */
StgWord32 _padding[0];
#endif
} bdescr;
+#endif
#if SIZEOF_VOID_P == 8
#define BDESCR_SIZE 0x40
#define BDESCR_SHIFT 5
#endif
-// Block contains objects evacuated during this GC
+/* Block contains objects evacuated during this GC */
#define BF_EVACUATED 1
-// Block is a large object
+/* Block is a large object */
#define BF_LARGE 2
-// Block is pinned
+/* Block is pinned */
#define BF_PINNED 4
-// Block is part of a compacted generation
+/* Block is part of a compacted generation */
#define BF_COMPACTED 8
/* Finding the block descriptor for a given block -------------------------- */
+#ifdef CMINUSMINUS
+
+#define Bdescr(p) \
+ ((((p) & MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT)) \
+ | ((p) & ~MBLOCK_MASK))
+
+#else
+
INLINE_HEADER bdescr *Bdescr(StgPtr p)
{
return (bdescr *)
);
}
+#endif
+
/* Useful Macros ------------------------------------------------------------ */
/* Offset of first real data block in a megablock */
#define BLOCKS_TO_MBLOCKS(n) \
(1 + (W_)MBLOCK_ROUND_UP((n-BLOCKS_PER_MBLOCK) * BLOCK_SIZE) / MBLOCK_SIZE)
+
+/* Double-linked block lists: --------------------------------------------- */
+
+#ifndef CMINUSMINUS
+INLINE_HEADER void
+dbl_link_onto(bdescr *bd, bdescr **list)
+{
+ bd->link = *list;
+ bd->u.back = NULL;
+ if (*list) {
+ (*list)->u.back = bd; /* double-link the list */
+ }
+ *list = bd;
+}
+#endif
+
#endif /* BLOCK_H */
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: CCall.h,v 1.4 2000/01/13 14:34:00 hwloidl Exp $
- *
- * (c) The GHC Team, 1998-1999
- *
- * Macros for performing C calls from the STG world.
- *
- * -------------------------------------------------------------------------- */
-
-#ifndef CCALL_H
-#define CCALL_H
-
-/*
- * Most C-Calls made from STG land are of the 'unsafe' variety.
- * An unsafe C-Call is one where we trust the C function not to do
- * anything nefarious while it has control.
- *
- * Nefarious actions include doing allocation on the Haskell heap,
- * garbage collecting, creating/deleting threads, re-entering the
- * scheduler, and messing with runtime system data structures.
- *
- * For these calls, the code generator will kindly provide CALLER_SAVE
- * and CALLER_RESTORE macros for any registers that are live across the
- * call. These macros may expand into saves of the relevant registers
- * if those registers are designated caller-saves by the C calling
- * convention, otherwise they will expand to nothing.
- */
-
-/* Unsafe C-Calls have no macros: we just use a straightforward call.
- */
-
-/*
- * An STGCALL<n> is used when we want the relevant registers to be
- * saved automatically. An STGCALL doesn't return a result, there's
- * an alternative set of RET_STGCALL<n> macros for that (and we hope
- * that the restoring of the caller-saves registers doesn't clobber
- * the result!)
- */
-
-#define STGCALL0(f) \
- CALLER_SAVE_ALL (void) f(); CALLER_RESTORE_ALL
-
-#define STGCALL1(f,a) \
- CALLER_SAVE_ALL (void) f(a); CALLER_RESTORE_ALL
-
-#define STGCALL2(f,a,b) \
- CALLER_SAVE_ALL (void) f(a,b); CALLER_RESTORE_ALL
-
-#define STGCALL3(f,a,b,c) \
- CALLER_SAVE_ALL (void) f(a,b,c); CALLER_RESTORE_ALL
-
-#define STGCALL4(f,a,b,c,d) \
- CALLER_SAVE_ALL (void) f(a,b,c,d); CALLER_RESTORE_ALL
-
-#define STGCALL5(f,a,b,c,d,e) \
- CALLER_SAVE_ALL (void) f(a,b,c,d,e); CALLER_RESTORE_ALL
-
-#define STGCALL6(f,a,b,c,d,e,z) \
- CALLER_SAVE_ALL (void) f(a,b,c,d,e,z); CALLER_RESTORE_ALL
-
-
-#define RET_STGCALL0(t,f) \
- ({ t _r; CALLER_SAVE_ALL _r = f(); CALLER_RESTORE_ALL; _r; })
-
-#define RET_STGCALL1(t,f,a) \
- ({ t _r; CALLER_SAVE_ALL _r = f(a); CALLER_RESTORE_ALL; _r; })
-
-#define RET_STGCALL2(t,f,a,b) \
- ({ t _r; CALLER_SAVE_ALL _r = f(a,b); CALLER_RESTORE_ALL; _r; })
-
-#define RET_STGCALL3(t,f,a,b,c) \
- ({ t _r; CALLER_SAVE_ALL _r = f(a,b,c); CALLER_RESTORE_ALL; _r; })
-
-#define RET_STGCALL4(t,f,a,b,c,d) \
- ({ t _r; CALLER_SAVE_ALL _r = f(a,b,c,d); CALLER_RESTORE_ALL; _r; })
-
-#define RET_STGCALL5(t,f,a,b,c,d,e) \
- ({ t _r; CALLER_SAVE_ALL _r = f(a,b,c,d,e); CALLER_RESTORE_ALL; _r; })
-
-#define RET_STGCALL6(t,f,a,b,c,d,e,z) \
- ({ t _r; CALLER_SAVE_ALL _r = f(a,b,c,d,e,z); CALLER_RESTORE_ALL; _r; })
-
-
-/*
- * A PRIM_STGCALL is used when we have arranged to save the R<n>,
- * F<n>, and D<n> registers already, we only need the "system"
- * registers saved for us. These are used in PrimOps, where the
- * compiler has a good idea of what registers are live, and so doesn't
- * need to save all of them.
- */
-
-#define PRIM_STGCALL0(f) \
- CALLER_SAVE_SYSTEM (void) f(); CALLER_RESTORE_SYSTEM
-
-#define PRIM_STGCALL1(f,a) \
- CALLER_SAVE_SYSTEM (void) f(a); CALLER_RESTORE_SYSTEM
-
-#define PRIM_STGCALL2(f,a,b) \
- CALLER_SAVE_SYSTEM (void) f(a,b); CALLER_RESTORE_SYSTEM
-
-#define PRIM_STGCALL3(f,a,b,c) \
- CALLER_SAVE_SYSTEM (void) f(a,b,c); CALLER_RESTORE_SYSTEM
-
-#define PRIM_STGCALL4(f,a,b,c,d) \
- CALLER_SAVE_SYSTEM (void) f(a,b,c,d); CALLER_RESTORE_SYSTEM
-
-#define PRIM_STGCALL5(f,a,b,c,d,e) \
- CALLER_SAVE_SYSTEM (void) f(a,b,c,d,e); CALLER_RESTORE_SYSTEM
-
-#define PRIM_STGCALL6(f,a,b,c,d,e,z) \
- CALLER_SAVE_SYSTEM (void) f(a,b,c,d,e,z); CALLER_RESTORE_SYSTEM
-
-
-#define RET_PRIM_STGCALL0(t,f) \
- ({ t _r; CALLER_SAVE_SYSTEM _r = f(); CALLER_RESTORE_SYSTEM; _r; })
-
-#define RET_PRIM_STGCALL1(t,f,a) \
- ({ t _r; CALLER_SAVE_SYSTEM _r = f(a); CALLER_RESTORE_SYSTEM; _r; })
-
-#define RET_PRIM_STGCALL2(t,f,a,b) \
- ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b); CALLER_RESTORE_SYSTEM; _r; })
-
-#define RET_PRIM_STGCALL3(t,f,a,b,c) \
- ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c); CALLER_RESTORE_SYSTEM; _r; })
-
-#define RET_PRIM_STGCALL4(t,f,a,b,c,d) \
- ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c,d); CALLER_RESTORE_SYSTEM; _r; })
-
-#define RET_PRIM_STGCALL5(t,f,a,b,c,d,e) \
- ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c,d,e); CALLER_RESTORE_SYSTEM; _r; })
-
-#define RET_PRIM_STGCALL6(t,f,a,b,c,d,e,z) \
- ({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c,d,e,z); CALLER_RESTORE_SYSTEM; _r; })
-
-/* ToDo: ccalls that might garbage collect - do we need to return to
- * the scheduler to perform these? Similarly, ccalls that might want
- * to call Haskell right back, or start a new thread or something.
- */
-
-#endif /* CCALL_H */
-
/* ----------------------------------------------------------------------------
- * $Id: ClosureMacros.h,v 1.38 2003/11/12 17:27:00 sof Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
* Macros for building and manipulating closures
*
-------------------------------------------------------------------------- */
-#define INIT_INFO(i) info : (StgInfoTable *)&(i)
#define SET_INFO(c,i) ((c)->header.info = (i))
#define GET_INFO(c) ((c)->header.info)
#define GET_ENTRY(c) (ENTRY_CODE(GET_INFO(c)))
#define get_fun_itbl(c) (FUN_INFO_PTR_TO_STRUCT((c)->header.info))
#define get_thunk_itbl(c) (THUNK_INFO_PTR_TO_STRUCT((c)->header.info))
+#define GET_TAG(con) (get_itbl(con)->srt_bitmap)
#ifdef TABLES_NEXT_TO_CODE
-#define INIT_ENTRY(e)
-#define ENTRY_CODE(info) (info)
#define INFO_PTR_TO_STRUCT(info) ((StgInfoTable *)(info) - 1)
#define RET_INFO_PTR_TO_STRUCT(info) ((StgRetInfoTable *)(info) - 1)
#define FUN_INFO_PTR_TO_STRUCT(info) ((StgFunInfoTable *)(info) - 1)
#define THUNK_INFO_PTR_TO_STRUCT(info) ((StgThunkInfoTable *)(info) - 1)
-INLINE_HEADER StgFunPtr get_entry(const StgInfoTable *itbl) {
- return (StgFunPtr)(itbl+1);
-}
#define itbl_to_fun_itbl(i) ((StgFunInfoTable *)(((StgInfoTable *)(i) + 1)) - 1)
#define itbl_to_ret_itbl(i) ((StgRetInfoTable *)(((StgInfoTable *)(i) + 1)) - 1)
#define itbl_to_thunk_itbl(i) ((StgThunkInfoTable *)(((StgInfoTable *)(i) + 1)) - 1)
#else
-#define INIT_ENTRY(e) entry : (F_)(e)
-#define ENTRY_CODE(info) (((StgInfoTable *)info)->entry)
#define INFO_PTR_TO_STRUCT(info) ((StgInfoTable *)info)
#define RET_INFO_PTR_TO_STRUCT(info) ((StgRetInfoTable *)info)
#define FUN_INFO_PTR_TO_STRUCT(info) ((StgFunInfoTable *)info)
#define THUNK_INFO_PTR_TO_STRUCT(info) ((StgThunkInfoTable *)info)
-INLINE_HEADER StgFunPtr get_entry(const StgInfoTable *itbl) {
- return itbl->entry;
-}
#define itbl_to_fun_itbl(i) ((StgFunInfoTable *)(i))
#define itbl_to_ret_itbl(i) ((StgRetInfoTable *)(i))
#define itbl_to_thunk_itbl(i) ((StgThunkInfoTable *)(i))
Note: change those functions building Haskell objects from C datatypes, i.e.,
all rts_mk???() functions in RtsAPI.c, as well.
*/
-extern StgWord flip;
#define SET_PROF_HDR(c,ccs_) \
((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = (retainerSet *)((StgWord)NULL | flip))
#else
*/
#define SET_PROF_HDR(c,ccs_) \
((c)->header.prof.ccs = ccs_, \
- LDV_recordCreate((c)))
+ LDV_RECORD_CREATE((c)))
#endif // DEBUG_RETAINER
#define SET_STATIC_PROF_HDR(ccs_) \
- prof : { ccs : ccs_, hp : { rs : NULL } },
+ prof : { ccs : (CostCentreStack *)ccs_, hp : { rs : NULL } },
#else
#define SET_PROF_HDR(c,ccs)
#define SET_STATIC_PROF_HDR(ccs)
#define SET_STATIC_TICKY_HDR(stuff)
#endif
-#define SET_HDR(c,info,ccs) \
+#define SET_HDR(c,_info,ccs) \
{ \
- SET_INFO(c,info); \
+ (c)->header.info = _info; \
SET_GRAN_HDR((StgClosure *)(c),ThisPE); \
SET_PAR_HDR((StgClosure *)(c),LOCAL_GA); \
SET_PROF_HDR((StgClosure *)(c),ccs); \
(c)->words = n_words;
/* -----------------------------------------------------------------------------
- Static closures are defined as follows:
-
-
- SET_STATIC_HDR(PrelBase_CZh_closure,PrelBase_CZh_info,costCentreStack,closure_class,info_class);
-
- The info argument must have type 'StgInfoTable' or
- 'StgSRTInfoTable', since we use '&' to get its address in the macro.
+ How to get hold of the static link field for a static closure.
+
+ Note that we have to use (*cast(T*,&e)) instead of cast(T,e)
+ because C won't let us take the address of a casted
+ expression. Huh?
-------------------------------------------------------------------------- */
-#define SET_STATIC_HDR(label,info,costCentreStack,closure_class,info_class) \
- info_class info; \
- closure_class StgClosure label = { \
- STATIC_HDR(info,costCentreStack)
-
-#define STATIC_HDR(info,ccs) \
- header : { \
- INIT_INFO(info), \
- SET_STATIC_GRAN_HDR \
- SET_STATIC_PAR_HDR(LOCAL_GA) \
- SET_STATIC_PROF_HDR(ccs) \
- SET_STATIC_TICKY_HDR(0) \
- }
-
-/* how to get hold of the static link field for a static closure.
- *
- * Note that we have to use (*cast(T*,&e)) instead of cast(T,e)
- * because C won't let us take the address of a casted expression. Huh?
- */
#define STATIC_LINK(info,p) \
(*(StgClosure**)(&((p)->payload[info->layout.payload.ptrs + \
info->layout.payload.nptrs])))
#define CHARLIKE_CLOSURE(n) ((P_)&stg_CHARLIKE_closure[(n)-MIN_CHARLIKE])
#define INTLIKE_CLOSURE(n) ((P_)&stg_INTLIKE_closure[(n)-MIN_INTLIKE])
-/* -----------------------------------------------------------------------------
- Closure Tables (for enumerated data types)
- -------------------------------------------------------------------------- */
-
-#define CLOSURE_TBL(lbl) const StgClosure *lbl[] = {
-
-/* -----------------------------------------------------------------------------
- CONSTRs.
- -------------------------------------------------------------------------- */
-
-/* constructors don't have SRTs */
-#define GET_TAG(info) (INFO_PTR_TO_STRUCT(info)->srt_bitmap)
-
#endif /* CLOSUREMACROS_H */
/* ----------------------------------------------------------------------------
- * $Id: Closures.h,v 1.35 2003/11/14 14:28:07 stolz Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
* Closures
*
#endif
} StgHeader;
-#define FIXED_HS (sizeof(StgHeader))
-
/* -----------------------------------------------------------------------------
Closure Types
#define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \
/ BITS_IN(StgWord))
-/* Dynamic stack frames - these have a liveness mask in the object
- * itself, rather than in the info table. Useful for generic heap
- * check code. See StgMacros.h, HEAP_CHK_GEN().
- */
-
+/* -----------------------------------------------------------------------------
+ Dynamic stack frames for generic heap checks.
+
+ These generic heap checks are slow, but have the advantage of being
+ usable in a variety of situations.
+
+ The one restriction is that any relevant SRTs must already be pointed
+ to from the stack. The return address doesn't need to have an info
+ table attached: hence it can be any old code pointer.
+
+ The liveness mask contains a 1 at bit n, if register Rn contains a
+ non-pointer. The contents of all 8 vanilla registers are always saved
+ on the stack; the liveness mask tells the GC which ones contain
+ pointers.
+
+ Good places to use a generic heap check:
+
+ - case alternatives (the return address with an SRT is already
+ on the stack).
+
+ - primitives (no SRT required).
+
+ The stack frame layout for a RET_DYN is like this:
+
+ some pointers |-- RET_DYN_PTRS(liveness) words
+ some nonpointers |-- RET_DYN_NONPTRS(liveness) words
+
+ L1 \
+ D1-2 |-- RET_DYN_NONPTR_REGS_SIZE words
+ F1-4 /
+
+ R1-8 |-- RET_DYN_BITMAP_SIZE words
+
+ return address \
+ liveness mask |-- StgRetDyn structure
+ stg_gen_chk_info /
+
+ we assume that the size of a double is always 2 pointers (wasting a
+ word when it is only one pointer, but avoiding lots of #ifdefs).
+
+ See Liveness.h for the macros (RET_DYN_PTRS() etc.).
+
+ NOTE: if you change the layout of RET_DYN stack frames, then you
+ might also need to adjust the value of RESERVED_STACK_WORDS in
+ Constants.h.
+ -------------------------------------------------------------------------- */
+
typedef struct {
const struct _StgInfoTable* info;
StgWord liveness;
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2004
+ *
+ * This file is included at the top of all .cmm source files (and
+ * *only* .cmm files). It defines a collection of useful macros for
+ * making .cmm code a bit less error-prone to write, and a bit easier
+ * on the eye for the reader.
+ *
+ * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * If you're used to the old HC file syntax, here's a quick cheat sheet
+ * for converting HC code:
+ *
+ * - Remove FB_/FE_
+ * - Remove all type casts
+ * - Remove '&'
+ * - STGFUN(foo) { ... } ==> foo { ... }
+ * - FN_(foo) { ... } ==> foo { ... }
+ * - JMP_(e) ==> jump e;
+ * - Remove EXTFUN(foo)
+ * - Sp[n] ==> Sp(n)
+ * - Hp[n] ==> Hp(n)
+ * - Sp += n ==> Sp_adj(n)
+ * - Hp += n ==> Hp_adj(n)
+ * - R1.i ==> R1 (similarly for R1.w, R1.cl etc.)
+ * - You need to explicitly dereference variables; eg.
+ * context_switch ==> CInt[context_switch]
+ * - convert all word offsets into byte offsets:
+ * - e ==> WDS(e)
+ * - sizeofW(StgFoo) ==> SIZEOF_StgFoo
+ * - ENTRY_CODE(e) ==> %ENTRY_CODE(e)
+ * - get_itbl(c) ==> %GET_STD_INFO(c)
+ * - Change liveness masks in STK_CHK_GEN, HP_CHK_GEN:
+ * R1_PTR | R2_PTR ==> R1_PTR & R2_PTR
+ * (NOTE: | becomes &)
+ * - Declarations like 'StgPtr p;' become just 'W_ p;'
+ * - e->payload[n] ==> PAYLOAD(e,n)
+ * - Be very careful with comparisons: the infix versions (>, >=, etc.)
+ * are unsigned, so use %lt(a,b) to get signed less-than for example.
+ *
+ * Accessing fields of structures defined in the RTS header files is
+ * done via automatically-generated macros in DerivedConstants.h. For
+ * example, where previously we used
+ *
+ * CurrentTSO->what_next = x
+ *
+ * in C-- we now use
+ *
+ * StgTSO_what_next(CurrentTSO) = x
+ *
+ * where the StgTSO_what_next() macro is automatically generated by
+ * mkDerivedConstnants.c. If you need to access a field that doesn't
+ * already have a macro, edit that file (it's pretty self-explanatory).
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef CMM_H
+#define CMM_H
+
+// In files that are included into both C and C-- (and perhaps
+// Haskell) sources, we sometimes need to conditionally compile bits
+// depending on the language. CMINUSMINUS==1 in .cmm sources:
+#define CMINUSMINUS 1
+
+#include "ghcconfig.h"
+#include "RtsConfig.h"
+
+/* -----------------------------------------------------------------------------
+ Types
+
+ The following synonyms for C-- types are declared here:
+
+ I8, I16, I32, I64 MachRep-style names for convenience
+
+ W_ is shorthand for the word type (== StgWord)
+ F_ shorthand for float (F_ == StgFloat == C's float)
+ D_ shorthand for double (D_ == StgDouble == C's double)
+
+ CInt has the same size as an int in C on this platform
+ CLong has the same size as a long in C on this platform
+
+ --------------------------------------------------------------------------- */
+
+#define I8 bits8
+#define I16 bits16
+#define I32 bits32
+#define I64 bits64
+
+#if SIZEOF_VOID_P == 4
+#define W_ bits32
+#elif SIZEOF_VOID_P == 8
+#define W_ bits64
+#else
+#error Unknown word size
+#endif
+
+#if SIZEOF_INT == 4
+#define CInt bits32
+#elif SIZEOF_INT = 8
+#define CInt bits64
+#else
+#error Unknown int size
+#endif
+
+#if SIZEOF_LONG == 4
+#define CLong bits32
+#elif SIZEOF_LONG = 8
+#define CLong bits64
+#else
+#error Unknown long size
+#endif
+
+#define F_ float32
+#define D_ float64
+#define L_ bits64
+
+#define SIZEOF_StgDouble 8
+#define SIZEOF_StgWord64 8
+
+/* -----------------------------------------------------------------------------
+ Misc useful stuff
+ -------------------------------------------------------------------------- */
+
+#define NULL (0::W_)
+
+#define STRING(name,str) \
+ section "rodata" { \
+ name : bits8[] str; \
+ } \
+
+/* -----------------------------------------------------------------------------
+ Byte/word macros
+
+ Everything in C-- is in byte offsets (well, most things). We use
+ some macros to allow us to express offsets in words and to try to
+ avoid byte/word confusion.
+ -------------------------------------------------------------------------- */
+
+#define SIZEOF_W SIZEOF_VOID_P
+#define W_MASK (SIZEOF_W-1)
+
+#if SIZEOF_W == 4
+#define W_SHIFT 2
+#elif SIZEOF_W == 8
+#define W_SHIFT 4
+#endif
+
+// Converting quantities of words to bytes
+#define WDS(n) ((n)*SIZEOF_W)
+
+// Converting quantities of bytes to words
+// NB. these work on *unsigned* values only
+#define BYTES_TO_WDS(n) ((n) / SIZEOF_W)
+#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W)
+
+// TO_W_(n) converts n to W_ type from a smaller type
+#if SIZEOF_W == 4
+#define TO_W_(x) %sx32(x)
+#define HALF_W_(x) %lobits16(x)
+#elif SIZEOF_W == 8
+#define TO_W_(x) %sx64(x)
+#define HALF_W_(x) %lobits32(x)
+#endif
+
+/* -----------------------------------------------------------------------------
+ Heap/stack access, and adjusting the heap/stack pointers.
+ -------------------------------------------------------------------------- */
+
+#define Sp(n) W_[Sp + WDS(n)]
+#define Hp(n) W_[Hp + WDS(n)]
+
+#define Sp_adj(n) Sp = Sp + WDS(n)
+#define Hp_adj(n) Hp = Hp + WDS(n)
+
+/* -----------------------------------------------------------------------------
+ Assertions and Debuggery
+ -------------------------------------------------------------------------- */
+
+#ifdef DEBUG
+#define ASSERT(predicate) \
+ if (predicate) { \
+ /*null*/; \
+ } else { \
+ foreign "C" _stgAssert(NULL, __LINE__); \
+ }
+#else
+#define ASSERT(p) /* nothing */
+#endif
+
+#ifdef DEBUG
+#define DEBUG_ONLY(s) s
+#else
+#define DEBUG_ONLY(s) /* nothing */
+#endif
+
+//
+// The IF_DEBUG macro is useful for debug messages that depend on one
+// of the RTS debug options. For example:
+//
+// IF_DEBUG(RtsFlags_DebugFlags_apply,
+// foreign "C" fprintf(stderr, stg_ap_0_ret_str));
+//
+// Note the syntax is slightly different to the C version of this macro.
+//
+#ifdef DEBUG
+#define IF_DEBUG(c,s) if (RtsFlags_DebugFlags_##c(RtsFlags)) { s; }
+#else
+#define IF_DEBUG(c,s) /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+ Entering
+
+ It isn't safe to "enter" every closure. Functions in particular
+ have no entry code as such; their entry point contains the code to
+ apply the function.
+
+ ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES,
+ but switch doesn't allow us to use exprs there yet.
+ -------------------------------------------------------------------------- */
+
+#define ENTER() \
+ again: \
+ switch [INVALID_OBJECT .. N_CLOSURE_TYPES] \
+ (TO_W_( %INFO_TYPE(%GET_STD_INFO(R1)) )) { \
+ case \
+ IND, \
+ IND_OLDGEN, \
+ IND_PERM, \
+ IND_OLDGEN_PERM, \
+ IND_STATIC: \
+ { \
+ R1 = StgInd_indirectee(R1); \
+ goto again; \
+ } \
+ case \
+ BCO, \
+ FUN, \
+ FUN_1_0, \
+ FUN_0_1, \
+ FUN_2_0, \
+ FUN_1_1, \
+ FUN_0_2, \
+ FUN_STATIC, \
+ PAP: \
+ { \
+ jump %ENTRY_CODE(Sp(0)); \
+ } \
+ default: \
+ { \
+ jump %GET_ENTRY(R1); \
+ } \
+ }
+
+/* -----------------------------------------------------------------------------
+ Constants.
+ -------------------------------------------------------------------------- */
+
+#include "Constants.h"
+#include "DerivedConstants.h"
+#include "ClosureTypes.h"
+#include "StgFun.h"
+
+//
+// Need MachRegs, because some of the RTS code is conditionally
+// compiled based on REG_R1, REG_R2, etc.
+//
+#define STOLEN_X86_REGS 4
+#include "MachRegs.h"
+
+#include "Liveness.h"
+#include "StgLdvProf.h"
+
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#include "Block.h" // For Bdescr()
+
+
+// Can't think of a better place to put this.
+#if SIZEOF_mp_limb_t != SIZEOF_VOID_P
+#error mp_limb_t != StgWord: assumptions in PrimOps.cmm are now false
+#endif
+
+/* -------------------------------------------------------------------------
+ Allocation and garbage collection
+ ------------------------------------------------------------------------- */
+
+// ALLOC_PRIM is for allocating memory on the heap for a primitive
+// object. It is used all over PrimOps.cmm.
+//
+// We make the simplifying assumption that the "admin" part of a
+// primitive closure is just the header when calculating sizes for
+// ticky-ticky. It's not clear whether eg. the size field of an array
+// should be counted as "admin", or the various fields of a BCO.
+//
+#define ALLOC_PRIM(bytes,liveness,reentry) \
+ HP_CHK_GEN_TICKY(bytes,liveness,reentry); \
+ TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \
+ CCCS_ALLOC(bytes);
+
+// CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words
+#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), W_[CCCS])
+
+#define HP_CHK_GEN_TICKY(alloc,liveness,reentry) \
+ HP_CHK_GEN(alloc,liveness,reentry); \
+ TICK_ALLOC_HEAP_NOCTR(alloc);
+
+#define MAYBE_GC(liveness,reentry) \
+ if (CInt[alloc_blocks] >= CInt[alloc_blocks_lim]) { \
+ R9 = liveness; \
+ R10 = reentry; \
+ jump stg_gc_gen_hp; \
+ }
+
+/* -----------------------------------------------------------------------------
+ Closures
+ -------------------------------------------------------------------------- */
+
+// The offset of the payload of an array
+#define BYTE_ARR_CTS(arr) ((arr) + SIZEOF_StgArrWords)
+
+// Getting/setting the info pointer of a closure
+#define SET_INFO(p,info) StgHeader_info(p) = info
+#define GET_INFO(p) StgHeader_info(p)
+
+// Determine the size of an ordinary closure from its info table
+#define sizeW_fromITBL(itbl) \
+ SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl))
+
+// NB. duplicated from InfoTables.h!
+#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)
+#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)
+
+// Debugging macros
+#define LOOKS_LIKE_INFO_PTR(p) \
+ ((p) != NULL && \
+ (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) && \
+ (TO_W_(%INFO_TYPE(%STD_INFO(p))) < N_CLOSURE_TYPES))
+
+#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(p)))
+
+//
+// The layout of the StgFunInfoExtra part of an info table changes
+// depending on TABLES_NEXT_TO_CODE. So we define field access
+// macros which use the appropriate version here:
+//
+#ifdef TABLES_NEXT_TO_CODE
+#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraRev_slow_apply(i)
+#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraRev_fun_type(i)
+#define StgFunInfoExtra_arity(i) StgFunInfoExtraRev_arity(i)
+#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraRev_bitmap(i)
+#else
+#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i)
+#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraFwd_fun_type(i)
+#define StgFunInfoExtra_arity(i) StgFunInfoExtraFwd_arity(i)
+#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i)
+#endif
+
+/* -----------------------------------------------------------------------------
+ Voluntary Yields/Blocks
+
+ We only have a generic version of this at the moment - if it turns
+ out to be slowing us down we can make specialised ones.
+ -------------------------------------------------------------------------- */
+
+#define YIELD(liveness,reentry) \
+ R9 = liveness; \
+ R10 = reentry; \
+ jump stg_gen_yield;
+
+#define BLOCK(liveness,reentry) \
+ R9 = liveness; \
+ R10 = reentry; \
+ jump stg_gen_block;
+
+/* -----------------------------------------------------------------------------
+ Ticky macros
+ -------------------------------------------------------------------------- */
+
+#ifdef TICKY_TICKY
+#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n
+#else
+#define TICK_BUMP_BY(ctr,n) /* nothing */
+#endif
+
+#define TICK_BUMP(ctr) TICK_BUMP_BY(ctr,1)
+
+#define TICK_ENT_DYN_IND() TICK_BUMP(ENT_DYN_IND_ctr)
+#define TICK_ENT_DYN_THK() TICK_BUMP(ENT_DYN_THK_ctr)
+#define TICK_ENT_VIA_NODE() TICK_BUMP(ENT_VIA_NODE_ctr)
+#define TICK_ENT_STATIC_IND() TICK_BUMP(ENT_STATIC_IND_ctr)
+#define TICK_ENT_PERM_IND() TICK_BUMP(ENT_PERM_IND_ctr)
+#define TICK_ENT_PAP() TICK_BUMP(ENT_PAP_ctr)
+#define TICK_ENT_AP() TICK_BUMP(ENT_AP_ctr)
+#define TICK_ENT_AP_STACK() TICK_BUMP(ENT_AP_STACK_ctr)
+#define TICK_ENT_BH() TICK_BUMP(ENT_BH_ctr)
+#define TICK_UNKNOWN_CALL() TICK_BUMP(UNKNOWN_CALL_ctr)
+#define TICK_UPDF_PUSHED() TICK_BUMP(UPDF_PUSHED_ctr)
+#define TICK_CATCHF_PUSHED() TICK_BUMP(CATCHF_PUSHED_ctr)
+#define TICK_UPDF_OMITTED() TICK_BUMP(UPDF_OMITTED_ctr)
+#define TICK_UPD_NEW_IND() TICK_BUMP(UPD_NEW_IND_ctr)
+#define TICK_UPD_NEW_PERM_IND() TICK_BUMP(UPD_NEW_PERM_IND_ctr)
+#define TICK_UPD_OLD_IND() TICK_BUMP(UPD_OLD_IND_ctr)
+#define TICK_UPD_OLD_PERM_IND() TICK_BUMP(UPD_OLD_PERM_IND_ctr)
+
+#define TICK_SLOW_CALL_FUN_TOO_FEW() TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr)
+#define TICK_SLOW_CALL_FUN_CORRECT() TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr)
+#define TICK_SLOW_CALL_FUN_TOO_MANY() TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr)
+#define TICK_SLOW_CALL_PAP_TOO_FEW() TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr)
+#define TICK_SLOW_CALL_PAP_CORRECT() TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr)
+#define TICK_SLOW_CALL_PAP_TOO_MANY() TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr)
+
+#define TICK_SLOW_CALL_v() TICK_BUMP(SLOW_CALL_v_ctr)
+#define TICK_SLOW_CALL_p() TICK_BUMP(SLOW_CALL_p_ctr)
+#define TICK_SLOW_CALL_pv() TICK_BUMP(SLOW_CALL_pv_ctr)
+#define TICK_SLOW_CALL_pp() TICK_BUMP(SLOW_CALL_pp_ctr)
+#define TICK_SLOW_CALL_ppp() TICK_BUMP(SLOW_CALL_ppp_ctr)
+#define TICK_SLOW_CALL_pppp() TICK_BUMP(SLOW_CALL_pppp_ctr)
+#define TICK_SLOW_CALL_ppppp() TICK_BUMP(SLOW_CALL_ppppp_ctr)
+#define TICK_SLOW_CALL_pppppp() TICK_BUMP(SLOW_CALL_pppppp_ctr)
+
+#ifdef TICKY_TICKY
+#define TICK_HISTO_BY(histo,n,i) \
+ W_ __idx; \
+ __idx = (n); \
+ if (__idx > 8) { \
+ __idx = 8; \
+ } \
+ CLong[histo##_hst + _idx*SIZEOF_LONG] \
+ = histo##_hst + __idx*SIZEOF_LONG] + i;
+#else
+#define TICK_HISTO_BY(histo,n,i) /* nothing */
+#endif
+
+#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1)
+
+// An unboxed tuple with n components.
+#define TICK_RET_UNBOXED_TUP(n) \
+ TICK_BUMP(RET_UNBOXED_TUP_ctr++); \
+ TICK_HISTO(RET_UNBOXED_TUP,n)
+
+// A slow call with n arguments. In the unevald case, this call has
+// already been counted once, so don't count it again.
+#define TICK_SLOW_CALL(n) \
+ TICK_BUMP(SLOW_CALL_ctr); \
+ TICK_HISTO(SLOW_CALL,n)
+
+// This slow call was found to be to an unevaluated function; undo the
+// ticks we did in TICK_SLOW_CALL.
+#define TICK_SLOW_CALL_UNEVALD(n) \
+ TICK_BUMP(SLOW_CALL_UNEVALD_ctr); \
+ TICK_BUMP_BY(SLOW_CALL_ctr,-1); \
+ TICK_HISTO_BY(SLOW_CALL,n,-1);
+
+// Updating a closure with a new CON
+#define TICK_UPD_CON_IN_NEW(n) \
+ TICK_BUMP(UPD_CON_IN_NEW_ctr); \
+ TICK_HISTO(UPD_CON_IN_NEW,n)
+
+#define TICK_ALLOC_HEAP_NOCTR(n) \
+ TICK_BUMP(ALLOC_HEAP_ctr); \
+ TICK_BUMP_BY(ALLOC_HEAP_tot,n)
+
+#endif // CMM_H
/* ----------------------------------------------------------------------------
- * $Id: Constants.h,v 1.25 2003/04/28 09:55:20 simonmar Exp $
+ * $Id: Constants.h,v 1.26 2004/08/13 13:09:13 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
* space.
*/
-#define MAX_SPEC_AP_SIZE 8
-/* ToDo: make it 8 again */
+#define MAX_SPEC_AP_SIZE 7
/* Specialised FUN/THUNK/CONSTR closure types */
#define MAX_SPEC_FUN_SIZE 2
#define MAX_SPEC_CONSTR_SIZE 2
+/* Range of built-in table of static small int-like and char-like closures.
+ *
+ * NB. This corresponds with the number of actual INTLIKE/CHARLIKE
+ * closures defined in rts/StgMiscClosures.cmm.
+ */
+#define MAX_INTLIKE 16
+#define MIN_INTLIKE (-16)
+
+#define MAX_CHARLIKE 255
+#define MIN_CHARLIKE 0
+
/* -----------------------------------------------------------------------------
STG Registers.
#define MAX_VANILLA_REG 8
#define MAX_FLOAT_REG 4
#define MAX_DOUBLE_REG 2
-/* register is only used for returning (unboxed) 64-bit vals */
#define MAX_LONG_REG 1
-/*---- Maximum number of constructors in a data type for direct-returns. */
+/* -----------------------------------------------------------------------------
+ * Maximum number of constructors in a data type for direct-returns.
+ *
+ * NB. There are various places that assume the value of this
+ * constant, such as the polymorphic return frames for updates
+ * (stg_upd_frame_info) and catch frames (stg_catch_frame_info).
+ * -------------------------------------------------------------------------- */
#define MAX_VECTORED_RTN 8
-/*---- Range of built-in table of static small int-like and char-like closures. */
-
-#define MAX_INTLIKE 16
-#define MIN_INTLIKE (-16)
-
-#define MAX_CHARLIKE 255
-#define MIN_CHARLIKE 0
-
-/* You can change these constants (I hope) but be sure to modify
- rts/StgMiscClosures.hs accordingly. */
-
/* -----------------------------------------------------------------------------
Semi-Tagging constants
#error unknown SIZEOF_VOID_P
#endif
+/* -----------------------------------------------------------------------------
+ Lag/Drag/Void constants
+ -------------------------------------------------------------------------- */
+
+/*
+ An LDV word is divided into 3 parts: state bits (LDV_STATE_MASK), creation
+ time bits (LDV_CREATE_MASK), and last use time bits (LDV_LAST_MASK).
+ */
+#if SIZEOF_VOID_P == 8
+#define LDV_SHIFT 30
+#define LDV_STATE_MASK 0x1000000000000000
+#define LDV_CREATE_MASK 0x0FFFFFFFC0000000
+#define LDV_LAST_MASK 0x000000003FFFFFFF
+#define LDV_STATE_CREATE 0x0000000000000000
+#define LDV_STATE_USE 0x1000000000000000
+#else
+#define LDV_SHIFT 15
+#define LDV_STATE_MASK 0x40000000
+#define LDV_CREATE_MASK 0x3FFF8000
+#define LDV_LAST_MASK 0x00007FFF
+#define LDV_STATE_CREATE 0x00000000
+#define LDV_STATE_USE 0x40000000
+#endif // SIZEOF_VOID_P
+
+/* -----------------------------------------------------------------------------
+ TSO related constants
+ -------------------------------------------------------------------------- */
+
+/*
+ * Constants for the what_next field of a TSO, which indicates how it
+ * is to be run.
+ */
+#define ThreadRunGHC 1 /* return to address on top of stack */
+#define ThreadInterpret 2 /* interpret this thread */
+#define ThreadKilled 3 /* thread has died, don't run it */
+#define ThreadRelocated 4 /* thread has moved, link points to new locn */
+#define ThreadComplete 5 /* thread has finished */
+
+/*
+ * Constants for the why_blocked field of a TSO
+ */
+#define NotBlocked 0
+#define BlockedOnMVar 1
+#define BlockedOnBlackHole 2
+#define BlockedOnException 3
+#define BlockedOnRead 4
+#define BlockedOnWrite 5
+#define BlockedOnDelay 6
+
+/* Win32 only: */
+#define BlockedOnDoProc 7
+
+/* Only relevant for PAR: */
+ /* blocked on a remote closure represented by a Global Address: */
+#define BlockedOnGA 8
+ /* same as above but without sending a Fetch message */
+#define BlockedOnGA_NoSend 9
+/* Only relevant for RTS_SUPPORTS_THREADS: */
+#define BlockedOnCCall 10
+#define BlockedOnCCall_NoUnblockExc 11
+ /* same as above but don't unblock async exceptions in resumeThread() */
+
+/*
+ * These constants are returned to the scheduler by a thread that has
+ * stopped for one reason or another. See typedef StgThreadReturnCode
+ * in TSO.h.
+ */
+#define HeapOverflow 1 /* might also be StackOverflow */
+#define StackOverflow 2
+#define ThreadYielding 3
+#define ThreadBlocked 4
+#define ThreadFinished 5
+
+/* -----------------------------------------------------------------------------
+ RET_DYN stack frames
+ -------------------------------------------------------------------------- */
+
+/* VERY MAGIC CONSTANTS!
+ * must agree with code in HeapStackCheck.c, stg_gen_chk, and
+ * RESERVED_STACK_WORDS in Constants.h.
+ */
+#define RET_DYN_BITMAP_SIZE 8
+#define RET_DYN_NONPTR_REGS_SIZE 10
+
+/* Sanity check that RESERVED_STACK_WORDS is reasonable. We can't
+ * just derive RESERVED_STACK_WORDS because it's used in Haskell code
+ * too.
+ */
+#if RESERVED_STACK_WORDS != (3 + RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE)
+#error RESERVED_STACK_WORDS may be wrong!
+#endif
+
#endif /* CONSTANTS_H */
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: Derived.h,v 1.2 2001/08/04 06:09:24 ken Exp $
- *
- * (c) The GHC Team, 1998-2001
- *
- * Configuration information derived from config.h.
- *
- * NOTE: assumes #include "config.h"
- *
- * NB: THIS FILE IS INCLUDED IN NON-C CODE AND DATA! #defines only please.
- * ---------------------------------------------------------------------------*/
-
-#ifndef DERIVED_H
-#define DERIVED_H
-
-/*
- * SUPPORT_LONG_LONGS controls whether we need to support long longs on a
- * particular platform. On 64-bit platforms, we don't need to support
- * long longs since regular machine words will do just fine.
- */
-#if HAVE_LONG_LONG && SIZEOF_VOID_P < 8
-#define SUPPORT_LONG_LONGS 1
-#endif
-
-/*
- * Whether the runtime system will use libbfd for debugging purposes.
- */
-#if defined(DEBUG) && defined(HAVE_BFD_H) && !defined(_WIN32) && !defined(PAR) && !defined(GRAN)
-#define USING_LIBBFD 1
-#endif
-
-#endif /* DERIVED_H */
+++ /dev/null
-
-typedef enum { dh_stdcall, dh_ccall } DH_CALLCONV;
-typedef int DH_MODULE;
-typedef char* DH_LPCSTR;
-
-extern __attribute__((__stdcall__))
- DH_MODULE DH_LoadLibrary ( DH_LPCSTR modname );
-extern __attribute__((__stdcall__))
- void* DH_GetProcAddress ( DH_CALLCONV cconv,
- DH_MODULE hModule,
- DH_LPCSTR lpProcName );
-
-
/* -----------------------------------------------------------------------------
- * $Id: HsFFI.h,v 1.19 2004/04/12 16:26:40 panne Exp $
+ * $Id: HsFFI.h,v 1.20 2004/08/13 13:09:13 simonmar Exp $
*
* (c) The GHC Team, 2000
*
#endif
/* get types from GHC's runtime system */
-#include "config.h"
+#include "ghcconfig.h"
+#include "RtsConfig.h"
#include "StgTypes.h"
/* get limits for integral types */
+++ /dev/null
-/* ----------------------------------------------------------------------------
- * $Id: InfoMacros.h,v 1.22 2003/05/14 09:14:01 simonmar Exp $
- *
- * (c) The GHC Team, 1998-2002
- *
- * Macros for building and deconstructing info tables.
- *
- * -------------------------------------------------------------------------- */
-
-#ifndef INFOMACROS_H
-#define INFOMACROS_H
-
-#define STD_INFO(srt_bitmap_, type_) \
- srt_bitmap : srt_bitmap_, \
- type : type_
-
-#define THUNK_INFO(srt_, srt_off_) \
- srt : (StgSRT *)((StgClosure **)srt_+srt_off_)
-
-#define FUN_GEN_INFO(srt_, srt_off_, fun_type_, arity_, bitmap_, slow_apply_) \
-
-#define RET_INFO(srt_, srt_off_) \
- srt : (StgSRT *)((StgClosure **)srt_+srt_off_)
-
-#ifdef PROFILING
-#define PROF_INFO(type_str, desc_str) \
- prof: { \
- closure_type: type_str, \
- closure_desc: desc_str, \
- },
-#else
-#define PROF_INFO(type_str, desc_str)
-#endif
-
-/*
- On the GranSim/GUM specific parts of the InfoTables (GRAN/PAR):
-
- In both GranSim and GUM we use revertible black holes (RBH) when putting
- an updatable closure into a packet for communication. The entry code for
- an RBH performs standard blocking (as with any kind of BH). The info
- table for the RBH resides just before the one for the std info
- table. (NB: there is one RBH ITBL for every ITBL of an updatable
- closure.) The @rbh_infoptr@ field in the ITBL points from the std ITBL to
- the RBH ITBL and vice versa. This is used by the RBH_INFOPTR and
- REVERT_INFOPTR macros to turn an updatable node into an RBH and vice
- versa. Note, that the only case where we have to revert the RBH in its
- original form is when a packet is sent back because of garbage collection
- on another PE. In the RTS for GdH we will use this reversion mechanism in
- order to deal with faults in the system.
- ToDo: Check that RBHs are needed for all the info tables below. From a quick
- check of the macros generated in the libs it seems that all of them are used
- for generating THUNKs.
- Possible optimisation: Note that any RBH ITBL is a fixed distance away from
- the actual ITBL. We could inline this offset as a constant into the RTS and
- avoid the rbh_infoptr fields altogether (Jim did that in the old RTS).
- -- HWL
-*/
-
-
-/* function/thunk info tables --------------------------------------------- */
-
-#if defined(GRAN) || defined(PAR)
-
-#define \
-INFO_TABLE_THUNK(info, /* info-table label */ \
- entry, /* entry code label */ \
- ptrs, nptrs, /* closure layout info */\
- srt_, srt_off_, srt_bitmap_, /* SRT info */ \
- type, /* closure type */ \
- info_class, entry_class, /* C storage classes */ \
- prof_descr, prof_type) /* profiling info */ \
- entry_class(stg_RBH_##entry); \
- entry_class(entry); \
- ED_RO_ StgInfoTable info; \
- info_class const StgInfoTable stg_RBH_##info = { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(RBH,srt_,srt_off_,srt_bitmap_), \
- INCLUDE_RBH_INFO(info), \
- INIT_ENTRY(stg_RBH_##entry) \
- } ; \
- StgFunPtr stg_RBH_##entry (void) { \
- FB_ \
- JMP_(stg_RBH_entry); \
- FE_ \
- } ; \
- info_class const StgInfoTable info = { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(type,srt_,srt_off_,srt_bitmap_), \
- INCLUDE_RBH_INFO(stg_RBH_##info), \
- INIT_ENTRY(entry) \
- }
-
-#else
-
-#define \
-INFO_TABLE_THUNK(info, /* info-table label */ \
- entry, /* entry code label */ \
- ptrs, nptrs, /* closure layout info */\
- srt_, srt_off_, srt_bitmap_, /* SRT info */ \
- type_, /* closure type */ \
- info_class, entry_class, /* C storage classes */ \
- prof_descr, prof_type) /* profiling info */ \
- entry_class(entry); \
- info_class const StgThunkInfoTable info = { \
- i : { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(srt_bitmap_, type_), \
- INIT_ENTRY(entry) \
- }, \
- THUNK_INFO(srt_,srt_off_), \
- }
-
-#endif
-
-/* direct-return address info tables --------------------------------------*/
-
-#if defined(GRAN) || defined(PAR)
-
-#define \
-INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_bitmap_, \
- type, info_class, entry_class, \
- prof_descr, prof_type) \
- entry_class(stg_RBH_##entry); \
- entry_class(entry); \
- ED_RO_ StgInfoTable info; \
- info_class const StgInfoTable stg_RBH_##info = { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(RBH,srt_,srt_off_,srt_bitmap_), \
- INCLUDE_RBH_INFO(info), \
- INIT_ENTRY(stg_RBH_##entry) \
- }; \
- StgFunPtr stg_RBH_##entry (void) { \
- FB_ \
- JMP_(stg_RBH_entry); \
- FE_ \
- } ; \
- info_class const StgInfoTable info = { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- PROF_INFO(prof_type, prof_descr) \
- SRT_INFO(type,srt_,srt_off_,srt_bitmap_), \
- INCLUDE_RBH_INFO(stg_RBH_##info), \
- INIT_ENTRY(entry) \
- }
-
-#else
-
-#define \
-INFO_TABLE_RET(info, entry, bitmap_, srt_, srt_off_, srt_bitmap_, \
- type_, info_class, entry_class, \
- prof_descr, prof_type) \
- entry_class(entry); \
- info_class const StgRetInfoTable info = { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(srt_bitmap_,type_), \
- INIT_ENTRY(entry) \
- }, \
- RET_INFO(srt_,srt_off_) \
- }
-#endif
-
-/* info-table without an SRT -----------------------------------------------*/
-
-#if defined(GRAN) || defined(PAR)
-
-#define \
-INFO_TABLE(info, entry, ptrs, nptrs, type, info_class, \
- entry_class, prof_descr, prof_type) \
- entry_class(stg_RBH_##entry); \
- entry_class(entry); \
- ED_ StgInfoTable info; \
- info_class const StgInfoTable stg_RBH_##info = { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(RBH), \
- INCLUDE_RBH_INFO(info), \
- INIT_ENTRY(stg_RBH_##entry) \
- } ; \
- StgFunPtr stg_RBH_##entry (void) { \
- FB_ \
- JMP_(stg_RBH_entry); \
- FE_ \
- } ; \
- info_class const StgInfoTable info = { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(type), \
- INCLUDE_RBH_INFO(stg_RBH_##info), \
- INIT_ENTRY(entry) \
- }
-
-#else
-
-#define \
-INFO_TABLE(info, entry, ptrs, nptrs, type, info_class, \
- entry_class, prof_descr, prof_type) \
- entry_class(entry); \
- info_class const StgInfoTable info = { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(0, type), \
- INIT_ENTRY(entry) \
- }
-
-#endif
-
-/* special selector-thunk info table ---------------------------------------*/
-
-#if defined(GRAN) || defined(PAR)
-
-#define \
-INFO_TABLE_SELECTOR(info, entry, offset, info_class, \
- entry_class, prof_descr, prof_type) \
- entry_class(stg_RBH_##entry); \
- entry_class(entry); \
- ED_RO_ StgInfoTable info; \
- info_class const StgInfoTable stg_RBH_##info = { \
- layout : { selector_offset : offset }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(RBH), \
- INCLUDE_RBH_INFO(info), \
- INIT_ENTRY(stg_RBH_##entry) \
- }; \
- StgFunPtr stg_RBH_##entry (void) { \
- FB_ \
- JMP_(stg_RBH_entry); \
- FE_ \
- } ; \
- info_class const StgInfoTable info = { \
- layout : { selector_offset : offset }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(THUNK_SELECTOR), \
- INCLUDE_RBH_INFO(stg_RBH_##info), \
- INIT_ENTRY(entry) \
- }
-
-#else
-
-#define \
-INFO_TABLE_SELECTOR(info, entry, offset, info_class, \
- entry_class, prof_descr, prof_type) \
- entry_class(entry); \
- info_class const StgInfoTable info = { \
- layout : { selector_offset : offset }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(0,THUNK_SELECTOR), \
- INIT_ENTRY(entry) \
- }
-
-#endif
-
-/* constructor info table --------------------------------------------------*/
-
-#define \
-INFO_TABLE_CONSTR(info, entry, ptrs, nptrs, tag_,type_,info_class, \
- entry_class, prof_descr, prof_type) \
- entry_class(entry); \
- info_class const StgInfoTable info = { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(tag_, type_), \
- INIT_ENTRY(entry) \
- }
-
-#define constrTag(con) (get_itbl(con)->srt_bitmap)
-
-/* function info table -----------------------------------------------------*/
-
-#define \
-INFO_TABLE_FUN_GEN(info, /* info-table label */ \
- entry, /* entry code label */ \
- ptrs, nptrs, /* closure layout info */\
- srt_, srt_off_, srt_bitmap_, /* SRT info */ \
- fun_type_, arity_, bitmap_, slow_apply_, \
- /* Function info */ \
- type_, /* closure type */ \
- info_class, entry_class, /* C storage classes */ \
- prof_descr, prof_type) /* profiling info */ \
- entry_class(entry); \
- info_class const StgFunInfoTable info = { \
- i : { \
- layout : { payload : {ptrs,nptrs} }, \
- PROF_INFO(prof_type, prof_descr) \
- STD_INFO(srt_bitmap_,type_), \
- INIT_ENTRY(entry) \
- }, \
- srt : (StgSRT *)((StgClosure **)srt_+srt_off_), \
- arity : arity_, \
- fun_type : fun_type_, \
- bitmap : (W_)bitmap_, \
- slow_apply : slow_apply_ \
- }
-
-/* return-vectors ----------------------------------------------------------*/
-
-/* vectored-return info tables have the vector slammed up against the
- * start of the info table.
- *
- * A vectored-return address always has an SRT and a bitmap-style
- * layout field, so we only need one macro for these.
- */
-
-#ifdef TABLES_NEXT_TO_CODE
-
-typedef struct {
- StgFunPtr vec[2];
- StgRetInfoTable i;
-} vec_info_2;
-
-typedef struct {
- StgFunPtr vec[3];
- StgRetInfoTable i;
-} vec_info_3;
-
-typedef struct {
- StgFunPtr vec[4];
- StgRetInfoTable i;
-} vec_info_4;
-
-typedef struct {
- StgFunPtr vec[5];
- StgRetInfoTable i;
-} vec_info_5;
-
-typedef struct {
- StgFunPtr vec[6];
- StgRetInfoTable i;
-} vec_info_6;
-
-typedef struct {
- StgFunPtr vec[7];
- StgRetInfoTable i;
-} vec_info_7;
-
-typedef struct {
- StgFunPtr vec[8];
- StgRetInfoTable i;
-} vec_info_8;
-
-#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2) \
- info_class const vec_info_2 info = { \
- { alt_2, alt_1 }, \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3 \
- ) \
- info_class const vec_info_3 info = { \
- { alt_3, alt_2, alt_1 }, \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4 \
- ) \
- info_class const vec_info_4 info = { \
- { alt_4, alt_3, alt_2, alt_1 }, \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4, \
- alt_5 \
- ) \
- info_class const vec_info_5 info = { \
- { alt_5, alt_4, alt_3, alt_2, \
- alt_1 }, \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6 \
- ) \
- info_class const vec_info_6 info = { \
- { alt_6, alt_5, alt_4, alt_3, \
- alt_2, alt_1 }, \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6, alt_7 \
- ) \
- info_class const vec_info_7 info = { \
- { alt_7, alt_6, alt_5, alt_4, \
- alt_3, alt_2, alt_1 }, \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6, alt_7, alt_8 \
- ) \
- info_class const vec_info_8 info = { \
- { alt_8, alt_7, alt_6, alt_5, \
- alt_4, alt_3, alt_2, alt_1 }, \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-
-#else
-
-/* We have to define these structure to work around a bug in gcc: if we
- * try to initialise the vector directly (it's defined as a zero-length
- * array tacked on the end of the info table structor), then gcc silently
- * throws away our vector table sometimes.
- */
-
-typedef struct {
- StgRetInfoTable i;
- StgFunPtr vec[2];
-} vec_info_2;
-
-typedef struct {
- StgRetInfoTable i;
- StgFunPtr vec[3];
-} vec_info_3;
-
-typedef struct {
- StgRetInfoTable i;
- StgFunPtr vec[4];
-} vec_info_4;
-
-typedef struct {
- StgRetInfoTable i;
- StgFunPtr vec[5];
-} vec_info_5;
-
-typedef struct {
- StgRetInfoTable i;
- StgFunPtr vec[6];
-} vec_info_6;
-
-typedef struct {
- StgRetInfoTable i;
- StgFunPtr vec[7];
-} vec_info_7;
-
-typedef struct {
- StgRetInfoTable i;
- StgFunPtr vec[8];
-} vec_info_8;
-
-#define VEC_INFO_2(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2) \
- info_class const vec_info_2 info = { \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-#define VEC_INFO_3(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3 \
- ) \
- info_class const vec_info_3 info = { \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- }, \
- vec : { alt_1, alt_2, alt_3 } \
- }
-
-#define VEC_INFO_4(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4 \
- ) \
- info_class const vec_info_4 info = { \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- }, \
- vec : { alt_1, alt_2, alt_3, alt_4 } \
- }
-
-#define VEC_INFO_5(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4, \
- alt_5 \
- ) \
- info_class const vec_info_5 info = { \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- }, \
- vec : { alt_1, alt_2, alt_3, alt_4, \
- alt_5 } \
- }
-
-#define VEC_INFO_6(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6 \
- ) \
- info_class const vec_info_6 info = { \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- }, \
- vec : { alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6 } \
- }
-
-#define VEC_INFO_7(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6, alt_7 \
- ) \
- info_class const vec_info_7 info = { \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- }, \
- vec : { alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6, alt_7 } \
- }
-
-#define VEC_INFO_8(info,bitmap_,srt_,srt_off_,srt_bitmap_, \
- type_, info_class, \
- alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6, alt_7, alt_8 \
- ) \
- info_class const vec_info_8 info = { \
- i : { \
- i : { \
- layout : { bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_,type_) \
- }, \
- RET_INFO(srt_,srt_off_) \
- }, \
- vec : { alt_1, alt_2, alt_3, alt_4, \
- alt_5, alt_6, alt_7, alt_8 } \
- }
-
-#endif /* TABLES_NEXT_TO_CODE */
-
-/* For polymorphic activation records, we need both a direct return
- * address and a return vector:
- */
-
-typedef vec_info_8 StgPolyInfoTable;
-
-#ifndef TABLES_NEXT_TO_CODE
-
-#define VEC_POLY_INFO_TABLE(nm, bitmap_, \
- srt_, srt_off_, srt_bitmap_, \
- type_, info_class, entry_class \
- ) \
- info_class const vec_info_8 nm##_info = { \
- i : { \
- i : { \
- layout : { \
- bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_, type_), \
- INIT_ENTRY(nm##_ret) \
- }, \
- RET_INFO(srt_,srt_off_) \
- }, \
- vec : { \
- (F_) nm##_0_ret, \
- (F_) nm##_1_ret, \
- (F_) nm##_2_ret, \
- (F_) nm##_3_ret, \
- (F_) nm##_4_ret, \
- (F_) nm##_5_ret, \
- (F_) nm##_6_ret, \
- (F_) nm##_7_ret \
- } \
- }
-#else
-
-#define VEC_POLY_INFO_TABLE(nm, bitmap_, \
- srt_, srt_off_, srt_bitmap_, \
- type_, info_class, entry_class \
- ) \
- info_class const vec_info_8 nm##_info = { \
- { \
- (F_) nm##_7_ret, \
- (F_) nm##_6_ret, \
- (F_) nm##_5_ret, \
- (F_) nm##_4_ret, \
- (F_) nm##_3_ret, \
- (F_) nm##_2_ret, \
- (F_) nm##_1_ret, \
- (F_) nm##_0_ret \
- }, \
- i : { \
- i : { \
- layout : { \
- bitmap : (StgWord)bitmap_ }, \
- STD_INFO(srt_bitmap_, type_), \
- INIT_ENTRY(nm##_ret) \
- }, \
- RET_INFO(srt_,srt_off_) \
- } \
- }
-
-#endif
-
-#define SRT(lbl) \
- static const StgSRT lbl = {
-
-/* DLL_SRT_ENTRY is used on the Win32 side when filling initialising
- an entry in an SRT table with a reference to a closure that's
- living in a DLL. See elsewhere for reasons as to why we need
- to distinguish these kinds of references.
- (ToDo: fill in a more precise href.)
-*/
-#ifdef ENABLE_WIN32_DLL_SUPPORT /* mingw DietHEP doesn't seem to care either way */
-#define DLL_SRT_ENTRY(x) ((StgClosure*)(((char*)&DLL_IMPORT_DATA_VAR(x)) + 1))
-#else
-#define DLL_SRT_ENTRY(x) no-can-do
-#endif
-
-#endif /* INFOMACROS_H */
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.32 2003/11/14 14:28:08 stolz Exp $
+ * $Id: InfoTables.h,v 1.33 2004/08/13 13:09:17 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
(usually on the stack) to the garbage collector. The two primary
uses are for stack frames, and functions (where we need to describe
the layout of a PAP to the GC).
+
+ In these bitmaps: 0 == ptr, 1 == non-ptr.
-------------------------------------------------------------------------- */
//
bitmap fields have also been omitted.
-------------------------------------------------------------------------- */
-typedef struct _StgFunInfoTable {
-#if defined(TABLES_NEXT_TO_CODE)
+typedef struct _StgFunInfoExtraRev {
StgFun *slow_apply; // apply to args on the stack
StgWord bitmap; // arg ptr/nonptr bitmap
StgSRT *srt; // pointer to the SRT table
StgHalfWord fun_type; // function type
StgHalfWord arity; // function arity
- StgInfoTable i;
-#else
- StgInfoTable i;
+} StgFunInfoExtraRev;
+
+typedef struct _StgFunInfoExtraFwd {
StgHalfWord fun_type; // function type
StgHalfWord arity; // function arity
StgSRT *srt; // pointer to the SRT table
StgWord bitmap; // arg ptr/nonptr bitmap
StgFun *slow_apply; // apply to args on the stack
+} StgFunInfoExtraFwd;
+
+typedef struct {
+#if defined(TABLES_NEXT_TO_CODE)
+ StgFunInfoExtraRev f;
+ StgInfoTable i;
+#else
+ StgInfoTable i;
+ StgFunInfoExtraFwd f;
#endif
} StgFunInfoTable;
// When info tables are laid out backwards, we can omit the SRT
// pointer iff srt_bitmap is zero.
-typedef struct _StgRetInfoTable {
-#if !defined(TABLES_NEXT_TO_CODE)
- StgInfoTable i;
-#endif
- StgSRT *srt; // pointer to the SRT table
+typedef struct {
#if defined(TABLES_NEXT_TO_CODE)
+ StgSRT *srt; // pointer to the SRT table
StgInfoTable i;
-#endif
-#if !defined(TABLES_NEXT_TO_CODE)
+#else
+ StgInfoTable i;
+ StgSRT *srt; // pointer to the SRT table
StgFunPtr vector[FLEXIBLE_ARRAY];
#endif
} StgRetInfoTable;
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2004
+ *
+ * Building liveness masks for RET_DYN stack frames.
+ * A few macros that are used in both .cmm and .c sources.
+ *
+ * A liveness mask is constructed like so:
+ *
+ * R1_PTR & R2_PTR & R3_PTR
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef LIVENESS_H
+#define LIVENESS_H
+
+#define NO_PTRS 0xff
+#define R1_PTR (NO_PTRS ^ (1<<0))
+#define R2_PTR (NO_PTRS ^ (1<<1))
+#define R3_PTR (NO_PTRS ^ (1<<2))
+#define R4_PTR (NO_PTRS ^ (1<<3))
+#define R5_PTR (NO_PTRS ^ (1<<4))
+#define R6_PTR (NO_PTRS ^ (1<<5))
+#define R7_PTR (NO_PTRS ^ (1<<6))
+#define R8_PTR (NO_PTRS ^ (1<<7))
+
+#define N_NONPTRS(n) ((n)<<16)
+#define N_PTRS(n) ((n)<<24)
+
+#define RET_DYN_NONPTRS(l) ((l)>>16 & 0xff)
+#define RET_DYN_PTRS(l) ((l)>>24 & 0xff)
+#define RET_DYN_LIVENESS(l) ((l) & 0xffff)
+
+#endif /* LIVENESS_H */
/* -----------------------------------------------------------------------------
- * $Id: MachDeps.h,v 1.8 2002/12/11 15:36:37 simonmar Exp $
*
* (c) The University of Glasgow 2002
*
#define MACHDEPS_H
/* Sizes of C types come from here... */
-#include "config.h"
+#include "ghcconfig.h"
/* Sizes of Haskell types follow. These sizes correspond to:
* - the number of bytes in the primitive type (eg. Int#)
/* -----------------------------------------------------------------------------
- * $Id: MachRegs.h,v 1.15 2003/12/10 11:35:25 wolfgang Exp $
+ * $Id: MachRegs.h,v 1.16 2004/08/13 13:09:18 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#define REG_Hp r25
#define REG_HpLim r26
-#define NCG_SpillTmp_I1 r27
-#define NCG_SpillTmp_I2 r28
-
-#define NCG_SpillTmp_D1 f20
-#define NCG_SpillTmp_D2 f21
+#define REG_Base r27
#endif /* powerpc */
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.22 2003/09/04 09:56:16 simonmar Exp $
+# $Id: Makefile,v 1.23 2004/08/13 13:09:18 simonmar Exp $
#
TOP = ..
#
# Header file built from the configure script's findings
#
-H_CONFIG = config.h
+H_CONFIG = ghcconfig.h
boot :: gmp.h
-all :: $(H_CONFIG) NativeDefs.h
+all :: $(H_CONFIG)
# gmp.h is copied from the GMP directory
gmp.h : $(FPTOOLS_TOP)/ghc/rts/gmp/gmp.h
$(H_CONFIG) :
@echo "Creating $@..."
@$(RM) $@
- @echo "#ifndef __FPTOOLS_CONFIG_H__" >$@
- @echo "#define __FPTOOLS_CONFIG_H__" >>$@
+ @echo "#ifndef __GHCCONFIG_H__" >$@
+ @echo "#define __GHCCONFIG_H__" >>$@
@echo >> $@
@echo "#define HostPlatform_TYPE $(HostPlatform_CPP)" >> $@
@echo "#define TargetPlatform_TYPE $(TargetPlatform_CPP)" >> $@
@echo "#define $(HostVendor_CPP)_HOST_VENDOR 1" >> $@
@echo "#define $(TargetVendor_CPP)_TARGET_VENDOR 1" >> $@
@echo "#define $(BuildVendor_CPP)_BUILD_VENDOR 1" >> $@
- @cat $(FPTOOLS_TOP)/mk/$@ >> $@
- @echo "#endif /* __FPTOOLS_CONFIG_H__ */" >> $@
+ @cat $(FPTOOLS_TOP)/mk/config.h >> $@
+ @echo "#endif /* __GHCCONFIG_H__ */" >> $@
@echo "Done."
# ---------------------------------------------------------------------------
$(CC) -o $@ $(CC_OPTS) $(LD_OPTS) mkDerivedConstants.o
DerivedConstants.h : mkDerivedConstantsHdr
- ./mkDerivedConstantsHdr >DerivedConstants.h
+ ./mkDerivedConstantsHdr >$@
CLEAN_FILES += mkDerivedConstantsHdr$(exeext) DerivedConstants.h
-# ---------------------------------------------------------------------------
-# Make NativeDefs.h for the NCG
+# -----------------------------------------------------------------------------
+#
-all :: NativeDefs.h
+all :: GHCConstants.h
-mkNativeHdr.o : DerivedConstants.h
+mkGHCConstants.c : $(H_CONFIG)
-mkNativeHdr : mkNativeHdr.o
- $(CC) -o $@ $(CC_OPTS) $(LD_OPTS) mkNativeHdr.o
+mkGHCConstants : mkGHCConstants.o
+ $(CC) -o $@ $(CC_OPTS) $(LD_OPTS) mkGHCConstants.o
-NativeDefs.h : mkNativeHdr
- ./mkNativeHdr >NativeDefs.h
+mkGHCConstants.o : mkDerivedConstants.c
+ $(CC) -o $@ -c $< -DGEN_HASKELL
-CLEAN_FILES += mkNativeHdr$(exeext) NativeDefs.h
+GHCConstants.h : mkGHCConstants
+ ./mkGHCConstants >$@
+
+CLEAN_FILES += mkDerivedConstantsHdr$(exeext) DerivedConstants.h
# ---------------------------------------------------------------------------
# boot setup:
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: PosixSource.h,v 1.2 2002/04/23 17:16:01 ken Exp $
- *
- * (c) The GHC Team, 1998-2001
- *
- * Include this file into sources which should not need any non-Posix services.
- * That includes most RTS C sources.
- * ---------------------------------------------------------------------------*/
-
-#ifndef POSIXSOURCE_H
-#define POSIXSOURCE_H
-
-#define _POSIX_SOURCE 1
-#define _POSIX_C_SOURCE 199506L
-#define _ISOC9X_SOURCE
-
-/* Let's be ISO C9X too... */
-
-#endif
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.107 2003/11/12 17:27:01 sof Exp $
- *
- * (c) The GHC Team, 1998-2000
- *
- * Macros for primitive operations in STG-ish C code.
- *
- * ---------------------------------------------------------------------------*/
-
-/* As of 5 Dec 01, this file no longer implements the primops, since they are
- translated into standard C in compiler/absCSyn/AbsCUtils during the absC
- flattening pass. Only {add,sub,mul}IntCzh remain untranslated. Most of
- what is here is now EXTFUN_RTS declarations for the out-of-line primop
- implementations which live in compiler/rts/PrimOps.hc.
-*/
-
-#ifndef PRIMOPS_H
-#define PRIMOPS_H
-
-#include "MachDeps.h"
-
-#if WORD_SIZE_IN_BITS < 32
-#error GHC C backend requires 32+-bit words
-#endif
-
-
-/* -----------------------------------------------------------------------------
- * Int operations with carry.
- * -------------------------------------------------------------------------- */
-
-/* Multiply with overflow checking.
- *
- * This is tricky - the usual sign rules for add/subtract don't apply.
- *
- * On 32-bit machines we use gcc's 'long long' types, finding
- * overflow with some careful bit-twiddling.
- *
- * On 64-bit machines where gcc's 'long long' type is also 64-bits,
- * we use a crude approximation, testing whether either operand is
- * larger than 32-bits; if neither is, then we go ahead with the
- * multiplication.
- *
- * Return non-zero if there is any possibility that the signed multiply
- * of a and b might overflow. Return zero only if you are absolutely sure
- * that it won't overflow. If in doubt, return non-zero.
- */
-
-#if SIZEOF_VOID_P == 4
-
-#ifdef WORDS_BIGENDIAN
-#define RTS_CARRY_IDX__ 0
-#define RTS_REM_IDX__ 1
-#else
-#define RTS_CARRY_IDX__ 1
-#define RTS_REM_IDX__ 0
-#endif
-
-typedef union {
- StgInt64 l;
- StgInt32 i[2];
-} long_long_u ;
-
-#define mulIntMayOflo(a,b) \
-({ \
- StgInt32 r, c; \
- long_long_u z; \
- z.l = (StgInt64)a * (StgInt64)b; \
- r = z.i[RTS_REM_IDX__]; \
- c = z.i[RTS_CARRY_IDX__]; \
- if (c == 0 || c == -1) { \
- c = ((StgWord)((a^b) ^ r)) \
- >> (BITS_IN (I_) - 1); \
- } \
- c; \
-})
-
-/* Careful: the carry calculation above is extremely delicate. Make sure
- * you test it thoroughly after changing it.
- */
-
-#else
-
-#define HALF_INT (((I_)1) << (BITS_IN (I_) / 2))
-
-#define stg_abs(a) (((I_)(a)) < 0 ? -((I_)(a)) : ((I_)(a)))
-
-#define mulIntMayOflo(a,b) \
-({ \
- I_ c; \
- if (stg_abs(a) >= HALF_INT || \
- stg_abs(b) >= HALF_INT) { \
- c = 1; \
- } else { \
- c = 0; \
- } \
- c; \
-})
-#endif
-
-
-/* -----------------------------------------------------------------------------
- Integer PrimOps.
- -------------------------------------------------------------------------- */
-
-/* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */
-
-/* Some of these are out-of-line: -------- */
-
-/* Integer arithmetic */
-EXTFUN_RTS(plusIntegerzh_fast);
-EXTFUN_RTS(minusIntegerzh_fast);
-EXTFUN_RTS(timesIntegerzh_fast);
-EXTFUN_RTS(gcdIntegerzh_fast);
-EXTFUN_RTS(quotRemIntegerzh_fast);
-EXTFUN_RTS(quotIntegerzh_fast);
-EXTFUN_RTS(remIntegerzh_fast);
-EXTFUN_RTS(divExactIntegerzh_fast);
-EXTFUN_RTS(divModIntegerzh_fast);
-
-EXTFUN_RTS(cmpIntegerIntzh_fast);
-EXTFUN_RTS(cmpIntegerzh_fast);
-EXTFUN_RTS(integer2Intzh_fast);
-EXTFUN_RTS(integer2Wordzh_fast);
-EXTFUN_RTS(gcdIntegerIntzh_fast);
-EXTFUN_RTS(gcdIntzh_fast);
-
-/* Conversions */
-EXTFUN_RTS(int2Integerzh_fast);
-EXTFUN_RTS(word2Integerzh_fast);
-
-/* Floating-point decodings */
-EXTFUN_RTS(decodeFloatzh_fast);
-EXTFUN_RTS(decodeDoublezh_fast);
-
-/* Bit operations */
-EXTFUN_RTS(andIntegerzh_fast);
-EXTFUN_RTS(orIntegerzh_fast);
-EXTFUN_RTS(xorIntegerzh_fast);
-EXTFUN_RTS(complementIntegerzh_fast);
-
-
-/* -----------------------------------------------------------------------------
- Word64 PrimOps.
- -------------------------------------------------------------------------- */
-
-#ifdef SUPPORT_LONG_LONGS
-
-/* Conversions */
-EXTFUN_RTS(int64ToIntegerzh_fast);
-EXTFUN_RTS(word64ToIntegerzh_fast);
-
-#endif
-
-/* -----------------------------------------------------------------------------
- Array PrimOps.
- -------------------------------------------------------------------------- */
-
-/* We cast to void* instead of StgChar* because this avoids a warning
- * about increasing the alignment requirements.
- */
-#define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
-#define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
-
-#ifdef DEBUG
-#define BYTE_ARR_CTS(a) \
- ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &stg_ARR_WORDS_info); \
- REAL_BYTE_ARR_CTS(a); })
-#define PTRS_ARR_CTS(a) \
- ({ ASSERT((GET_INFO((StgMutArrPtrs *)(a)) == &stg_MUT_ARR_PTRS_FROZEN_info) \
- || (GET_INFO((StgMutArrPtrs *)(a)) == &stg_MUT_ARR_PTRS_info)); \
- REAL_PTRS_ARR_CTS(a); })
-#else
-#define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
-#define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
-#endif
-
-
-extern I_ genSymZh(void);
-extern I_ resetGenSymZh(void);
-
-/*--- Almost everything in line. */
-
-EXTFUN_RTS(unsafeThawArrayzh_fast);
-EXTFUN_RTS(newByteArrayzh_fast);
-EXTFUN_RTS(newPinnedByteArrayzh_fast);
-EXTFUN_RTS(newArrayzh_fast);
-
-/* The decode operations are out-of-line because they need to allocate
- * a byte array.
- */
-
-/* We only support IEEE floating point formats. */
-#include "ieee-flpt.h"
-EXTFUN_RTS(decodeFloatzh_fast);
-EXTFUN_RTS(decodeDoublezh_fast);
-
-/* grimy low-level support functions defined in StgPrimFloat.c */
-extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
-extern StgDouble __int_encodeDouble (I_ j, I_ e);
-extern StgFloat __encodeFloat (I_ size, StgByteArray arr, I_ e);
-extern StgFloat __int_encodeFloat (I_ j, I_ e);
-extern void __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
-extern void __decodeFloat (MP_INT *man, I_ *_exp, StgFloat flt);
-extern StgInt isDoubleNaN(StgDouble d);
-extern StgInt isDoubleInfinite(StgDouble d);
-extern StgInt isDoubleDenormalized(StgDouble d);
-extern StgInt isDoubleNegativeZero(StgDouble d);
-extern StgInt isFloatNaN(StgFloat f);
-extern StgInt isFloatInfinite(StgFloat f);
-extern StgInt isFloatDenormalized(StgFloat f);
-extern StgInt isFloatNegativeZero(StgFloat f);
-
-
-/* -----------------------------------------------------------------------------
- Mutable variables
-
- newMutVar is out of line.
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(newMutVarzh_fast);
-EXTFUN_RTS(atomicModifyMutVarzh_fast);
-
-/* -----------------------------------------------------------------------------
- MVar PrimOps.
-
- All out of line, because they either allocate or may block.
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(isEmptyMVarzh_fast);
-EXTFUN_RTS(newMVarzh_fast);
-EXTFUN_RTS(takeMVarzh_fast);
-EXTFUN_RTS(putMVarzh_fast);
-EXTFUN_RTS(tryTakeMVarzh_fast);
-EXTFUN_RTS(tryPutMVarzh_fast);
-
-
-/* -----------------------------------------------------------------------------
- Delay/Wait PrimOps
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(waitReadzh_fast);
-EXTFUN_RTS(waitWritezh_fast);
-EXTFUN_RTS(delayzh_fast);
-#ifdef mingw32_TARGET_OS
-EXTFUN_RTS(asyncReadzh_fast);
-EXTFUN_RTS(asyncWritezh_fast);
-EXTFUN_RTS(asyncDoProczh_fast);
-#endif
-
-
-/* -----------------------------------------------------------------------------
- Primitive I/O, error-handling PrimOps
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(catchzh_fast);
-EXTFUN_RTS(raisezh_fast);
-EXTFUN_RTS(raiseIOzh_fast);
-
-extern void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
-
-/* -----------------------------------------------------------------------------
- Stable Name / Stable Pointer PrimOps
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(makeStableNamezh_fast);
-EXTFUN_RTS(makeStablePtrzh_fast);
-EXTFUN_RTS(deRefStablePtrzh_fast);
-
-
-/* -----------------------------------------------------------------------------
- Concurrency/Exception PrimOps.
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(forkzh_fast);
-EXTFUN_RTS(yieldzh_fast);
-EXTFUN_RTS(killThreadzh_fast);
-EXTFUN_RTS(seqzh_fast);
-EXTFUN_RTS(blockAsyncExceptionszh_fast);
-EXTFUN_RTS(unblockAsyncExceptionszh_fast);
-EXTFUN_RTS(myThreadIdzh_fast);
-EXTFUN_RTS(labelThreadzh_fast);
-EXTFUN_RTS(isCurrentThreadBoundzh_fast);
-
-extern int cmp_thread(StgPtr tso1, StgPtr tso2);
-extern int rts_getThreadId(StgPtr tso);
-extern int forkOS_createThread ( HsStablePtr entry );
-
-/* -----------------------------------------------------------------------------
- Weak Pointer PrimOps.
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(mkWeakzh_fast);
-EXTFUN_RTS(finalizzeWeakzh_fast);
-EXTFUN_RTS(deRefWeakzh_fast);
-
-
-/* -----------------------------------------------------------------------------
- Foreign Object PrimOps.
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(mkForeignObjzh_fast);
-
-
-/* -----------------------------------------------------------------------------
- Constructor tags
- -------------------------------------------------------------------------- */
-
-/*
- * This macro is only used when compiling unregisterised code (see
- * AbsCUtils.dsCOpStmt for motivation & the Story).
- */
-#ifndef TABLES_NEXT_TO_CODE
-# define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
-#endif
-
-/* -----------------------------------------------------------------------------
- BCOs and BCO linkery
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(newBCOzh_fast);
-EXTFUN_RTS(mkApUpd0zh_fast);
-
-/* ------------------------------------------------------------------------
- Parallel PrimOps
-
- A par in the Haskell code is ultimately translated to a parzh macro
- (with a case wrapped around it to guarantee that the macro is actually
- executed; see compiler/prelude/PrimOps.lhs)
- In GUM and SMP we only add a pointer to the spark pool.
- In GranSim we call an RTS fct, forwarding additional parameters which
- supply info on granularity of the computation, size of the result value
- and the degree of parallelism in the sparked expression.
- ---------------------------------------------------------------------- */
-
-#if defined(GRAN)
-//@cindex _par_
-#define parzh(r,node) parAny(r,node,1,0,0,0,0,0)
-
-//@cindex _parAt_
-#define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
- parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
-
-//@cindex _parAtAbs_
-#define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
- parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
-
-//@cindex _parAtRel_
-#define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
- parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
-
-//@cindex _parAtForNow_
-#define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
- parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
-
-#define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
-{ \
- if (closure_SHOULD_SPARK((StgClosure*)node)) { \
- rtsSparkQ result; \
- PEs p; \
- \
- STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
- switch (local) { \
- case 2: p = where; /* parAtAbs means absolute PE no. expected */ \
- break; \
- case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
- break; \
- default: p = where_is(where); /* parAt means closure expected */ \
- break; \
- } \
- /* update GranSim state according to this spark */ \
- STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier); \
- } \
-}
-
-//@cindex _parLocal_
-#define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
- parAny(r,node,rest,identifier,gran_info,size_info,par_info,1)
-
-//@cindex _parGlobal_
-#define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
- parAny(r,node,rest,identifier,gran_info,size_info,par_info,0)
-
-#define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
-{ \
- if (closure_SHOULD_SPARK((StgClosure*)node)) { \
- rtsSpark *result; \
- result = RET_STGCALL6(rtsSpark*, newSpark, \
- node,identifier,gran_info,size_info,par_info,local);\
- STGCALL1(add_to_spark_queue,result); \
- STGCALL2(GranSimSpark, local,(P_)node); \
- } \
-}
-
-#define copyablezh(r,node) \
- /* copyable not yet implemented!! */
-
-#define noFollowzh(r,node) \
- /* noFollow not yet implemented!! */
-
-#elif defined(SMP) || defined(PAR)
-
-#define parzh(r,node) \
-{ \
- extern unsigned int context_switch; \
- if (closure_SHOULD_SPARK((StgClosure *)node) && \
- SparkTl < SparkLim) { \
- *SparkTl++ = (StgClosure *)(node); \
- } \
- r = context_switch = 1; \
-}
-#else /* !GRAN && !SMP && !PAR */
-#define parzh(r,node) r = 1
-#endif
-
-/* -----------------------------------------------------------------------------
- ForeignObj - the C backend still needs this.
- -------------------------------------------------------------------------- */
-#define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
-
-
-#endif /* PRIMOPS_H */
--- /dev/null
+-----------------------------------------------------------------------------
+The External API to the GHC Runtime System.
+-----------------------------------------------------------------------------
+
+The header files in this directory form the external API for the
+runtime. The header files are used in the following scenarios:
+
+ 1. Included into the RTS source code itself.
+ In this case we include "Rts.h", which includes everything
+ else in the appropriate order.
+
+ Pretty much everything falls into this category.
+
+ 2. Included into a .hc file generated by the compiler.
+ In this case we include Stg.h, which includes a
+ subset of the headers, in the appropriate order and
+ with the appropriate settings (e.g. global register variables
+ turned on).
+
+ Includes everything below Stg.h in the hierarchy (see below).
+
+ 3. Included into external C source code.
+ The following headers are designed to be included into
+ external C code (i.e. C code compiled using a GHC installation,
+ not part of GHC itself or the RTS):
+
+ HsFFI.h
+ RtsAPI.h
+ SchedAPI.h
+ RtsFlags.h
+ Linker.h
+
+ These interfaces are intended to be relatively stable.
+
+ Also Rts.h can be included to get hold of everything else, including
+ definitions of heap objects, info tables, the storage manager interface
+ and so on. But be warned: none of this is guaranteed to remain stable
+ from one GHC release to the next.
+
+ 4. Included into non-C source code, including Haskell (GHC itself)
+ and C-- code in the RTS.
+
+ The following headers are #included into non-C source, so
+ cannot contain any C code or declarations:
+ config.h
+ RtsConfig.h
+ Constants.h
+ DerivedConstants.h
+ ClosureTypes.h
+ StgFun.h
+ MachRegs.h
+ Liveness.h
+ StgLdvProf.h
+
+Here is a rough hierarchy of the header files by dependency.
+
+Rts.h
+ Stg.h
+ config.h // configuration info derived by the configure script.
+ RtsConfig.h // settings for Rts things (eg. eager vs. lazy BH)
+ MachDeps.h // sizes of various basic types
+ StgTypes.h // basic types specific to the virtual machine
+ TailCalls.h // tail calls in .hc code
+ StgDLL.h // stuff related to Windows DLLs
+ MachRegs.h // global register assignments for this arch
+ Regs.h // "registers" in the virtual machine
+ StgProf.h // profiling gubbins
+ StgMiscClosures.h // decls for closures & info tables in the RTS
+ RtsExternal.h // decls for RTS things required by .hc code
+ (RtsAPI.h)
+ (HsFFI.h)
+
+ RtsTypes.h // types used in the RTS
+
+ Constants.h // build-time constants
+ StgLdvProf.h
+ StgFun.h
+ Closures.h
+ Liveness.h // macros for constructing RET_DYN liveness masks
+ ClosureMacros.h
+ ClosureTypes.h
+ InfoTables.h
+ TSO.h
+ Updates.h // macros for performing updates
+ GranSim.h
+ Parallel.h
+ SMP.h
+ Block.h
+ StgTicky.h
+ Stable.h
+ Hooks.h
+ Signals.h
+ DNInvoke.h
+ Dotnet.h
+
+Cmm.h // included into .cmm source only
+ DerivedConstants.h // generated by mkDerivedConstants.c from other
+ // .h files.
+ (Constants.h)
+ (ClosureTypes.h)
+ (StgFun.h)
+ (MachRegs.h)
+ (Liveness.h)
+ (Block.h)
+
+Bytecodes.h // Bytecode definitions for the interpreter
+Linker.h // External API to the linker
+RtsFlags.h // External API to the RTS runtime flags
+SchedAPI.h // External API to the RTS scheduler
+ieee-flpt.h // ToDo: needed?
+
+RtsAPI.h // The top-level interface to the RTS (rts_evalIO(), etc.)
+HsFFI.h // The external FFI api
+
/* -----------------------------------------------------------------------------
- * $Id: Regs.h,v 1.14 2003/11/14 14:28:08 stolz Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
- * Registers used in STG code. Might or might not correspond to
- * actual machine registers.
+ * Registers in the STG machine.
+ *
+ * The STG machine has a collection of "registers", each one of which
+ * may or may not correspond to an actual machine register when
+ * running code.
+ *
+ * The register set is backed by a table in memory (struct
+ * StgRegTable). If a particular STG register is not mapped to a
+ * machine register, then the apprpriate slot in this table is used
+ * instead.
+ *
+ * This table is itself pointed to by another register, BaseReg. If
+ * BaseReg is not in a machine register, then the register table is
+ * used from an absolute location (MainCapability).
*
* ---------------------------------------------------------------------------*/
#ifndef REGS_H
#define REGS_H
-/*
- * This file should do the right thing if we have no machine-registers
- * defined, i.e. everything lives in the RegTable.
- */
/*
* This is the table that holds shadow-locations for all the STG
StgFunPtr stgGCFun;
} StgFunTable;
+/*
+ * Vanilla registers are given this union type, which is purely so
+ * that we can cast the vanilla reg to a variety of types with the
+ * minimum of syntax. eg. R1.w instead of (StgWord)R1.
+ */
+typedef union {
+ StgWord w;
+ StgAddr a;
+ StgChar c;
+ StgInt8 i8;
+ StgFloat f;
+ StgInt i;
+ StgPtr p;
+ StgClosurePtr cl;
+ StgStackOffset offset; /* unused? */
+ StgByteArray b;
+ StgTSOPtr t;
+} StgUnion;
+
typedef struct StgRegTable_ {
StgUnion rR1;
StgUnion rR2;
StgPtr rSpLim;
StgPtr rHp;
StgPtr rHpLim;
- StgTSO *rCurrentTSO;
- struct _bdescr *rNursery;
- struct _bdescr *rCurrentNursery;
- StgWord rHpAlloc; // number of words being allocated in heap
+ struct StgTSO_ *rCurrentTSO;
+ struct bdescr_ *rNursery;
+ struct bdescr_ *rCurrentNursery;
+ StgWord rHpAlloc; // number of *bytes* being allocated in heap
#if defined(SMP) || defined(PAR)
StgSparkPool rSparks; // per-task spark pool
#endif
#endif
} Capability;
-/* No such thing as a MainRegTable under SMP - each thread must
- * have its own MainRegTable.
+/* No such thing as a MainCapability under SMP - each thread must have
+ * its own Capability.
*/
#ifndef SMP
+#if IN_STG_CODE
+extern W_ MainCapability[];
+#else
extern DLL_IMPORT_RTS Capability MainCapability;
#endif
+#endif
#if IN_STG_CODE
#ifdef SMP
#error BaseReg must be in a register for SMP
#endif
-#define BaseReg (&MainCapability.r)
+#define BaseReg (&((Capability *)MainCapability)[0].r)
#endif
#ifdef REG_Sp
#endif
#ifdef REG_CurrentTSO
-GLOBAL_REG_DECL(StgTSO *,CurrentTSO,REG_CurrentTSO)
+GLOBAL_REG_DECL(struct _StgTSO *,CurrentTSO,REG_CurrentTSO)
#else
#define CurrentTSO (BaseReg->rCurrentTSO)
#endif
#define CALLER_RESTORE_SYSTEM /* nothing */
#endif /* IN_STG_CODE */
-
#define CALLER_SAVE_ALL \
CALLER_SAVE_SYSTEM \
CALLER_SAVE_USER
CALLER_RESTORE_USER
#endif /* REGS_H */
-
/* -----------------------------------------------------------------------------
- * $Id: Rts.h,v 1.23 2003/11/12 17:27:03 sof Exp $
+ * $Id: Rts.h,v 1.24 2004/08/13 13:09:27 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#endif
#include "Stg.h"
+#include "RtsTypes.h"
+
+#if __GNUC__ >= 3
+/* Assume that a flexible array member at the end of a struct
+ * can be defined thus: T arr[]; */
+#define FLEXIBLE_ARRAY
+#else
+/* Assume that it must be defined thus: T arr[0]; */
+#define FLEXIBLE_ARRAY 0
+#endif
+
+#if defined(SMP) || defined(THREADED_RTS)
+#define RTS_SUPPORTS_THREADS 1
+#endif
+
+/* Fix for mingw stat problem (done here so it's early enough) */
+#ifdef mingw32_TARGET_OS
+#define __MSVCRT__ 1
+#endif
+
+#if defined(__GNUC__)
+#define GNU_ATTRIBUTE(at) __attribute__((at))
+#else
+#define GNU_ATTRIBUTE(at)
+#endif
+
+#if __GNUC__ >= 3
+#define GNUC3_ATTRIBUTE(at) __attribute__((at))
+#else
+#define GNUC3_ATTRIBUTE(at)
+#endif
+
+/*
+ * Empty structures isn't supported by all, so to define
+ * empty structures, please protect the defn with an
+ * #if SUPPORTS_EMPTY_STRUCTS. Similarly for use,
+ * employ the macro MAYBE_EMPTY_STRUCT():
+ *
+ * MAYBE_EMPTY_STRUCT(structFoo, fieldName);
+ */
+#if SUPPORTS_EMPTY_STRUCTS
+# define MAYBE_EMPTY_STRUCT(a,b) a b;
+#else
+# define MAYBE_EMPTY_STRUCT(a,b) /* empty */
+#endif
+
+/*
+ * We often want to know the size of something in units of an
+ * StgWord... (rounded up, of course!)
+ */
+#define sizeofW(t) ((sizeof(t)+sizeof(W_)-1)/sizeof(W_))
+
+/*
+ * It's nice to be able to grep for casts
+ */
+#define stgCast(ty,e) ((ty)(e))
+
+/* -----------------------------------------------------------------------------
+ Assertions and Debuggery
+ -------------------------------------------------------------------------- */
+
+#ifndef DEBUG
+#define ASSERT(predicate) /* nothing */
+#else
+
+void _stgAssert (char *, unsigned int);
+
+#define ASSERT(predicate) \
+ if (predicate) \
+ /*null*/; \
+ else \
+ _stgAssert(__FILE__, __LINE__)
+#endif /* DEBUG */
+
+/*
+ * Use this on the RHS of macros which expand to nothing
+ * to make sure that the macro can be used in a context which
+ * demands a non-empty statement.
+ */
+
+#define doNothing() do { } while (0)
+
+/* -----------------------------------------------------------------------------
+ Include everything STG-ish
+ -------------------------------------------------------------------------- */
+
+/* System headers: stdlib.h is eeded so that we can use NULL. It must
+ * come after MachRegs.h, because stdlib.h might define some inline
+ * functions which may only be defined after register variables have
+ * been declared.
+ */
+#include <stdlib.h>
+
+/* Global constaints */
+#include "Constants.h"
+
+/* Profiling information */
+#include "StgProf.h"
+#include "StgLdvProf.h"
+
+/* Storage format definitions */
+#include "StgFun.h"
+#include "Closures.h"
+#include "Liveness.h"
+#include "ClosureTypes.h"
+#include "InfoTables.h"
+#include "TSO.h"
+
+/* Info tables, closures & code fragments defined in the RTS */
+#include "StgMiscClosures.h"
+
+/* Simulated-parallel information */
+#include "GranSim.h"
+
+/* Parallel information */
+#include "Parallel.h"
+
+/* STG/Optimised-C related stuff */
+#include "SMP.h"
+#include "Block.h"
+
+#ifdef SMP
+#include <pthread.h>
+#endif
+
+/* GNU mp library */
+#include "gmp.h"
+
+/* Macros for STG/C code */
+#include "ClosureMacros.h"
+#include "StgTicky.h"
+#include "Stable.h"
+
+/* Runtime-system hooks */
+#include "Hooks.h"
+
+#include "ieee-flpt.h"
+
+#include "Signals.h"
+
+/* Misc stuff without a home */
+DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */
+DLL_IMPORT_RTS extern int prog_argc;
+DLL_IMPORT_RTS extern char *prog_name;
+
+extern void stackOverflow(void);
+
+extern void __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
+extern void __decodeFloat (MP_INT *man, I_ *_exp, StgFloat flt);
+
+#if defined(WANT_DOTNET_SUPPORT)
+#include "DNInvoke.h"
+#endif
+
+/* Creating and destroying an adjustor thunk and initialising the whole
+ adjustor thunk machinery. I cannot make myself create a separate .h file
+ for these three (sof.)
+
+*/
+extern void* createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr);
+extern void freeHaskellFunctionPtr(void* ptr);
+extern rtsBool initAdjustor(void);
+
+extern void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
+
/* -----------------------------------------------------------------------------
RTS Exit codes
-------------------------------------------------------------------------- */
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.h,v 1.36 2003/09/21 22:20:52 wolfgang Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
* API for invoking Haskell functions via the RTS
*
These are used by foreign export and foreign import "wrapper" stubs.
----------------------------------------------------------------------- */
-extern StgClosure GHCziTopHandler_runIO_closure;
-extern StgClosure GHCziTopHandler_runNonIO_closure;
-#define runIO_closure (&GHCziTopHandler_runIO_closure)
-#define runNonIO_closure (&GHCziTopHandler_runNonIO_closure)
+extern StgWord GHCziTopHandler_runIO_closure[];
+extern StgWord GHCziTopHandler_runNonIO_closure[];
+#define runIO_closure GHCziTopHandler_runIO_closure
+#define runNonIO_closure GHCziTopHandler_runNonIO_closure
/* ------------------------------------------------------------------------ */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Rts settings.
+ *
+ * NOTE: assumes #include "ghcconfig.h"
+ *
+ * NB: THIS FILE IS INCLUDED IN NON-C CODE AND DATA! #defines only please.
+ * ---------------------------------------------------------------------------*/
+
+#ifndef RTSCONFIG_H
+#define RTSCONFIG_H
+
+/*
+ * SUPPORT_LONG_LONGS controls whether we need to support long longs on a
+ * particular platform. On 64-bit platforms, we don't need to support
+ * long longs since regular machine words will do just fine.
+ */
+#if HAVE_LONG_LONG && SIZEOF_VOID_P < 8
+#define SUPPORT_LONG_LONGS 1
+#endif
+
+/*
+ * Whether the runtime system will use libbfd for debugging purposes.
+ */
+#if defined(DEBUG) && defined(HAVE_BFD_H) && !defined(_WIN32) && !defined(PAR) && !defined(GRAN)
+#define USING_LIBBFD 1
+#endif
+
+/* Turn lazy blackholing and eager blackholing on/off.
+ *
+ * Using eager blackholing makes things easier to debug because
+ * the blackholes are more predictable - but it's slower and less sexy.
+ *
+ * For now, do lazy and not eager.
+ */
+
+/* TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
+ * single-entry thunks.
+ *
+ * SMP needs EAGER_BLACKHOLING because it has to lock thunks
+ * synchronously, in case another thread is trying to evaluate the
+ * same thunk simultaneously.
+ */
+#if defined(SMP) || defined(TICKY_TICKY)
+# define EAGER_BLACKHOLING
+#else
+# define LAZY_BLACKHOLING
+#endif
+
+/* TABLES_NEXT_TO_CODE says whether to assume that info tables are
+ * assumed to reside just before the code for a function.
+ *
+ * UNDEFINING THIS WON'T WORK ON ITS OWN. You have been warned.
+ */
+#if !defined(USE_MINIINTERPRETER) && !defined(ia64_TARGET_ARCH)
+#define TABLES_NEXT_TO_CODE
+#endif
+
+/* -----------------------------------------------------------------------------
+ Labels - entry labels & info labels point to the same place in
+ TABLES_NEXT_TO_CODE, so we only generate the _info label. Jumps
+ must therefore be directed to foo_info rather than foo_entry when
+ TABLES_NEXT_TO_CODE is on.
+
+ This isn't a good place for these macros, but they need to be
+ available to .cmm sources as well as C and we don't have a better
+ place.
+ -------------------------------------------------------------------------- */
+
+#ifdef TABLES_NEXT_TO_CODE
+#define ENTRY_LBL(f) f##_info
+#else
+#define ENTRY_LBL(f) f##_entry
+#endif
+
+#ifdef TABLES_NEXT_TO_CODE
+#define RET_LBL(f) f##_info
+#else
+#define RET_LBL(f) f##_ret
+#endif
+
+#endif /* RTSCONFIG_H */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: RtsExternal.h,v 1.2 2004/08/13 13:09:29 simonmar Exp $
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Things visible externally to the RTS
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef RTSEXTERNAL_H
+#define RTSEXTERNAL_H
+
+/* The RTS public interface. */
+#include "RtsAPI.h"
+
+/* The standard FFI interface */
+#include "HsFFI.h"
+
+/* -----------------------------------------------------------------------------
+ Functions exported by the RTS for use in Stg code
+ -------------------------------------------------------------------------- */
+
+#if IN_STG_CODE
+extern void newCAF(void*);
+#else
+extern void newCAF(StgClosure*);
+#endif
+
+/* ToDo: remove? */
+extern I_ genSymZh(void);
+extern I_ resetGenSymZh(void);
+
+/* Concurrency/Exception PrimOps. */
+extern int cmp_thread(StgPtr tso1, StgPtr tso2);
+extern int rts_getThreadId(StgPtr tso);
+extern int forkOS_createThread ( HsStablePtr entry );
+
+/* grimy low-level support functions defined in StgPrimFloat.c */
+extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
+extern StgDouble __int_encodeDouble (I_ j, I_ e);
+extern StgFloat __encodeFloat (I_ size, StgByteArray arr, I_ e);
+extern StgFloat __int_encodeFloat (I_ j, I_ e);
+extern StgInt isDoubleNaN(StgDouble d);
+extern StgInt isDoubleInfinite(StgDouble d);
+extern StgInt isDoubleDenormalized(StgDouble d);
+extern StgInt isDoubleNegativeZero(StgDouble d);
+extern StgInt isFloatNaN(StgFloat f);
+extern StgInt isFloatInfinite(StgFloat f);
+extern StgInt isFloatDenormalized(StgFloat f);
+extern StgInt isFloatNegativeZero(StgFloat f);
+
+/* Suspending/resuming threads around foreign calls */
+extern StgInt suspendThread ( StgRegTable * );
+extern StgRegTable * resumeThread ( StgInt );
+
+/* -----------------------------------------------------------------------------
+ Storage manager stuff exported
+ -------------------------------------------------------------------------- */
+
+/* Prototype for an evacuate-like function */
+typedef void (*evac_fn)(StgClosure **);
+
+extern void performGC(void);
+extern void performMajorGC(void);
+extern void performGCWithRoots(void (*get_roots)(evac_fn));
+
+#endif /* RTSEXTERNAL_H */
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.45 2003/01/23 12:13:10 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.46 2004/08/13 13:09:29 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
int msecsPerTick; /* derived */
};
-#ifdef PROFILING
struct PROFILING_FLAGS {
unsigned int doHeapProfile;
-
- nat profileInterval; /* delta between samples (in ms) */
- nat profileIntervalTicks; /* delta between samples (in 'ticks') */
- rtsBool includeTSOs;
-
-
# define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */
# define HEAP_BY_CCS 1
# define HEAP_BY_MOD 2
# define HEAP_BY_RETAINER 6
# define HEAP_BY_LDV 7
+# define HEAP_BY_INFOPTR 1 /* DEBUG only */
+# define HEAP_BY_CLOSURE_TYPE 2 /* DEBUG only */
+
+ nat profileInterval; /* delta between samples (in ms) */
+ nat profileIntervalTicks; /* delta between samples (in 'ticks') */
+ rtsBool includeTSOs;
+
+
rtsBool showCCSOnException;
nat maxRetainerSetSize;
char* bioSelector;
};
-#elif defined(DEBUG)
-# define NO_HEAP_PROFILING 0
-# define HEAP_BY_INFOPTR 1
-# define HEAP_BY_CLOSURE_TYPE 2
-struct PROFILING_FLAGS {
- unsigned int doHeapProfile; /* heap profile using symbol table */
-
-};
-#endif /* DEBUG || PROFILING */
struct CONCURRENT_FLAGS {
int ctxtSwitchTime; /* in milliseconds */
};
#endif /* GRAN */
-#ifdef TICKY_TICKY
struct TICKY_FLAGS {
rtsBool showTickyStats;
FILE *tickyFile;
};
-#endif /* TICKY_TICKY */
/* Put them together: */
-struct RTS_FLAGS {
- struct GC_FLAGS GcFlags;
- struct CONCURRENT_FLAGS ConcFlags;
-
-#ifdef DEBUG
- struct DEBUG_FLAGS DebugFlags;
-#endif
-#if defined(PROFILING) || defined(PAR)
+typedef struct _RTS_FLAGS {
+ // The first portion of RTS_FLAGS is invariant.
+ struct GC_FLAGS GcFlags;
+ struct CONCURRENT_FLAGS ConcFlags;
+ struct DEBUG_FLAGS DebugFlags;
struct COST_CENTRE_FLAGS CcFlags;
-#endif
-#if defined(PROFILING) || defined(DEBUG)
- struct PROFILING_FLAGS ProfFlags;
-#endif
+ struct PROFILING_FLAGS ProfFlags;
+ struct TICKY_FLAGS TickyFlags;
+
#if defined(SMP) || defined(PAR)
struct PAR_FLAGS ParFlags;
#endif
#ifdef GRAN
struct GRAN_FLAGS GranFlags;
#endif
-#ifdef TICKY_TICKY
- struct TICKY_FLAGS TickyFlags;
-#endif
-};
+} RTS_FLAGS;
#ifdef COMPILING_RTS_MAIN
-extern DLLIMPORT struct RTS_FLAGS RtsFlags;
+extern DLLIMPORT RTS_FLAGS RtsFlags;
+#elif IN_STG_CODE
+// Hack because the C code generator can't generate '&label'.
+extern RTS_FLAGS RtsFlags[];
#else
-extern struct RTS_FLAGS RtsFlags;
+extern RTS_FLAGS RtsFlags;
#endif
/* Routines that operate-on/to-do-with RTS flags: */
/* -----------------------------------------------------------------------------
- * $Id: Stable.h,v 1.15 2003/11/12 17:27:03 sof Exp $
*
- * (c) The GHC Team, 1998-2000
+ * (c) The GHC Team, 1998-2004
*
* Stable Pointers: A stable pointer is represented as an index into
* the stable pointer table in the low BITS_PER_WORD-8 bits with a
extern StgPtr deRefStablePtr(StgStablePtr sp);
#endif
+extern void initStablePtrTable ( void );
+extern void enlargeStablePtrTable ( void );
+extern StgWord lookupStableName ( StgPtr p );
+
+extern void markStablePtrTable ( evac_fn evac );
+extern void threadStablePtrTable ( evac_fn evac );
+extern void gcStablePtrTable ( void );
+extern void updateStablePtrTable ( rtsBool full );
+
#endif
/* -----------------------------------------------------------------------------
- * $Id: Stg.h,v 1.62 2004/03/23 10:03:18 simonmar Exp $
+ * $Id: Stg.h,v 1.63 2004/08/13 13:09:30 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
* Top-level include file for everything STG-ish.
*
* functions are defined (some system headers have been known to
* define the odd inline function).
*
+ * We generally try to keep as little visible as possible when
+ * compiling .hc files. So for example the definitions of the
+ * InfoTable structs, closure structs and other RTS types are not
+ * visible here. The compiler knows enough about the representations
+ * of these types to generate code which manipulates them directly
+ * with pointer arithmetic.
+ *
* ---------------------------------------------------------------------------*/
#ifndef STG_H
#endif
/* Configuration */
-#include "config.h"
-
-/* This needs to be up near the top as the register line on alpha needs
- * to be before all procedures */
-#include "TailCalls.h"
-
-#if __GNUC__ >= 3
-/* Assume that a flexible array member at the end of a struct
- * can be defined thus: T arr[]; */
-#define FLEXIBLE_ARRAY
-#else
-/* Assume that it must be defined thus: T arr[0]; */
-#define FLEXIBLE_ARRAY 0
-#endif
-
-#if defined(SMP) || defined(THREADED_RTS)
-#define RTS_SUPPORTS_THREADS 1
-#endif
-
-/* Some macros to handle DLLing (Win32 only at the moment). */
-#include "StgDLL.h"
+#include "ghcconfig.h"
+#include "RtsConfig.h"
-/* Fix for mingw stat problem (done here so it's early enough) */
-#ifdef mingw32_TARGET_OS
-#define __MSVCRT__ 1
-#endif
-
-/* Turn lazy blackholing and eager blackholing on/off.
- *
- * Using eager blackholing makes things easier to debug because
- * the blackholes are more predictable - but it's slower and less sexy.
- *
- * For now, do lazy and not eager.
- */
+/* -----------------------------------------------------------------------------
+ Useful definitions
+ -------------------------------------------------------------------------- */
-/* TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
- * single-entry thunks.
- *
- * SMP needs EAGER_BLACKHOLING because it has to lock thunks
- * synchronously, in case another thread is trying to evaluate the
- * same thunk simultaneously.
+/*
+ * The C backend like to refer to labels by just mentioning their
+ * names. Howevver, when a symbol is declared as a variable in C, the
+ * C compiler will implicitly dereference it when it occurs in source.
+ * So we must subvert this behaviour for .hc files by declaring
+ * variables as arrays, which eliminates the implicit dereference.
*/
-#if defined(SMP) || defined(TICKY_TICKY)
-# define EAGER_BLACKHOLING
+#if IN_STG_CODE
+#define RTS_VAR(x) (x)[]
+#define RTS_DEREF(x) (*(x))
#else
-# define LAZY_BLACKHOLING
+#define RTS_VAR(x) x
+#define RTS_DEREF(x) x
#endif
-#if defined(__GNUC__)
-#define GNU_ATTRIBUTE(at) __attribute__((at))
-#else
-#define GNU_ATTRIBUTE(at)
-#endif
-
-#if __GNUC__ >= 3
-#define GNUC3_ATTRIBUTE(at) __attribute__((at))
-#else
-#define GNUC3_ATTRIBUTE(at)
-#endif
-
-/*
- * Empty structures isn't supported by all, so to define
- * empty structures, please protect the defn with an
- * #if SUPPORTS_EMPTY_STRUCTS. Similarly for use,
- * employ the macro MAYBE_EMPTY_STRUCT():
- *
- * MAYBE_EMPTY_STRUCT(structFoo, fieldName);
+/* bit macros
*/
-#if SUPPORTS_EMPTY_STRUCTS
-# define MAYBE_EMPTY_STRUCT(a,b) a b;
-#else
-# define MAYBE_EMPTY_STRUCT(a,b) /* empty */
-#endif
+#define BITS_PER_BYTE 8
+#define BITS_IN(x) (BITS_PER_BYTE * sizeof(x))
/*
- * 'Portable'
+ * 'Portable' inlining
*/
#if defined(__GNUC__) || defined( __INTEL_COMPILER)
# define INLINE_HEADER static inline
# error "Don't know how to inline functions with your C compiler."
#endif
-/* TABLES_NEXT_TO_CODE says whether to assume that info tables are
- * assumed to reside just before the code for a function.
- *
- * UNDEFINING THIS WON'T WORK ON ITS OWN. You have been warned.
- */
-#if !defined(USE_MINIINTERPRETER) && !defined(ia64_TARGET_ARCH)
-#define TABLES_NEXT_TO_CODE
-#endif
-
-/* bit macros
- */
-#define BITS_PER_BYTE 8
-#define BITS_IN(x) (BITS_PER_BYTE * sizeof(x))
-
-/* -----------------------------------------------------------------------------
- Assertions and Debuggery
- -------------------------------------------------------------------------- */
-
-#ifndef DEBUG
-#define ASSERT(predicate) /* nothing */
-#else
-
-void _stgAssert (char *, unsigned int);
-
-#define ASSERT(predicate) \
- if (predicate) \
- /*null*/; \
- else \
- _stgAssert(__FILE__, __LINE__)
-#endif /* DEBUG */
-
-/*
- * Use this on the RHS of macros which expand to nothing
- * to make sure that the macro can be used in a context which
- * demands a non-empty statement.
- */
-
-#define doNothing() do { } while (0)
-
/* -----------------------------------------------------------------------------
Global type definitions
-------------------------------------------------------------------------- */
+#include "MachDeps.h"
#include "StgTypes.h"
-#include "RtsTypes.h"
/* -----------------------------------------------------------------------------
Shorthand forms
typedef StgInt64 LI_;
typedef StgWord64 LW_;
-/*
- * We often want to know the size of something in units of an
- * StgWord... (rounded up, of course!)
- */
+#define IF_(f) static F_ f(void)
+#define FN_(f) F_ f(void)
+#define EF_(f) extern F_ f(void)
-#define sizeofW(t) ((sizeof(t)+sizeof(W_)-1)/sizeof(W_))
+typedef StgWord StgWordArray[];
+#define EI_ extern StgWordArray
+#define II_ static StgWordArray
-/*
- * It's nice to be able to grep for casts
- */
+/* -----------------------------------------------------------------------------
+ Tail calls
+
+ This needs to be up near the top as the register line on alpha needs
+ to be before all procedures (inline & out-of-line).
+ -------------------------------------------------------------------------- */
-#define stgCast(ty,e) ((ty)(e))
+#include "TailCalls.h"
/* -----------------------------------------------------------------------------
- Include everything STG-ish
+ Moving Floats and Doubles
+
+ ASSIGN_FLT is for assigning a float to memory (usually the
+ stack/heap). The memory address is guaranteed to be
+ StgWord aligned (currently == sizeof(void *)).
+
+ PK_FLT is for pulling a float out of memory. The memory is
+ guaranteed to be StgWord aligned.
-------------------------------------------------------------------------- */
-/* Global constaints */
-#include "Constants.h"
+INLINE_HEADER void ASSIGN_FLT (W_ [], StgFloat);
+INLINE_HEADER StgFloat PK_FLT (W_ []);
-/* Profiling information */
-#include "StgProf.h"
-#include "StgLdvProf.h"
+#if ALIGNMENT_FLOAT <= ALIGNMENT_LONG
-/* Storage format definitions */
-#include "StgFun.h"
-#include "Closures.h"
-#include "ClosureTypes.h"
-#include "InfoTables.h"
-#include "TSO.h"
+INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }
+INLINE_HEADER StgFloat PK_FLT (W_ p_src[]) { return *(StgFloat *)p_src; }
-/* Simulated-parallel information */
-#include "GranSim.h"
+#else /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */
-/* Parallel information */
-#include "Parallel.h"
+INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src)
+{
+ float_thing y;
+ y.f = src;
+ *p_dest = y.fu;
+}
-/* STG/Optimised-C related stuff */
-#include "SMP.h"
-#include "MachRegs.h"
-#include "Regs.h"
-#include "Block.h"
+INLINE_HEADER StgFloat PK_FLT(W_ p_src[])
+{
+ float_thing y;
+ y.fu = *p_src;
+ return(y.f);
+}
+
+#endif /* ALIGNMENT_FLOAT > ALIGNMENT_LONG */
+
+#if ALIGNMENT_DOUBLE <= ALIGNMENT_LONG
+
+INLINE_HEADER void ASSIGN_DBL (W_ [], StgDouble);
+INLINE_HEADER StgDouble PK_DBL (W_ []);
-/* RTS public interface */
-#include "RtsAPI.h"
+INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }
+INLINE_HEADER StgDouble PK_DBL (W_ p_src[]) { return *(StgDouble *)p_src; }
-/* System headers: stdlib.h is eeded so that we can use NULL. It must
- * come after MachRegs.h, because stdlib.h might define some inline
- * functions which may only be defined after register variables have
- * been declared.
+#else /* ALIGNMENT_DOUBLE > ALIGNMENT_LONG */
+
+/* Sparc uses two floating point registers to hold a double. We can
+ * write ASSIGN_DBL and PK_DBL by directly accessing the registers
+ * independently - unfortunately this code isn't writable in C, we
+ * have to use inline assembler.
*/
-#include <stdlib.h>
+#if sparc_TARGET_ARCH
+
+#define ASSIGN_DBL(dst0,src) \
+ { StgPtr dst = (StgPtr)(dst0); \
+ __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
+ "=m" (((P_)(dst))[1]) : "f" (src)); \
+ }
+
+#define PK_DBL(src0) \
+ ( { StgPtr src = (StgPtr)(src0); \
+ register double d; \
+ __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
+ "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
+ } )
+
+#else /* ! sparc_TARGET_ARCH */
+
+INLINE_HEADER void ASSIGN_DBL (W_ [], StgDouble);
+INLINE_HEADER StgDouble PK_DBL (W_ []);
+
+typedef struct
+ { StgWord dhi;
+ StgWord dlo;
+ } unpacked_double;
+
+typedef union
+ { StgDouble d;
+ unpacked_double du;
+ } double_thing;
+
+INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src)
+{
+ double_thing y;
+ y.d = src;
+ p_dest[0] = y.du.dhi;
+ p_dest[1] = y.du.dlo;
+}
+
+/* GCC also works with this version, but it generates
+ the same code as the previous one, and is not ANSI
+
+#define ASSIGN_DBL( p_dest, src ) \
+ *p_dest = ((double_thing) src).du.dhi; \
+ *(p_dest+1) = ((double_thing) src).du.dlo \
+*/
-#ifdef SMP
-#include <pthread.h>
-#endif
+INLINE_HEADER StgDouble PK_DBL(W_ p_src[])
+{
+ double_thing y;
+ y.du.dhi = p_src[0];
+ y.du.dlo = p_src[1];
+ return(y.d);
+}
-/* GNU mp library */
-#include "gmp.h"
+#endif /* ! sparc_TARGET_ARCH */
-/* Storage Manager */
-#include "StgStorage.h"
+#endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */
-/* Macros for STG/C code */
-#include "ClosureMacros.h"
-#include "InfoMacros.h"
-#include "StgMacros.h"
-#include "PrimOps.h"
-#include "Updates.h"
-#include "StgTicky.h"
-#include "CCall.h"
-#include "Stable.h"
-/* Built-in entry points */
+/* -----------------------------------------------------------------------------
+ Moving 64-bit quantities around
+
+ ASSIGN_Word64 assign an StgWord64/StgInt64 to a memory location
+ PK_Word64 load an StgWord64/StgInt64 from a amemory location
+
+ In both cases the memory location might not be 64-bit aligned.
+ -------------------------------------------------------------------------- */
+
+#ifdef SUPPORT_LONG_LONGS
+
+typedef struct
+ { StgWord dhi;
+ StgWord dlo;
+ } unpacked_double_word;
+
+typedef union
+ { StgInt64 i;
+ unpacked_double_word iu;
+ } int64_thing;
+
+typedef union
+ { StgWord64 w;
+ unpacked_double_word wu;
+ } word64_thing;
+
+INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
+{
+ word64_thing y;
+ y.w = src;
+ p_dest[0] = y.wu.dhi;
+ p_dest[1] = y.wu.dlo;
+}
+
+INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
+{
+ word64_thing y;
+ y.wu.dhi = p_src[0];
+ y.wu.dlo = p_src[1];
+ return(y.w);
+}
+
+INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
+{
+ int64_thing y;
+ y.i = src;
+ p_dest[0] = y.iu.dhi;
+ p_dest[1] = y.iu.dlo;
+}
+
+INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
+{
+ int64_thing y;
+ y.iu.dhi = p_src[0];
+ y.iu.dlo = p_src[1];
+ return(y.i);
+}
+
+#elif SIZEOF_VOID_P == 8
+
+INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
+{
+ p_dest[0] = src;
+}
+
+INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
+{
+ return p_src[0];
+}
+
+INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
+{
+ p_dest[0] = src;
+}
+
+INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
+{
+ return p_src[0];
+}
+
+#endif
+
+/* -----------------------------------------------------------------------------
+ Other Stg stuff...
+ -------------------------------------------------------------------------- */
+
+#include "StgDLL.h"
+#include "MachRegs.h"
+#include "Regs.h"
+#include "StgProf.h" /* ToDo: separate out RTS-only stuff from here */
+
+#if IN_STG_CODE
+/*
+ * This is included later for RTS sources, after definitions of
+ * StgInfoTable, StgClosure and so on.
+ */
#include "StgMiscClosures.h"
+#endif
-/* Runtime-system hooks */
-#include "Hooks.h"
+/* RTS external interface */
+#include "RtsExternal.h"
-#include "Signals.h"
+/* -----------------------------------------------------------------------------
+ Split markers
+ -------------------------------------------------------------------------- */
-#include "HsFFI.h"
+#if defined(USE_SPLIT_MARKERS)
+#if defined(LEADING_UNDERSCORE)
+#define __STG_SPLIT_MARKER __asm__("\n___stg_split_marker:");
+#else
+#define __STG_SPLIT_MARKER __asm__("\n__stg_split_marker:");
+#endif
+#else
+#define __STG_SPLIT_MARKER /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+ Integer multiply with overflow
+ -------------------------------------------------------------------------- */
-/* Misc stuff without a home */
-DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */
-DLL_IMPORT_RTS extern int prog_argc;
-DLL_IMPORT_RTS extern char *prog_name;
+/* Multiply with overflow checking.
+ *
+ * This is tricky - the usual sign rules for add/subtract don't apply.
+ *
+ * On 32-bit machines we use gcc's 'long long' types, finding
+ * overflow with some careful bit-twiddling.
+ *
+ * On 64-bit machines where gcc's 'long long' type is also 64-bits,
+ * we use a crude approximation, testing whether either operand is
+ * larger than 32-bits; if neither is, then we go ahead with the
+ * multiplication.
+ *
+ * Return non-zero if there is any possibility that the signed multiply
+ * of a and b might overflow. Return zero only if you are absolutely sure
+ * that it won't overflow. If in doubt, return non-zero.
+ */
-extern void stackOverflow(void);
+#if SIZEOF_VOID_P == 4
-#if defined(WANT_DOTNET_SUPPORT)
-#include "DNInvoke.h"
+#ifdef WORDS_BIGENDIAN
+#define RTS_CARRY_IDX__ 0
+#define RTS_REM_IDX__ 1
+#else
+#define RTS_CARRY_IDX__ 1
+#define RTS_REM_IDX__ 0
#endif
-/* Creating and destroying an adjustor thunk and initialising the whole
- adjustor thunk machinery. I cannot make myself create a separate .h file
- for these three (sof.)
-
-*/
-extern void* createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr);
-extern void freeHaskellFunctionPtr(void* ptr);
-extern rtsBool initAdjustor(void);
+typedef union {
+ StgInt64 l;
+ StgInt32 i[2];
+} long_long_u ;
+
+#define mulIntMayOflo(a,b) \
+({ \
+ StgInt32 r, c; \
+ long_long_u z; \
+ z.l = (StgInt64)a * (StgInt64)b; \
+ r = z.i[RTS_REM_IDX__]; \
+ c = z.i[RTS_CARRY_IDX__]; \
+ if (c == 0 || c == -1) { \
+ c = ((StgWord)((a^b) ^ r)) \
+ >> (BITS_IN (I_) - 1); \
+ } \
+ c; \
+})
+
+/* Careful: the carry calculation above is extremely delicate. Make sure
+ * you test it thoroughly after changing it.
+ */
+
+#else
+
+#define HALF_INT (((I_)1) << (BITS_IN (I_) / 2))
+
+#define stg_abs(a) (((I_)(a)) < 0 ? -((I_)(a)) : ((I_)(a)))
+
+#define mulIntMayOflo(a,b) \
+({ \
+ I_ c; \
+ if (stg_abs(a) >= HALF_INT || \
+ stg_abs(b) >= HALF_INT) { \
+ c = 1; \
+ } else { \
+ c = 0; \
+ } \
+ c; \
+})
+#endif
#endif /* STG_H */
/* specialised function types: bitmaps and calling sequences
* for these functions are pre-generated (see ghc/utils/genapply), and
* the generated code in ghc/rts/AutoApply.hc.
+ *
+ * NOTE: this ordering/numbering is hard-coded into the tables
+ * generated by GenApply.hs which end up in AutoApply.cmm.
*/
#define ARG_N 3
#define ARG_P 4
#define ARG_NP 9
#define ARG_PN 10
#define ARG_PP 11
-#define ARG_FF 12
-#define ARG_DD 13
-#define ARG_LL 14
-#define ARG_NNN 15
-#define ARG_NNP 16
-#define ARG_NPN 17
-#define ARG_NPP 18
-#define ARG_PNN 19
-#define ARG_PNP 20
-#define ARG_PPN 21
-#define ARG_PPP 22
-#define ARG_PPPP 23
-#define ARG_PPPPP 24
-#define ARG_PPPPPP 25
-#define ARG_PPPPPPP 26
-#define ARG_PPPPPPPP 27
+#define ARG_NNN 12
+#define ARG_NNP 13
+#define ARG_NPN 14
+#define ARG_NPP 15
+#define ARG_PNN 16
+#define ARG_PNP 17
+#define ARG_PPN 18
+#define ARG_PPP 19
+#define ARG_PPPP 20
+#define ARG_PPPPP 21
+#define ARG_PPPPPP 22
+#define ARG_PPPPPPP 23
+#define ARG_PPPPPPPP 24
#endif // STGFUN_H
/* -----------------------------------------------------------------------------
- * $Id: StgLdvProf.h,v 1.2 2001/11/26 16:54:22 simonmar Exp $
*
- * (c) The GHC Team, 2001
- * Author: Sungwoo Park
+ * (c) The University of Glasgow, 2004
*
* Lag/Drag/Void profiling.
*
#ifndef STGLDVPROF_H
#define STGLDVPROF_H
-/*
- An LDV word is divided into 3 parts: state bits (LDV_STATE_MASK), creation
- time bits (LDV_CREATE_MASK), and last use time bits (LDV_LAST_MASK).
- */
-#if SIZEOF_VOID_P == 8
-#define LDV_SHIFT 30
-#define LDV_STATE_MASK 0x1000000000000000
-#define LDV_CREATE_MASK 0x0FFFFFFFC0000000
-#define LDV_LAST_MASK 0x000000003FFFFFFF
-#define LDV_STATE_CREATE 0x0000000000000000
-#define LDV_STATE_USE 0x1000000000000000
-#else
-#define LDV_SHIFT 15
-#define LDV_STATE_MASK 0x40000000
-#define LDV_CREATE_MASK 0x3FFF8000
-#define LDV_LAST_MASK 0x00007FFF
-#define LDV_STATE_CREATE 0x00000000
-#define LDV_STATE_USE 0x40000000
-#endif // SIZEOF_VOID_P
-
#ifdef PROFILING
-extern nat era;
-
-// retrieves the LDV word from closure c
+/* retrieves the LDV word from closure c */
#define LDVW(c) (((StgClosure *)(c))->header.prof.hp.ldvw)
-// Stores the creation time for closure c.
-// This macro is called at the very moment of closure creation.
-//
-// NOTE: this initializes LDVW(c) to zero, which ensures that there
-// is no conflict between retainer profiling and LDV profiling,
-// because retainer profiling also expects LDVW(c) to be initialised
-// to zero.
-#define LDV_recordCreate(c) \
- LDVW((c)) = (era << LDV_SHIFT) | LDV_STATE_CREATE
-
-// Stores the last use time for closure c.
-// This macro *must* be called whenever a closure is used, that is, it is
-// entered.
-#define LDV_recordUse(c) \
- { \
- if (era > 0) \
- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | \
- era | \
- LDV_STATE_USE; \
- }
-
-// Macros called when a closure is entered.
-// The closure is not an 'inherently used' one.
-// The closure is not IND or IND_OLDGEN because neither is considered for LDV
-// profiling.
-#define LDV_ENTER(c) LDV_recordUse((c))
+/*
+ * Stores the creation time for closure c.
+ * This macro is called at the very moment of closure creation.
+ *
+ * NOTE: this initializes LDVW(c) to zero, which ensures that there
+ * is no conflict between retainer profiling and LDV profiling,
+ * because retainer profiling also expects LDVW(c) to be initialised
+ * to zero.
+ */
+#ifndef CMINUSMINUS
+#define LDV_RECORD_CREATE(c) \
+ LDVW((c)) = (RTS_DEREF(era) << LDV_SHIFT) | LDV_STATE_CREATE
+#endif
+
+#ifdef CMINUSMINUS
+#define LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(c) \
+ foreign "C" LDV_recordDead_FILL_SLOP_DYNAMIC(c "ptr")
+#else
+#define LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(c) \
+ LDV_recordDead_FILL_SLOP_DYNAMIC(c)
+#endif
-#else // !PROFILING
+#else /* !PROFILING */
-#define LDV_ENTER(c)
+#define LDV_RECORD_CREATE(c) /* nothing */
+#define LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(c) /* nothing */
-#endif // PROFILING
-#endif // STGLDVPROF_H
+#endif /* PROFILING */
+#endif /* STGLDVPROF_H */
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StgMacros.h,v 1.57 2003/11/12 17:27:04 sof Exp $
- *
- * (c) The GHC Team, 1998-1999
- *
- * Macros used for writing STG-ish C code.
- *
- * ---------------------------------------------------------------------------*/
-
-#ifndef STGMACROS_H
-#define STGMACROS_H
-
-/* -----------------------------------------------------------------------------
- The following macros create function headers.
-
- Each basic block is represented by a C function with no arguments.
- We therefore always begin with either
-
- extern F_ f(void)
-
- or
-
- static F_ f(void)
-
- The macros can be used either to define the function itself, or to provide
- prototypes (by following with a ';').
-
- Note: the various I*_ shorthands in the second block below are used to
- declare forward references to local symbols. These shorthands *have* to
- use the 'extern' type specifier and not 'static'. The reason for this is
- that 'static' declares a reference as being a static/local variable,
- and *not* as a forward reference to a static variable.
-
- This might seem obvious, but it had me stumped as to why my info tables
- were suddenly all filled with 0s.
-
- -- sof 1/99
-
- --------------------------------------------------------------------------- */
-
-#define STGFUN(f) StgFunPtr f(void)
-#define EXTFUN(f) extern StgFunPtr f(void)
-#define EXTFUN_RTS(f) extern DLL_IMPORT_RTS StgFunPtr f(void)
-#define FN_(f) F_ f(void)
-#define IF_(f) static F_ f(void)
-#define EF_(f) extern F_ f(void)
-#define EDF_(f) extern DLLIMPORT F_ f(void)
-
-#define EXTINFO_RTS extern DLL_IMPORT_RTS const StgInfoTable
-#define ETI_RTS extern DLL_IMPORT_RTS const StgThunkInfoTable
-
-// Info tables as generated by the compiler are simply arrays of words.
-typedef StgWord StgWordArray[];
-
-#define ED_ extern
-#define EDD_ extern DLLIMPORT
-#define ED_RO_ extern const
-#define ID_ static
-#define ID_RO_ static const
-#define EI_ extern StgWordArray
-#define ERI_ extern const StgRetInfoTable
-#define II_ static StgWordArray
-#define IRI_ static const StgRetInfoTable
-#define EC_ extern StgClosure
-#define EDC_ extern DLLIMPORT StgClosure
-#define IC_ static StgClosure
-#define ECP_(x) extern const StgClosure *(x)[]
-#define EDCP_(x) extern DLLIMPORT StgClosure *(x)[]
-#define ICP_(x) static const StgClosure *(x)[]
-
-/* -----------------------------------------------------------------------------
- Entering
-
- It isn't safe to "enter" every closure. Functions in particular
- have no entry code as such; their entry point contains the code to
- apply the function.
- -------------------------------------------------------------------------- */
-
-#define ENTER() \
- { \
- again: \
- switch (get_itbl(R1.cl)->type) { \
- case IND: \
- case IND_OLDGEN: \
- case IND_PERM: \
- case IND_OLDGEN_PERM: \
- case IND_STATIC: \
- R1.cl = ((StgInd *)R1.cl)->indirectee; \
- goto again; \
- case BCO: \
- case FUN: \
- case FUN_1_0: \
- case FUN_0_1: \
- case FUN_2_0: \
- case FUN_1_1: \
- case FUN_0_2: \
- case FUN_STATIC: \
- case PAP: \
- JMP_(ENTRY_CODE(Sp[0])); \
- default: \
- JMP_(GET_ENTRY(R1.cl)); \
- } \
- }
-
-/* -----------------------------------------------------------------------------
- Heap/Stack Checks.
-
- When failing a check, we save a return address on the stack and
- jump to a pre-compiled code fragment that saves the live registers
- and returns to the scheduler.
-
- The return address in most cases will be the beginning of the basic
- block in which the check resides, since we need to perform the check
- again on re-entry because someone else might have stolen the resource
- in the meantime.
- ------------------------------------------------------------------------- */
-
-#define STK_CHK_FUN(headroom,assts) \
- if (Sp - headroom < SpLim) { \
- assts \
- JMP_(stg_gc_fun); \
- }
-
-#define HP_CHK_FUN(headroom,assts) \
- DO_GRAN_ALLOCATE(headroom) \
- if ((Hp += headroom) > HpLim) { \
- HpAlloc = (headroom); \
- assts \
- JMP_(stg_gc_fun); \
- }
-
-// When doing both a heap and a stack check, don't move the heap
-// pointer unless the stack check succeeds. Otherwise we might end up
-// with slop at the end of the current block, which can confuse the
-// LDV profiler.
-#define HP_STK_CHK_FUN(stk_headroom,hp_headroom,assts) \
- DO_GRAN_ALLOCATE(hp_headroom) \
- if (Sp - stk_headroom < SpLim || (Hp += hp_headroom) > HpLim) { \
- HpAlloc = (hp_headroom); \
- assts \
- JMP_(stg_gc_fun); \
- }
-
-/* -----------------------------------------------------------------------------
- A Heap Check in a case alternative are much simpler: everything is
- on the stack and covered by a liveness mask already, and there is
- even a return address with an SRT info table there as well.
-
- Just push R1 and return to the scheduler saying 'EnterGHC'
-
- {STK,HP,HP_STK}_CHK_NP are the various checking macros for
- bog-standard case alternatives, thunks, and non-top-level
- functions. In all these cases, node points to a closure that we
- can just enter to restart the heap check (the NP stands for 'node points').
-
- In the NP case GranSim absolutely has to check whether the current node
- resides on the current processor. Otherwise a FETCH event has to be
- scheduled. All that is done in GranSimFetch. -- HWL
-
- HpLim points to the LAST WORD of valid allocation space.
- -------------------------------------------------------------------------- */
-
-#define STK_CHK_NP(headroom,tag_assts) \
- if ((Sp - (headroom)) < SpLim) { \
- tag_assts \
- JMP_(stg_gc_enter_1); \
- }
-
-#define HP_CHK_NP(headroom,tag_assts) \
- DO_GRAN_ALLOCATE(headroom) \
- if ((Hp += (headroom)) > HpLim) { \
- HpAlloc = (headroom); \
- tag_assts \
- JMP_(stg_gc_enter_1); \
- }
-
-// See comment on HP_STK_CHK_FUN above.
-#define HP_STK_CHK_NP(stk_headroom, hp_headroom, tag_assts) \
- DO_GRAN_ALLOCATE(hp_headroom) \
- if ((Sp - (stk_headroom)) < SpLim || (Hp += (hp_headroom)) > HpLim) { \
- HpAlloc = (hp_headroom); \
- tag_assts \
- JMP_(stg_gc_enter_1); \
- }
-
-
-/* Heap checks for branches of a primitive case / unboxed tuple return */
-
-#define GEN_HP_CHK_ALT(headroom,lbl,tag_assts) \
- DO_GRAN_ALLOCATE(headroom) \
- if ((Hp += (headroom)) > HpLim) { \
- HpAlloc = (headroom); \
- tag_assts \
- JMP_(lbl); \
- }
-
-#define HP_CHK_NOREGS(headroom,tag_assts) \
- GEN_HP_CHK_ALT(headroom,stg_gc_noregs,tag_assts);
-#define HP_CHK_UNPT_R1(headroom,tag_assts) \
- GEN_HP_CHK_ALT(headroom,stg_gc_unpt_r1,tag_assts);
-#define HP_CHK_UNBX_R1(headroom,tag_assts) \
- GEN_HP_CHK_ALT(headroom,stg_gc_unbx_r1,tag_assts);
-#define HP_CHK_F1(headroom,tag_assts) \
- GEN_HP_CHK_ALT(headroom,stg_gc_f1,tag_assts);
-#define HP_CHK_D1(headroom,tag_assts) \
- GEN_HP_CHK_ALT(headroom,stg_gc_d1,tag_assts);
-#define HP_CHK_L1(headroom,tag_assts) \
- GEN_HP_CHK_ALT(headroom,stg_gc_l1,tag_assts);
-
-/* -----------------------------------------------------------------------------
- Generic Heap checks.
-
- These are slow, but have the advantage of being usable in a variety
- of situations.
-
- The one restriction is that any relevant SRTs must already be pointed
- to from the stack. The return address doesn't need to have an info
- table attached: hence it can be any old code pointer.
-
- The liveness mask is a logical 'XOR' of NO_PTRS and zero or more
- Rn_PTR constants defined below. All registers will be saved, but
- the garbage collector needs to know which ones contain pointers.
-
- Good places to use a generic heap check:
-
- - case alternatives (the return address with an SRT is already
- on the stack).
-
- - primitives (no SRT required).
-
- The stack frame layout for a RET_DYN is like this:
-
- some pointers |-- GET_PTRS(liveness) words
- some nonpointers |-- GET_NONPTRS(liveness) words
-
- L1 \
- D1-2 |-- RET_DYN_NONPTR_REGS_SIZE words
- F1-4 /
-
- R1-8 |-- RET_DYN_BITMAP_SIZE words
-
- return address \
- liveness mask |-- StgRetDyn structure
- stg_gen_chk_info /
-
- we assume that the size of a double is always 2 pointers (wasting a
- word when it is only one pointer, but avoiding lots of #ifdefs).
-
- NOTE: if you change the layout of RET_DYN stack frames, then you
- might also need to adjust the value of RESERVED_STACK_WORDS in
- Constants.h.
- -------------------------------------------------------------------------- */
-
-// VERY MAGIC CONSTANTS!
-// must agree with code in HeapStackCheck.c, stg_gen_chk, and
-// RESERVED_STACK_WORDS in Constants.h.
-//
-#define RET_DYN_BITMAP_SIZE 8
-#define RET_DYN_NONPTR_REGS_SIZE 10
-#define ALL_NON_PTRS 0xff
-
-// Sanity check that RESERVED_STACK_WORDS is reasonable. We can't
-// just derive RESERVED_STACK_WORDS because it's used in Haskell code
-// too.
-#if RESERVED_STACK_WORDS != (3 + RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE)
-#error RESERVED_STACK_WORDS may be wrong!
-#endif
-
-#define LIVENESS_MASK(ptr_regs) (ALL_NON_PTRS ^ (ptr_regs))
-
-// We can have up to 255 pointers and 255 nonpointers in the stack
-// frame.
-#define N_NONPTRS(n) ((n)<<16)
-#define N_PTRS(n) ((n)<<24)
-
-#define GET_NONPTRS(l) ((l)>>16 & 0xff)
-#define GET_PTRS(l) ((l)>>24 & 0xff)
-#define GET_LIVENESS(l) ((l) & 0xffff)
-
-#define NO_PTRS 0
-#define R1_PTR 1<<0
-#define R2_PTR 1<<1
-#define R3_PTR 1<<2
-#define R4_PTR 1<<3
-#define R5_PTR 1<<4
-#define R6_PTR 1<<5
-#define R7_PTR 1<<6
-#define R8_PTR 1<<7
-
-#define HP_CHK_UNBX_TUPLE(headroom,liveness,code) \
- if ((Hp += (headroom)) > HpLim ) { \
- HpAlloc = (headroom); \
- code \
- R9.w = (W_)LIVENESS_MASK(liveness); \
- JMP_(stg_gc_ut); \
- }
-
-#define HP_CHK_GEN(headroom,liveness,reentry) \
- if ((Hp += (headroom)) > HpLim ) { \
- HpAlloc = (headroom); \
- R9.w = (W_)LIVENESS_MASK(liveness); \
- R10.w = (W_)reentry; \
- JMP_(stg_gc_gen); \
- }
-
-#define HP_CHK_GEN_TICKY(headroom,liveness,reentry) \
- HP_CHK_GEN(headroom,liveness,reentry); \
- TICK_ALLOC_HEAP_NOCTR(headroom)
-
-#define STK_CHK_GEN(headroom,liveness,reentry) \
- if ((Sp - (headroom)) < SpLim) { \
- R9.w = (W_)LIVENESS_MASK(liveness); \
- R10.w = (W_)reentry; \
- JMP_(stg_gc_gen); \
- }
-
-#define MAYBE_GC(liveness,reentry) \
- if (doYouWantToGC()) { \
- R9.w = (W_)LIVENESS_MASK(liveness); \
- R10.w = (W_)reentry; \
- JMP_(stg_gc_gen_hp); \
- }
-
-/* -----------------------------------------------------------------------------
- Voluntary Yields/Blocks
-
- We only have a generic version of this at the moment - if it turns
- out to be slowing us down we can make specialised ones.
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(stg_gen_yield);
-EXTFUN_RTS(stg_gen_block);
-
-#define YIELD(liveness,reentry) \
- { \
- R9.w = (W_)LIVENESS_MASK(liveness); \
- R10.w = (W_)reentry; \
- JMP_(stg_gen_yield); \
- }
-
-#define BLOCK(liveness,reentry) \
- { \
- R9.w = (W_)LIVENESS_MASK(liveness); \
- R10.w = (W_)reentry; \
- JMP_(stg_gen_block); \
- }
-
-#define BLOCK_NP(ptrs) \
- { \
- EXTFUN_RTS(stg_block_##ptrs); \
- JMP_(stg_block_##ptrs); \
- }
-
-#if defined(PAR)
-/*
- Similar to BLOCK_NP but separates the saving of the thread state from the
- actual jump via an StgReturn
-*/
-
-#define SAVE_THREAD_STATE(ptrs) \
- ASSERT(ptrs==1); \
- Sp -= 1; \
- Sp[0] = R1.w; \
- SaveThreadState();
-
-#define THREAD_RETURN(ptrs) \
- ASSERT(ptrs==1); \
- CurrentTSO->what_next = ThreadEnterGHC; \
- R1.i = ThreadBlocked; \
- JMP_(StgReturn);
-#endif
-
-/* -----------------------------------------------------------------------------
- CCall_GC needs to push a dummy stack frame containing the contents
- of volatile registers and variables.
-
- We use a RET_DYN frame the same as for a dynamic heap check.
- ------------------------------------------------------------------------- */
-
-/* -----------------------------------------------------------------------------
- Vectored Returns
-
- RETVEC(p,t) where 'p' is a pointer to the info table for a
- vectored return address, returns the address of the return code for
- tag 't'.
-
- Return vectors are placed in *reverse order* immediately before the info
- table for the return address. Hence the formula for computing the
- actual return address is (addr - sizeof(RetInfoTable) - tag - 1).
- The extra subtraction of one word is because tags start at zero.
- -------------------------------------------------------------------------- */
-
-#ifdef TABLES_NEXT_TO_CODE
-#define RET_VEC(p,t) (*((P_)(p) - sizeofW(StgRetInfoTable) - t - 1))
-#else
-#define RET_VEC(p,t) (((StgRetInfoTable *)p)->vector[t])
-#endif
-
-/* -----------------------------------------------------------------------------
- Misc
- -------------------------------------------------------------------------- */
-
-
-/* set the tag register (if we have one) */
-#define SET_TAG(t) /* nothing */
-
-#ifdef EAGER_BLACKHOLING
-# ifdef SMP
-# define UPD_BH_UPDATABLE(info) \
- TICK_UPD_BH_UPDATABLE(); \
- { \
- bdescr *bd = Bdescr(R1.p); \
- if (bd->u.back != (bdescr *)BaseReg) { \
- if (bd->gen_no >= 1 || bd->step->no >= 1) { \
- LOCK_THUNK(info); \
- } else { \
- EXTFUN_RTS(stg_gc_enter_1_hponly); \
- JMP_(stg_gc_enter_1_hponly); \
- } \
- } \
- } \
- SET_INFO(R1.cl,&stg_BLACKHOLE_info)
-# define UPD_BH_SINGLE_ENTRY(info) \
- TICK_UPD_BH_SINGLE_ENTRY(); \
- { \
- bdescr *bd = Bdescr(R1.p); \
- if (bd->u.back != (bdescr *)BaseReg) { \
- if (bd->gen_no >= 1 || bd->step->no >= 1) { \
- LOCK_THUNK(info); \
- } else { \
- EXTFUN_RTS(stg_gc_enter_1_hponly); \
- JMP_(stg_gc_enter_1_hponly); \
- } \
- } \
- } \
- SET_INFO(R1.cl,&stg_BLACKHOLE_info)
-# else
-# ifndef PROFILING
-# define UPD_BH_UPDATABLE(info) \
- TICK_UPD_BH_UPDATABLE(); \
- SET_INFO(R1.cl,&stg_BLACKHOLE_info)
-# define UPD_BH_SINGLE_ENTRY(info) \
- TICK_UPD_BH_SINGLE_ENTRY(); \
- SET_INFO(R1.cl,&stg_SE_BLACKHOLE_info)
-# else
-// An object is replaced by a blackhole, so we fill the slop with zeros.
-//
-// This looks like it can't work - we're overwriting the contents of
-// the THUNK with slop! Perhaps this never worked??? --SDM
-// The problem is that with eager-black-holing we currently perform
-// the black-holing operation at the *beginning* of the basic block,
-// when we still need the contents of the thunk.
-// Perhaps the thing to do is to overwrite it at the *end* of the
-// basic block, when we've already sucked out the thunk's contents? -- SLPJ
-//
-// Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
-//
-# define UPD_BH_UPDATABLE(info) \
- TICK_UPD_BH_UPDATABLE(); \
- LDV_recordDead_FILL_SLOP_DYNAMIC(R1.cl); \
- SET_INFO(R1.cl,&stg_BLACKHOLE_info); \
- LDV_recordCreate(R1.cl)
-# define UPD_BH_SINGLE_ENTRY(info) \
- TICK_UPD_BH_SINGLE_ENTRY(); \
- LDV_recordDead_FILL_SLOP_DYNAMIC(R1.cl); \
- SET_INFO(R1.cl,&stg_SE_BLACKHOLE_info) \
- LDV_recordCreate(R1.cl)
-# endif /* PROFILING */
-# endif
-#else /* !EAGER_BLACKHOLING */
-# define UPD_BH_UPDATABLE(thunk) /* nothing */
-# define UPD_BH_SINGLE_ENTRY(thunk) /* nothing */
-#endif /* EAGER_BLACKHOLING */
-
-/* -----------------------------------------------------------------------------
- Moving Floats and Doubles
-
- ASSIGN_FLT is for assigning a float to memory (usually the
- stack/heap). The memory address is guaranteed to be
- StgWord aligned (currently == sizeof(void *)).
-
- PK_FLT is for pulling a float out of memory. The memory is
- guaranteed to be StgWord aligned.
- -------------------------------------------------------------------------- */
-
-INLINE_HEADER void ASSIGN_FLT (W_ [], StgFloat);
-INLINE_HEADER StgFloat PK_FLT (W_ []);
-
-#if ALIGNMENT_FLOAT <= ALIGNMENT_LONG
-
-INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }
-INLINE_HEADER StgFloat PK_FLT (W_ p_src[]) { return *(StgFloat *)p_src; }
-
-#else /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */
-
-INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src)
-{
- float_thing y;
- y.f = src;
- *p_dest = y.fu;
-}
-
-INLINE_HEADER StgFloat PK_FLT(W_ p_src[])
-{
- float_thing y;
- y.fu = *p_src;
- return(y.f);
-}
-
-#endif /* ALIGNMENT_FLOAT > ALIGNMENT_LONG */
-
-#if ALIGNMENT_DOUBLE <= ALIGNMENT_LONG
-
-INLINE_HEADER void ASSIGN_DBL (W_ [], StgDouble);
-INLINE_HEADER StgDouble PK_DBL (W_ []);
-
-INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }
-INLINE_HEADER StgDouble PK_DBL (W_ p_src[]) { return *(StgDouble *)p_src; }
-
-#else /* ALIGNMENT_DOUBLE > ALIGNMENT_LONG */
-
-/* Sparc uses two floating point registers to hold a double. We can
- * write ASSIGN_DBL and PK_DBL by directly accessing the registers
- * independently - unfortunately this code isn't writable in C, we
- * have to use inline assembler.
- */
-#if sparc_TARGET_ARCH
-
-#define ASSIGN_DBL(dst0,src) \
- { StgPtr dst = (StgPtr)(dst0); \
- __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
- "=m" (((P_)(dst))[1]) : "f" (src)); \
- }
-
-#define PK_DBL(src0) \
- ( { StgPtr src = (StgPtr)(src0); \
- register double d; \
- __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
- "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
- } )
-
-#else /* ! sparc_TARGET_ARCH */
-
-INLINE_HEADER void ASSIGN_DBL (W_ [], StgDouble);
-INLINE_HEADER StgDouble PK_DBL (W_ []);
-
-typedef struct
- { StgWord dhi;
- StgWord dlo;
- } unpacked_double;
-
-typedef union
- { StgDouble d;
- unpacked_double du;
- } double_thing;
-
-INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src)
-{
- double_thing y;
- y.d = src;
- p_dest[0] = y.du.dhi;
- p_dest[1] = y.du.dlo;
-}
-
-/* GCC also works with this version, but it generates
- the same code as the previous one, and is not ANSI
-
-#define ASSIGN_DBL( p_dest, src ) \
- *p_dest = ((double_thing) src).du.dhi; \
- *(p_dest+1) = ((double_thing) src).du.dlo \
-*/
-
-INLINE_HEADER StgDouble PK_DBL(W_ p_src[])
-{
- double_thing y;
- y.du.dhi = p_src[0];
- y.du.dlo = p_src[1];
- return(y.d);
-}
-
-#endif /* ! sparc_TARGET_ARCH */
-
-#endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */
-
-#ifdef SUPPORT_LONG_LONGS
-
-typedef struct
- { StgWord dhi;
- StgWord dlo;
- } unpacked_double_word;
-
-typedef union
- { StgInt64 i;
- unpacked_double_word iu;
- } int64_thing;
-
-typedef union
- { StgWord64 w;
- unpacked_double_word wu;
- } word64_thing;
-
-INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
-{
- word64_thing y;
- y.w = src;
- p_dest[0] = y.wu.dhi;
- p_dest[1] = y.wu.dlo;
-}
-
-INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
-{
- word64_thing y;
- y.wu.dhi = p_src[0];
- y.wu.dlo = p_src[1];
- return(y.w);
-}
-
-INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
-{
- int64_thing y;
- y.i = src;
- p_dest[0] = y.iu.dhi;
- p_dest[1] = y.iu.dlo;
-}
-
-INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
-{
- int64_thing y;
- y.iu.dhi = p_src[0];
- y.iu.dlo = p_src[1];
- return(y.i);
-}
-
-#elif SIZEOF_VOID_P == 8
-
-INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
-{
- p_dest[0] = src;
-}
-
-INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
-{
- return p_src[0];
-}
-
-INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
-{
- p_dest[0] = src;
-}
-
-INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
-{
- return p_src[0];
-}
-
-#endif
-
-/* -----------------------------------------------------------------------------
- Catch frames
- -------------------------------------------------------------------------- */
-
-extern DLL_IMPORT_RTS const StgPolyInfoTable stg_catch_frame_info;
-
-/* -----------------------------------------------------------------------------
- Split markers
- -------------------------------------------------------------------------- */
-
-#if defined(USE_SPLIT_MARKERS)
-#if defined(LEADING_UNDERSCORE)
-#define __STG_SPLIT_MARKER __asm__("\n___stg_split_marker:");
-#else
-#define __STG_SPLIT_MARKER __asm__("\n__stg_split_marker:");
-#endif
-#else
-#define __STG_SPLIT_MARKER /* nothing */
-#endif
-
-/* -----------------------------------------------------------------------------
- Closure and Info Macros with casting.
-
- We don't want to mess around with casts in the generated C code, so
- we use this casting versions of the closure macro.
-
- This version of SET_HDR also includes CCS_ALLOC for profiling - the
- reason we don't use two separate macros is that the cost centre
- field is sometimes a non-simple expression and we want to share its
- value between SET_HDR and CCS_ALLOC.
- -------------------------------------------------------------------------- */
-
-#define SET_HDR_(c,info,ccs,size) \
- { \
- CostCentreStack *tmp = (ccs); \
- SET_HDR((StgClosure *)(c),(StgInfoTable *)(info),tmp); \
- CCS_ALLOC(tmp,size); \
- }
-
-/* -----------------------------------------------------------------------------
- Saving context for exit from the STG world, and loading up context
- on entry to STG code.
-
- We save all the STG registers (that is, the ones that are mapped to
- machine registers) in their places in the TSO.
-
- The stack registers go into the current stack object, and the
- current nursery is updated from the heap pointer.
-
- These functions assume that BaseReg is loaded appropriately (if
- we have one).
- -------------------------------------------------------------------------- */
-
-#if IN_STG_CODE
-
-INLINE_HEADER void
-SaveThreadState(void)
-{
- StgTSO *tso;
-
- /* Don't need to save REG_Base, it won't have changed. */
-
- tso = CurrentTSO;
- tso->sp = Sp;
- CloseNursery(Hp);
-
-#ifdef REG_CurrentTSO
- SAVE_CurrentTSO = tso;
-#endif
-#ifdef REG_CurrentNursery
- SAVE_CurrentNursery = CurrentNursery;
-#endif
-#if defined(PROFILING)
- CurrentTSO->prof.CCCS = CCCS;
-#endif
-}
-
-INLINE_HEADER void
-LoadThreadState (void)
-{
- StgTSO *tso;
-
-#ifdef REG_CurrentTSO
- CurrentTSO = SAVE_CurrentTSO;
-#endif
-
- tso = CurrentTSO;
- Sp = tso->sp;
- SpLim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
- OpenNursery(Hp,HpLim);
-
-#ifdef REG_CurrentNursery
- CurrentNursery = SAVE_CurrentNursery;
-#endif
-# if defined(PROFILING)
- CCCS = CurrentTSO->prof.CCCS;
-# endif
-}
-
-#endif
-
-/* -----------------------------------------------------------------------------
- Module initialisation
-
- The module initialisation code looks like this, roughly:
-
- FN(__stginit_Foo) {
- JMP_(__stginit_Foo_1_p)
- }
-
- FN(__stginit_Foo_1_p) {
- ...
- }
-
- We have one version of the init code with a module version and the
- 'way' attached to it. The version number helps to catch cases
- where modules are not compiled in dependency order before being
- linked: if a module has been compiled since any modules which depend on
- it, then the latter modules will refer to a different version in their
- init blocks and a link error will ensue.
-
- The 'way' suffix helps to catch cases where modules compiled in different
- ways are linked together (eg. profiled and non-profiled).
-
- We provide a plain, unadorned, version of the module init code
- which just jumps to the version with the label and way attached. The
- reason for this is that when using foreign exports, the caller of
- startupHaskell() must supply the name of the init function for the "top"
- module in the program, and we don't want to require that this name
- has the version and way info appended to it.
- -------------------------------------------------------------------------- */
-
-#define PUSH_INIT_STACK(reg_function) \
- *(Sp++) = (W_)reg_function
-
-#define POP_INIT_STACK() \
- *(--Sp)
-
-#define MOD_INIT_WRAPPER(label,real_init) \
-
-
-#define START_MOD_INIT(plain_lbl, real_lbl) \
- static int _module_registered = 0; \
- EF_(real_lbl); \
- FN_(plain_lbl) { \
- FB_ \
- JMP_(real_lbl); \
- FE_ \
- } \
- FN_(real_lbl) { \
- FB_; \
- if (! _module_registered) { \
- _module_registered = 1; \
- {
- /* extern decls go here, followed by init code */
-
-#define REGISTER_FOREIGN_EXPORT(reg_fe_binder) \
- STGCALL1(getStablePtr,reg_fe_binder)
-
-#define REGISTER_IMPORT(reg_mod_name) \
- PUSH_INIT_STACK(reg_mod_name)
-
-#define END_MOD_INIT() \
- }}; \
- JMP_(POP_INIT_STACK()); \
- FE_ }
-
-/* -----------------------------------------------------------------------------
- Support for _ccall_GC_ and _casm_GC.
- -------------------------------------------------------------------------- */
-
-/*
- * Suspending/resuming threads for doing external C-calls (_ccall_GC).
- * These functions are defined in rts/Schedule.c.
- */
-StgInt suspendThread ( StgRegTable *, rtsBool);
-StgRegTable * resumeThread ( StgInt, rtsBool );
-
-#define SUSPEND_THREAD(token,threaded) \
- SaveThreadState(); \
- token = suspendThread(BaseReg,threaded);
-
-#ifdef SMP
-#define RESUME_THREAD(token,threaded) \
- BaseReg = resumeThread(token,threaded); \
- LoadThreadState();
-#else
-#define RESUME_THREAD(token,threaded) \
- (void)resumeThread(token,threaded); \
- LoadThreadState();
-#endif
-
-#endif /* STGMACROS_H */
-
-/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.47 2003/03/27 13:54:31 simonmar Exp $
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
*
- * (c) The GHC Team, 1998-2002
+ * Declarations for various symbols exported by the RTS.
*
- * Entry code for various built-in closure types.
+ * ToDo: many of the symbols in here don't need to be exported, but
+ * our Cmm code generator doesn't know how to generate local symbols
+ * for the RTS bits (it assumes all RTS symbols are external).
*
- * ---------------------------------------------------------------------------*/
+ * --------------------------------------------------------------------------*/
+
+#ifndef STGMISCCLOSURES_H
+#define STGMISCCLOSURES_H
+
+#if IN_STG_CODE
+# define RTS_RET_INFO(i) extern W_(i)[]
+# define RTS_FUN_INFO(i) extern W_(i)[]
+# define RTS_THUNK_INFO(i) extern W_(i)[]
+# define RTS_INFO(i) extern W_(i)[]
+# define RTS_CLOSURE(i) extern W_(i)[]
+# define RTS_FUN(f) extern DLL_IMPORT_RTS StgFunPtr f(void)
+#else
+# define RTS_RET_INFO(i) extern DLL_IMPORT_RTS const StgRetInfoTable i
+# define RTS_FUN_INFO(i) extern DLL_IMPORT_RTS const StgFunInfoTable i
+# define RTS_THUNK_INFO(i) extern DLL_IMPORT_RTS const StgThunkInfoTable i
+# define RTS_INFO(i) extern DLL_IMPORT_RTS const StgInfoTable i
+# define RTS_CLOSURE(i) extern DLL_IMPORT_RTS StgClosure i
+# define RTS_FUN(f) extern DLL_IMPORT_RTS StgFunPtr f(void)
+#endif
-/* The naming scheme here follows the naming scheme for closure types
- * defined in InfoTables.h. The actual info tables and entry code for
- * these objects can be found in StgMiscClosures.hc.
- */
+#ifdef TABLES_NEXT_TO_CODE
+# define RTS_ENTRY(f) /* nothing */
+#else
+# define RTS_ENTRY(f) RTS_FUN(f)
+#endif
-/* Various entry points */
-STGFUN(stg_PAP_entry);
-STGFUN(stg_BCO_entry);
+/* Stack frames */
+RTS_RET_INFO(stg_upd_frame_info);
+RTS_RET_INFO(stg_noupd_frame_info);
+RTS_RET_INFO(stg_seq_frame_info);
+RTS_RET_INFO(stg_catch_frame_info);
+
+RTS_ENTRY(stg_upd_frame_ret);
+RTS_ENTRY(stg_seq_frame_ret);
/* Entry code for constructors created by the bytecode interpreter */
-STGFUN(stg_interp_constr_entry);
-STGFUN(stg_interp_constr1_entry);
-STGFUN(stg_interp_constr2_entry);
-STGFUN(stg_interp_constr3_entry);
-STGFUN(stg_interp_constr4_entry);
-STGFUN(stg_interp_constr5_entry);
-STGFUN(stg_interp_constr6_entry);
-STGFUN(stg_interp_constr7_entry);
-STGFUN(stg_interp_constr8_entry);
+RTS_ENTRY(stg_interp_constr_entry);
+RTS_ENTRY(stg_interp_constr1_entry);
+RTS_ENTRY(stg_interp_constr2_entry);
+RTS_ENTRY(stg_interp_constr3_entry);
+RTS_ENTRY(stg_interp_constr4_entry);
+RTS_ENTRY(stg_interp_constr5_entry);
+RTS_ENTRY(stg_interp_constr6_entry);
+RTS_ENTRY(stg_interp_constr7_entry);
+RTS_ENTRY(stg_interp_constr8_entry);
/* Magic glue code for when compiled code returns a value in R1/F1/D1
or a VoidRep to the interpreter. */
-extern DLL_IMPORT_RTS const StgPolyInfoTable stg_ctoi_ret_R1p_info;
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_R1unpt_info;
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_R1n_info;
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_F1_info;
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_D1_info;
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_L1_info;
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_ctoi_ret_V_info;
-
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_apply_interp_info;
-
-/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
-#define END_TSO_QUEUE ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
-/* this is the NIL ptr for a list CAFs */
-#define END_ECAF_LIST ((StgCAF *)(void*)&stg_END_TSO_QUEUE_closure)
+RTS_RET_INFO(stg_ctoi_R1p_info);
+RTS_RET_INFO(stg_ctoi_R1unpt_info);
+RTS_RET_INFO(stg_ctoi_R1n_info);
+RTS_RET_INFO(stg_ctoi_F1_info);
+RTS_RET_INFO(stg_ctoi_D1_info);
+RTS_RET_INFO(stg_ctoi_L1_info);
+RTS_RET_INFO(stg_ctoi_V_info);
+
+RTS_ENTRY(stg_ctoi_R1p_ret);
+RTS_ENTRY(stg_ctoi_R1unpt_ret);
+RTS_ENTRY(stg_ctoi_R1n_ret);
+RTS_ENTRY(stg_ctoi_F1_ret);
+RTS_ENTRY(stg_ctoi_D1_ret);
+RTS_ENTRY(stg_ctoi_L1_ret);
+RTS_ENTRY(stg_ctoi_V_ret);
+
+RTS_RET_INFO(stg_apply_interp_info);
+RTS_ENTRY(stg_apply_interp_ret);
+
+RTS_INFO(stg_IND_info);
+RTS_INFO(stg_IND_direct_info);
+RTS_INFO(stg_IND_0_info);
+RTS_INFO(stg_IND_1_info);
+RTS_INFO(stg_IND_2_info);
+RTS_INFO(stg_IND_3_info);
+RTS_INFO(stg_IND_4_info);
+RTS_INFO(stg_IND_5_info);
+RTS_INFO(stg_IND_6_info);
+RTS_INFO(stg_IND_7_info);
+RTS_INFO(stg_IND_STATIC_info);
+RTS_INFO(stg_IND_PERM_info);
+RTS_INFO(stg_IND_OLDGEN_info);
+RTS_INFO(stg_IND_OLDGEN_PERM_info);
+RTS_INFO(stg_CAF_UNENTERED_info);
+RTS_INFO(stg_CAF_ENTERED_info);
+RTS_INFO(stg_BLACKHOLE_info);
+RTS_INFO(stg_CAF_BLACKHOLE_info);
+RTS_INFO(stg_BLACKHOLE_BQ_info);
+#ifdef TICKY_TICKY
+RTS_INFO(stg_SE_BLACKHOLE_info);
+RTS_INFO(stg_SE_CAF_BLACKHOLE_info);
+#endif
+
#if defined(PAR) || defined(GRAN)
-/* this is the NIL ptr for a blocking queue */
-# define END_BQ_QUEUE ((StgBlockingQueueElement *)(void*)&stg_END_TSO_QUEUE_closure)
-/* this is the NIL ptr for a blocked fetch queue (as in PendingFetches in GUM) */
-# define END_BF_QUEUE ((StgBlockedFetch *)(void*)&stg_END_TSO_QUEUE_closure)
+RTS_INFO(stg_RBH_info);
#endif
-/* ToDo?: different name for end of sleeping queue ? -- HWL */
-
-/* info tables */
-
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_direct_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_0_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_1_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_2_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_3_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_4_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_5_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_6_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_7_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_STATIC_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_PERM_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_OLDGEN_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_IND_OLDGEN_PERM_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_CAF_UNENTERED_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_CAF_ENTERED_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_BLACKHOLE_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_CAF_BLACKHOLE_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_BLACKHOLE_BQ_info;
-#ifdef SMP
-extern DLL_IMPORT_RTS const StgInfoTable stg_WHITEHOLE_info;
+#if defined(PAR)
+RTS_INFO(stg_FETCH_ME_BQ_info);
#endif
+RTS_FUN_INFO(stg_BCO_info);
+RTS_INFO(stg_EVACUATED_info);
+RTS_INFO(stg_FOREIGN_info);
+RTS_INFO(stg_WEAK_info);
+RTS_INFO(stg_DEAD_WEAK_info);
+RTS_INFO(stg_STABLE_NAME_info);
+RTS_INFO(stg_FULL_MVAR_info);
+RTS_INFO(stg_EMPTY_MVAR_info);
+RTS_INFO(stg_TSO_info);
+RTS_INFO(stg_ARR_WORDS_info);
+RTS_INFO(stg_MUT_ARR_WORDS_info);
+RTS_INFO(stg_MUT_ARR_PTRS_info);
+RTS_INFO(stg_MUT_ARR_PTRS_FROZEN_info);
+RTS_INFO(stg_MUT_VAR_info);
+RTS_INFO(stg_END_TSO_QUEUE_info);
+RTS_INFO(stg_MUT_CONS_info);
+RTS_INFO(stg_END_MUT_LIST_info);
+RTS_INFO(stg_catch_info);
+RTS_INFO(stg_PAP_info);
+RTS_INFO(stg_AP_info);
+RTS_INFO(stg_AP_STACK_info);
+RTS_INFO(stg_dummy_ret_info);
+RTS_INFO(stg_raise_info);
+
+RTS_ENTRY(stg_IND_entry);
+RTS_ENTRY(stg_IND_direct_entry);
+RTS_ENTRY(stg_IND_0_entry);
+RTS_ENTRY(stg_IND_1_entry);
+RTS_ENTRY(stg_IND_2_entry);
+RTS_ENTRY(stg_IND_3_entry);
+RTS_ENTRY(stg_IND_4_entry);
+RTS_ENTRY(stg_IND_5_entry);
+RTS_ENTRY(stg_IND_6_entry);
+RTS_ENTRY(stg_IND_7_entry);
+RTS_ENTRY(stg_IND_STATIC_entry);
+RTS_ENTRY(stg_IND_PERM_entry);
+RTS_ENTRY(stg_IND_OLDGEN_entry);
+RTS_ENTRY(stg_IND_OLDGEN_PERM_entry);
+RTS_ENTRY(stg_CAF_UNENTERED_entry);
+RTS_ENTRY(stg_CAF_ENTERED_entry);
+RTS_ENTRY(stg_BLACKHOLE_entry);
+RTS_ENTRY(stg_CAF_BLACKHOLE_entry);
+RTS_ENTRY(stg_BLACKHOLE_BQ_entry);
#ifdef TICKY_TICKY
-extern DLL_IMPORT_RTS const StgInfoTable stg_SE_BLACKHOLE_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_SE_CAF_BLACKHOLE_info;
+RTS_ENTRY(stg_SE_BLACKHOLE_entry);
+RTS_ENTRY(stg_SE_CAF_BLACKHOLE_entry);
#endif
#if defined(PAR) || defined(GRAN)
-extern DLL_IMPORT_RTS const StgInfoTable stg_RBH_info;
+RTS_ENTRY(stg_RBH_entry);
#endif
#if defined(PAR)
-extern DLL_IMPORT_RTS const StgInfoTable stg_FETCH_ME_BQ_info;
+RTS_ENTRY(stg_FETCH_ME_BQ_entry);
#endif
-extern DLL_IMPORT_RTS const StgFunInfoTable stg_BCO_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_EVACUATED_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_FOREIGN_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_WEAK_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_DEAD_WEAK_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_STABLE_NAME_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_FULL_MVAR_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_EMPTY_MVAR_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_TSO_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_ARR_WORDS_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_MUT_ARR_WORDS_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_MUT_ARR_PTRS_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_MUT_ARR_PTRS_FROZEN_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_MUT_VAR_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_END_TSO_QUEUE_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_MUT_CONS_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_END_MUT_LIST_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_catch_info;
-extern DLL_IMPORT_RTS const StgPolyInfoTable stg_seq_frame_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_PAP_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_AP_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_AP_STACK_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_dummy_ret_info;
-extern DLL_IMPORT_RTS const StgInfoTable stg_raise_info;
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_forceIO_info;
-extern DLL_IMPORT_RTS const StgRetInfoTable stg_noforceIO_info;
+RTS_ENTRY(stg_BCO_entry);
+RTS_ENTRY(stg_EVACUATED_entry);
+RTS_ENTRY(stg_FOREIGN_entry);
+RTS_ENTRY(stg_WEAK_entry);
+RTS_ENTRY(stg_DEAD_WEAK_entry);
+RTS_ENTRY(stg_STABLE_NAME_entry);
+RTS_ENTRY(stg_FULL_MVAR_entry);
+RTS_ENTRY(stg_EMPTY_MVAR_entry);
+RTS_ENTRY(stg_TSO_entry);
+RTS_ENTRY(stg_ARR_WORDS_entry);
+RTS_ENTRY(stg_MUT_ARR_WORDS_entry);
+RTS_ENTRY(stg_MUT_ARR_PTRS_entry);
+RTS_ENTRY(stg_MUT_ARR_PTRS_FROZEN_entry);
+RTS_ENTRY(stg_MUT_VAR_entry);
+RTS_ENTRY(stg_END_TSO_QUEUE_entry);
+RTS_ENTRY(stg_MUT_CONS_entry);
+RTS_ENTRY(stg_END_MUT_LIST_entry);
+RTS_ENTRY(stg_catch_entry);
+RTS_ENTRY(stg_PAP_entry);
+RTS_ENTRY(stg_AP_entry);
+RTS_ENTRY(stg_AP_STACK_entry);
+RTS_ENTRY(stg_dummy_ret_entry);
+RTS_ENTRY(stg_raise_entry);
+
+
+RTS_ENTRY(stg_unblockAsyncExceptionszh_ret_ret);
+RTS_ENTRY(stg_blockAsyncExceptionszh_ret_ret);
+RTS_ENTRY(stg_catch_frame_ret);
+RTS_ENTRY(stg_catch_entry);
+RTS_ENTRY(stg_raise_entry);
+
/* closures */
-extern DLL_IMPORT_RTS StgClosure stg_END_TSO_QUEUE_closure;
-extern DLL_IMPORT_RTS StgClosure stg_END_MUT_LIST_closure;
-extern DLL_IMPORT_RTS StgClosure stg_NO_FINALIZER_closure;
-extern DLL_IMPORT_RTS StgClosure stg_dummy_ret_closure;
-extern DLL_IMPORT_RTS StgClosure stg_forceIO_closure;
+RTS_CLOSURE(stg_END_TSO_QUEUE_closure);
+RTS_CLOSURE(stg_END_MUT_LIST_closure);
+RTS_CLOSURE(stg_NO_FINALIZER_closure);
+RTS_CLOSURE(stg_dummy_ret_closure);
+RTS_CLOSURE(stg_forceIO_closure);
+
+RTS_ENTRY(stg_NO_FINALIZER_entry);
+RTS_ENTRY(stg_END_EXCEPTION_LIST_entry);
+RTS_ENTRY(stg_EXCEPTION_CONS_entry);
+#if IN_STG_CODE
+extern DLL_IMPORT_RTS StgWordArray stg_CHARLIKE_closure;
+extern DLL_IMPORT_RTS StgWordArray stg_INTLIKE_closure;
+#else
extern DLL_IMPORT_RTS StgIntCharlikeClosure stg_CHARLIKE_closure[];
extern DLL_IMPORT_RTS StgIntCharlikeClosure stg_INTLIKE_closure[];
+#endif
+
+/* StgStartup */
+
+RTS_RET_INFO(stg_forceIO_info);
+RTS_ENTRY(stg_forceIO_ret);
+RTS_RET_INFO(stg_noforceIO_info);
+RTS_ENTRY(stg_noforceIO_ret);
/* standard entry points */
/* standard selector thunks */
-EXTINFO_RTS stg_sel_0_upd_info;
-EXTINFO_RTS stg_sel_1_upd_info;
-EXTINFO_RTS stg_sel_2_upd_info;
-EXTINFO_RTS stg_sel_3_upd_info;
-EXTINFO_RTS stg_sel_4_upd_info;
-EXTINFO_RTS stg_sel_5_upd_info;
-EXTINFO_RTS stg_sel_6_upd_info;
-EXTINFO_RTS stg_sel_7_upd_info;
-EXTINFO_RTS stg_sel_8_upd_info;
-EXTINFO_RTS stg_sel_8_upd_info;
-EXTINFO_RTS stg_sel_9_upd_info;
-EXTINFO_RTS stg_sel_10_upd_info;
-EXTINFO_RTS stg_sel_11_upd_info;
-EXTINFO_RTS stg_sel_12_upd_info;
-EXTINFO_RTS stg_sel_13_upd_info;
-EXTINFO_RTS stg_sel_14_upd_info;
-EXTINFO_RTS stg_sel_15_upd_info;
-
-EXTINFO_RTS stg_sel_0_noupd_info;
-EXTINFO_RTS stg_sel_1_noupd_info;
-EXTINFO_RTS stg_sel_2_noupd_info;
-EXTINFO_RTS stg_sel_3_noupd_info;
-EXTINFO_RTS stg_sel_4_noupd_info;
-EXTINFO_RTS stg_sel_5_noupd_info;
-EXTINFO_RTS stg_sel_6_noupd_info;
-EXTINFO_RTS stg_sel_7_noupd_info;
-EXTINFO_RTS stg_sel_8_noupd_info;
-EXTINFO_RTS stg_sel_9_noupd_info;
-EXTINFO_RTS stg_sel_10_noupd_info;
-EXTINFO_RTS stg_sel_11_noupd_info;
-EXTINFO_RTS stg_sel_12_noupd_info;
-EXTINFO_RTS stg_sel_13_noupd_info;
-EXTINFO_RTS stg_sel_14_noupd_info;
-EXTINFO_RTS stg_sel_15_noupd_info;
-
- /* and their standard entry points -- KSW 1998-12 */
-
-EXTFUN_RTS(stg_sel_0_upd_entry);
-EXTFUN_RTS(stg_sel_1_upd_entry);
-EXTFUN_RTS(stg_sel_2_upd_entry);
-EXTFUN_RTS(stg_sel_3_upd_entry);
-EXTFUN_RTS(stg_sel_4_upd_entry);
-EXTFUN_RTS(stg_sel_5_upd_entry);
-EXTFUN_RTS(stg_sel_6_upd_entry);
-EXTFUN_RTS(stg_sel_7_upd_entry);
-EXTFUN_RTS(stg_sel_8_upd_entry);
-EXTFUN_RTS(stg_sel_8_upd_entry);
-EXTFUN_RTS(stg_sel_9_upd_entry);
-EXTFUN_RTS(stg_sel_10_upd_entry);
-EXTFUN_RTS(stg_sel_11_upd_entry);
-EXTFUN_RTS(stg_sel_12_upd_entry);
-EXTFUN_RTS(stg_sel_13_upd_entry);
-EXTFUN_RTS(stg_sel_14_upd_entry);
-EXTFUN_RTS(stg_sel_15_upd_entry);
-
-EXTFUN_RTS(stg_sel_0_noupd_entry);
-EXTFUN_RTS(stg_sel_1_noupd_entry);
-EXTFUN_RTS(stg_sel_2_noupd_entry);
-EXTFUN_RTS(stg_sel_3_noupd_entry);
-EXTFUN_RTS(stg_sel_4_noupd_entry);
-EXTFUN_RTS(stg_sel_5_noupd_entry);
-EXTFUN_RTS(stg_sel_6_noupd_entry);
-EXTFUN_RTS(stg_sel_7_noupd_entry);
-EXTFUN_RTS(stg_sel_8_noupd_entry);
-EXTFUN_RTS(stg_sel_9_noupd_entry);
-EXTFUN_RTS(stg_sel_10_noupd_entry);
-EXTFUN_RTS(stg_sel_11_noupd_entry);
-EXTFUN_RTS(stg_sel_12_noupd_entry);
-EXTFUN_RTS(stg_sel_13_noupd_entry);
-EXTFUN_RTS(stg_sel_14_noupd_entry);
-EXTFUN_RTS(stg_sel_15_noupd_entry);
-
-// standard ap thunks
-
-ETI_RTS stg_ap_1_upd_info;
-ETI_RTS stg_ap_2_upd_info;
-ETI_RTS stg_ap_3_upd_info;
-ETI_RTS stg_ap_4_upd_info;
-ETI_RTS stg_ap_5_upd_info;
-ETI_RTS stg_ap_6_upd_info;
-ETI_RTS stg_ap_7_upd_info;
-ETI_RTS stg_ap_8_upd_info;
-
-// standard application routines (see also rts/gen_apply.py,
-// and compiler/codeGen/CgStackery.lhs).
-
-extern DLL_IMPORT_RTS const StgPolyInfoTable stg_ap_0_info;
-ERI_(stg_ap_v_info);
-ERI_(stg_ap_f_info);
-ERI_(stg_ap_d_info);
-ERI_(stg_ap_l_info);
-ERI_(stg_ap_n_info);
-ERI_(stg_ap_p_info);
-ERI_(stg_ap_pv_info);
-ERI_(stg_ap_pp_info);
-ERI_(stg_ap_ppv_info);
-ERI_(stg_ap_ppp_info);
-ERI_(stg_ap_pppp_info);
-ERI_(stg_ap_ppppp_info);
-ERI_(stg_ap_pppppp_info);
-ERI_(stg_ap_ppppppp_info);
-
-EXTFUN(stg_ap_0_ret);
-EXTFUN(stg_ap_v_ret);
-EXTFUN(stg_ap_f_ret);
-EXTFUN(stg_ap_d_ret);
-EXTFUN(stg_ap_l_ret);
-EXTFUN(stg_ap_n_ret);
-EXTFUN(stg_ap_p_ret);
-EXTFUN(stg_ap_pv_ret);
-EXTFUN(stg_ap_pp_ret);
-EXTFUN(stg_ap_ppv_ret);
-EXTFUN(stg_ap_ppp_ret);
-EXTFUN(stg_ap_pppp_ret);
-EXTFUN(stg_ap_ppppp_ret);
-EXTFUN(stg_ap_pppppp_ret);
-EXTFUN(stg_ap_ppppppp_ret);
+RTS_ENTRY(stg_sel_ret_0_upd_ret);
+RTS_ENTRY(stg_sel_ret_1_upd_ret);
+RTS_ENTRY(stg_sel_ret_2_upd_ret);
+RTS_ENTRY(stg_sel_ret_3_upd_ret);
+RTS_ENTRY(stg_sel_ret_4_upd_ret);
+RTS_ENTRY(stg_sel_ret_5_upd_ret);
+RTS_ENTRY(stg_sel_ret_6_upd_ret);
+RTS_ENTRY(stg_sel_ret_7_upd_ret);
+RTS_ENTRY(stg_sel_ret_8_upd_ret);
+RTS_ENTRY(stg_sel_ret_8_upd_ret);
+RTS_ENTRY(stg_sel_ret_9_upd_ret);
+RTS_ENTRY(stg_sel_ret_10_upd_ret);
+RTS_ENTRY(stg_sel_ret_11_upd_ret);
+RTS_ENTRY(stg_sel_ret_12_upd_ret);
+RTS_ENTRY(stg_sel_ret_13_upd_ret);
+RTS_ENTRY(stg_sel_ret_14_upd_ret);
+RTS_ENTRY(stg_sel_ret_15_upd_ret);
+
+RTS_INFO(stg_sel_0_upd_info);
+RTS_INFO(stg_sel_1_upd_info);
+RTS_INFO(stg_sel_2_upd_info);
+RTS_INFO(stg_sel_3_upd_info);
+RTS_INFO(stg_sel_4_upd_info);
+RTS_INFO(stg_sel_5_upd_info);
+RTS_INFO(stg_sel_6_upd_info);
+RTS_INFO(stg_sel_7_upd_info);
+RTS_INFO(stg_sel_8_upd_info);
+RTS_INFO(stg_sel_8_upd_info);
+RTS_INFO(stg_sel_9_upd_info);
+RTS_INFO(stg_sel_10_upd_info);
+RTS_INFO(stg_sel_11_upd_info);
+RTS_INFO(stg_sel_12_upd_info);
+RTS_INFO(stg_sel_13_upd_info);
+RTS_INFO(stg_sel_14_upd_info);
+RTS_INFO(stg_sel_15_upd_info);
+
+RTS_ENTRY(stg_sel_0_upd_entry);
+RTS_ENTRY(stg_sel_1_upd_entry);
+RTS_ENTRY(stg_sel_2_upd_entry);
+RTS_ENTRY(stg_sel_3_upd_entry);
+RTS_ENTRY(stg_sel_4_upd_entry);
+RTS_ENTRY(stg_sel_5_upd_entry);
+RTS_ENTRY(stg_sel_6_upd_entry);
+RTS_ENTRY(stg_sel_7_upd_entry);
+RTS_ENTRY(stg_sel_8_upd_entry);
+RTS_ENTRY(stg_sel_8_upd_entry);
+RTS_ENTRY(stg_sel_9_upd_entry);
+RTS_ENTRY(stg_sel_10_upd_entry);
+RTS_ENTRY(stg_sel_11_upd_entry);
+RTS_ENTRY(stg_sel_12_upd_entry);
+RTS_ENTRY(stg_sel_13_upd_entry);
+RTS_ENTRY(stg_sel_14_upd_entry);
+RTS_ENTRY(stg_sel_15_upd_entry);
+
+RTS_ENTRY(stg_sel_ret_0_noupd_ret);
+RTS_ENTRY(stg_sel_ret_1_noupd_ret);
+RTS_ENTRY(stg_sel_ret_2_noupd_ret);
+RTS_ENTRY(stg_sel_ret_3_noupd_ret);
+RTS_ENTRY(stg_sel_ret_4_noupd_ret);
+RTS_ENTRY(stg_sel_ret_5_noupd_ret);
+RTS_ENTRY(stg_sel_ret_6_noupd_ret);
+RTS_ENTRY(stg_sel_ret_7_noupd_ret);
+RTS_ENTRY(stg_sel_ret_8_noupd_ret);
+RTS_ENTRY(stg_sel_ret_8_noupd_ret);
+RTS_ENTRY(stg_sel_ret_9_noupd_ret);
+RTS_ENTRY(stg_sel_ret_10_noupd_ret);
+RTS_ENTRY(stg_sel_ret_11_noupd_ret);
+RTS_ENTRY(stg_sel_ret_12_noupd_ret);
+RTS_ENTRY(stg_sel_ret_13_noupd_ret);
+RTS_ENTRY(stg_sel_ret_14_noupd_ret);
+RTS_ENTRY(stg_sel_ret_15_noupd_ret);
+
+RTS_INFO(stg_sel_0_noupd_info);
+RTS_INFO(stg_sel_1_noupd_info);
+RTS_INFO(stg_sel_2_noupd_info);
+RTS_INFO(stg_sel_3_noupd_info);
+RTS_INFO(stg_sel_4_noupd_info);
+RTS_INFO(stg_sel_5_noupd_info);
+RTS_INFO(stg_sel_6_noupd_info);
+RTS_INFO(stg_sel_7_noupd_info);
+RTS_INFO(stg_sel_8_noupd_info);
+RTS_INFO(stg_sel_9_noupd_info);
+RTS_INFO(stg_sel_10_noupd_info);
+RTS_INFO(stg_sel_11_noupd_info);
+RTS_INFO(stg_sel_12_noupd_info);
+RTS_INFO(stg_sel_13_noupd_info);
+RTS_INFO(stg_sel_14_noupd_info);
+RTS_INFO(stg_sel_15_noupd_info);
+
+RTS_ENTRY(stg_sel_0_noupd_entry);
+RTS_ENTRY(stg_sel_1_noupd_entry);
+RTS_ENTRY(stg_sel_2_noupd_entry);
+RTS_ENTRY(stg_sel_3_noupd_entry);
+RTS_ENTRY(stg_sel_4_noupd_entry);
+RTS_ENTRY(stg_sel_5_noupd_entry);
+RTS_ENTRY(stg_sel_6_noupd_entry);
+RTS_ENTRY(stg_sel_7_noupd_entry);
+RTS_ENTRY(stg_sel_8_noupd_entry);
+RTS_ENTRY(stg_sel_9_noupd_entry);
+RTS_ENTRY(stg_sel_10_noupd_entry);
+RTS_ENTRY(stg_sel_11_noupd_entry);
+RTS_ENTRY(stg_sel_12_noupd_entry);
+RTS_ENTRY(stg_sel_13_noupd_entry);
+RTS_ENTRY(stg_sel_14_noupd_entry);
+RTS_ENTRY(stg_sel_15_noupd_entry);
+
+/* standard ap thunks */
+
+RTS_THUNK_INFO(stg_ap_1_upd_info);
+RTS_THUNK_INFO(stg_ap_2_upd_info);
+RTS_THUNK_INFO(stg_ap_3_upd_info);
+RTS_THUNK_INFO(stg_ap_4_upd_info);
+RTS_THUNK_INFO(stg_ap_5_upd_info);
+RTS_THUNK_INFO(stg_ap_6_upd_info);
+RTS_THUNK_INFO(stg_ap_7_upd_info);
+
+RTS_ENTRY(stg_ap_1_upd_entry);
+RTS_ENTRY(stg_ap_2_upd_entry);
+RTS_ENTRY(stg_ap_3_upd_entry);
+RTS_ENTRY(stg_ap_4_upd_entry);
+RTS_ENTRY(stg_ap_5_upd_entry);
+RTS_ENTRY(stg_ap_6_upd_entry);
+RTS_ENTRY(stg_ap_7_upd_entry);
+
+/* standard application routines (see also rts/gen_apply.py,
+ * and compiler/codeGen/CgStackery.lhs).
+ */
+RTS_RET_INFO(stg_ap_0_info);
+RTS_RET_INFO(stg_ap_v_info);
+RTS_RET_INFO(stg_ap_f_info);
+RTS_RET_INFO(stg_ap_d_info);
+RTS_RET_INFO(stg_ap_l_info);
+RTS_RET_INFO(stg_ap_n_info);
+RTS_RET_INFO(stg_ap_p_info);
+RTS_RET_INFO(stg_ap_pv_info);
+RTS_RET_INFO(stg_ap_pp_info);
+RTS_RET_INFO(stg_ap_ppv_info);
+RTS_RET_INFO(stg_ap_ppp_info);
+RTS_RET_INFO(stg_ap_pppv_info);
+RTS_RET_INFO(stg_ap_pppp_info);
+RTS_RET_INFO(stg_ap_ppppp_info);
+RTS_RET_INFO(stg_ap_pppppp_info);
+
+RTS_ENTRY(stg_ap_0_ret);
+RTS_ENTRY(stg_ap_v_ret);
+RTS_ENTRY(stg_ap_f_ret);
+RTS_ENTRY(stg_ap_d_ret);
+RTS_ENTRY(stg_ap_l_ret);
+RTS_ENTRY(stg_ap_n_ret);
+RTS_ENTRY(stg_ap_p_ret);
+RTS_ENTRY(stg_ap_pv_ret);
+RTS_ENTRY(stg_ap_pp_ret);
+RTS_ENTRY(stg_ap_ppv_ret);
+RTS_ENTRY(stg_ap_ppp_ret);
+RTS_ENTRY(stg_ap_pppv_ret);
+RTS_ENTRY(stg_ap_pppp_ret);
+RTS_ENTRY(stg_ap_ppppp_ret);
+RTS_ENTRY(stg_ap_pppppp_ret);
/* standard GC & stack check entry points, all defined in HeapStackCheck.hc */
-ERI_(stg_enter_info);
-EF_(stg_enter_ret);
+RTS_RET_INFO(stg_enter_info);
+RTS_ENTRY(stg_enter_ret);
+
+RTS_RET_INFO(stg_gc_void_info);
+RTS_ENTRY(stg_gc_void_ret);
+
+RTS_FUN(__stg_gc_enter_1);
+
+RTS_FUN(stg_gc_noregs);
-ERI_(stg_gc_void_info);
+RTS_RET_INFO(stg_gc_unpt_r1_info);
+RTS_ENTRY(stg_gc_unpt_r1_ret);
+RTS_FUN(stg_gc_unpt_r1);
-EF_(__stg_gc_enter_1);
+RTS_RET_INFO(stg_gc_unbx_r1_info);
+RTS_ENTRY(stg_gc_unbx_r1_ret);
+RTS_FUN(stg_gc_unbx_r1);
-EF_(stg_gc_noregs);
+RTS_RET_INFO(stg_gc_f1_info);
+RTS_ENTRY(stg_gc_f1_ret);
+RTS_FUN(stg_gc_f1);
-ERI_(stg_gc_unpt_r1_info);
-EF_(stg_gc_unpt_r1);
+RTS_RET_INFO(stg_gc_d1_info);
+RTS_ENTRY(stg_gc_d1_ret);
+RTS_FUN(stg_gc_d1);
-ERI_(stg_gc_unbx_r1_info);
-EF_(stg_gc_unbx_r1);
+RTS_RET_INFO(stg_gc_l1_info);
+RTS_ENTRY(stg_gc_l1_ret);
+RTS_FUN(stg_gc_l1);
-ERI_(stg_gc_f1_info);
-EF_(stg_gc_f1);
+RTS_FUN(__stg_gc_fun);
+RTS_RET_INFO(stg_gc_fun_info);
+RTS_ENTRY(stg_gc_fun_ret);
-ERI_(stg_gc_d1_info);
-EF_(stg_gc_d1);
+RTS_RET_INFO(stg_gc_gen_info);
+RTS_ENTRY(stg_gc_gen_ret);
+RTS_FUN(stg_gc_gen);
-ERI_(stg_gc_l1_info);
-EF_(stg_gc_l1);
+RTS_ENTRY(stg_ut_1_0_unreg_ret);
+RTS_RET_INFO(stg_ut_1_0_unreg_info);
-EF_(__stg_gc_fun);
-ERI_(stg_gc_fun_info);
-EF_(stg_gc_fun_ret);
+RTS_FUN(stg_gc_gen_hp);
+RTS_FUN(stg_gc_ut);
+RTS_FUN(stg_gen_yield);
+RTS_FUN(stg_yield_noregs);
+RTS_FUN(stg_yield_to_interpreter);
+RTS_FUN(stg_gen_block);
+RTS_FUN(stg_block_noregs);
+RTS_FUN(stg_block_1);
+RTS_FUN(stg_block_takemvar);
+RTS_ENTRY(stg_block_takemvar_ret);
+RTS_FUN(stg_block_putmvar);
+RTS_ENTRY(stg_block_putmvar_ret);
+#ifdef mingw32_TARGET_OS
+RTS_FUN(stg_block_async);
+#endif
+
+/* Entry/exit points from StgStartup.cmm */
+
+RTS_RET_INFO(stg_stop_thread_info);
+RTS_ENTRY(stg_stop_thread_ret);
+
+RTS_FUN(stg_returnToStackTop);
+RTS_FUN(stg_enterStackTop);
+
+RTS_FUN(stg_init_finish);
+RTS_FUN(stg_init);
+
+/* -----------------------------------------------------------------------------
+ PrimOps
+ -------------------------------------------------------------------------- */
+
+RTS_FUN(plusIntegerzh_fast);
+RTS_FUN(minusIntegerzh_fast);
+RTS_FUN(timesIntegerzh_fast);
+RTS_FUN(gcdIntegerzh_fast);
+RTS_FUN(quotRemIntegerzh_fast);
+RTS_FUN(quotIntegerzh_fast);
+RTS_FUN(remIntegerzh_fast);
+RTS_FUN(divExactIntegerzh_fast);
+RTS_FUN(divModIntegerzh_fast);
+
+RTS_FUN(cmpIntegerIntzh_fast);
+RTS_FUN(cmpIntegerzh_fast);
+RTS_FUN(integer2Intzh_fast);
+RTS_FUN(integer2Wordzh_fast);
+RTS_FUN(gcdIntegerIntzh_fast);
+RTS_FUN(gcdIntzh_fast);
+
+RTS_FUN(int2Integerzh_fast);
+RTS_FUN(word2Integerzh_fast);
+
+RTS_FUN(decodeFloatzh_fast);
+RTS_FUN(decodeDoublezh_fast);
+
+RTS_FUN(andIntegerzh_fast);
+RTS_FUN(orIntegerzh_fast);
+RTS_FUN(xorIntegerzh_fast);
+RTS_FUN(complementIntegerzh_fast);
+
+#ifdef SUPPORT_LONG_LONGS
+
+RTS_FUN(int64ToIntegerzh_fast);
+RTS_FUN(word64ToIntegerzh_fast);
+
+#endif
-EF_(stg_gc_gen);
-ERI_(stg_gc_gen_info);
+RTS_FUN(unsafeThawArrayzh_fast);
+RTS_FUN(newByteArrayzh_fast);
+RTS_FUN(newPinnedByteArrayzh_fast);
+RTS_FUN(newArrayzh_fast);
-EF_(stg_ut_1_0_unreg_ret);
-ERI_(stg_ut_1_0_unreg_info);
+RTS_FUN(decodeFloatzh_fast);
+RTS_FUN(decodeDoublezh_fast);
-EF_(stg_gc_gen_hp);
-EF_(stg_gc_ut);
-EF_(stg_gen_yield);
-EF_(stg_yield_noregs);
-EF_(stg_yield_to_interpreter);
-EF_(stg_gen_block);
-EF_(stg_block_noregs);
-EF_(stg_block_1);
-EF_(stg_block_takemvar);
-EF_(stg_block_putmvar);
+RTS_FUN(newMutVarzh_fast);
+RTS_FUN(atomicModifyMutVarzh_fast);
+
+RTS_FUN(isEmptyMVarzh_fast);
+RTS_FUN(newMVarzh_fast);
+RTS_FUN(takeMVarzh_fast);
+RTS_FUN(putMVarzh_fast);
+RTS_FUN(tryTakeMVarzh_fast);
+RTS_FUN(tryPutMVarzh_fast);
+
+RTS_FUN(waitReadzh_fast);
+RTS_FUN(waitWritezh_fast);
+RTS_FUN(delayzh_fast);
#ifdef mingw32_TARGET_OS
-EF_(stg_block_async);
+RTS_FUN(asyncReadzh_fast);
+RTS_FUN(asyncWritezh_fast);
+RTS_FUN(asyncDoProczh_fast);
#endif
+
+RTS_FUN(catchzh_fast);
+RTS_FUN(raisezh_fast);
+RTS_FUN(raiseIOzh_fast);
+
+RTS_FUN(makeStableNamezh_fast);
+RTS_FUN(makeStablePtrzh_fast);
+RTS_FUN(deRefStablePtrzh_fast);
+
+RTS_FUN(forkzh_fast);
+RTS_FUN(yieldzh_fast);
+RTS_FUN(killThreadzh_fast);
+RTS_FUN(blockAsyncExceptionszh_fast);
+RTS_FUN(unblockAsyncExceptionszh_fast);
+RTS_FUN(myThreadIdzh_fast);
+RTS_FUN(labelThreadzh_fast);
+RTS_FUN(isCurrentThreadBoundzh_fast);
+
+RTS_FUN(mkWeakzh_fast);
+RTS_FUN(finalizzeWeakzh_fast);
+RTS_FUN(deRefWeakzh_fast);
+
+RTS_FUN(mkForeignObjzh_fast);
+
+RTS_FUN(newBCOzh_fast);
+RTS_FUN(mkApUpd0zh_fast);
+
+#endif /* STGMISCCLOSURES_H */
/* -----------------------------------------------------------------------------
- * $Id: StgProf.h,v 1.17 2003/11/12 17:27:04 sof Exp $
+ * $Id: StgProf.h,v 1.18 2004/08/13 13:09:37 simonmar Exp $
*
* (c) The GHC Team, 1998
*
* Data Structures
* ---------------------------------------------------------------------------*/
typedef struct _CostCentre {
- int ccID;
+ StgInt ccID;
- char *label;
- char *module;
+ char * label;
+ char * module;
/* used for accumulating costs at the end of the run... */
- unsigned long time_ticks;
- ullong mem_alloc;
+ StgWord time_ticks;
+ StgWord64 mem_alloc;
- char is_caf;
+ StgInt is_caf;
struct _CostCentre *link;
} CostCentre;
typedef struct _CostCentreStack {
- int ccsID;
+ StgInt ccsID;
CostCentre *cc;
struct _CostCentreStack *prevStack;
struct _IndexTable *indexTable;
- unsigned int selected;
-
- ullong scc_count;
-
- unsigned long time_ticks;
-
- ullong mem_alloc;
-
- unsigned long inherited_ticks;
- ullong inherited_alloc;
+ StgWord selected;
+ StgWord64 scc_count;
+ StgWord time_ticks;
+ StgWord64 mem_alloc;
+ StgWord inherited_ticks;
+ StgWord64 inherited_alloc;
CostCentre *root;
} CostCentreStack;
Pre-defined cost centres and cost centre stacks
-------------------------------------------------------------------------- */
-extern CostCentreStack *CCCS; /* current CCS */
+extern CostCentreStack * RTS_VAR(CCCS); /* current CCS */
+#if IN_STG_CODE
+
+extern StgWord CC_MAIN[];
+extern StgWord CCS_MAIN[]; /* Top CCS */
+
+extern StgWord CC_SYSTEM[];
+extern StgWord CCS_SYSTEM[]; /* RTS costs */
+
+extern StgWord CC_GC[];
+extern StgWord CCS_GC[]; /* Garbage collector costs */
+
+extern StgWord CC_SUBSUMED[];
+extern StgWord CCS_SUBSUMED[]; /* Costs are subsumed by caller */
+
+extern StgWord CC_OVERHEAD[];
+extern StgWord CCS_OVERHEAD[]; /* Profiling overhead */
+
+extern StgWord CC_DONT_CARE[];
+extern StgWord CCS_DONT_CARE[]; /* shouldn't ever get set */
+
+#else
+
extern CostCentre CC_MAIN[];
extern CostCentreStack CCS_MAIN[]; /* Top CCS */
extern CostCentre CC_DONT_CARE[];
extern CostCentreStack CCS_DONT_CARE[]; /* shouldn't ever get set */
-extern unsigned int CC_ID; /* global ids */
-extern unsigned int CCS_ID;
-extern unsigned int HP_ID;
+#endif // IN_STG_CODE
+
+extern unsigned int RTS_VAR(CC_ID); /* global ids */
+extern unsigned int RTS_VAR(CCS_ID);
+extern unsigned int RTS_VAR(HP_ID);
+
+extern unsigned int RTS_VAR(era);
/* -----------------------------------------------------------------------------
* Functions
* ---------------------------------------------------------------------------*/
-CostCentreStack *EnterFunCCS ( CostCentreStack *cccs, CostCentreStack *ccsfn );
+void EnterFunCCS ( CostCentreStack *ccsfn );
CostCentreStack *PushCostCentre ( CostCentreStack *, CostCentre * );
CostCentreStack *AppendCCS ( CostCentreStack *ccs1, CostCentreStack *ccs2 );
-extern unsigned int entering_PAP;
+extern unsigned int RTS_VAR(entering_PAP);
/* -----------------------------------------------------------------------------
* Registering CCs
-------------------------------------------------------------------------- */
-extern CostCentre *CC_LIST; /* registered CC list */
-extern CostCentreStack *CCS_LIST; /* registered CCS list */
+extern CostCentre * RTS_VAR(CC_LIST); /* registered CC list */
+extern CostCentreStack * RTS_VAR(CCS_LIST); /* registered CCS list */
#define REGISTER_CC(cc) \
do { \
/* Restore the CCCS from a stack frame.
* (addr should always be Sp->header.prof.ccs)
*/
-#define RESTORE_CCCS(addr) (CCCS = (CostCentreStack *)(addr))
+#define RESTORE_CCCS(addr) (*CCCS = (CostCentreStack *)(addr))
/* -----------------------------------------------------------------------------
* Pushing a new cost centre (i.e. for scc annotations)
#define ENTER_CCS_T(ccs) \
do { \
- CCCS = (CostCentreStack *)(ccs); \
+ *CCCS = (CostCentreStack *)(ccs); \
CCCS_DETAIL_COUNT(CCCS->thunk_count); \
} while(0)
* (b) The CCS is CAF-ish.
* -------------------------------------------------------------------------- */
-#define ENTER_CCS_F(stack) \
- do { \
- CostCentreStack *ccs = (CostCentreStack *) (stack); \
- CCCS_DETAIL_COUNT(CCCS->function_count); \
- CCCS = EnterFunCCS(CCCS,ccs); \
- } while(0)
+#define ENTER_CCS_F(stack) EnterFunCCS(stack)
#define ENTER_CCS_FCL(closure) ENTER_CCS_F(CCS_HDR(closure))
#define ENTER_CCS_PAP(stack) \
do { \
ENTER_CCS_F(stack); \
- entering_PAP = rtsTrue; \
+ *entering_PAP = rtsTrue; \
} while(0)
#define ENTER_CCS_PAP_CL(closure) \
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StgStorage.h,v 1.12 2003/03/26 17:40:58 sof Exp $
- *
- * (c) The GHC Team, 1998-1999
- *
- * STG Storage Manager Interface
- *
- * ---------------------------------------------------------------------------*/
-
-#ifndef STGSTORAGE_H
-#define STGSTORAGE_H
-
-/* GENERATION GC NOTES
- *
- * We support an arbitrary number of generations, with an arbitrary number
- * of steps per generation. Notes (in no particular order):
- *
- * - all generations except the oldest should have two steps. This gives
- * objects a decent chance to age before being promoted, and in
- * particular will ensure that we don't end up with too many
- * thunks being updated in older generations.
- *
- * - the oldest generation has one step. There's no point in aging
- * objects in the oldest generation.
- *
- * - generation 0, step 0 (G0S0) is the allocation area. It is given
- * a fixed set of blocks during initialisation, and these blocks
- * are never freed.
- *
- * - during garbage collection, each step which is an evacuation
- * destination (i.e. all steps except G0S0) is allocated a to-space.
- * evacuated objects are allocated into the step's to-space until
- * GC is finished, when the original step's contents may be freed
- * and replaced by the to-space.
- *
- * - the mutable-list is per-generation (not per-step). G0 doesn't
- * have one (since every garbage collection collects at least G0).
- *
- * - block descriptors contain pointers to both the step and the
- * generation that the block belongs to, for convenience.
- *
- * - static objects are stored in per-generation lists. See GC.c for
- * details of how we collect CAFs in the generational scheme.
- *
- * - large objects are per-step, and are promoted in the same way
- * as small objects, except that we may allocate large objects into
- * generation 1 initially.
- */
-
-typedef struct _step {
- unsigned int no; /* step number */
- bdescr * blocks; /* blocks in this step */
- unsigned int n_blocks; /* number of blocks */
- struct _step * to; /* destination step for live objects */
- struct _generation * gen; /* generation this step belongs to */
- unsigned int gen_no; /* generation number (cached) */
- bdescr * large_objects; /* large objects (doubly linked) */
- unsigned int n_large_blocks; /* no. of blocks used by large objs */
- int is_compacted; /* compact this step? (old gen only) */
-
- /* temporary use during GC: */
- StgPtr hp; /* next free locn in to-space */
- StgPtr hpLim; /* end of current to-space block */
- bdescr * hp_bd; /* bdescr of current to-space block */
- bdescr * to_blocks; /* bdescr of first to-space block */
- unsigned int n_to_blocks; /* number of blocks in to-space */
- bdescr * scan_bd; /* block currently being scanned */
- StgPtr scan; /* scan pointer in current block */
- bdescr * new_large_objects; /* large objects collected so far */
- bdescr * scavenged_large_objects; /* live large objs after GC (d-link) */
- unsigned int n_scavenged_large_blocks;/* size of above */
- bdescr * bitmap; /* bitmap for compacting collection */
-} step;
-
-typedef struct _generation {
- unsigned int no; /* generation number */
- step * steps; /* steps */
- unsigned int n_steps; /* number of steps */
- unsigned int max_blocks; /* max blocks in step 0 */
- StgMutClosure *mut_list; /* mut objects in this gen (not G0)*/
- StgMutClosure *mut_once_list; /* objects that point to younger gens */
-
- /* temporary use during GC: */
- StgMutClosure * saved_mut_list;
-
- /* stats information */
- unsigned int collections;
- unsigned int failed_promotions;
-} generation;
-
-/* -----------------------------------------------------------------------------
- Allocation area for compiled code
-
- OpenNursery(hp,hplim) Opens the allocation area, and sets hp
- and hplim appropriately.
-
- CloseNursery(hp) Closes the allocation area.
-
- -------------------------------------------------------------------------- */
-
-#define OpenNursery(hp,hplim) \
- (hp = CurrentNursery->free-1, \
- hplim = CurrentNursery->start + CurrentNursery->blocks*BLOCK_SIZE_W - 1)
-
-#define CloseNursery(hp) (CurrentNursery->free = (P_)(hp)+1)
-
-/* -----------------------------------------------------------------------------
- Prototype for an evacuate-like function
- -------------------------------------------------------------------------- */
-
-typedef void (*evac_fn)(StgClosure **);
-
-/* -----------------------------------------------------------------------------
- Trigger a GC from Haskell land.
- -------------------------------------------------------------------------- */
-
-extern void performGC(void);
-extern void performMajorGC(void);
-extern void performGCWithRoots(void (*get_roots)(evac_fn));
-
-#endif /* STGSTORAGE_H */
/* ----------------------------------------------------------------------------
- * $Id: StgTicky.h,v 1.15 2003/07/28 15:59:09 simonmar Exp $
+ * $Id: StgTicky.h,v 1.16 2004/08/13 13:09:38 simonmar Exp $
*
* (c) The AQUA project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
#ifndef TICKY_H
#define TICKY_H
+/* -----------------------------------------------------------------------------
+ The StgEntCounter type - needed regardless of TICKY_TICKY
+ -------------------------------------------------------------------------- */
+
+typedef struct _StgEntCounter {
+ StgWord16 registeredp; /* 0 == no, 1 == yes */
+ StgWord16 arity; /* arity (static info) */
+ StgWord16 stk_args; /* # of args off stack */
+ /* (rest of args are in registers) */
+ char *str; /* name of the thing */
+ char *arg_kinds; /* info about the args types */
+ StgInt entry_count; /* Trips to fast entry code */
+ StgInt allocs; /* number of allocations by this fun */
+ struct _StgEntCounter *link;/* link to chain them all together */
+} StgEntCounter;
+
+
#ifdef TICKY_TICKY
/* -----------------------------------------------------------------------------
ALLOC_BH_gds += (g); ALLOC_BH_slp += (s); \
TICK_ALLOC_HISTO(BH,_HS,g,s)
+// admin size doesn't take into account the FUN, that is accounted for
+// in the "goods".
#define TICK_ALLOC_PAP(g,s) \
ALLOC_PAP_ctr++; ALLOC_PAP_adm += sizeofW(StgPAP)-1; \
ALLOC_PAP_gds += (g); ALLOC_PAP_slp += (s); \
#define TICK_ENT_STATIC_THK() ENT_STATIC_THK_ctr++
#define TICK_ENT_DYN_THK() ENT_DYN_THK_ctr++
-typedef struct _StgEntCounter {
- unsigned registeredp:16, /* 0 == no, 1 == yes */
- arity:16, /* arity (static info) */
- stk_args:16; /* # of args off stack */
- /* (rest of args are in registers) */
- char *str; /* name of the thing */
- char *arg_kinds; /* info about the args types */
- I_ entry_count; /* Trips to fast entry code */
- I_ allocs; /* number of allocations by this fun */
- struct _StgEntCounter *link;/* link to chain them all together */
-} StgEntCounter;
-
#define TICK_CTR(f_ct, str, arity, args, arg_kinds) \
static StgEntCounter f_ct \
= { 0, arity, args, \
SLOW_CALL_hst[((__idx > 8) ? 8 : __idx)] += 1; \
}
-// A slow call with n arguments
-#define TICK_SLOW_CALL(n) SLOW_CALL_ctr++; \
- TICK_SLOW_HISTO(n)
-
-// A slow call to a FUN found insufficient arguments, and built a PAP
-#define TICK_SLOW_CALL_BUILT_PAP() SLOW_CALL_BUILT_PAP_ctr++
+#define UNDO_TICK_SLOW_HISTO(n) \
+ { unsigned __idx; \
+ __idx = (n); \
+ SLOW_CALL_hst[((__idx > 8) ? 8 : __idx)] -= 1; \
+ }
-// A slow call to a PAP found insufficient arguments, and build a new PAP
-#define TICK_SLOW_CALL_NEW_PAP() SLOW_CALL_NEW_PAP_ctr++
+// A slow call with n arguments. In the unevald case, this call has
+// already been counted once, so don't count it again.
+#define TICK_SLOW_CALL(n) \
+ SLOW_CALL_ctr++; \
+ TICK_SLOW_HISTO(n)
+
+// This slow call was found to be to an unevaluated function; undo the
+// ticks we did in TICK_SLOW_CALL.
+#define TICK_SLOW_CALL_UNEVALD(n) \
+ SLOW_CALL_UNEVALD_ctr++; \
+ SLOW_CALL_ctr--; \
+ UNDO_TICK_SLOW_HISTO(n)
+
+#define TICK_MULTI_CHUNK_SLOW_CALL(pattern, chunks) \
+ fprintf(stderr, "Multi-chunk slow call: %s\n", pattern); \
+ MULTI_CHUNK_SLOW_CALL_ctr++; \
+ MULTI_CHUNK_SLOW_CALL_CHUNKS_ctr += chunks;
+
+// A completely unknown tail-call
+#define TICK_UNKNOWN_CALL() UNKNOWN_CALL_ctr++
+
+// slow call patterns (includes "extra" args to known calls,
+// so the total of these will be greater than UNKNOWN_CALL_ctr).
+#define TICK_SLOW_CALL_v() SLOW_CALL_v_ctr++
+#define TICK_SLOW_CALL_f() SLOW_CALL_f_ctr++
+#define TICK_SLOW_CALL_d() SLOW_CALL_d_ctr++
+#define TICK_SLOW_CALL_l() SLOW_CALL_l_ctr++
+#define TICK_SLOW_CALL_n() SLOW_CALL_n_ctr++
+#define TICK_SLOW_CALL_p() SLOW_CALL_p_ctr++
+#define TICK_SLOW_CALL_pv() SLOW_CALL_pv_ctr++
+#define TICK_SLOW_CALL_pp() SLOW_CALL_pp_ctr++
+#define TICK_SLOW_CALL_ppv() SLOW_CALL_ppv_ctr++
+#define TICK_SLOW_CALL_ppp() SLOW_CALL_ppp_ctr++
+#define TICK_SLOW_CALL_pppv() SLOW_CALL_pppv_ctr++
+#define TICK_SLOW_CALL_pppp() SLOW_CALL_pppp_ctr++
+#define TICK_SLOW_CALL_ppppp() SLOW_CALL_ppppp_ctr++
+#define TICK_SLOW_CALL_pppppp() SLOW_CALL_pppppp_ctr++
+#define TICK_SLOW_CALL_OTHER(pattern) \
+ fprintf(stderr,"slow call: %s\n", pattern); \
+ SLOW_CALL_OTHER_ctr++
+
+#define TICK_KNOWN_CALL() KNOWN_CALL_ctr++
+#define TICK_KNOWN_CALL_TOO_FEW_ARGS() KNOWN_CALL_TOO_FEW_ARGS_ctr++
+#define TICK_KNOWN_CALL_EXTRA_ARGS() KNOWN_CALL_EXTRA_ARGS_ctr++
+// A slow call to a FUN found insufficient arguments, and built a PAP
+#define TICK_SLOW_CALL_FUN_TOO_FEW() SLOW_CALL_FUN_TOO_FEW_ctr++
+#define TICK_SLOW_CALL_FUN_CORRECT() SLOW_CALL_FUN_CORRECT_ctr++
+#define TICK_SLOW_CALL_FUN_TOO_MANY() SLOW_CALL_FUN_TOO_MANY_ctr++
+#define TICK_SLOW_CALL_PAP_TOO_FEW() SLOW_CALL_PAP_TOO_FEW_ctr++
+#define TICK_SLOW_CALL_PAP_CORRECT() SLOW_CALL_PAP_CORRECT_ctr++
+#define TICK_SLOW_CALL_PAP_TOO_MANY() SLOW_CALL_PAP_TOO_MANY_ctr++
+
/* -----------------------------------------------------------------------------
Returns
-------------------------------------------------------------------------- */
EXTERN unsigned long ENT_AP_STACK_ctr INIT(0);
EXTERN unsigned long ENT_BH_ctr INIT(0);
+EXTERN unsigned long UNKNOWN_CALL_ctr INIT(0);
+
+EXTERN unsigned long SLOW_CALL_v_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_f_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_d_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_l_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_n_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_p_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_pv_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_pp_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_ppv_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_ppp_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_pppv_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_pppp_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_ppppp_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_pppppp_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_OTHER_ctr INIT(0);
+
+EXTERN unsigned long ticky_slow_call_unevald INIT(0);
EXTERN unsigned long SLOW_CALL_ctr INIT(0);
-EXTERN unsigned long SLOW_CALL_BUILT_PAP_ctr INIT(0);
-EXTERN unsigned long SLOW_CALL_NEW_PAP_ctr INIT(0);
+EXTERN unsigned long MULTI_CHUNK_SLOW_CALL_ctr INIT(0);
+EXTERN unsigned long MULTI_CHUNK_SLOW_CALL_CHUNKS_ctr INIT(0);
+EXTERN unsigned long KNOWN_CALL_ctr INIT(0);
+EXTERN unsigned long KNOWN_CALL_TOO_FEW_ARGS_ctr INIT(0);
+EXTERN unsigned long KNOWN_CALL_EXTRA_ARGS_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_FUN_TOO_FEW_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_FUN_CORRECT_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_FUN_TOO_MANY_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_PAP_TOO_FEW_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_PAP_CORRECT_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_PAP_TOO_MANY_ctr INIT(0);
+EXTERN unsigned long SLOW_CALL_UNEVALD_ctr INIT(0);
EXTERN unsigned long SLOW_CALL_hst[8]
#ifdef TICKY_C
#define TICK_ENT_BH()
#define TICK_SLOW_CALL(n)
-#define TICK_SLOW_CALL_BUILT_PAP()
-#define TICK_SLOW_CALL_NEW_PAP()
+#define TICK_SLOW_CALL_UNEVALD(n)
+#define TICK_SLOW_CALL_FUN_TOO_FEW()
+#define TICK_SLOW_CALL_FUN_CORRECT()
+#define TICK_SLOW_CALL_FUN_TOO_MANY()
+#define TICK_SLOW_CALL_PAP_TOO_FEW()
+#define TICK_SLOW_CALL_PAP_CORRECT()
+#define TICK_SLOW_CALL_PAP_TOO_MANY()
+
+#define TICK_SLOW_CALL_v()
+#define TICK_SLOW_CALL_f()
+#define TICK_SLOW_CALL_d()
+#define TICK_SLOW_CALL_l()
+#define TICK_SLOW_CALL_n()
+#define TICK_SLOW_CALL_p()
+#define TICK_SLOW_CALL_pv()
+#define TICK_SLOW_CALL_pp()
+#define TICK_SLOW_CALL_ppv()
+#define TICK_SLOW_CALL_ppp()
+#define TICK_SLOW_CALL_pppv()
+#define TICK_SLOW_CALL_pppp()
+#define TICK_SLOW_CALL_ppppp()
+#define TICK_SLOW_CALL_pppppp()
+#define TICK_SLOW_CALL_OTHER(pattern)
+
+#define TICK_KNOWN_CALL()
+#define TICK_KNOWN_CALL_TOO_FEW_ARGS()
+#define TICK_KNOWN_CALL_EXTRA_ARGS()
+#define TICK_UNKNOWN_CALL()
#define TICK_RET_NEW(n)
#define TICK_RET_OLD(n)
/* -----------------------------------------------------------------------------
- * $Id: StgTypes.h,v 1.20 2003/11/12 17:27:05 sof Exp $
*
- * (c) The GHC Team, 1998-2000
+ * (c) The GHC Team, 1998-2004
*
* Various C datatypes used in the run-time system. This is the
- * lowest-level include file, after config.h and Derived.h.
+ * lowest-level include file, after ghcconfig.h and RtsConfig.h.
*
* This module should define types *only*, all beginning with "Stg".
*
* WARNING: Keep this file, MachDeps.h, and HsFFI.h in synch!
*
- * NOTE: assumes #include "config.h"
+ * NOTE: assumes #include "ghcconfig.h"
*
* Works with or without _POSIX_SOURCE.
*
#ifndef STGTYPES_H
#define STGTYPES_H
-#include "Derived.h"
-
/*
* First, platform-dependent definitions of size-specific integers.
* Assume for now that the int type is 32 bits.
typedef void *(*(*StgFunPtr)(void))(void);
typedef StgFunPtr StgFun(void);
-typedef union {
- StgWord w;
- StgAddr a;
- StgChar c;
- StgInt8 i8;
- StgFloat f;
- StgInt i;
- StgPtr p;
- StgClosurePtr cl;
- StgStackOffset offset; /* unused? */
- StgByteArray b;
- StgTSOPtr t;
-} StgUnion;
-
#endif /* STGTYPES_H */
/* -----------------------------------------------------------------------------
- * $Id: Storage.h,v 1.53 2003/11/12 17:49:11 sof Exp $
*
- * (c) The GHC Team, 1998-2002
+ * (c) The GHC Team, 1998-2004
*
* External Storage Manger Interface
*
#ifndef STORAGE_H
#define STORAGE_H
-#include "Block.h"
-#include "MBlock.h"
-#include "BlockAlloc.h"
-#include "StoragePriv.h"
-#ifdef PROFILING
-#include "LdvProfile.h"
-#endif
+#include <stddef.h>
+
+/* -----------------------------------------------------------------------------
+ * Generational GC
+ *
+ * We support an arbitrary number of generations, with an arbitrary number
+ * of steps per generation. Notes (in no particular order):
+ *
+ * - all generations except the oldest should have two steps. This gives
+ * objects a decent chance to age before being promoted, and in
+ * particular will ensure that we don't end up with too many
+ * thunks being updated in older generations.
+ *
+ * - the oldest generation has one step. There's no point in aging
+ * objects in the oldest generation.
+ *
+ * - generation 0, step 0 (G0S0) is the allocation area. It is given
+ * a fixed set of blocks during initialisation, and these blocks
+ * are never freed.
+ *
+ * - during garbage collection, each step which is an evacuation
+ * destination (i.e. all steps except G0S0) is allocated a to-space.
+ * evacuated objects are allocated into the step's to-space until
+ * GC is finished, when the original step's contents may be freed
+ * and replaced by the to-space.
+ *
+ * - the mutable-list is per-generation (not per-step). G0 doesn't
+ * have one (since every garbage collection collects at least G0).
+ *
+ * - block descriptors contain pointers to both the step and the
+ * generation that the block belongs to, for convenience.
+ *
+ * - static objects are stored in per-generation lists. See GC.c for
+ * details of how we collect CAFs in the generational scheme.
+ *
+ * - large objects are per-step, and are promoted in the same way
+ * as small objects, except that we may allocate large objects into
+ * generation 1 initially.
+ *
+ * ------------------------------------------------------------------------- */
+
+typedef struct _step {
+ unsigned int no; /* step number */
+ bdescr * blocks; /* blocks in this step */
+ unsigned int n_blocks; /* number of blocks */
+ struct _step * to; /* destination step for live objects */
+ struct _generation * gen; /* generation this step belongs to */
+ unsigned int gen_no; /* generation number (cached) */
+ bdescr * large_objects; /* large objects (doubly linked) */
+ unsigned int n_large_blocks; /* no. of blocks used by large objs */
+ int is_compacted; /* compact this step? (old gen only) */
+
+ /* temporary use during GC: */
+ StgPtr hp; /* next free locn in to-space */
+ StgPtr hpLim; /* end of current to-space block */
+ bdescr * hp_bd; /* bdescr of current to-space block */
+ bdescr * to_blocks; /* bdescr of first to-space block */
+ unsigned int n_to_blocks; /* number of blocks in to-space */
+ bdescr * scan_bd; /* block currently being scanned */
+ StgPtr scan; /* scan pointer in current block */
+ bdescr * new_large_objects; /* large objects collected so far */
+ bdescr * scavenged_large_objects; /* live large objs after GC (d-link) */
+ unsigned int n_scavenged_large_blocks;/* size of above */
+ bdescr * bitmap; /* bitmap for compacting collection */
+} step;
+
+typedef struct _generation {
+ unsigned int no; /* generation number */
+ step * steps; /* steps */
+ unsigned int n_steps; /* number of steps */
+ unsigned int max_blocks; /* max blocks in step 0 */
+ StgMutClosure *mut_list; /* mut objects in this gen (not G0)*/
+ StgMutClosure *mut_once_list; /* objects that point to younger gens */
+
+ /* temporary use during GC: */
+ StgMutClosure * saved_mut_list;
+
+ /* stats information */
+ unsigned int collections;
+ unsigned int failed_promotions;
+} generation;
+
+extern generation * RTS_VAR(generations);
+
+extern generation * RTS_VAR(g0);
+extern step * RTS_VAR(g0s0);
+extern generation * RTS_VAR(oldest_gen);
/* -----------------------------------------------------------------------------
Initialisation / De-initialisation
extern StgPtr allocatePinned ( nat n );
extern lnat allocated_bytes ( void );
+extern bdescr * RTS_VAR(small_alloc_list);
+extern bdescr * RTS_VAR(large_alloc_list);
+extern bdescr * RTS_VAR(pinned_object_block);
+
+extern StgPtr RTS_VAR(alloc_Hp);
+extern StgPtr RTS_VAR(alloc_HpLim);
+
+extern nat RTS_VAR(alloc_blocks);
+extern nat RTS_VAR(alloc_blocks_lim);
+
INLINE_HEADER rtsBool
doYouWantToGC( void )
{
}
/* -----------------------------------------------------------------------------
- ExtendNursery(hp,hplim) When hplim is reached, try to grab
- some more allocation space. Returns
- False if the allocation space is
- exhausted, and the application should
- call GarbageCollect().
- -------------------------------------------------------------------------- */
-
-#define ExtendNursery(hp,hplim) \
- (CloseNursery(hp), \
- CurrentNursery->link == NULL ? rtsFalse : \
- (CurrentNursery = CurrentNursery->link, \
- OpenNursery(hp,hplim), \
- rtsTrue))
-
-/* -----------------------------------------------------------------------------
Performing Garbage Collection
GarbageCollect(get_roots) Performs a garbage collection.
bd = Bdescr((P_)p);
if (bd->gen_no > 0) {
- p->mut_link = generations[bd->gen_no].mut_list;
- generations[bd->gen_no].mut_list = p;
+ p->mut_link = RTS_DEREF(generations)[bd->gen_no].mut_list;
+ RTS_DEREF(generations)[bd->gen_no].mut_list = p;
}
}
bd = Bdescr((P_)p);
if (bd->gen_no > 0) {
- p->mut_link = generations[bd->gen_no].mut_once_list;
- generations[bd->gen_no].mut_once_list = p;
- }
-}
-
-// @LDV profiling
-// We zero out the slop when PROFILING is on.
-// #ifndef DEBUG
-#if !defined(DEBUG) && !defined(PROFILING)
-#define updateWithIndirection(info, ind_info, p1, p2, and_then) \
- { \
- bdescr *bd; \
- \
- bd = Bdescr((P_)p1); \
- if (bd->gen_no == 0) { \
- ((StgInd *)p1)->indirectee = p2; \
- SET_INFO(p1,ind_info); \
- TICK_UPD_NEW_IND(); \
- and_then; \
- } else { \
- ((StgIndOldGen *)p1)->indirectee = p2; \
- if (info != &stg_BLACKHOLE_BQ_info) { \
- ACQUIRE_SM_LOCK; \
- ((StgIndOldGen *)p1)->mut_link = generations[bd->gen_no].mut_once_list; \
- generations[bd->gen_no].mut_once_list = (StgMutClosure *)p1; \
- RELEASE_SM_LOCK; \
- } \
- SET_INFO(p1,&stg_IND_OLDGEN_info); \
- TICK_UPD_OLD_IND(); \
- and_then; \
- } \
- }
-#elif defined(PROFILING)
-// @LDV profiling
-// We call LDV_recordDead_FILL_SLOP_DYNAMIC(p1) regardless of the generation in
-// which p1 resides.
-//
-// Note:
-// After all, we do *NOT* need to call LDV_recordCreate() for both IND and
-// IND_OLDGEN closures because they are inherently used. But, it corrupts
-// the invariants that every closure keeps its creation time in the profiling
-// field. So, we call LDV_recordCreate().
-
-#define updateWithIndirection(info, ind_info, p1, p2, and_then) \
- { \
- bdescr *bd; \
- \
- LDV_recordDead_FILL_SLOP_DYNAMIC((p1)); \
- bd = Bdescr((P_)p1); \
- if (bd->gen_no == 0) { \
- ((StgInd *)p1)->indirectee = p2; \
- SET_INFO(p1,ind_info); \
- LDV_recordCreate((p1)); \
- TICK_UPD_NEW_IND(); \
- and_then; \
- } else { \
- ((StgIndOldGen *)p1)->indirectee = p2; \
- if (info != &stg_BLACKHOLE_BQ_info) { \
- ACQUIRE_SM_LOCK; \
- ((StgIndOldGen *)p1)->mut_link = generations[bd->gen_no].mut_once_list; \
- generations[bd->gen_no].mut_once_list = (StgMutClosure *)p1; \
- RELEASE_SM_LOCK; \
- } \
- SET_INFO(p1,&stg_IND_OLDGEN_info); \
- LDV_recordCreate((p1)); \
- and_then; \
- } \
- }
-
-#else
-
-/* In the DEBUG case, we also zero out the slop of the old closure,
- * so that the sanity checker can tell where the next closure is.
- *
- * Two important invariants: we should never try to update a closure
- * to point to itself, and the closure being updated should not
- * already have been updated (the mutable list will get messed up
- * otherwise).
- */
-#define updateWithIndirection(info, ind_info, p1, p2, and_then) \
- { \
- bdescr *bd; \
- \
- ASSERT( p1 != p2 && !closure_IND(p1) ); \
- bd = Bdescr((P_)p1); \
- if (bd->gen_no == 0) { \
- ((StgInd *)p1)->indirectee = p2; \
- SET_INFO(p1,ind_info); \
- TICK_UPD_NEW_IND(); \
- and_then; \
- } else { \
- if (info != &stg_BLACKHOLE_BQ_info) { \
- { \
- StgInfoTable *inf = get_itbl(p1); \
- nat np = inf->layout.payload.ptrs, \
- nw = inf->layout.payload.nptrs, i; \
- if (inf->type != THUNK_SELECTOR) { \
- for (i = 0; i < np + nw; i++) { \
- ((StgClosure *)p1)->payload[i] = 0; \
- } \
- } \
- } \
- ACQUIRE_SM_LOCK; \
- ((StgIndOldGen *)p1)->mut_link = generations[bd->gen_no].mut_once_list; \
- generations[bd->gen_no].mut_once_list = (StgMutClosure *)p1; \
- RELEASE_SM_LOCK; \
- } \
- ((StgIndOldGen *)p1)->indirectee = p2; \
- SET_INFO(p1,&stg_IND_OLDGEN_info); \
- TICK_UPD_OLD_IND(); \
- and_then; \
- } \
- }
-#endif
-
-/* Static objects all live in the oldest generation
- */
-#define updateWithStaticIndirection(info, p1, p2) \
- { \
- ASSERT( p1 != p2 && !closure_IND(p1) ); \
- ASSERT( ((StgMutClosure*)p1)->mut_link == NULL ); \
- \
- ACQUIRE_SM_LOCK; \
- ((StgMutClosure *)p1)->mut_link = oldest_gen->mut_once_list; \
- oldest_gen->mut_once_list = (StgMutClosure *)p1; \
- RELEASE_SM_LOCK; \
- \
- ((StgInd *)p1)->indirectee = p2; \
- SET_INFO((StgInd *)p1, &stg_IND_STATIC_info); \
- TICK_UPD_STATIC_IND(); \
- }
-
-#if defined(TICKY_TICKY) || defined(PROFILING)
-INLINE_HEADER void
-updateWithPermIndirection(const StgInfoTable *info, StgClosure *p1, StgClosure *p2)
-{
- bdescr *bd;
-
- ASSERT( p1 != p2 && !closure_IND(p1) );
-
-#ifdef PROFILING
- // @LDV profiling
- // Destroy the old closure.
- // Nb: LDV_* stuff cannot mix with ticky-ticky
- LDV_recordDead_FILL_SLOP_DYNAMIC(p1);
-#endif
- bd = Bdescr((P_)p1);
- if (bd->gen_no == 0) {
- ((StgInd *)p1)->indirectee = p2;
- SET_INFO(p1,&stg_IND_PERM_info);
-#ifdef PROFILING
- // @LDV profiling
- // We have just created a new closure.
- LDV_recordCreate(p1);
-#endif
- TICK_UPD_NEW_PERM_IND(p1);
- } else {
- ((StgIndOldGen *)p1)->indirectee = p2;
- if (info != &stg_BLACKHOLE_BQ_info) {
- ACQUIRE_SM_LOCK;
- ((StgIndOldGen *)p1)->mut_link = generations[bd->gen_no].mut_once_list;
- generations[bd->gen_no].mut_once_list = (StgMutClosure *)p1;
- RELEASE_SM_LOCK;
- }
- SET_INFO(p1,&stg_IND_OLDGEN_PERM_info);
-#ifdef PROFILING
- // @LDV profiling
- // We have just created a new closure.
- LDV_recordCreate(p1);
-#endif
- TICK_UPD_OLD_PERM_IND();
+ p->mut_link = RTS_DEREF(generations)[bd->gen_no].mut_once_list;
+ RTS_DEREF(generations)[bd->gen_no].mut_once_list = p;
}
}
-#endif
/* -----------------------------------------------------------------------------
The CAF table - used to let us revert CAFs in GHCi
StgRetDyn *dyn = (StgRetDyn *)frame;
return sizeofW(StgRetDyn) + RET_DYN_BITMAP_SIZE +
RET_DYN_NONPTR_REGS_SIZE +
- GET_PTRS(dyn->liveness) + GET_NONPTRS(dyn->liveness);
+ RET_DYN_PTRS(dyn->liveness) + RET_DYN_NONPTRS(dyn->liveness);
}
case RET_FUN:
}
/* -----------------------------------------------------------------------------
- Debugging bits
+ Nursery manipulation
+ -------------------------------------------------------------------------- */
+
+extern void allocNurseries ( void );
+extern void resetNurseries ( void );
+extern bdescr * allocNursery ( bdescr *last_bd, nat blocks );
+extern void resizeNursery ( nat blocks );
+extern void tidyAllocateLists ( void );
+
+/* -----------------------------------------------------------------------------
+ MUTABLE LISTS
+ A mutable list is ended with END_MUT_LIST, so that we can use NULL
+ as an indication that an object is not on a mutable list.
+ ------------------------------------------------------------------------- */
+
+#define END_MUT_LIST ((StgMutClosure *)(void *)&stg_END_MUT_LIST_closure)
+
+/* -----------------------------------------------------------------------------
+ Functions from GC.c
+ -------------------------------------------------------------------------- */
+
+extern void threadPaused ( StgTSO * );
+extern StgClosure * isAlive ( StgClosure *p );
+extern void markCAFs ( evac_fn evac );
+
+/* -----------------------------------------------------------------------------
+ Stats 'n' DEBUG stuff
-------------------------------------------------------------------------- */
+extern lnat RTS_VAR(total_allocated);
+
+extern lnat calcAllocated ( void );
+extern lnat calcLive ( void );
+extern lnat calcNeeded ( void );
+
+#if defined(DEBUG)
+extern void memInventory(void);
+extern void checkSanity(void);
+extern nat countBlocks(bdescr *);
+#endif
+
#if defined(DEBUG)
void printMutOnceList(generation *gen);
void printMutableList(generation *gen);
#endif
+/* ----------------------------------------------------------------------------
+ Storage manager internal APIs and globals
+ ------------------------------------------------------------------------- */
+
+#define END_OF_STATIC_LIST stgCast(StgClosure*,1)
+
+extern void newDynCAF(StgClosure *);
+
+extern void move_TSO(StgTSO *src, StgTSO *dest);
+extern StgTSO *relocate_stack(StgTSO *dest, ptrdiff_t diff);
+
+extern StgClosure * RTS_VAR(static_objects);
+extern StgClosure * RTS_VAR(scavenged_static_objects);
+extern StgWeak * RTS_VAR(old_weak_ptr_list);
+extern StgWeak * RTS_VAR(weak_ptr_list);
+extern StgClosure * RTS_VAR(caf_list);
+extern StgTSO * RTS_VAR(resurrected_threads);
+
#endif // STORAGE_H
/* -----------------------------------------------------------------------------
- * $Id: TSO.h,v 1.34 2004/03/01 14:18:35 simonmar Exp $
+ * $Id: TSO.h,v 1.35 2004/08/13 13:09:40 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
} StgTSOStatBuf;
#endif
-#if defined(PROFILING)
+/*
+ * PROFILING info in a TSO
+ */
typedef struct {
CostCentreStack *CCCS; /* thread's current CCS */
} StgTSOProfInfo;
-#else /* !PROFILING */
-# if defined(SUPPORTS_EMPTY_STRUCTS)
-typedef struct {
- /* empty */
-} StgTSOProfInfo;
-# endif
-#endif /* PROFILING */
-#if defined(PAR)
+/*
+ * PAR info in a TSO
+ */
+#ifdef PAR
typedef StgTSOStatBuf StgTSOParInfo;
-#else /* !PAR */
-# if defined(SUPPORTS_EMPTY_STRUCTS)
+#else
+#ifdef SUPPORTS_EMPTY_STRUCTS
typedef struct {
- /* empty */
+ /* empty */
} StgTSOParInfo;
-# endif
-#endif /* PAR */
+#endif
+#endif
-#if defined(DIST)
+/*
+ * DIST info in a TSO
+ */
+#ifdef DIST
typedef struct {
StgThreadPriority priority;
StgInt revalTid; /* ToDo: merge both into 1 word */
StgInt revalSlot;
} StgTSODistInfo;
-#else /* !DIST */
-# if defined(SUPPORTS_EMPTY_STRUCTS)
+#else
+#ifdef SUPPORTS_EMPTY_STRUCTS
typedef struct {
- /* empty */
+ /* empty */
} StgTSODistInfo;
-# endif
-#endif /* DIST */
+#endif
+#endif
-#if defined(GRAN)
+/*
+ * GRAN info in a TSO
+ */
+#ifdef GRAN
typedef StgTSOStatBuf StgTSOGranInfo;
-#else /* !GRAN */
-# if defined(SUPPORTS_EMPTY_STRUCTS)
+#else
+#ifdef SUPPORTS_EMPTY_STRUCTS
typedef struct {
- /* empty */
+ /* empty */
} StgTSOGranInfo;
-# endif
-#endif /* GRAN */
-
+#endif
+#endif
-#if defined(TICKY)
-typedef struct {
-} StgTSOTickyInfo;
-#else /* !TICKY_TICKY */
-# if defined(SUPPORTS_EMPTY_STRUCTS)
+/*
+ * TICKY_TICKY info in a TSO
+ */
+#ifdef SUPPORTS_EMPTY_STRUCTS
typedef struct {
/* empty */
} StgTSOTickyInfo;
-# endif
-#endif /* TICKY_TICKY */
-
-typedef enum {
- tso_state_runnable,
- tso_state_stopped
-} StgTSOState;
-
-/*
- * The what_next field of a TSO indicates how the thread is to be run.
- */
-typedef enum {
- ThreadRunGHC, /* return to address on top of stack */
- ThreadInterpret, /* interpret this thread */
- ThreadKilled, /* thread has died, don't run it */
- ThreadRelocated, /* thread has moved, link points to new locn */
- ThreadComplete /* thread has finished */
-} StgTSOWhatNext;
+#endif
/*
* Thread IDs are 32 bits.
typedef StgWord32 StgThreadID;
/*
- * This type is returned to the scheduler by a thread that has
- * stopped for one reason or another.
+ * Type returned after running a thread. Values of this type
+ * include HeapOverflow, StackOverflow etc. See Constants.h for the
+ * full list.
*/
-
-typedef enum {
- HeapOverflow, /* might also be StackOverflow */
- StackOverflow,
- ThreadYielding,
- ThreadBlocked,
- ThreadFinished
-} StgThreadReturnCode;
+typedef unsigned int StgThreadReturnCode;
/*
* We distinguish between the various classes of threads in the system.
RevalPriority
} StgThreadPriority;
-/*
- * Threads may be blocked for several reasons. A blocked thread will
- * have the reason in the why_blocked field of the TSO, and some
- * further info (such as the closure the thread is blocked on, or the
- * file descriptor if the thread is waiting on I/O) in the block_info
- * field.
- */
-
-typedef enum {
- NotBlocked,
- BlockedOnMVar,
- BlockedOnBlackHole,
- BlockedOnException,
- BlockedOnRead,
- BlockedOnWrite,
- BlockedOnDelay
-#if defined(mingw32_TARGET_OS)
- , BlockedOnDoProc
-#endif
-#if defined(PAR)
- , BlockedOnGA // blocked on a remote closure represented by a Global Address
- , BlockedOnGA_NoSend // same as above but without sending a Fetch message
-#endif
- , BlockedOnCCall
- , BlockedOnCCall_NoUnblockExc // same as above but don't unblock
- // async exceptions in resumeThread()
-} StgTSOBlockReason;
-
#if defined(mingw32_TARGET_OS)
/* results from an async I/O request + it's ID. */
typedef struct {
*/
/*
+ * Threads may be blocked for several reasons. A blocked thread will
+ * have the reason in the why_blocked field of the TSO, and some
+ * further info (such as the closure the thread is blocked on, or the
+ * file descriptor if the thread is waiting on I/O) in the block_info
+ * field.
+ */
+
+/*
* ToDo: make this structure sensible on a non-32-bit arch.
*/
typedef struct StgTSO_ {
StgHeader header;
- struct StgTSO_* link; /* Links threads onto blocking queues */
- StgMutClosure * mut_link; /* TSO's are mutable of course! */
- struct StgTSO_* global_link; /* Links all threads together */
+ struct StgTSO_* link; // Links threads onto blocking queues */
+ StgMutClosure * mut_link; // TSO's are mutable of course! */
+ struct StgTSO_* global_link; // Links all threads together */
- StgTSOWhatNext what_next : 16;
- StgTSOBlockReason why_blocked : 16;
- StgTSOBlockInfo block_info;
- struct StgTSO_* blocked_exceptions;
- StgThreadID id;
- int saved_errno;
- struct StgMainThread_* main;
+ StgWord16 what_next; // Values defined in Constants.h
+ StgWord16 why_blocked; // Values defined in Constants.h
+ StgTSOBlockInfo block_info;
+ struct StgTSO_* blocked_exceptions;
+ StgThreadID id;
+ int saved_errno;
+#ifdef TICKY_TICKY
MAYBE_EMPTY_STRUCT(StgTSOTickyInfo,ticky)
- MAYBE_EMPTY_STRUCT(StgTSOProfInfo,prof)
- MAYBE_EMPTY_STRUCT(StgTSOParInfo,par)
- MAYBE_EMPTY_STRUCT(StgTSOGranInfo,gran)
- MAYBE_EMPTY_STRUCT(StgTSODistInfo,dist)
-
+#endif
+#ifdef PROFILING
+ StgTSOProfInfo prof;
+#endif
+
+ MAYBE_EMPTY_STRUCT(StgTSOParInfo,par);
+ MAYBE_EMPTY_STRUCT(StgTSOGranInfo,gran);
+ MAYBE_EMPTY_STRUCT(StgTSODistInfo,dist);
+
/* The thread stack... */
StgWord stack_size; /* stack size in *words* */
StgWord max_stack_size; /* maximum stack size in *words* */
#define TSO_STRUCT_SIZEW (TSO_STRUCT_SIZE / sizeof(W_))
+
+/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
+#define END_TSO_QUEUE ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
+
+#if defined(PAR) || defined(GRAN)
+/* this is the NIL ptr for a blocking queue */
+# define END_BQ_QUEUE ((StgBlockingQueueElement *)(void*)&stg_END_TSO_QUEUE_closure)
+/* this is the NIL ptr for a blocked fetch queue (as in PendingFetches in GUM) */
+# define END_BF_QUEUE ((StgBlockedFetch *)(void*)&stg_END_TSO_QUEUE_closure)
+#endif
+/* ToDo?: different name for end of sleeping queue ? -- HWL */
+
#endif /* TSO_H */
/* -----------------------------------------------------------------------------
- * $Id: TailCalls.h,v 1.15 2003/10/12 13:24:52 igloo Exp $
+ * $Id: TailCalls.h,v 1.16 2004/08/13 13:09:41 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#ifdef USE_MINIINTERPRETER
-#define JMP_(cont) return(stgCast(StgFunPtr,cont))
+#define JMP_(cont) return((StgFunPtr)(cont))
#define FB_
#define FE_
/* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.34 2003/11/12 17:27:06 sof Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
- * Definitions related to updates.
+ * Performing updates.
*
* ---------------------------------------------------------------------------*/
#define UPDATES_H
/* -----------------------------------------------------------------------------
- Update a closure with an indirection. This may also involve waking
- up a queue of blocked threads waiting on the result of this
- computation.
- -------------------------------------------------------------------------- */
+ Updates
-/* ToDo: overwrite slop words with something safe in case sanity checking
- * is turned on.
- * (I think the fancy version of the GC is supposed to do this too.)
- */
+ We have two layers of update macros. The top layer, UPD_IND() and
+ friends perform all the work of an update. In detail:
-/* This expands to a fair chunk of code, what with waking up threads
- * and checking whether we're updating something in a old generation.
- * preferably don't use this macro inline in compiled code.
- */
+ - if the closure being updated is a blocking queue, then all the
+ threads waiting on the blocking queue are updated.
+
+ - then the lower level updateWithIndirection() macro is invoked
+ to actually replace the closure with an indirection (see below).
+
+ -------------------------------------------------------------------------- */
#ifdef TICKY_TICKY
# define UPD_IND(updclosure, heapptr) \
#else
# define SEMI ;
# define UPD_IND(updclosure, heapptr) \
- UPD_REAL_IND(updclosure,&stg_IND_info,heapptr,SEMI)
+ UPD_REAL_IND(updclosure,INFO_PTR(stg_IND_info),heapptr,SEMI)
# define UPD_SPEC_IND(updclosure, ind_info, heapptr, and_then) \
UPD_REAL_IND(updclosure,ind_info,heapptr,and_then)
#endif
+/* These macros have to work in both C and C--, so here's the
+ * impedence matching:
+ */
+#ifdef CMINUSMINUS
+#define DECLARE_IPTR(info) W_ info
+#define FCALL foreign "C"
+#define INFO_PTR(info) info
+#define ARG_PTR "ptr"
+#else
+#define DECLARE_IPTR(info) const StgInfoTable *(info)
+#define FCALL /* nothing */
+#define INFO_PTR(info) &info
+#define StgBlockingQueue_blocking_queue(closure) \
+ (((StgBlockingQueue *)closure)->blocking_queue)
+#define ARG_PTR /* nothing */
+#endif
+
/* UPD_IND actually does a PERM_IND if TICKY_TICKY is on;
if you *really* need an IND use UPD_REAL_IND
*/
-#ifdef SMP
#define UPD_REAL_IND(updclosure, ind_info, heapptr, and_then) \
- { \
- const StgInfoTable *info; \
- if (Bdescr((P_)updclosure)->u.back != (bdescr *)BaseReg) { \
- info = LOCK_CLOSURE(updclosure); \
- } else { \
- info = updclosure->header.info; \
- } \
+ DECLARE_IPTR(info); \
+ info = GET_INFO(updclosure); \
AWAKEN_BQ(info,updclosure); \
- updateWithIndirection(info, ind_info, \
- (StgClosure *)updclosure, \
- (StgClosure *)heapptr, \
- and_then); \
- }
-#else
-#define UPD_REAL_IND(updclosure, ind_info, heapptr, and_then) \
- { \
- const StgInfoTable *info; \
- info = ((StgClosure *)updclosure)->header.info; \
- AWAKEN_BQ(info,updclosure); \
- updateWithIndirection(((StgClosure *)updclosure)->header.info, ind_info, \
- (StgClosure *)updclosure, \
- (StgClosure *)heapptr, \
- and_then); \
- }
-#endif
-
-#define UPD_STATIC_IND(updclosure, heapptr) \
- { \
- const StgInfoTable *info; \
- info = ((StgClosure *)updclosure)->header.info; \
- AWAKEN_STATIC_BQ(info,updclosure); \
- updateWithStaticIndirection(info, \
- (StgClosure *)updclosure, \
- (StgClosure *)heapptr); \
- }
+ updateWithIndirection(GET_INFO(updclosure), ind_info, \
+ updclosure, \
+ heapptr, \
+ and_then);
#if defined(PROFILING) || defined(TICKY_TICKY)
-#define UPD_PERM_IND(updclosure, heapptr) \
- { \
- const StgInfoTable *info; \
- info = ((StgClosure *)updclosure)->header.info; \
- AWAKEN_BQ(info,updclosure); \
- updateWithPermIndirection(info, \
- (StgClosure *)updclosure, \
- (StgClosure *)heapptr); \
- }
+#define UPD_PERM_IND(updclosure, heapptr) \
+ DECLARE_IPTR(info); \
+ info = GET_INFO(updclosure); \
+ AWAKEN_BQ(info,updclosure); \
+ updateWithPermIndirection(info, \
+ updclosure, \
+ heapptr);
#endif
-#ifdef SMP
-#define UPD_IND_NOLOCK(updclosure, heapptr) \
- { \
- const StgInfoTable *info; \
- info = updclosure->header.info; \
- AWAKEN_BQ(info,updclosure); \
- updateWithIndirection(info,&stg_IND_info, \
- (StgClosure *)updclosure, \
- (StgClosure *)heapptr,); \
- }
-#elif defined(RTS_SUPPORTS_THREADS)
+#if defined(RTS_SUPPORTS_THREADS)
# ifdef TICKY_TICKY
-# define UPD_IND_NOLOCK(updclosure, heapptr) \
- { \
- const StgInfoTable *info; \
- info = ((StgClosure *)updclosure)->header.info; \
- AWAKEN_BQ_NOLOCK(info,updclosure); \
- updateWithPermIndirection(info, \
- (StgClosure *)updclosure, \
- (StgClosure *)heapptr); \
- }
+# define UPD_IND_NOLOCK(updclosure, heapptr) \
+ DECLARE_IPTR(info); \
+ info = GET_INFO(updclosure); \
+ AWAKEN_BQ_NOLOCK(info,updclosure); \
+ updateWithPermIndirection(info, \
+ updclosure, \
+ heapptr)
# else
# define UPD_IND_NOLOCK(updclosure, heapptr) \
- { \
- const StgInfoTable *info; \
- info = ((StgClosure *)updclosure)->header.info; \
+ DECLARE_IPTR(info); \
+ info = GET_INFO(updclosure); \
AWAKEN_BQ_NOLOCK(info,updclosure); \
- updateWithIndirection(info,&stg_IND_info, \
- (StgClosure *)updclosure, \
- (StgClosure *)heapptr,); \
- }
+ updateWithIndirection(info,stg_IND_info, \
+ updclosure, \
+ heapptr,);
# endif
#else
#endif
/* -----------------------------------------------------------------------------
- Awaken any threads waiting on this computation
+ Awaken any threads waiting on a blocking queue (BLACKHOLE_BQ).
-------------------------------------------------------------------------- */
#if defined(PAR)
#else /* !GRAN && !PAR */
-extern void awakenBlockedQueue(StgTSO *q);
#define DO_AWAKEN_BQ(closure) \
- STGCALL1(awakenBlockedQueue, \
- ((StgBlockingQueue *)closure)->blocking_queue);
+ FCALL awakenBlockedQueue(StgBlockingQueue_blocking_queue(closure) ARG_PTR);
#define AWAKEN_BQ(info,closure) \
- if (info == &stg_BLACKHOLE_BQ_info) { \
+ if (info == INFO_PTR(stg_BLACKHOLE_BQ_info)) { \
DO_AWAKEN_BQ(closure); \
}
#define AWAKEN_STATIC_BQ(info,closure) \
- if (info == &stg_BLACKHOLE_BQ_STATIC_info) { \
+ if (info == INFO_PTR(stg_BLACKHOLE_BQ_STATIC_info)) { \
DO_AWAKEN_BQ(closure); \
}
#ifdef RTS_SUPPORTS_THREADS
-extern void awakenBlockedQueueNoLock(StgTSO *q);
-#define DO_AWAKEN_BQ_NOLOCK(closure) \
- STGCALL1(awakenBlockedQueueNoLock, \
- ((StgBlockingQueue *)closure)->blocking_queue);
+#define DO_AWAKEN_BQ_NOLOCK(closure) \
+ FCALL awakenBlockedQueueNoLock(StgBlockingQueue_blocking_queue(closure) ARG_PTR);
#define AWAKEN_BQ_NOLOCK(info,closure) \
- if (info == &stg_BLACKHOLE_BQ_info) { \
+ if (info == INFO_PTR(stg_BLACKHOLE_BQ_info)) { \
DO_AWAKEN_BQ_NOLOCK(closure); \
}
#endif
#endif /* GRAN || PAR */
-/* -------------------------------------------------------------------------
- Push an update frame on the stack.
- ------------------------------------------------------------------------- */
-
-#if defined(PROFILING)
-// frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) is unnecessary
-// because it is not used anyhow.
-#define PUSH_STD_CCCS(frame) (frame->header.prof.ccs = CCCS)
-#else
-#define PUSH_STD_CCCS(frame)
-#endif
+/* -----------------------------------------------------------------------------
+ Updates: lower-level macros which update a closure with an
+ indirection to another closure.
-extern DLL_IMPORT_RTS const StgPolyInfoTable stg_upd_frame_info;
-extern DLL_IMPORT_RTS const StgPolyInfoTable stg_noupd_frame_info;
-
-#define PUSH_UPD_FRAME(target, Sp_offset) \
- { \
- StgUpdateFrame *__frame; \
- TICK_UPDF_PUSHED(target, GET_INFO((StgClosure*)target)); \
- __frame = (StgUpdateFrame *)(Sp + (Sp_offset)) - 1; \
- SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info); \
- __frame->updatee = (StgClosure *)(target); \
- PUSH_STD_CCCS(__frame); \
- }
+ There are several variants of this code.
-/* -----------------------------------------------------------------------------
- Entering CAFs
+ PROFILING:
+ -------------------------------------------------------------------------- */
- When a CAF is first entered, it creates a black hole in the heap,
- and updates itself with an indirection to this new black hole.
+/* LDV profiling:
+ * We call LDV_recordDead_FILL_SLOP_DYNAMIC(p1) regardless of the generation in
+ * which p1 resides.
+ *
+ * Note:
+ * After all, we do *NOT* need to call LDV_RECORD_CREATE() for both IND and
+ * IND_OLDGEN closures because they are inherently used. But, it corrupts
+ * the invariants that every closure keeps its creation time in the profiling
+ * field. So, we call LDV_RECORD_CREATE().
+ */
- We update the CAF with an indirection to a newly-allocated black
- hole in the heap. We also set the blocking queue on the newly
- allocated black hole to be empty.
+/* In the DEBUG case, we also zero out the slop of the old closure,
+ * so that the sanity checker can tell where the next closure is.
+ *
+ * Two important invariants: we should never try to update a closure
+ * to point to itself, and the closure being updated should not
+ * already have been updated (the mutable list will get messed up
+ * otherwise).
+ */
+#if !defined(DEBUG)
+
+#define DEBUG_FILL_SLOP(p) /* nothing */
+
+#else /* DEBUG */
+
+#ifdef CMINUSMINUS
+
+#define DEBUG_FILL_SLOP(p) \
+ W_ inf; \
+ W_ np; \
+ W_ nw; \
+ W_ i; \
+ inf = %GET_STD_INFO(p); \
+ np = TO_W_(%INFO_PTRS(inf)); \
+ nw = TO_W_(%INFO_NPTRS(inf)); \
+ if (%INFO_TYPE(inf) != THUNK_SELECTOR::I16) { \
+ i = 0; \
+ for: \
+ if (i < np + nw) { \
+ StgClosure_payload(p,i) = 0; \
+ i = i + 1; \
+ goto for; \
+ } \
+ }
- Why do we make a black hole in the heap when we enter a CAF?
-
- - for a generational garbage collector, which needs a fast
- test for whether an updatee is in an old generation or not
- - for the parallel system, which can implement updates more
- easily if the updatee is always in the heap. (allegedly).
+#else /* !CMINUSMINUS */
- When debugging, we maintain a separate CAF list so we can tell when
- a CAF has been garbage collected.
- -------------------------------------------------------------------------- */
-
-/* ToDo: only call newCAF when debugging. */
+INLINE_HEADER void
+DEBUG_FILL_SLOP(StgClosure *p)
+{
+ StgInfoTable *inf = get_itbl(p);
+ nat np = inf->layout.payload.ptrs,
+ nw = inf->layout.payload.nptrs, i;
+ if (inf->type != THUNK_SELECTOR) {
+ for (i = 0; i < np + nw; i++) {
+ ((StgClosure *)p)->payload[i] = 0;
+ }
+ }
+}
-extern void newCAF(StgClosure*);
+#endif /* CMINUSMINUS */
+#endif /* DEBUG */
-/* newCAF must be called before the itbl ptr is overwritten, since
- newCAF records the old itbl ptr in order to do CAF reverting
- (which Hugs needs to do in order that combined mode works right.)
-*/
-#define UPD_CAF(cafptr, bhptr) \
+/* We have two versions of this macro (sadly), one for use in C-- code,
+ * and the other for C.
+ *
+ * The and_then argument is a performance hack so that we can paste in
+ * the continuation code directly. It helps shave a couple of
+ * instructions off the common case in the update code, which is
+ * worthwhile (the update code is often part of the inner loop).
+ * (except that gcc now appears to common up this code again and
+ * invert the optimisation. Grrrr --SDM).
+ */
+#ifdef CMINUSMINUS
+#define generation(n) (W_[generations] + n*SIZEOF_generation)
+#define updateWithIndirection(info, ind_info, p1, p2, and_then) \
+ W_ bd; \
+ \
+/* ASSERT( p1 != p2 && !closure_IND(p1) ); \
+ */ LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(p1); \
+ bd = Bdescr(p1); \
+ if (bdescr_gen_no(bd) == 0) { \
+ StgInd_indirectee(p1) = p2; \
+ SET_INFO(p1, ind_info); \
+ LDV_RECORD_CREATE(p1); \
+ TICK_UPD_NEW_IND(); \
+ and_then; \
+ } else { \
+ if (info != stg_BLACKHOLE_BQ_info) { \
+ DEBUG_FILL_SLOP(p1); \
+ W_ __mut_once_list; \
+ __mut_once_list = generation(bdescr_gen_no(bd)) + \
+ OFFSET_generation_mut_once_list; \
+ StgMutClosure_mut_link(p1) = W_[__mut_once_list]; \
+ W_[__mut_once_list] = p1; \
+ } \
+ StgInd_indirectee(p1) = p2; \
+ SET_INFO(p1, stg_IND_OLDGEN_info); \
+ LDV_RECORD_CREATE(p1); \
+ TICK_UPD_OLD_IND(); \
+ and_then; \
+ }
+#else
+#define updateWithIndirection(_info, ind_info, p1, p2, and_then) \
{ \
- LOCK_CLOSURE(cafptr); \
- STGCALL1(newCAF,(StgClosure *)cafptr); \
- ((StgInd *)cafptr)->indirectee = (StgClosure *)(bhptr); \
- SET_INFO((StgInd *)cafptr,(const StgInfoTable*)&stg_IND_STATIC_info);\
+ bdescr *bd; \
+ \
+ ASSERT( (P_)p1 != (P_)p2 && !closure_IND(p1) ); \
+ LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(p1); \
+ bd = Bdescr((P_)p1); \
+ if (bd->gen_no == 0) { \
+ ((StgInd *)p1)->indirectee = p2; \
+ SET_INFO(p1, ind_info); \
+ LDV_RECORD_CREATE(p1); \
+ TICK_UPD_NEW_IND(); \
+ and_then; \
+ } else { \
+ if (_info != &stg_BLACKHOLE_BQ_info) { \
+ DEBUG_FILL_SLOP(p1); \
+ ((StgIndOldGen *)p1)->mut_link = generations[bd->gen_no].mut_once_list; \
+ generations[bd->gen_no].mut_once_list = (StgMutClosure *)p1; \
+ } \
+ ((StgIndOldGen *)p1)->indirectee = p2; \
+ SET_INFO(p1, &stg_IND_OLDGEN_info); \
+ TICK_UPD_OLD_IND(); \
+ and_then; \
+ } \
}
+#endif
-/* -----------------------------------------------------------------------------
- Update-related prototypes
- -------------------------------------------------------------------------- */
+/* The permanent indirection version isn't performance critical. We
+ * therefore use an inline C function instead of the C-- macro.
+ */
+#ifndef CMINUSMINUS
+INLINE_HEADER void
+updateWithPermIndirection(const StgInfoTable *info,
+ StgClosure *p1,
+ StgClosure *p2)
+{
+ bdescr *bd;
+
+ ASSERT( p1 != p2 && !closure_IND(p1) );
+
+ // @LDV profiling
+ // Destroy the old closure.
+ // Nb: LDV_* stuff cannot mix with ticky-ticky
+ LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(p1);
+
+ bd = Bdescr((P_)p1);
+ if (bd->gen_no == 0) {
+ ((StgInd *)p1)->indirectee = p2;
+ SET_INFO(p1, &stg_IND_PERM_info);
+ // @LDV profiling
+ // We have just created a new closure.
+ LDV_RECORD_CREATE(p1);
+ TICK_UPD_NEW_PERM_IND(p1);
+ } else {
+ if (info != &stg_BLACKHOLE_BQ_info) {
+ ((StgIndOldGen *)p1)->mut_link = generations[bd->gen_no].mut_once_list;
+ generations[bd->gen_no].mut_once_list = (StgMutClosure *)p1;
+ }
+ ((StgIndOldGen *)p1)->indirectee = p2;
+ SET_INFO(p1, &stg_IND_OLDGEN_PERM_info);
+ // @LDV profiling
+ // We have just created a new closure.
+ LDV_RECORD_CREATE(p1);
+ TICK_UPD_OLD_PERM_IND();
+ }
+}
+#endif
#endif /* UPDATES_H */
/* --------------------------------------------------------------------------
- * $Id: mkDerivedConstants.c,v 1.5 2004/03/08 10:31:00 stolz Exp $
*
- * (c) The GHC Team, 1992-1998
+ * (c) The GHC Team, 1992-2004
*
- * Generate a header for the native code generator
+ * mkDerivedConstants.c
+ *
+ * Basically this is a C program that extracts information from the C
+ * declarations in the header files (primarily struct field offsets)
+ * and generates a header file that can be #included into non-C source
+ * containing this information.
*
* ------------------------------------------------------------------------*/
#include <stdio.h>
#define IN_STG_CODE 0
-#include "Stg.h"
+
+// We need offsets of profiled things... better be careful that this
+// doesn't affect the offsets of anything else.
+#define PROFILING
+
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "Storage.h"
+
+#define str(a,b) #a "_" #b
#define OFFSET(s_type, field) ((unsigned int)&(((s_type*)0)->field))
+#if defined(GEN_HASKELL)
+#define def_offset(str, offset) \
+ printf("oFFSET_" str " = %d::Int\n", offset);
+#else
+#define def_offset(str, offset) \
+ printf("#define OFFSET_" str " %d\n", offset);
+#endif
+
+#if defined(GEN_HASKELL)
+#define ctype(type) /* nothing */
+#else
+#define ctype(type) \
+ printf("#define SIZEOF_" #type " %d\n", sizeof(type));
+#endif
+
+#if defined(GEN_HASKELL)
+#define field_type_(str, s_type, field) /* nothing */
+#else
+#define field_type_(str, s_type, field) \
+ printf("#define REP_" str " I"); \
+ printf("%d\n", sizeof (__typeof__(((((s_type*)0)->field)))) * 8);
+#endif
+
+#define field_type(s_type, field) \
+ field_type_(str(s_type,field),s_type,field);
+
+#define field_offset_(str, s_type, field) \
+ def_offset(str, OFFSET(s_type,field));
+
+#define field_offset(s_type, field) \
+ field_offset_(str(s_type,field),s_type,field);
+
+// An access macro for use in C-- sources.
+#define struct_field_macro(str) \
+ printf("#define " str "(__ptr__) REP_" str "[__ptr__+OFFSET_" str "]\n");
+
+// Outputs the byte offset and MachRep for a field
+#define struct_field(s_type, field) \
+ field_offset(s_type, field); \
+ field_type(s_type, field); \
+ struct_field_macro(str(s_type,field))
+
+#define struct_field_(str, s_type, field) \
+ field_offset_(str, s_type, field); \
+ field_type_(str, s_type, field); \
+ struct_field_macro(str)
+
+#if defined(GEN_HASKELL)
+#define def_size(str, size) \
+ printf("sIZEOF_" str " = %d::Int\n", size);
+#else
+#define def_size(str, size) \
+ printf("#define SIZEOF_" str " %d\n", size);
+#endif
+
+#if defined(GEN_HASKELL)
+#define def_closure_size(str, size) /* nothing */
+#else
+#define def_closure_size(str, size) \
+ printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%d)\n", size);
+#endif
+
+#define struct_size(s_type) \
+ def_size(#s_type, sizeof(s_type));
+
+// Size of a closure type, minus the header, named SIZEOF_<type>_NoHdr
+// Also, we #define SIZEOF_<type> to be the size of the whole closure for .cmm.
+#define closure_size(s_type) \
+ def_size(#s_type "_NoHdr", sizeof(s_type) - sizeof(StgHeader)); \
+ def_closure_size(#s_type, sizeof(s_type) - sizeof(StgHeader));
+
+// An access macro for use in C-- sources.
+#define closure_field_macro(str) \
+ printf("#define " str "(__ptr__) REP_" str "[__ptr__+SIZEOF_StgHeader+OFFSET_" str "]\n");
+
+#define closure_field_offset_(str, s_type,field) \
+ def_offset(str, OFFSET(s_type,field) - sizeof(StgHeader));
+
+#define closure_field_offset(s_type,field) \
+ closure_field_offset_(str(s_type,field),s_type,field);
+
+#define closure_payload_macro(str) \
+ printf("#define " str "(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_" str " + WDS(__ix__)]\n");
+
+#define closure_payload(s_type,field) \
+ closure_field_offset_(str(s_type,field),s_type,field); \
+ closure_payload_macro(str(s_type,field));
+
+// Byte offset and MachRep for a closure field, minus the header
+#define closure_field(s_type, field) \
+ closure_field_offset(s_type,field) \
+ field_type(s_type, field); \
+ closure_field_macro(str(s_type,field))
+
+// Byte offset and MachRep for a closure field, minus the header
+#define closure_field_(str, s_type, field) \
+ closure_field_offset_(str,s_type,field) \
+ field_type_(str, s_type, field); \
+ closure_field_macro(str)
+
+// Byte offset and MachRep for a TSO field, minus the header and
+// variable prof bit.
+#define tso_offset(s_type, field) \
+ def_offset(str(s_type,field), OFFSET(s_type,field) - sizeof(StgHeader) - sizeof(StgTSOProfInfo));
+
+#define tso_field_macro(str) \
+ printf("#define " str "(__ptr__) REP_" str "[__ptr__+SIZEOF_StgHeader+SIZEOF_OPT_StgTSOProfInfo+SIZEOF_OPT_StgTSOTickyInfo+SIZEOF_OPT_StgTSOParInfo+SIZEOF_OPT_StgTSOGranInfo+SIZEOF_OPT_StgTSODistInfo+OFFSET_" str "]\n");
+
+#define tso_field(s_type, field) \
+ tso_offset(s_type, field); \
+ field_type(s_type, field); \
+ tso_field_macro(str(s_type,field))
+
+#define opt_struct_size(s_type, option) \
+ printf("#ifdef " #option "\n"); \
+ printf("#define SIZEOF_OPT_" #s_type " SIZEOF_" #s_type "\n"); \
+ printf("#else\n"); \
+ printf("#define SIZEOF_OPT_" #s_type " 0\n"); \
+ printf("#endif\n\n");
+
+#define FUN_OFFSET(sym) (OFFSET(Capability,f.sym) - OFFSET(Capability,r))
+
+
int
main(int argc, char *argv[])
{
- printf("-- This file is created automatically. Do not edit by hand.\n\n");
+#ifndef GEN_HASKELL
+ printf("/* This file is created automatically. Do not edit by hand.*/\n\n");
- printf("#define STD_HDR_SIZE %d\n", sizeofW(StgHeader));
+ printf("#define STD_HDR_SIZE %d\n", sizeofW(StgHeader) - sizeofW(StgProfHeader));
+ // grrr.. PROFILING is on so we need to subtract sizeofW(StgProfHeader)
printf("#define PROF_HDR_SIZE %d\n", sizeofW(StgProfHeader));
printf("#define GRAN_HDR_SIZE %d\n", sizeofW(StgGranHeader));
- printf("#define ARR_WORDS_HDR_SIZE %d\n",
- sizeofW(StgArrWords) - sizeofW(StgHeader));
-
- printf("#define ARR_PTRS_HDR_SIZE %d\n",
- sizeofW(StgMutArrPtrs) - sizeofW(StgHeader));
-
printf("#define STD_ITBL_SIZE %d\n", sizeofW(StgInfoTable));
printf("#define RET_ITBL_SIZE %d\n", sizeofW(StgRetInfoTable) - sizeofW(StgInfoTable));
printf("#define PROF_ITBL_SIZE %d\n", sizeofW(StgProfInfo));
printf("#define GRAN_ITBL_SIZE %d\n", 0);
printf("#define TICKY_ITBL_SIZE %d\n", sizeofW(StgTickyInfo));
- printf("#define STD_UF_SIZE %d\n", sizeofW(StgUpdateFrame));
- printf("#define GRAN_UF_SIZE %d\n",
- sizeofW(StgUpdateFrame) + sizeofW(StgGranHeader));
- printf("#define PROF_UF_SIZE %d\n",
- sizeofW(StgUpdateFrame) + sizeofW(StgProfHeader));
+ printf("#define BLOCK_SIZE %d\n", BLOCK_SIZE);
+ printf("#define MBLOCK_SIZE %d\n", MBLOCK_SIZE);
- printf("#define UF_RET %d\n",
- OFFSET(StgUpdateFrame,header.info));
+ printf("\n\n");
+#endif
- printf("#define UF_UPDATEE %d\n",
- OFFSET(StgUpdateFrame,updatee) / sizeof(W_));
+ field_offset(StgRegTable, rR1);
+ field_offset(StgRegTable, rR2);
+ field_offset(StgRegTable, rR3);
+ field_offset(StgRegTable, rR4);
+ field_offset(StgRegTable, rR5);
+ field_offset(StgRegTable, rR6);
+ field_offset(StgRegTable, rR7);
+ field_offset(StgRegTable, rR8);
+ field_offset(StgRegTable, rR9);
+ field_offset(StgRegTable, rR10);
+ field_offset(StgRegTable, rF1);
+ field_offset(StgRegTable, rF2);
+ field_offset(StgRegTable, rF3);
+ field_offset(StgRegTable, rF4);
+ field_offset(StgRegTable, rD1);
+ field_offset(StgRegTable, rD2);
+#ifdef SUPPORT_LONG_LONGS
+ field_offset(StgRegTable, rL1);
+#endif
+ field_offset(StgRegTable, rSp);
+ field_offset(StgRegTable, rSpLim);
+ field_offset(StgRegTable, rHp);
+ field_offset(StgRegTable, rHpLim);
+ field_offset(StgRegTable, rCurrentTSO);
+ field_offset(StgRegTable, rCurrentNursery);
+ field_offset(StgRegTable, rHpAlloc);
- printf("#define BLOCK_SIZE %d\n", BLOCK_SIZE);
- printf("#define MBLOCK_SIZE %d\n", MBLOCK_SIZE);
+ def_offset("stgGCEnter1", FUN_OFFSET(stgGCEnter1));
+ def_offset("stgGCFun", FUN_OFFSET(stgGCFun));
+
+ field_offset(Capability, r);
+
+ struct_field(bdescr, start);
+ struct_field(bdescr, free);
+ struct_field(bdescr, blocks);
+ struct_field(bdescr, gen_no);
+ struct_field(bdescr, link);
+
+ struct_size(generation);
+ struct_field(generation, mut_once_list);
+
+ struct_field(CostCentreStack, ccsID);
+ struct_field(CostCentreStack, mem_alloc);
+ struct_field(CostCentreStack, scc_count);
+ struct_field(CostCentreStack, prevStack);
+
+ struct_field(CostCentre, ccID);
+ struct_field(CostCentre, link);
+
+ struct_field(StgHeader, info);
+ struct_field_("StgHeader_ccs", StgHeader, prof.ccs);
+ struct_field_("StgHeader_ldvw", StgHeader, prof.hp.ldvw);
+
+ closure_payload(StgClosure,payload);
+
+ struct_field(StgEntCounter, allocs);
+ struct_field(StgEntCounter, registeredp);
+ struct_field(StgEntCounter, link);
+
+ closure_size(StgUpdateFrame);
+ closure_size(StgCatchFrame);
+ closure_size(StgStopFrame);
+
+ closure_size(StgMutArrPtrs);
+ closure_field(StgMutArrPtrs, ptrs);
+
+ closure_size(StgArrWords);
+ closure_field(StgArrWords, words);
+ closure_payload(StgArrWords, payload);
+
+ closure_field(StgTSO, link);
+ closure_field(StgTSO, mut_link);
+ closure_field(StgTSO, global_link);
+ closure_field(StgTSO, what_next);
+ closure_field(StgTSO, why_blocked);
+ closure_field(StgTSO, block_info);
+ closure_field(StgTSO, blocked_exceptions);
+ closure_field(StgTSO, id);
+ closure_field(StgTSO, saved_errno);
+ closure_field_("StgTSO_CCCS", StgTSO, prof.CCCS);
+ tso_field(StgTSO, sp);
+ tso_offset(StgTSO, stack);
+ tso_field(StgTSO, stack_size);
+
+ struct_size(StgTSOProfInfo);
+ struct_size(StgTSOTickyInfo);
+ struct_size(StgTSOParInfo);
+ struct_size(StgTSOGranInfo);
+ struct_size(StgTSODistInfo);
+
+ opt_struct_size(StgTSOProfInfo,PROFILING);
+ opt_struct_size(StgTSOTickyInfo,TICKY_TICKY);
+ opt_struct_size(StgTSOParInfo,PAR);
+ opt_struct_size(StgTSOGranInfo,GRAN);
+ opt_struct_size(StgTSODistInfo,DIST);
+
+ closure_size(StgBlockingQueue);
+ closure_field(StgBlockingQueue, blocking_queue);
+
+ closure_field(StgUpdateFrame, updatee);
+
+ closure_field(StgCatchFrame, handler);
+ closure_field(StgCatchFrame, exceptions_blocked);
+
+ closure_size(StgPAP);
+ closure_field(StgPAP, n_args);
+ closure_field(StgPAP, fun);
+ closure_field(StgPAP, arity);
+ closure_payload(StgPAP, payload);
+
+ closure_size(StgAP);
+ closure_field(StgAP, n_args);
+ closure_field(StgAP, fun);
+ closure_payload(StgAP, payload);
+
+ closure_size(StgAP_STACK);
+ closure_field(StgAP_STACK, size);
+ closure_field(StgAP_STACK, fun);
+ closure_payload(StgAP_STACK, payload);
+
+ closure_field(StgInd, indirectee);
+ closure_field(StgMutClosure, mut_link);
+
+ closure_size(StgMutVar);
+ closure_field(StgMutVar, var);
+
+ closure_size(StgForeignObj);
+ closure_field(StgForeignObj,data);
+
+ closure_size(StgWeak);
+ closure_field(StgWeak,link);
+ closure_field(StgWeak,key);
+ closure_field(StgWeak,value);
+ closure_field(StgWeak,finalizer);
+
+ closure_size(StgMVar);
+ closure_field(StgMVar,head);
+ closure_field(StgMVar,tail);
+ closure_field(StgMVar,value);
+
+ closure_size(StgBCO);
+ closure_field(StgBCO, instrs);
+ closure_field(StgBCO, literals);
+ closure_field(StgBCO, ptrs);
+ closure_field(StgBCO, itbls);
+ closure_field(StgBCO, arity);
+ closure_field(StgBCO, size);
+ closure_payload(StgBCO, bitmap);
+
+ closure_size(StgStableName);
+ closure_field(StgStableName,sn);
+
+ struct_field_("RtsFlags_ProfFlags_showCCSOnException",
+ RTS_FLAGS, ProfFlags.showCCSOnException);
+ struct_field_("RtsFlags_DebugFlags_apply",
+ RTS_FLAGS, DebugFlags.apply);
+ struct_field_("RtsFlags_DebugFlags_sanity",
+ RTS_FLAGS, DebugFlags.sanity);
+ struct_field_("RtsFlags_DebugFlags_weak",
+ RTS_FLAGS, DebugFlags.weak);
+ struct_field_("RtsFlags_GcFlags_initialStkSize",
+ RTS_FLAGS, GcFlags.initialStkSize);
+
+ struct_size(StgFunInfoExtraFwd);
+ struct_field(StgFunInfoExtraFwd, slow_apply);
+ struct_field(StgFunInfoExtraFwd, fun_type);
+ struct_field(StgFunInfoExtraFwd, arity);
+ struct_field(StgFunInfoExtraFwd, bitmap);
+
+ struct_size(StgFunInfoExtraRev);
+ struct_field(StgFunInfoExtraRev, slow_apply);
+ struct_field(StgFunInfoExtraRev, fun_type);
+ struct_field(StgFunInfoExtraRev, arity);
+ struct_field(StgFunInfoExtraRev, bitmap);
+
+ struct_field(StgLargeBitmap, size);
+ field_offset(StgLargeBitmap, bitmap);
+
+ struct_size(snEntry);
+ struct_field(snEntry,sn_obj);
+ struct_field(snEntry,addr);
+
+#ifdef mingw32_TARGET_OS
+ struct_size(StgAsyncIOResult);
+ struct_field(StgAsyncIOResult, reqID);
+ struct_field(StgAsyncIOResult, len);
+ struct_field(StgAsyncIOResult, errCode);
+#endif
+
+ struct_size(MP_INT);
+ struct_field(MP_INT,_mp_alloc);
+ struct_field(MP_INT,_mp_size);
+ struct_field(MP_INT,_mp_d);
+
+ ctype(mp_limb_t);
return 0;
}
+++ /dev/null
-/* --------------------------------------------------------------------------
- * $Id: mkNativeHdr.c,v 1.12 2003/03/21 15:48:06 sof Exp $
- *
- * (c) The GHC Team, 1992-1998
- *
- * Generate a header for the native code generator
- *
- * ------------------------------------------------------------------------*/
-
-#include "Stg.h"
-
-#include <stdio.h>
-
-#define OFFSET(table, x) ((StgUnion *) &(x) - (StgUnion *) (&table))
-
-#define OFFSET_R1 OFFSET(RegTable, RegTable.rR1)
-#define OFFSET_R2 OFFSET(RegTable, RegTable.rR2)
-#define OFFSET_R3 OFFSET(RegTable, RegTable.rR3)
-#define OFFSET_R4 OFFSET(RegTable, RegTable.rR4)
-#define OFFSET_R5 OFFSET(RegTable, RegTable.rR5)
-#define OFFSET_R6 OFFSET(RegTable, RegTable.rR6)
-#define OFFSET_R7 OFFSET(RegTable, RegTable.rR7)
-#define OFFSET_R8 OFFSET(RegTable, RegTable.rR8)
-#define OFFSET_R9 OFFSET(RegTable, RegTable.rR9)
-#define OFFSET_R10 OFFSET(RegTable, RegTable.rR10)
-#define OFFSET_F1 OFFSET(RegTable, RegTable.rF1)
-#define OFFSET_F2 OFFSET(RegTable, RegTable.rF2)
-#define OFFSET_F3 OFFSET(RegTable, RegTable.rF3)
-#define OFFSET_F4 OFFSET(RegTable, RegTable.rF4)
-#define OFFSET_D1 OFFSET(RegTable, RegTable.rD1)
-#define OFFSET_D2 OFFSET(RegTable, RegTable.rD2)
-#define OFFSET_L1 OFFSET(RegTable, RegTable.rL1)
-#define OFFSET_Sp OFFSET(RegTable, RegTable.rSp)
-#define OFFSET_SpLim OFFSET(RegTable, RegTable.rSpLim)
-#define OFFSET_Hp OFFSET(RegTable, RegTable.rHp)
-#define OFFSET_HpLim OFFSET(RegTable, RegTable.rHpLim)
-#define OFFSET_CurrentTSO OFFSET(RegTable, RegTable.rCurrentTSO)
-#define OFFSET_CurrentNursery OFFSET(RegTable, RegTable.rCurrentNursery)
-#define OFFSET_HpAlloc OFFSET(RegTable, RegTable.rHpAlloc)
-
-#define FUN_OFFSET(sym) ((StgPtr)&cap.f.sym - (StgPtr)&cap.r)
-
-#define OFFSET_stgGCEnter1 FUN_OFFSET(stgGCEnter1)
-#define OFFSET_stgGCFun FUN_OFFSET(stgGCFun)
-
-#define OFFW_Capability_r OFFSET(cap, cap.r)
-
-#define TSO_SP OFFSET(tso, tso.sp)
-#define TSO_STACK OFFSET(tso, tso.stack)
-
-#define BDESCR_START OFFSET(bd, bd.start)
-#define BDESCR_FREE OFFSET(bd, bd.free)
-#define BDESCR_BLOCKS OFFSET(bd, bd.blocks)
-
-StgRegTable RegTable;
-
-Capability cap;
-
-StgTSO tso;
-bdescr bd;
-
-int
-main()
-{
- printf("-- This file is created automatically. Do not edit by hand.\n\n");
-
- printf("\n-- Base table offsets for the Native Code Generator\n");
-
- printf("#define OFFSET_R1 %d\n", OFFSET_R1);
- printf("#define OFFSET_R2 %d\n", OFFSET_R2);
- printf("#define OFFSET_R3 %d\n", OFFSET_R3);
- printf("#define OFFSET_R4 %d\n", OFFSET_R4);
- printf("#define OFFSET_R5 %d\n", OFFSET_R5);
- printf("#define OFFSET_R6 %d\n", OFFSET_R6);
- printf("#define OFFSET_R7 %d\n", OFFSET_R7);
- printf("#define OFFSET_R8 %d\n", OFFSET_R8);
- printf("#define OFFSET_R9 %d\n", OFFSET_R9);
- printf("#define OFFSET_R10 %d\n", OFFSET_R10);
- printf("#define OFFSET_F1 %d\n", OFFSET_F1);
- printf("#define OFFSET_F2 %d\n", OFFSET_F2);
- printf("#define OFFSET_F3 %d\n", OFFSET_F3);
- printf("#define OFFSET_F4 %d\n", OFFSET_F4);
- printf("#define OFFSET_D1 %d\n", OFFSET_D1);
- printf("#define OFFSET_D2 %d\n", OFFSET_D2);
-#ifdef SUPPORT_LONG_LONGS
- printf("#define OFFSET_L1 %d\n", OFFSET_L1);
-#endif
- printf("#define OFFSET_Sp %d\n", OFFSET_Sp);
- printf("#define OFFSET_SpLim %d\n", OFFSET_SpLim);
- printf("#define OFFSET_Hp %d\n", OFFSET_Hp);
- printf("#define OFFSET_HpLim %d\n", OFFSET_HpLim);
- printf("#define OFFSET_CurrentTSO %d\n", OFFSET_CurrentTSO);
- printf("#define OFFSET_CurrentNursery %d\n", OFFSET_CurrentNursery);
- printf("#define OFFSET_HpAlloc %d\n", OFFSET_HpAlloc);
-
- printf("#define OFFSET_stgGCEnter1 (%d)\n", OFFSET_stgGCEnter1);
- printf("#define OFFSET_stgGCFun (%d)\n", OFFSET_stgGCFun);
-
- printf("\n-- Offset of the .r (StgRegTable) field in a Capability\n");
-
- printf("#define OFFW_Capability_r (%d)\n", OFFW_Capability_r);
-
- printf("\n-- Storage Manager offsets for the Native Code Generator\n");
-
- printf("\n-- TSO offsets for the Native Code Generator\n");
-
- printf("#define TSO_SP %d\n", TSO_SP);
- printf("#define TSO_STACK %d\n", TSO_STACK);
-
- printf("\n-- Block descriptor offsets for the Native Code Generator\n");
-
- printf("#define BDESCR_START %d\n", BDESCR_START);
- printf("#define BDESCR_FREE %d\n", BDESCR_FREE);
- printf("#define BDESCR_BLOCKS %d\n", BDESCR_BLOCKS);
-
- exit(0);
-}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2004
+ *
+ * Application-related bits.
+ *
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC. It is compiled by GHC directly. For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * -------------------------------------------------------------------------- */
+
+#include "Cmm.h"
+
+/* ----------------------------------------------------------------------------
+ * Evaluate a closure and return it.
+ *
+ * stg_ap_0_info <--- Sp
+ *
+ * NOTE: this needs to be a polymorphic return point, because we can't
+ * be sure that the thing being evaluated is not a function.
+ */
+
+#if MAX_VECTORED_RTN > 8
+#error MAX_VECTORED_RTN has changed: please modify stg_ap_0 too.
+#endif
+
+STRING(stg_ap_0_ret_str,"stg_ap_0_ret... ")
+
+INFO_TABLE_RET( stg_ap_0,
+ 0/*framsize*/, 0/*bitmap*/, RET_SMALL,
+ RET_LBL(stg_ap_0),
+ RET_LBL(stg_ap_0),
+ RET_LBL(stg_ap_0),
+ RET_LBL(stg_ap_0),
+ RET_LBL(stg_ap_0),
+ RET_LBL(stg_ap_0),
+ RET_LBL(stg_ap_0),
+ RET_LBL(stg_ap_0) )
+{
+ // fn is in R1, no args on the stack
+
+ IF_DEBUG(apply,
+ foreign "C" fprintf(stderr, stg_ap_0_ret_str);
+ foreign "C" printClosure(R1 "ptr"));
+
+ IF_DEBUG(sanity,
+ foreign "C" checkStackChunk(Sp+WDS(1) "ptr",
+ CurrentTSO + OFFSET_StgTSO_stack +
+ WDS(StgTSO_stack_size(CurrentTSO)) "ptr"));
+
+ Sp_adj(1);
+ ENTER();
+}
+
+/* -----------------------------------------------------------------------------
+ Entry Code for a PAP.
+
+ This entry code is *only* called by one of the stg_ap functions.
+ On entry: Sp points to the remaining arguments on the stack. If
+ the stack check fails, we can just push the PAP on the stack and
+ return to the scheduler.
+
+ On entry: R1 points to the PAP. The rest of the function's
+ arguments (apart from those that are already in the PAP) are on the
+ stack, starting at Sp(0). R2 contains an info table which
+ describes these arguments, which is used in the event that the
+ stack check in the entry code below fails. The info table is
+ currently one of the stg_ap_*_ret family, as this code is always
+ entered from those functions.
+
+ The idea is to copy the chunk of stack from the PAP object onto the
+ stack / into registers, and enter the function.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_PAP,/*special layout*/0,0,PAP,"PAP","PAP")
+{
+ W_ Words;
+ W_ pap;
+
+ pap = R1;
+
+ Words = TO_W_(StgPAP_n_args(pap));
+
+ //
+ // Check for stack overflow and bump the stack pointer.
+ // We have a hand-rolled stack check fragment here, because none of
+ // the canned ones suit this situation.
+ //
+ if ((Sp - WDS(Words)) < SpLim) {
+ // there is a return address in R2 in the event of a
+ // stack check failure. The various stg_apply functions arrange
+ // this before calling stg_PAP_entry.
+ Sp_adj(-1);
+ Sp(0) = R2;
+ jump stg_gc_unpt_r1;
+ }
+ Sp_adj(-Words);
+
+ // profiling
+ TICK_ENT_PAP();
+ LDV_ENTER(pap);
+ // Enter PAP cost centre
+ ENTER_CCS_PAP_CL(pap);
+
+ R1 = StgPAP_fun(pap);
+
+ // Reload the stack
+ W_ i;
+ W_ p;
+ p = pap + SIZEOF_StgHeader + OFFSET_StgPAP_payload;
+ i = 0;
+for:
+ if (i < Words) {
+ Sp(i) = W_[p];
+ p = p + WDS(1);
+ i = i + 1;
+ goto for;
+ }
+
+ // Off we go!
+ TICK_ENT_VIA_NODE();
+
+#ifdef NO_ARG_REGS
+ jump %GET_ENTRY(R1);
+#else
+ W_ info;
+ info = %GET_FUN_INFO(R1);
+ W_ type;
+ type = TO_W_(StgFunInfoExtra_fun_type(info));
+ if (type == ARG_GEN) {
+ jump StgFunInfoExtra_slow_apply(info);
+ }
+ if (type == ARG_GEN_BIG) {
+ jump StgFunInfoExtra_slow_apply(info);
+ }
+ if (type == ARG_BCO) {
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_apply_interp_info;
+ jump stg_yield_to_interpreter;
+ }
+ jump W_[stg_ap_stack_entries +
+ WDS(TO_W_(StgFunInfoExtra_fun_type(info)))];
+#endif
+}
+
+/* -----------------------------------------------------------------------------
+ Entry Code for an AP (a PAP with arity zero).
+
+ The entry code is very similar to a PAP, except there are no
+ further arguments on the stack to worry about, so the stack check
+ is simpler. We must also push an update frame on the stack before
+ applying the function.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_AP,/*special layout*/0,0,AP,"AP","AP")
+{
+ W_ Words;
+ W_ ap;
+
+ ap = R1;
+
+ Words = TO_W_(StgAP_n_args(ap));
+
+ /*
+ * Check for stack overflow. IMPORTANT: use a _NP check here,
+ * because if the check fails, we might end up blackholing this very
+ * closure, in which case we must enter the blackhole on return rather
+ * than continuing to evaluate the now-defunct closure.
+ */
+ STK_CHK_NP(WDS(Words) + SIZEOF_StgUpdateFrame);
+
+ PUSH_UPD_FRAME(Sp - SIZEOF_StgUpdateFrame, R1);
+ Sp = Sp - SIZEOF_StgUpdateFrame - WDS(Words);
+
+ TICK_ENT_AP();
+ LDV_ENTER(ap);
+
+ // Enter PAP cost centre
+ ENTER_CCS_PAP_CL(ap); // ToDo: ENTER_CC_AP_CL
+
+ R1 = StgAP_fun(ap);
+
+ // Reload the stack
+ W_ i;
+ W_ p;
+ p = ap + SIZEOF_StgHeader + OFFSET_StgAP_payload;
+ i = 0;
+for:
+ if (i < Words) {
+ Sp(i) = W_[p];
+ p = p + WDS(1);
+ i = i + 1;
+ goto for;
+ }
+
+ // Off we go!
+ TICK_ENT_VIA_NODE();
+
+#ifdef NO_ARG_REGS
+ jump %GET_ENTRY(R1);
+#else
+ W_ info;
+ info = %GET_FUN_INFO(R1);
+ W_ type;
+ type = TO_W_(StgFunInfoExtra_fun_type(info));
+ if (type == ARG_GEN) {
+ jump StgFunInfoExtra_slow_apply(info);
+ }
+ if (type == ARG_GEN_BIG) {
+ jump StgFunInfoExtra_slow_apply(info);
+ }
+ if (type == ARG_BCO) {
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_apply_interp_info;
+ jump stg_yield_to_interpreter;
+ }
+ jump W_[stg_ap_stack_entries +
+ WDS(TO_W_(StgFunInfoExtra_fun_type(info)))];
+#endif
+}
+
+/* -----------------------------------------------------------------------------
+ Entry Code for an AP_STACK.
+
+ Very similar to a PAP and AP. The layout is the same as PAP
+ and AP, except that the payload is a chunk of stack instead of
+ being described by the function's info table. Like an AP,
+ there are no further arguments on the stack to worry about.
+ However, the function closure (ap->fun) does not necessarily point
+ directly to a function, so we have to enter it using stg_ap_0.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK")
+{
+ W_ Words;
+ W_ ap;
+
+ ap = R1;
+
+ Words = StgAP_STACK_size(ap);
+
+ /*
+ * Check for stack overflow. IMPORTANT: use a _NP check here,
+ * because if the check fails, we might end up blackholing this very
+ * closure, in which case we must enter the blackhole on return rather
+ * than continuing to evaluate the now-defunct closure.
+ */
+ STK_CHK_NP(WDS(Words) + SIZEOF_StgUpdateFrame);
+
+ PUSH_UPD_FRAME(Sp - SIZEOF_StgUpdateFrame, R1);
+ Sp = Sp - SIZEOF_StgUpdateFrame - WDS(Words);
+
+ TICK_ENT_AP();
+ LDV_ENTER(ap);
+
+ // Enter PAP cost centre
+ ENTER_CCS_PAP_CL(ap); // ToDo: ENTER_CC_AP_CL
+
+ R1 = StgAP_STACK_fun(ap);
+
+ // Reload the stack
+ W_ i;
+ W_ p;
+ p = ap + SIZEOF_StgHeader + OFFSET_StgAP_STACK_payload;
+ i = 0;
+for:
+ if (i < Words) {
+ Sp(i) = W_[p];
+ p = p + WDS(1);
+ i = i + 1;
+ goto for;
+ }
+
+ // Off we go!
+ TICK_ENT_VIA_NODE();
+
+ ENTER();
+}
-// -----------------------------------------------------------------------------
-// Apply.h
-//
-// (c) The University of Glasgow 2002
-//
-// Helper bits for the generic apply code (AutoApply.hc)
-// -----------------------------------------------------------------------------
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2002-2004
+ *
+ * Declarations for things defined in AutoApply.cmm
+ *
+ * -------------------------------------------------------------------------- */
#ifndef APPLY_H
#define APPLY_H
-// Build a new PAP: function is in R1,p
-// ret addr and m arguments taking up n words are on the stack.
-#define BUILD_PAP(m,n,f) \
- { \
- StgPAP *pap; \
- nat size, i; \
- TICK_SLOW_CALL_BUILT_PAP(); \
- size = PAP_sizeW(n); \
- HP_CHK_NP(size, Sp[0] = f;); \
- TICK_ALLOC_PAP(n, 0); \
- pap = (StgPAP *) (Hp + 1 - size); \
- SET_HDR(pap, &stg_PAP_info, CCCS); \
- pap->arity = arity - m; \
- pap->fun = R1.cl; \
- pap->n_args = n; \
- for (i = 0; i < n; i++) { \
- pap->payload[i] = (StgClosure *)Sp[1+i]; \
- } \
- R1.p = (P_)pap; \
- Sp += 1 + n; \
- JMP_(ENTRY_CODE(Sp[0])); \
- }
-
-// Copy the old PAP, build a new one with the extra arg(s)
-// ret addr and m arguments taking up n words are on the stack.
-#define NEW_PAP(m,n,f) \
- { \
- StgPAP *pap, *new_pap; \
- nat size, i; \
- TICK_SLOW_CALL_NEW_PAP(); \
- pap = (StgPAP *)R1.p; \
- size = PAP_sizeW(pap->n_args + n); \
- HP_CHK_NP(size, Sp[0] = f;); \
- TICK_ALLOC_PAP(n, 0); \
- new_pap = (StgPAP *) (Hp + 1 - size); \
- SET_HDR(new_pap, &stg_PAP_info, CCCS); \
- new_pap->arity = arity - m; \
- new_pap->n_args = pap->n_args + n; \
- new_pap->fun = pap->fun; \
- for (i = 0; i < pap->n_args; i++) { \
- new_pap->payload[i] = pap->payload[i]; \
- } \
- for (i = 0; i < n; i++) { \
- new_pap->payload[pap->n_args+i] = (StgClosure *)Sp[1+i]; \
- } \
- R1.p = (P_)new_pap; \
- Sp += n+1; \
- JMP_(ENTRY_CODE(Sp[0])); \
- }
-
// canned slow entry points, indexed by arg type (ARG_P, ARG_PP, etc.)
-extern StgFun * stg_ap_stack_entries[];
+#ifdef IN_STG_CODE
+extern StgWord stg_ap_stack_entries[];
+#else
+extern StgFun *stg_ap_stack_entries[];
+#endif
// canned register save code for heap check failure in a function
-extern StgFun * stg_stack_save_entries[];
+#ifdef IN_STG_CODE
+extern StgWord stg_stack_save_entries[];
+#else
+extern StgFun *stg_stack_save_entries[];
+#endif
// canned bitmap for each arg type
extern StgWord stg_arg_bitmaps[];
#endif // APPLY_H
-
+++ /dev/null
-// -----------------------------------------------------------------------------
-// Apply.hc
-//
-// (c) The University of Glasgow 2002
-//
-// Application-related bits.
-//
-// -----------------------------------------------------------------------------
-
-#include "Stg.h"
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "Storage.h"
-#include "RtsUtils.h"
-#include "Printer.h"
-#include "Sanity.h"
-#include "Apply.h"
-
-#include <stdio.h>
-
-// ----------------------------------------------------------------------------
-// Evaluate a closure and return it.
-//
-// stg_ap_0_info <--- Sp
-//
-// NOTE: this needs to be a polymorphic return point, because we can't
-// be sure that the thing being evaluated is not a function.
-
-// These names are just to keep VEC_POLY_INFO_TABLE() happy - all the
-// entry points in the polymorphic info table point to the same code.
-#define stg_ap_0_0_ret stg_ap_0_ret
-#define stg_ap_0_1_ret stg_ap_0_ret
-#define stg_ap_0_2_ret stg_ap_0_ret
-#define stg_ap_0_3_ret stg_ap_0_ret
-#define stg_ap_0_4_ret stg_ap_0_ret
-#define stg_ap_0_5_ret stg_ap_0_ret
-#define stg_ap_0_6_ret stg_ap_0_ret
-#define stg_ap_0_7_ret stg_ap_0_ret
-
-VEC_POLY_INFO_TABLE(stg_ap_0,
- MK_SMALL_BITMAP(0/*framsize*/, 0/*bitmap*/),
- 0,0,0,RET_SMALL,,EF_);
-F_
-stg_ap_0_ret(void)
-{
- // fn is in R1, no args on the stack
- StgInfoTable *info;
- nat arity;
- FB_;
-
- IF_DEBUG(apply,fprintf(stderr, "stg_ap_0_ret... "); printClosure(R1.cl));
- IF_DEBUG(sanity,checkStackChunk(Sp+1,CurrentTSO->stack + CurrentTSO->stack_size));
-
- Sp++;
- ENTER();
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Entry Code for a PAP.
-
- This entry code is *only* called by one of the stg_ap functions.
- On entry: Sp points to the remaining arguments on the stack. If
- the stack check fails, we can just push the PAP on the stack and
- return to the scheduler.
-
- On entry: R1 points to the PAP. The rest of the function's
- arguments (apart from those that are already in the PAP) are on the
- stack, starting at Sp[0]. R2 contains an info table which
- describes these arguments, which is used in the event that the
- stack check in the entry code below fails. The info table is
- currently one of the stg_ap_*_ret family, as this code is always
- entered from those functions.
-
- The idea is to copy the chunk of stack from the PAP object onto the
- stack / into registers, and enter the function.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_PAP_info,stg_PAP_entry,/*special layout*/0,0,PAP,,EF_,"PAP","PAP");
-STGFUN(stg_PAP_entry)
-{
- nat Words;
- StgPtr p;
- nat i;
- StgPAP *pap;
- FB_
-
- pap = (StgPAP *) R1.p;
-
- Words = pap->n_args;
-
- // Check for stack overflow and bump the stack pointer.
- // We have a hand-rolled stack check fragment here, because none of
- // the canned ones suit this situation.
- if ((Sp - Words) < SpLim) {
- // there is a return address in R2 in the event of a
- // stack check failure. The various stg_apply functions arrange
- // this before calling stg_PAP_entry.
- Sp--;
- Sp[0] = R2.w;
- JMP_(stg_gc_unpt_r1);
- }
- Sp -= Words;
-
- // profiling
- TICK_ENT_PAP(pap);
- LDV_ENTER(pap);
- // Enter PAP cost centre -- lexical scoping only
- ENTER_CCS_PAP_CL(pap);
-
- R1.cl = pap->fun;
- p = (P_)(pap->payload);
-
- // Reload the stack
- for (i=0; i<Words; i++) {
- Sp[i] = (W_) *p++;
- }
-
- // Off we go!
- TICK_ENT_VIA_NODE();
-
-#ifdef NO_ARG_REGS
- JMP_(GET_ENTRY(R1.cl));
-#else
- {
- StgFunInfoTable *info;
- info = get_fun_itbl(R1.cl);
- if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
- JMP_(info->slow_apply);
- } else if (info->fun_type == ARG_BCO) {
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_apply_interp_info;
- JMP_(stg_yield_to_interpreter);
- } else {
- JMP_(stg_ap_stack_entries[info->fun_type]);
- }
- }
-#endif
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Entry Code for an AP (a PAP with arity zero).
-
- The entry code is very similar to a PAP, except there are no
- further arguments on the stack to worry about, so the stack check
- is simpler. We must also push an update frame on the stack before
- applying the function.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_AP_info,stg_AP_entry,/*special layout*/0,0,AP,,EF_,"AP","AP");
-STGFUN(stg_AP_entry)
-{
- nat Words;
- P_ p;
- nat i;
- StgAP *ap;
-
- FB_
-
- ap = (StgAP *) R1.p;
-
- Words = ap->n_args;
-
- // Check for stack overflow. IMPORTANT: use a _NP check here,
- // because if the check fails, we might end up blackholing this very
- // closure, in which case we must enter the blackhole on return rather
- // than continuing to evaluate the now-defunct closure.
- STK_CHK_NP(Words+sizeofW(StgUpdateFrame),);
-
- PUSH_UPD_FRAME(R1.p, 0);
- Sp -= sizeofW(StgUpdateFrame) + Words;
-
- TICK_ENT_AP(ap);
- LDV_ENTER(ap);
-
- // Enter PAP cost centre -- lexical scoping only
- ENTER_CCS_PAP_CL(ap); /* ToDo: ENTER_CC_AP_CL */
-
- R1.cl = ap->fun;
- p = (P_)(ap->payload);
-
- // Reload the stack
- for (i=0; i<Words; i++) Sp[i] = (W_) *p++;
-
- // Off we go!
- TICK_ENT_VIA_NODE();
-
-#ifdef NO_ARG_REGS
- JMP_(GET_ENTRY(R1.cl));
-#else
- {
- StgFunInfoTable *info;
- info = get_fun_itbl(R1.cl);
- if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
- JMP_(info->slow_apply);
- } else if (info->fun_type == ARG_BCO) {
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_apply_interp_info;
- JMP_(stg_yield_to_interpreter);
- } else {
- JMP_(stg_ap_stack_entries[info->fun_type]);
- }
- }
-#endif
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Entry Code for an AP_STACK.
-
- Very similar to a PAP and AP. The layout is the same as PAP
- and AP, except that the payload is a chunk of stack instead of
- being described by the function's info table. Like an AP,
- there are no further arguments on the stack to worry about.
- However, the function closure (ap->fun) does not necessarily point
- directly to a function, so we have to enter it using stg_ap_0.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_AP_STACK_info,stg_AP_STACK_entry,/*special layout*/0,0,AP_STACK,,EF_,"AP_STACK","AP_STACK");
-STGFUN(stg_AP_STACK_entry)
-{
- nat Words;
- P_ p;
- nat i;
- StgAP_STACK *ap;
-
- FB_
-
- ap = (StgAP_STACK *) R1.p;
-
- Words = ap->size;
-
- // Check for stack overflow. IMPORTANT: use a _NP check here,
- // because if the check fails, we might end up blackholing this very
- // closure, in which case we must enter the blackhole on return rather
- // than continuing to evaluate the now-defunct closure.
- STK_CHK_NP(Words+sizeofW(StgUpdateFrame),);
-
- PUSH_UPD_FRAME(R1.p, 0);
- Sp -= sizeofW(StgUpdateFrame) + Words;
-
- TICK_ENT_AP(ap);
- LDV_ENTER(ap);
-
- // Enter PAP cost centre -- lexical scoping only */
- ENTER_CCS_PAP_CL(ap); /* ToDo: ENTER_CC_AP_STACK_CL */
-
- R1.cl = ap->fun;
- p = (P_)(ap->payload);
-
- // Reload the stack
- for (i=0; i<Words; i++) Sp[i] = (W_) *p++;
-
- // Off we go!
- TICK_ENT_VIA_NODE();
- ENTER();
- FE_
-}
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2002-2004
+ *
+ * Helper bits for the generic apply code (AutoApply.hc)
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef AUTOAPPLY_H
+#define AUTOAPPLY_H
+
+// Build a new PAP: function is in R1
+// ret addr and m arguments taking up n words are on the stack.
+// NB. x is a dummy argument attached to the 'for' label so that
+// BUILD_PAP can be used multiple times in the same function.
+#define BUILD_PAP(m,n,f,x) \
+ W_ pap; \
+ W_ size; \
+ W_ i; \
+ size = SIZEOF_StgPAP + WDS(n); \
+ HP_CHK_NP_ASSIGN_SP0(size,f); \
+ TICK_ALLOC_HEAP_NOCTR(BYTES_TO_WDS(size)); \
+ TICK_ALLOC_PAP(n+1 /* +1 for the FUN */, 0); \
+ pap = Hp + WDS(1) - size; \
+ SET_HDR(pap, stg_PAP_info, W_[CCCS]); \
+ StgPAP_arity(pap) = HALF_W_(arity - m); \
+ StgPAP_fun(pap) = R1; \
+ StgPAP_n_args(pap) = HALF_W_(n); \
+ i = 0; \
+ for##x: \
+ if (i < n) { \
+ StgPAP_payload(pap,i) = Sp(1+i); \
+ i = i + 1; \
+ goto for##x; \
+ } \
+ R1 = pap; \
+ Sp_adj(1 + n); \
+ jump %ENTRY_CODE(Sp(0));
+
+// Copy the old PAP, build a new one with the extra arg(s)
+// ret addr and m arguments taking up n words are on the stack.
+// NB. x is a dummy argument attached to the 'for' label so that
+// BUILD_PAP can be used multiple times in the same function.
+#define NEW_PAP(m,n,f,x) \
+ W_ pap; \
+ W_ new_pap; \
+ W_ size; \
+ W_ i; \
+ pap = R1; \
+ size = SIZEOF_StgPAP + WDS(TO_W_(StgPAP_n_args(pap))) + WDS(n); \
+ HP_CHK_NP_ASSIGN_SP0(size,f); \
+ TICK_ALLOC_HEAP_NOCTR(BYTES_TO_WDS(size)); \
+ TICK_ALLOC_PAP(n+1 /* +1 for the FUN */, 0); \
+ new_pap = Hp + WDS(1) - size; \
+ SET_HDR(new_pap, stg_PAP_info, W_[CCCS]); \
+ StgPAP_arity(new_pap) = HALF_W_(arity - m); \
+ W_ n_args; \
+ n_args = TO_W_(StgPAP_n_args(pap)); \
+ StgPAP_n_args(new_pap) = HALF_W_(n_args + n); \
+ StgPAP_fun(new_pap) = StgPAP_fun(pap); \
+ i = 0; \
+ for1##x: \
+ if (i < n_args) { \
+ StgPAP_payload(new_pap,i) = StgPAP_payload(pap,i); \
+ i = i + 1; \
+ goto for1##x; \
+ } \
+ i = 0; \
+ for2##x: \
+ if (i < n) { \
+ StgPAP_payload(new_pap,n_args+i) = Sp(1+i); \
+ i = i + 1; \
+ goto for2##x; \
+ } \
+ R1 = new_pap; \
+ Sp_adj(n+1); \
+ jump %ENTRY_CODE(Sp(0));
+
+#endif // APPLY_H
+
#ifndef __CAPABILITY_H__
#define __CAPABILITY_H__
-#if !defined(SMP)
-extern Capability MainCapability;
-#endif
-
// Initialised the available capabilities.
//
extern void initCapabilities( void );
* Copyright (c) 1994-2002.
*
* $RCSfile: Disassembler.c,v $
- * $Revision: 1.27 $
- * $Date: 2003/03/25 17:04:09 $
+ * $Revision: 1.28 $
+ * $Date: 2004/08/13 13:09:46 $
* ---------------------------------------------------------------------------*/
#ifdef DEBUG
case bci_PUSH_APPLY_PPPPPP:
fprintf(stderr, "PUSH_APPLY_PPPPPP\n");
break;
- case bci_PUSH_APPLY_PPPPPPP:
- fprintf(stderr, "PUSH_APPLY_PPPPPPP\n");
- break;
case bci_SLIDE:
fprintf(stderr, "SLIDE %d down by %d\n", instrs[pc], instrs[pc+1] );
pc += 2; break;
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Exception support
+ *
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC. It is compiled by GHC directly. For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Cmm.h"
+
+/* -----------------------------------------------------------------------------
+ Exception Primitives
+
+ A thread can request that asynchronous exceptions not be delivered
+ ("blocked") for the duration of an I/O computation. The primitive
+
+ blockAsyncExceptions# :: IO a -> IO a
+
+ is used for this purpose. During a blocked section, asynchronous
+ exceptions may be unblocked again temporarily:
+
+ unblockAsyncExceptions# :: IO a -> IO a
+
+ Furthermore, asynchronous exceptions are blocked automatically during
+ the execution of an exception handler. Both of these primitives
+ leave a continuation on the stack which reverts to the previous
+ state (blocked or unblocked) on exit.
+
+ A thread which wants to raise an exception in another thread (using
+ killThread#) must block until the target thread is ready to receive
+ it. The action of unblocking exceptions in a thread will release all
+ the threads waiting to deliver exceptions to that thread.
+
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
+ 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+{
+ ASSERT(StgTSO_blocked_exceptions(CurrentTSO) != NULL);
+#if defined(GRAN) || defined(PAR)
+ foreign "C" awakenBlockedQueue(StgTSO_blocked_exceptions(CurrentTSO) "ptr",
+ NULL "ptr");
+#else
+ foreign "C" awakenBlockedQueue(StgTSO_blocked_exceptions(CurrentTSO) "ptr");
+#endif
+ StgTSO_blocked_exceptions(CurrentTSO) = NULL;
+#ifdef REG_R1
+ Sp_adj(1);
+ jump %ENTRY_CODE(Sp(0));
+#else
+ Sp(1) = Sp(0);
+ Sp_adj(1);
+ jump %ENTRY_CODE(Sp(1));
+#endif
+}
+
+INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret,
+ 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+{
+ ASSERT(StgTSO_blocked_exceptions(CurrentTSO) == NULL);
+ StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
+#ifdef REG_R1
+ Sp_adj(1);
+ jump %ENTRY_CODE(Sp(0));
+#else
+ Sp(1) = Sp(0);
+ Sp_adj(1);
+ jump %ENTRY_CODE(Sp(1));
+#endif
+}
+
+blockAsyncExceptionszh_fast
+{
+ /* Args: R1 :: IO a */
+ STK_CHK_GEN( WDS(2)/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
+
+ if (StgTSO_blocked_exceptions(CurrentTSO) == NULL) {
+ StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
+ /* avoid growing the stack unnecessarily */
+ if (Sp(0) == stg_blockAsyncExceptionszh_ret_info) {
+ Sp_adj(1);
+ } else {
+ Sp_adj(-1);
+ Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
+ }
+ }
+ Sp_adj(-1);
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_v();
+ jump RET_LBL(stg_ap_v);
+}
+
+unblockAsyncExceptionszh_fast
+{
+ /* Args: R1 :: IO a */
+ STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
+
+ if (StgTSO_blocked_exceptions(CurrentTSO) != NULL) {
+#if defined(GRAN) || defined(PAR)
+ foreign "C" awakenBlockedQueue(StgTSO_blocked_exceptions(CurrentTSO) "ptr",
+ StgTSO_block_info(CurrentTSO) "ptr");
+#else
+ foreign "C" awakenBlockedQueue(StgTSO_blocked_exceptions(CurrentTSO) "ptr");
+#endif
+ StgTSO_blocked_exceptions(CurrentTSO) = NULL;
+
+ /* avoid growing the stack unnecessarily */
+ if (Sp(0) == stg_unblockAsyncExceptionszh_ret_info) {
+ Sp_adj(1);
+ } else {
+ Sp_adj(-1);
+ Sp(0) = stg_blockAsyncExceptionszh_ret_info;
+ }
+ }
+ Sp_adj(-1);
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_v();
+ jump RET_LBL(stg_ap_v);
+}
+
+
+#define interruptible(what_next) \
+ ( what_next == BlockedOnMVar \
+ || what_next == BlockedOnException \
+ || what_next == BlockedOnRead \
+ || what_next == BlockedOnWrite \
+ || what_next == BlockedOnDelay \
+ || what_next == BlockedOnDoProc)
+
+killThreadzh_fast
+{
+ /* args: R1 = TSO to kill, R2 = Exception */
+
+ W_ why_blocked;
+
+ /* This thread may have been relocated.
+ * (see Schedule.c:threadStackOverflow)
+ */
+ while:
+ if (StgTSO_what_next(R1) == ThreadRelocated::I16) {
+ R1 = StgTSO_link(R1);
+ goto while;
+ }
+
+ /* Determine whether this thread is interruptible or not */
+
+ /* If the target thread is currently blocking async exceptions,
+ * we'll have to block until it's ready to accept them. The
+ * exception is interruptible threads - ie. those that are blocked
+ * on some resource.
+ */
+ why_blocked = TO_W_(StgTSO_why_blocked(R1));
+ if (StgTSO_blocked_exceptions(R1) != NULL && !interruptible(why_blocked))
+ {
+ StgTSO_link(CurrentTSO) = StgTSO_blocked_exceptions(R1);
+ StgTSO_blocked_exceptions(R1) = CurrentTSO;
+
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnException::I16;
+ StgTSO_block_info(CurrentTSO) = R1;
+
+ BLOCK( R1_PTR & R2_PTR, killThreadzh_fast );
+ }
+
+ /* Killed threads turn into zombies, which might be garbage
+ * collected at a later date. That's why we don't have to
+ * explicitly remove them from any queues they might be on.
+ */
+
+ /* We might have killed ourselves. In which case, better be *very*
+ * careful. If the exception killed us, then return to the scheduler.
+ * If the exception went to a catch frame, we'll just continue from
+ * the handler.
+ */
+ if (R1 == CurrentTSO) {
+ SAVE_THREAD_STATE();
+ foreign "C" raiseAsyncWithLock(R1 "ptr", R2 "ptr");
+ if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
+ R1 = ThreadFinished;
+ jump StgReturn;
+ } else {
+ LOAD_THREAD_STATE();
+ ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+ jump %ENTRY_CODE(Sp(0));
+ }
+ } else {
+ foreign "C" raiseAsyncWithLock(R1 "ptr", R2 "ptr");
+ }
+
+ jump %ENTRY_CODE(Sp(0));
+}
+
+/* -----------------------------------------------------------------------------
+ Catch frames
+ -------------------------------------------------------------------------- */
+
+#ifdef REG_R1
+#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \
+ label \
+ { \
+ Sp = Sp + SIZEOF_StgCatchFrame; \
+ jump ret; \
+ }
+#else
+#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \
+ label \
+ { \
+ W_ rval; \
+ rval = Sp(0); \
+ Sp_adj(1); \
+ Sp = Sp + SIZEOF_StgCatchFrame - WDS(1); \
+ Sp(0) = rval; \
+ jump ret; \
+ }
+#endif
+
+#ifdef REG_R1
+#define SP_OFF 0
+#else
+#define SP_OFF 1
+#endif
+
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_0_ret,%RET_VEC(Sp(SP_OFF),0))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_1_ret,%RET_VEC(Sp(SP_OFF),1))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_2_ret,%RET_VEC(Sp(SP_OFF),2))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_3_ret,%RET_VEC(Sp(SP_OFF),3))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_4_ret,%RET_VEC(Sp(SP_OFF),4))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_5_ret,%RET_VEC(Sp(SP_OFF),5))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_6_ret,%RET_VEC(Sp(SP_OFF),6))
+CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_7_ret,%RET_VEC(Sp(SP_OFF),7))
+
+#if MAX_VECTORED_RTN > 8
+#error MAX_VECTORED_RTN has changed: please modify stg_catch_frame too.
+#endif
+
+#if defined(PROFILING)
+#define CATCH_FRAME_BITMAP 7
+#define CATCH_FRAME_WORDS 4
+#else
+#define CATCH_FRAME_BITMAP 1
+#define CATCH_FRAME_WORDS 2
+#endif
+
+/* Catch frames are very similar to update frames, but when entering
+ * one we just pop the frame off the stack and perform the correct
+ * kind of return to the activation record underneath us on the stack.
+ */
+
+INFO_TABLE_RET(stg_catch_frame,
+ CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP,
+ CATCH_FRAME,
+ stg_catch_frame_0_ret,
+ stg_catch_frame_1_ret,
+ stg_catch_frame_2_ret,
+ stg_catch_frame_3_ret,
+ stg_catch_frame_4_ret,
+ stg_catch_frame_5_ret,
+ stg_catch_frame_6_ret,
+ stg_catch_frame_7_ret)
+CATCH_FRAME_ENTRY_TEMPLATE(,%ENTRY_CODE(Sp(SP_OFF)))
+
+/* -----------------------------------------------------------------------------
+ * The catch infotable
+ *
+ * This should be exactly the same as would be generated by this STG code
+ *
+ * catch = {x,h} \n {} -> catch#{x,h}
+ *
+ * It is used in deleteThread when reverting blackholes.
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_catch,2,0,FUN,"catch","catch")
+{
+ R2 = StgClosure_payload(R1,1); /* h */
+ R1 = StgClosure_payload(R1,0); /* x */
+ jump catchzh_fast;
+}
+
+catchzh_fast
+{
+ /* args: R1 = m :: IO a, R2 = handler :: Exception -> IO a */
+ STK_CHK_GEN(SIZEOF_StgCatchFrame + WDS(1), R1_PTR & R2_PTR, catchzh_fast);
+
+ /* Set up the catch frame */
+ Sp = Sp - SIZEOF_StgCatchFrame;
+ SET_HDR(Sp,stg_catch_frame_info,CCCS);
+
+ StgCatchFrame_handler(Sp) = R2;
+ StgCatchFrame_exceptions_blocked(Sp) =
+ (StgTSO_blocked_exceptions(CurrentTSO) != NULL);
+ TICK_CATCHF_PUSHED();
+
+ /* Apply R1 to the realworld token */
+ Sp_adj(-1);
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_v();
+ jump RET_LBL(stg_ap_v);
+}
+
+/* -----------------------------------------------------------------------------
+ * The raise infotable
+ *
+ * This should be exactly the same as would be generated by this STG code
+ *
+ * raise = {err} \n {} -> raise#{err}
+ *
+ * It is used in raisezh_fast to update thunks on the update list
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_raise,1,0,THUNK,"raise","raise")
+{
+ R1 = StgClosure_payload(R1,0);
+ jump raisezh_fast;
+}
+
+raisezh_fast
+{
+ W_ handler;
+ W_ raise_closure;
+ W_ frame_type;
+ /* args : R1 :: Exception */
+
+
+#if defined(PROFILING)
+ /* Debugging tool: on raising an exception, show where we are. */
+
+ /* ToDo: currently this is a hack. Would be much better if
+ * the info was only displayed for an *uncaught* exception.
+ */
+ if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags)) {
+ foreign "C" fprintCCS(stderr,CCCS);
+ }
+#endif
+
+ StgTSO_sp(CurrentTSO) = Sp;
+ frame_type = foreign "C" raiseExceptionHelper(CurrentTSO "ptr", R1 "ptr");
+ Sp = StgTSO_sp(CurrentTSO);
+
+ if (frame_type == STOP_FRAME) {
+ /* We've stripped the entire stack, the thread is now dead. */
+ Sp = CurrentTSO + OFFSET_StgTSO_stack
+ + WDS(StgTSO_stack_size(CurrentTSO)) - WDS(1);
+ Sp(0) = R1; /* save the exception */
+ StgTSO_what_next(CurrentTSO) = ThreadKilled::I16;
+ SAVE_THREAD_STATE(); /* inline! */
+ R1 = ThreadFinished;
+ jump StgReturn;
+ }
+
+ /* Ok, Sp points to the enclosing CATCH_FRAME. Pop everything down to
+ * and including this frame, update Su, push R1, and enter the handler.
+ */
+ handler = StgCatchFrame_handler(Sp);
+
+ /* Restore the blocked/unblocked state for asynchronous exceptions
+ * at the CATCH_FRAME.
+ *
+ * If exceptions were unblocked, arrange that they are unblocked
+ * again after executing the handler by pushing an
+ * unblockAsyncExceptions_ret stack frame.
+ */
+ W_ frame;
+ frame = Sp;
+ Sp = Sp + SIZEOF_StgCatchFrame;
+
+ if (StgCatchFrame_exceptions_blocked(frame) == 0) {
+ Sp_adj(-1);
+ Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
+ }
+
+ /* Ensure that async excpetions are blocked when running the handler.
+ */
+ if (StgTSO_blocked_exceptions(CurrentTSO) == NULL) {
+ StgTSO_blocked_exceptions(CurrentTSO) = END_TSO_QUEUE;
+ }
+
+ /* Call the handler, passing the exception value and a realworld
+ * token as arguments.
+ */
+ Sp_adj(-1);
+ Sp(0) = R1;
+ R1 = handler;
+ Sp_adj(-1);
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_pv();
+ jump RET_LBL(stg_ap_pv);
+}
+
+raiseIOzh_fast
+{
+ /* Args :: R1 :: Exception */
+ jump raisezh_fast;
+}
/* -----------------------------------------------------------------------------
- * $Id: Exception.h,v 1.8 2004/03/01 14:18:35 simonmar Exp $
+ * $Id: Exception.h,v 1.9 2004/08/13 13:09:46 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
return 0;
}
}
+
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: Exception.hc,v 1.29 2003/06/26 20:47:08 panne Exp $
- *
- * (c) The GHC Team, 1998-2000
- *
- * Exception support
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Stg.h"
-#include "Rts.h"
-#include "Exception.h"
-#include "Schedule.h"
-#include "StgRun.h"
-#include "Storage.h"
-#include "RtsUtils.h"
-#include "RtsFlags.h"
-#if defined(PAR)
-# include "FetchMe.h"
-#endif
-#if defined(PROFILING)
-# include "Profiling.h"
-#endif
-
-/* -----------------------------------------------------------------------------
- Exception Primitives
-
- A thread can request that asynchronous exceptions not be delivered
- ("blocked") for the duration of an I/O computation. The primitive
-
- blockAsyncExceptions# :: IO a -> IO a
-
- is used for this purpose. During a blocked section, asynchronous
- exceptions may be unblocked again temporarily:
-
- unblockAsyncExceptions# :: IO a -> IO a
-
- Furthermore, asynchronous exceptions are blocked automatically during
- the execution of an exception handler. Both of these primitives
- leave a continuation on the stack which reverts to the previous
- state (blocked or unblocked) on exit.
-
- A thread which wants to raise an exception in another thread (using
- killThread#) must block until the target thread is ready to receive
- it. The action of unblocking exceptions in a thread will release all
- the threads waiting to deliver exceptions to that thread.
-
- -------------------------------------------------------------------------- */
-
-FN_(blockAsyncExceptionszh_fast)
-{
- FB_
- /* Args: R1 :: IO a */
- STK_CHK_GEN( 2/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
-
- if (CurrentTSO->blocked_exceptions == NULL) {
- CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
- /* avoid growing the stack unnecessarily */
- if (Sp[0] == (W_)&stg_blockAsyncExceptionszh_ret_info) {
- Sp++;
- } else {
- Sp--;
- Sp[0] = (W_)&stg_unblockAsyncExceptionszh_ret_info;
- }
- }
- Sp--;
- JMP_(stg_ap_v_ret);
- FE_
-}
-
-INFO_TABLE_RET( \
- stg_unblockAsyncExceptionszh_ret_info, \
- stg_unblockAsyncExceptionszh_ret_entry, \
- MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/), \
- 0, 0, 0, RET_SMALL, , EF_, 0, 0 \
-);
-
-FN_(stg_unblockAsyncExceptionszh_ret_entry)
-{
- FB_
- ASSERT(CurrentTSO->blocked_exceptions != NULL);
-#if defined(GRAN)
- awakenBlockedQueue(CurrentTSO->blocked_exceptions,
- (StgClosure*)NULL);
-#elif defined(PAR)
- /* we don't need node info (2nd arg) in this case
- (note that CurrentTSO->block_info.closure isn't always set) */
- awakenBlockedQueue(CurrentTSO->blocked_exceptions,
- (StgClosure*)NULL);
-#else
- awakenBlockedQueue(CurrentTSO->blocked_exceptions);
-#endif
- CurrentTSO->blocked_exceptions = NULL;
-#ifdef REG_R1
- Sp++;
- JMP_(ENTRY_CODE(Sp[0]));
-#else
- Sp[1] = Sp[0];
- Sp++;
- JMP_(ENTRY_CODE(Sp[1]));
-#endif
- FE_
-}
-
-FN_(unblockAsyncExceptionszh_fast)
-{
- FB_
- /* Args: R1 :: IO a */
- STK_CHK_GEN(2, R1_PTR, unblockAsyncExceptionszh_fast);
-
- if (CurrentTSO->blocked_exceptions != NULL) {
-#if defined(GRAN)
- awakenBlockedQueue(CurrentTSO->blocked_exceptions,
- CurrentTSO->block_info.closure);
-#elif defined(PAR)
- // is CurrentTSO->block_info.closure always set to the node
- // holding the blocking queue !? -- HWL
- awakenBlockedQueue(CurrentTSO->blocked_exceptions,
- CurrentTSO->block_info.closure);
-#else
- awakenBlockedQueue(CurrentTSO->blocked_exceptions);
-#endif
- CurrentTSO->blocked_exceptions = NULL;
-
- /* avoid growing the stack unnecessarily */
- if (Sp[0] == (W_)&stg_unblockAsyncExceptionszh_ret_info) {
- Sp++;
- } else {
- Sp--;
- Sp[0] = (W_)&stg_blockAsyncExceptionszh_ret_info;
- }
- }
- Sp--;
- JMP_(stg_ap_v_ret);
- FE_
-}
-
-INFO_TABLE_RET( \
- stg_blockAsyncExceptionszh_ret_info, \
- stg_blockAsyncExceptionszh_ret_entry, \
- MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/), \
- 0, 0, 0, RET_SMALL, , EF_, 0, 0 \
-);
-
-FN_(stg_blockAsyncExceptionszh_ret_entry)
-{
- FB_
- ASSERT(CurrentTSO->blocked_exceptions == NULL);
- CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
-#ifdef REG_R1
- Sp++;
- JMP_(ENTRY_CODE(Sp[0]));
-#else
- Sp[1] = Sp[0];
- Sp++;
- JMP_(ENTRY_CODE(Sp[1]));
-#endif
- FE_
-}
-
-FN_(killThreadzh_fast)
-{
- FB_
- /* args: R1.p = TSO to kill, R2.p = Exception */
-
- /* This thread may have been relocated.
- * (see Schedule.c:threadStackOverflow)
- */
- while (R1.t->what_next == ThreadRelocated) {
- R1.t = R1.t->link;
- }
-
- /* If the target thread is currently blocking async exceptions,
- * we'll have to block until it's ready to accept them. The
- * exception is interruptible threads - ie. those that are blocked
- * on some resource.
- */
- if (R1.t->blocked_exceptions != NULL && !interruptible(R1.t) ) {
-
- /* ToDo (SMP): locking if destination thread is currently
- * running...
- */
- CurrentTSO->link = R1.t->blocked_exceptions;
- R1.t->blocked_exceptions = CurrentTSO;
-
- CurrentTSO->why_blocked = BlockedOnException;
- CurrentTSO->block_info.tso = R1.t;
-
- BLOCK( R1_PTR | R2_PTR, killThreadzh_fast );
- }
-
- /* Killed threads turn into zombies, which might be garbage
- * collected at a later date. That's why we don't have to
- * explicitly remove them from any queues they might be on.
- */
-
- /* We might have killed ourselves. In which case, better be *very*
- * careful. If the exception killed us, then return to the scheduler.
- * If the exception went to a catch frame, we'll just continue from
- * the handler.
- */
- if (R1.t == CurrentTSO) {
- SaveThreadState(); /* inline! */
- STGCALL2(raiseAsyncWithLock, R1.t, R2.cl);
- if (CurrentTSO->what_next == ThreadKilled) {
- R1.w = ThreadFinished;
- JMP_(StgReturn);
- } else {
- LoadThreadState();
- ASSERT(CurrentTSO->what_next == ThreadRunGHC);
- JMP_(ENTRY_CODE(Sp[0]));
- }
- } else {
- STGCALL2(raiseAsyncWithLock, R1.t, R2.cl);
- }
-
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-
-/* -----------------------------------------------------------------------------
- Catch frames
- -------------------------------------------------------------------------- */
-
-#ifdef REG_R1
-#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \
- FN_(label); \
- FN_(label) \
- { \
- FB_ \
- Sp += sizeofW(StgCatchFrame); \
- JMP_(ret); \
- FE_ \
- }
-#else
-#define CATCH_FRAME_ENTRY_TEMPLATE(label,ret) \
- FN_(label); \
- FN_(label) \
- { \
- StgWord rval; \
- FB_ \
- rval = Sp[0]; \
- Sp++; \
- Sp += sizeofW(StgCatchFrame) - 1; \
- Sp[0] = rval; \
- JMP_(ret); \
- FE_ \
- }
-#endif
-
-#ifdef REG_R1
-#define SP_OFF 0
-#else
-#define SP_OFF 1
-#endif
-
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_ret,ENTRY_CODE(Sp[SP_OFF]));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_0_ret,RET_VEC(Sp[SP_OFF],0));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_1_ret,RET_VEC(Sp[SP_OFF],1));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_2_ret,RET_VEC(Sp[SP_OFF],2));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_3_ret,RET_VEC(Sp[SP_OFF],3));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_4_ret,RET_VEC(Sp[SP_OFF],4));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_5_ret,RET_VEC(Sp[SP_OFF],5));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_6_ret,RET_VEC(Sp[SP_OFF],6));
-CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_7_ret,RET_VEC(Sp[SP_OFF],7));
-
-#if defined(PROFILING)
-#define CATCH_FRAME_BITMAP 7
-#define CATCH_FRAME_WORDS 4
-#else
-#define CATCH_FRAME_BITMAP 1
-#define CATCH_FRAME_WORDS 2
-#endif
-
-/* Catch frames are very similar to update frames, but when entering
- * one we just pop the frame off the stack and perform the correct
- * kind of return to the activation record underneath us on the stack.
- */
-
-VEC_POLY_INFO_TABLE(stg_catch_frame, \
- MK_SMALL_BITMAP(CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP), \
- NULL/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, CATCH_FRAME,, EF_);
-
-/* -----------------------------------------------------------------------------
- * The catch infotable
- *
- * This should be exactly the same as would be generated by this STG code
- *
- * catch = {x,h} \n {} -> catch#{x,h}
- *
- * It is used in deleteThread when reverting blackholes.
- * -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_catch_info,stg_catch_entry,2,0,FUN,,EF_,0,0);
-STGFUN(stg_catch_entry)
-{
- FB_
- R2.cl = R1.cl->payload[1]; /* h */
- R1.cl = R1.cl->payload[0]; /* x */
- JMP_(catchzh_fast);
- FE_
-}
-
-FN_(catchzh_fast)
-{
- StgCatchFrame *fp;
- FB_
-
- /* args: R1 = m :: IO a, R2 = handler :: Exception -> IO a */
- STK_CHK_GEN(sizeofW(StgCatchFrame) + 1, R1_PTR | R2_PTR, catchzh_fast);
-
- /* Set up the catch frame */
- Sp -= sizeofW(StgCatchFrame);
- fp = (StgCatchFrame *)Sp;
- SET_HDR(fp,(StgInfoTable *)&stg_catch_frame_info,CCCS);
- fp -> handler = R2.cl;
- fp -> exceptions_blocked = (CurrentTSO->blocked_exceptions != NULL);
- TICK_CATCHF_PUSHED();
-
-
-/* Apply R1 to the realworld token */
- Sp--;
- JMP_(stg_ap_v_ret);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- * The raise infotable
- *
- * This should be exactly the same as would be generated by this STG code
- *
- * raise = {err} \n {} -> raise#{err}
- *
- * It is used in raisezh_fast to update thunks on the update list
- * -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_raise_info,stg_raise_entry,1,0,THUNK,,EF_,0,0);
-STGFUN(stg_raise_entry)
-{
- FB_
- R1.cl = R1.cl->payload[0];
- JMP_(raisezh_fast);
- FE_
-}
-
-FN_(raisezh_fast)
-{
- StgClosure *handler;
- StgPtr p;
- StgClosure *raise_closure;
- FB_
- /* args : R1.p :: Exception */
-
-
-#if defined(PROFILING)
- /* Debugging tool: on raising an exception, show where we are. */
-
- /* ToDo: currently this is a hack. Would be much better if
- * the info was only displayed for an *uncaught* exception.
- */
- if (RtsFlags.ProfFlags.showCCSOnException) {
- STGCALL2(fprintCCS,stderr,CCCS);
- }
-#endif
-
- /* This closure represents the expression 'raise# E' where E
- * is the exception raise. It is used to overwrite all the
- * thunks which are currently under evaluataion.
- */
- /*
- // @LDV profiling
- // stg_raise_info has THUNK as its closure type. Since a THUNK takes at least
- // MIN_UPD_SIZE words in its payload, MIN_UPD_SIZE is more approprate than 1.
- // It seems that 1 does not cause any problem unless profiling is performed.
- // However, when LDV profiling goes on, we need to linearly scan small object pool,
- // where raise_closure is stored, so we should use MIN_UPD_SIZE.
- raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
- sizeofW(StgClosure)+1);
- */
- raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
- sizeofW(StgClosure)+MIN_UPD_SIZE);
- SET_HDR(raise_closure, &stg_raise_info, CCCS);
- raise_closure->payload[0] = R1.cl;
-
- // Walk up the stack, looking for the catch frame. On the way,
- // we update any closures pointed to from update frames with the
- // raise closure that we just built.
- {
- StgPtr next;
- StgRetInfoTable *info;
-
- p = Sp;
- while(1) {
-
- info = get_ret_itbl((StgClosure *)p);
- next = p + stack_frame_sizeW((StgClosure *)p);
- switch (info->i.type) {
-
- case UPDATE_FRAME:
- UPD_IND(((StgUpdateFrame *)p)->updatee,raise_closure);
- p = next;
- continue;
-
- case CATCH_FRAME:
- /* found it! */
- break;
-
- case STOP_FRAME:
- /* We've stripped the entire stack, the thread is now dead. */
- Sp = CurrentTSO->stack + CurrentTSO->stack_size - 1;
- Sp[0] = R1.w; /* save the exception */
- CurrentTSO->what_next = ThreadKilled;
- SaveThreadState(); /* inline! */
- R1.w = ThreadFinished;
- JMP_(StgReturn);
-
- default:
- p = next;
- continue;
- }
-
- break;
- }
- }
-
- /* Ok, p points to the enclosing CATCH_FRAME. Pop everything down to
- * and including this frame, update Su, push R1, and enter the handler.
- */
- handler = ((StgCatchFrame *)p)->handler;
-
- Sp = (P_)p + sizeofW(StgCatchFrame);
-
- /* Restore the blocked/unblocked state for asynchronous exceptions
- * at the CATCH_FRAME.
- *
- * If exceptions were unblocked, arrange that they are unblocked
- * again after executing the handler by pushing an
- * unblockAsyncExceptions_ret stack frame.
- */
- if (! ((StgCatchFrame *)p)->exceptions_blocked) {
- *(--Sp) = (W_)&stg_unblockAsyncExceptionszh_ret_info;
- }
-
- /* Ensure that async excpetions are blocked when running the handler.
- */
- if (CurrentTSO->blocked_exceptions == NULL) {
- CurrentTSO->blocked_exceptions = END_TSO_QUEUE;
- }
-
- /* Call the handler, passing the exception value and a realworld
- * token as arguments.
- */
- Sp -= 2;
- Sp[1] = (W_)&stg_ap_v_info;
- Sp[0] = R1.w;
- R1.cl = handler;
- Sp--;
- JMP_(stg_ap_p_ret);
- FE_
-}
-
-FN_(raiseIOzh_fast)
-{
- FB_
- /* Args :: R1.p :: Exception */
- JMP_(raisezh_fast);
- FE_
-}
/* -----------------------------------------------------------------------------
- * $Id: FrontPanel.c,v 1.8 2003/06/24 08:49:55 stolz Exp $
+ * $Id: FrontPanel.c,v 1.9 2004/08/13 13:09:49 simonmar Exp $
*
* (c) The GHC Team 2000
*
#include "MBlock.h"
#include "FrontPanel.h"
#include "Storage.h"
-#include "StoragePriv.h"
#include "Stats.h"
#include "RtsFlags.h"
#include "Schedule.h"
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.167 2004/05/21 13:28:59 simonmar Exp $
+ * $Id: GC.c,v 1.168 2004/08/13 13:09:49 simonmar Exp $
*
* (c) The GHC Team 1998-2003
*
#include "RtsUtils.h"
#include "Apply.h"
#include "Storage.h"
-#include "StoragePriv.h"
+#include "LdvProfile.h"
+#include "Updates.h"
#include "Stats.h"
#include "Schedule.h"
#include "SchedAPI.h" // for ReverCAFs prototype
#include "ProfHeap.h"
#include "SchedAPI.h"
#include "Weak.h"
-#include "StablePriv.h"
#include "Prelude.h"
#include "ParTicky.h" // ToDo: move into Rts.h
#include "GCCompact.h"
#endif
#include "RetainerProfile.h"
-#include "LdvProfile.h"
#include <string.h>
*/
markStablePtrTable(mark_root);
-#ifdef INTERPRETER
- {
- /* ToDo: To fix the caf leak, we need to make the commented out
- * parts of this code do something sensible - as described in
- * the CAF document.
- */
- extern void markHugsObjects(void);
- markHugsObjects();
- }
-#endif
-
/* -------------------------------------------------------------------------
* Repeatedly scavenge all the areas we know about until there's no
* more scavenging to be done.
ASSERT((Bdescr((P_)p)->flags & BF_EVACUATED) == 0);
// not true: (ToDo: perhaps it should be)
// ASSERT(Bdescr((P_)dest)->flags & BF_EVACUATED);
- p->header.info = &stg_EVACUATED_info;
+ SET_INFO(p, &stg_EVACUATED_info);
((StgEvacuated *)p)->evacuee = dest;
}
// For the purposes of LDV profiling, we have destroyed
// the original selector thunk.
SET_INFO(p, info_ptr);
- LDV_recordDead_FILL_SLOP_DYNAMIC(selectee);
+ LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(selectee);
#endif
((StgInd *)selectee)->indirectee = val;
SET_INFO(selectee,&stg_IND_info);
-#ifdef PROFILING
+
// For the purposes of LDV profiling, we have created an
// indirection.
- LDV_recordCreate(selectee);
-#endif
+ LDV_RECORD_CREATE(selectee);
+
selectee = val;
goto selector_loop;
}
StgFunInfoTable *fun_info;
fun_info = itbl_to_fun_itbl(info);
- scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)fun_info->f.srt, fun_info->i.srt_bitmap);
}
STATIC_INLINE void
nat size;
p = (StgPtr)args;
- switch (fun_info->fun_type) {
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
- bitmap = BITMAP_BITS(fun_info->bitmap);
- size = BITMAP_SIZE(fun_info->bitmap);
+ bitmap = BITMAP_BITS(fun_info->f.bitmap);
+ size = BITMAP_SIZE(fun_info->f.bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->bitmap)->size;
- scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
+ scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
p += size;
break;
default:
- bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
- size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+ size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
small_bitmap:
while (size > 0) {
if ((bitmap & 1) == 0) {
p = (StgPtr)pap->payload;
size = pap->n_args;
- switch (fun_info->fun_type) {
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
- bitmap = BITMAP_BITS(fun_info->bitmap);
+ bitmap = BITMAP_BITS(fun_info->f.bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
p += size;
break;
case ARG_BCO:
p += size;
break;
default:
- bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
small_bitmap:
size = pap->n_args;
while (size > 0) {
LDV_recordDead((StgClosure *)p, sizeofW(StgInd));
#endif
//
- // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
+ // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
//
SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info);
-#ifdef PROFILING
- // @LDV profiling
+
// We pretend that p has just been created.
- LDV_recordCreate((StgClosure *)p);
-#endif
+ LDV_RECORD_CREATE((StgClosure *)p);
}
// fall through
case IND_OLDGEN_PERM:
dyn = ((StgRetDyn *)p)->liveness;
// traverse the bitmap first
- bitmap = GET_LIVENESS(dyn);
+ bitmap = RET_DYN_LIVENESS(dyn);
p = (P_)&((StgRetDyn *)p)->payload[0];
size = RET_DYN_BITMAP_SIZE;
p = scavenge_small_bitmap(p, size, bitmap);
// skip over the non-ptr words
- p += GET_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
+ p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
// follow the ptr words
- for (size = GET_PTRS(dyn); size > 0; size--) {
+ for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
(StgClosure *)*p = evacuate((StgClosure *)*p);
p++;
}
for (c = (StgIndStatic *)caf_list; c != NULL;
c = (StgIndStatic *)c->static_link)
{
- c->header.info = c->saved_info;
+ SET_INFO(c, c->saved_info);
c->saved_info = NULL;
// could, but not necessary: c->static_link = NULL;
}
LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
#endif
SET_INFO(bh,&stg_BLACKHOLE_info);
-#ifdef PROFILING
- // @LDV profiling
+
// We pretend that bh has just been created.
- LDV_recordCreate(bh);
-#endif
+ LDV_RECORD_CREATE(bh);
}
frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
// We pretend that bh is now dead.
LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
#endif
- // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
+ // Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
SET_INFO(bh,&stg_BLACKHOLE_info);
-#ifdef PROFILING
+
// We pretend that bh has just been created.
- LDV_recordCreate(bh);
-#endif
+ LDV_RECORD_CREATE(bh);
}
prev_was_update_frame = rtsTrue;
/* -----------------------------------------------------------------------------
- * $Id: GCCompact.c,v 1.18 2003/11/12 17:49:07 sof Exp $
+ * $Id: GCCompact.c,v 1.19 2004/08/13 13:09:56 simonmar Exp $
*
* (c) The GHC Team 2001
*
#include "MBlock.h"
#include "GCCompact.h"
#include "Schedule.h"
-#include "StablePriv.h"
#include "Apply.h"
// Turn off inlining when debugging - it obfuscates things
nat size;
p = (StgPtr)args;
- switch (fun_info->fun_type) {
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
- bitmap = BITMAP_BITS(fun_info->bitmap);
- size = BITMAP_SIZE(fun_info->bitmap);
+ bitmap = BITMAP_BITS(fun_info->f.bitmap);
+ size = BITMAP_SIZE(fun_info->f.bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->bitmap)->size;
- thread_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
+ thread_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
p += size;
break;
default:
- bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
- size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+ size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
small_bitmap:
while (size > 0) {
if ((bitmap & 1) == 0) {
dyn = ((StgRetDyn *)p)->liveness;
// traverse the bitmap first
- bitmap = GET_LIVENESS(dyn);
+ bitmap = RET_DYN_LIVENESS(dyn);
p = (P_)&((StgRetDyn *)p)->payload[0];
size = RET_DYN_BITMAP_SIZE;
while (size > 0) {
}
// skip over the non-ptr words
- p += GET_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
+ p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
// follow the ptr words
- for (size = GET_PTRS(dyn); size > 0; size--) {
+ for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
thread(p);
p++;
}
p = (StgPtr)pap->payload;
size = pap->n_args;
- switch (fun_info->fun_type) {
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
- bitmap = BITMAP_BITS(fun_info->bitmap);
+ bitmap = BITMAP_BITS(fun_info->f.bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- thread_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ thread_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
p += size;
break;
case ARG_BCO:
p += size;
break;
default:
- bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
small_bitmap:
size = pap->n_args;
while (size > 0) {
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Canned Heap-Check and Stack-Check sequences.
+ *
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC. It is compiled by GHC directly. For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Cmm.h"
+
+/* Stack/Heap Check Failure
+ * ------------------------
+ *
+ * On discovering that a stack or heap check has failed, we do the following:
+ *
+ * - If the context_switch flag is set, indicating that there are more
+ * threads waiting to run, we yield to the scheduler
+ * (return ThreadYielding).
+ *
+ * - If Hp > HpLim, we've had a heap check failure. This means we've
+ * come to the end of the current heap block, so we try to chain
+ * another block on with ExtendNursery().
+ *
+ * - If this succeeds, we carry on without returning to the
+ * scheduler.
+ *
+ * - If it fails, we return to the scheduler claiming HeapOverflow
+ * so that a garbage collection can be performed.
+ *
+ * - If Hp <= HpLim, it must have been a stack check that failed. In
+ * which case, we return to the scheduler claiming StackOverflow, the
+ * scheduler will either increase the size of our stack, or raise
+ * an exception if the stack is already too big.
+ *
+ * The effect of checking for context switch only in the heap/stack check
+ * failure code is that we'll switch threads after the current thread has
+ * reached the end of its heap block. If a thread isn't allocating
+ * at all, it won't yield. Hopefully this won't be a problem in practice.
+ */
+
+/* Remember that the return address is *removed* when returning to a
+ * ThreadRunGHC thread.
+ */
+
+#define GC_GENERIC \
+ DEBUG_ONLY(foreign "C" heapCheckFail()); \
+ if (Hp > HpLim) { \
+ Hp = Hp - HpAlloc/*in bytes*/; \
+ if (HpAlloc <= BLOCK_SIZE \
+ && bdescr_link(CurrentNursery) != NULL) { \
+ CLOSE_NURSERY(); \
+ CurrentNursery = bdescr_link(CurrentNursery); \
+ OPEN_NURSERY(); \
+ if (CInt[context_switch] != 0) { \
+ R1 = ThreadYielding; \
+ goto sched; \
+ } else { \
+ jump %ENTRY_CODE(Sp(0)); \
+ } \
+ } else { \
+ R1 = HeapOverflow; \
+ goto sched; \
+ } \
+ } else { \
+ R1 = StackOverflow; \
+ } \
+ sched: \
+ SAVE_THREAD_STATE(); \
+ StgTSO_what_next(CurrentTSO) = ThreadRunGHC::I16; \
+ jump StgReturn;
+
+#define RETURN_TO_SCHED(why,what_next) \
+ SAVE_THREAD_STATE(); \
+ StgTSO_what_next(CurrentTSO) = what_next::I16; \
+ R1 = why; \
+ jump StgReturn;
+
+#define HP_GENERIC RETURN_TO_SCHED(HeapOverflow, ThreadRunGHC)
+#define YIELD_GENERIC RETURN_TO_SCHED(ThreadYielding, ThreadRunGHC)
+#define YIELD_TO_INTERPRETER RETURN_TO_SCHED(ThreadYielding, ThreadInterpret)
+#define BLOCK_GENERIC RETURN_TO_SCHED(ThreadBlocked, ThreadRunGHC)
+
+/* -----------------------------------------------------------------------------
+ Heap checks in thunks/functions.
+
+ In these cases, node always points to the function closure. This gives
+ us an easy way to return to the function: just leave R1 on the top of
+ the stack, and have the scheduler enter it to return.
+
+ There are canned sequences for 'n' pointer values in registers.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE_RET( stg_enter, 1/*framesize*/, 0/*bitmap*/, RET_SMALL)
+{
+ R1 = Sp(1);
+ Sp_adj(2);
+ ENTER();
+}
+
+__stg_gc_enter_1
+{
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_enter_info;
+ GC_GENERIC
+}
+
+#ifdef SMP
+stg_gc_enter_1_hponly
+{
+ Sp_adj(-1);
+ Sp(0) = R1;
+ R1 = HeapOverflow;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC::I16;
+ jump StgReturn;
+}
+#endif
+
+#if defined(GRAN)
+/*
+ ToDo: merge the block and yield macros, calling something like BLOCK(N)
+ at the end;
+*/
+
+/*
+ Should we actually ever do a yield in such a case?? -- HWL
+*/
+gran_yield_0
+{
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+gran_yield_1
+{
+ Sp_adj(-1);
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+/*- 2 Regs--------------------------------------------------------------------*/
+
+gran_yield_2
+{
+ Sp_adj(-2);
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+/*- 3 Regs -------------------------------------------------------------------*/
+
+gran_yield_3
+{
+ Sp_adj(-3);
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+/*- 4 Regs -------------------------------------------------------------------*/
+
+gran_yield_4
+{
+ Sp_adj(-4);
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+/*- 5 Regs -------------------------------------------------------------------*/
+
+gran_yield_5
+{
+ Sp_adj(-5);
+ Sp(4) = R5;
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+/*- 6 Regs -------------------------------------------------------------------*/
+
+gran_yield_6
+{
+ Sp_adj(-6);
+ Sp(5) = R6;
+ Sp(4) = R5;
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+/*- 7 Regs -------------------------------------------------------------------*/
+
+gran_yield_7
+{
+ Sp_adj(-7);
+ Sp(6) = R7;
+ Sp(5) = R6;
+ Sp(4) = R5;
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+/*- 8 Regs -------------------------------------------------------------------*/
+
+gran_yield_8
+{
+ Sp_adj(-8);
+ Sp(7) = R8;
+ Sp(6) = R7;
+ Sp(5) = R6;
+ Sp(4) = R5;
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadYielding;
+ jump StgReturn;
+}
+
+// the same routines but with a block rather than a yield
+
+gran_block_1
+{
+ Sp_adj(-1);
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+/*- 2 Regs--------------------------------------------------------------------*/
+
+gran_block_2
+{
+ Sp_adj(-2);
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+/*- 3 Regs -------------------------------------------------------------------*/
+
+gran_block_3
+{
+ Sp_adj(-3);
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+/*- 4 Regs -------------------------------------------------------------------*/
+
+gran_block_4
+{
+ Sp_adj(-4);
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+/*- 5 Regs -------------------------------------------------------------------*/
+
+gran_block_5
+{
+ Sp_adj(-5);
+ Sp(4) = R5;
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+/*- 6 Regs -------------------------------------------------------------------*/
+
+gran_block_6
+{
+ Sp_adj(-6);
+ Sp(5) = R6;
+ Sp(4) = R5;
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+/*- 7 Regs -------------------------------------------------------------------*/
+
+gran_block_7
+{
+ Sp_adj(-7);
+ Sp(6) = R7;
+ Sp(5) = R6;
+ Sp(4) = R5;
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+/*- 8 Regs -------------------------------------------------------------------*/
+
+gran_block_8
+{
+ Sp_adj(-8);
+ Sp(7) = R8;
+ Sp(6) = R7;
+ Sp(5) = R6;
+ Sp(4) = R5;
+ Sp(3) = R4;
+ Sp(2) = R3;
+ Sp(1) = R2;
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+#endif
+
+#if 0 && defined(PAR)
+
+/*
+ Similar to stg_block_1 (called via StgMacro BLOCK_NP) but separates the
+ saving of the thread state from the actual jump via an StgReturn.
+ We need this separation because we call RTS routines in blocking entry codes
+ before jumping back into the RTS (see parallel/FetchMe.hc).
+*/
+
+par_block_1_no_jump
+{
+ Sp_adj(-1);
+ Sp(0) = R1;
+ SAVE_THREAD_STATE();
+}
+
+par_jump
+{
+ TSO_what_next(CurrentTSO) = ThreadRunGHC;
+ R1 = ThreadBlocked;
+ jump StgReturn;
+}
+
+#endif
+
+/* -----------------------------------------------------------------------------
+ Heap checks in Primitive case alternatives
+
+ A primitive case alternative is entered with a value either in
+ R1, FloatReg1 or D1 depending on the return convention. All the
+ cases are covered below.
+ -------------------------------------------------------------------------- */
+
+/*-- No Registers live ------------------------------------------------------ */
+
+stg_gc_noregs
+{
+ GC_GENERIC
+}
+
+/*-- void return ------------------------------------------------------------ */
+
+INFO_TABLE_RET( stg_gc_void, 0/*framesize*/, 0/*bitmap*/, RET_SMALL)
+{
+ Sp_adj(1);
+ jump %ENTRY_CODE(Sp(0));
+}
+
+/*-- R1 is boxed/unpointed -------------------------------------------------- */
+
+INFO_TABLE_RET( stg_gc_unpt_r1, 1/*framesize*/, 0/*bitmap*/, RET_SMALL)
+{
+ R1 = Sp(1);
+ Sp_adj(2);
+ jump %ENTRY_CODE(Sp(0));
+}
+
+stg_gc_unpt_r1
+{
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_gc_unpt_r1_info;
+ GC_GENERIC
+}
+
+/*-- R1 is unboxed -------------------------------------------------- */
+
+/* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */
+INFO_TABLE_RET( stg_gc_unbx_r1, 1/*framesize*/, 1/*bitmap*/, RET_SMALL )
+{
+ R1 = Sp(1);
+ Sp_adj(2);
+ jump %ENTRY_CODE(Sp(0));
+}
+
+stg_gc_unbx_r1
+{
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_gc_unbx_r1_info;
+ GC_GENERIC
+}
+
+/*-- F1 contains a float ------------------------------------------------- */
+
+INFO_TABLE_RET( stg_gc_f1, 1/*framesize*/, 1/*bitmap*/, RET_SMALL )
+{
+ F1 = F_[Sp+WDS(1)];
+ Sp_adj(2);
+ jump %ENTRY_CODE(Sp(0));
+}
+
+stg_gc_f1
+{
+ Sp_adj(-2);
+ F_[Sp + WDS(1)] = F1;
+ Sp(0) = stg_gc_f1_info;
+ GC_GENERIC
+}
+
+/*-- D1 contains a double ------------------------------------------------- */
+
+/* we support doubles of either 1 or 2 words in size */
+
+#if SIZEOF_DOUBLE == SIZEOF_VOID_P
+# define DBL_BITMAP 1
+# define DBL_WORDS 1
+#else
+# define DBL_BITMAP 3
+# define DBL_WORDS 2
+#endif
+
+INFO_TABLE_RET( stg_gc_d1, DBL_WORDS/*framesize*/, DBL_BITMAP/*bitmap*/, RET_SMALL )
+{
+ D1 = D_[Sp + WDS(1)];
+ Sp = Sp + WDS(1) + SIZEOF_StgDouble;
+ jump %ENTRY_CODE(Sp(0));
+}
+
+stg_gc_d1
+{
+ Sp = Sp - WDS(1) - SIZEOF_StgDouble;
+ D_[Sp + WDS(1)] = D1;
+ Sp(0) = stg_gc_d1_info;
+ GC_GENERIC
+}
+
+
+/*-- L1 contains an int64 ------------------------------------------------- */
+
+/* we support int64s of either 1 or 2 words in size */
+
+#if SIZEOF_VOID_P == 8
+# define LLI_BITMAP 1
+# define LLI_WORDS 1
+#else
+# define LLI_BITMAP 3
+# define LLI_WORDS 2
+#endif
+
+INFO_TABLE_RET( stg_gc_l1, LLI_WORDS/*framesize*/, LLI_BITMAP/*bitmap*/, RET_SMALL )
+{
+ L1 = L_[Sp + WDS(1)];
+ Sp_adj(1) + SIZEOF_StgWord64;
+ jump %ENTRY_CODE(Sp(0));
+}
+
+stg_gc_l1
+{
+ Sp_adj(-1) - SIZEOF_StgWord64;
+ L_[Sp + WDS(1)] = L1;
+ Sp(0) = stg_gc_l1_info;
+ GC_GENERIC
+}
+
+/*-- Unboxed tuple return, one pointer (unregisterised build only) ---------- */
+
+INFO_TABLE_RET( stg_ut_1_0_unreg, 1/*size*/, 0/*BITMAP*/, RET_SMALL )
+{
+ Sp_adj(1);
+ // one ptr is on the stack (Sp(0))
+ jump %ENTRY_CODE(Sp(1));
+}
+
+/* -----------------------------------------------------------------------------
+ Generic function entry heap check code.
+
+ At a function entry point, the arguments are as per the calling convention,
+ i.e. some in regs and some on the stack. There may or may not be
+ a pointer to the function closure in R1 - if there isn't, then the heap
+ check failure code in the function will arrange to load it.
+
+ The function's argument types are described in its info table, so we
+ can just jump to this bit of generic code to save away all the
+ registers and return to the scheduler.
+
+ This code arranges the stack like this:
+
+ | .... |
+ | args |
+ +---------------------+
+ | f_closure |
+ +---------------------+
+ | size |
+ +---------------------+
+ | stg_gc_fun_info |
+ +---------------------+
+
+ The size is the number of words of arguments on the stack, and is cached
+ in the frame in order to simplify stack walking: otherwise the size of
+ this stack frame would have to be calculated by looking at f's info table.
+
+ -------------------------------------------------------------------------- */
+
+__stg_gc_fun
+{
+ W_ size;
+ W_ info;
+ W_ type;
+
+ info = %GET_FUN_INFO(R1);
+
+ // cache the size
+ type = TO_W_(StgFunInfoExtra_fun_type(info));
+ if (type == ARG_GEN) {
+ size = BITMAP_SIZE(StgFunInfoExtra_bitmap(info));
+ } else {
+ if (type == ARG_GEN_BIG) {
+ size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
+ } else {
+ size = BITMAP_SIZE(W_[stg_arg_bitmaps + WDS(type)]);
+ }
+ }
+
+#ifdef NO_ARG_REGS
+ // we don't have to save any registers away
+ Sp_adj(-3);
+ Sp(2) = R1;
+ Sp(1) = size;
+ Sp(0) = stg_gc_fun_info;
+ GC_GENERIC
+#else
+ W_ type;
+ type = TO_W_(StgFunInfoExtra_fun_type(info));
+ // cache the size
+ if (type == ARG_GEN || type == ARG_GEN_BIG) {
+ // regs already saved by the heap check code
+ Sp_adj(-3);
+ Sp(2) = R1;
+ Sp(1) = size;
+ Sp(0) = stg_gc_fun_info;
+ // DEBUG_ONLY(foreign "C" fprintf(stderr, "stg_fun_gc_gen(ARG_GEN)"););
+ GC_GENERIC
+ } else {
+ jump W_[stg_stack_save_entries + WDS(type)];
+ // jumps to stg_gc_noregs after saving stuff
+ }
+#endif // !NO_ARG_REGS
+}
+
+/* -----------------------------------------------------------------------------
+ Generic Apply (return point)
+
+ The dual to stg_fun_gc_gen (above): this fragment returns to the
+ function, passing arguments in the stack and in registers
+ appropriately. The stack layout is given above.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE_RET( stg_gc_fun, 0/*framesize*/, 0/*bitmap*/, RET_FUN )
+{
+ R1 = Sp(2);
+ Sp_adj(3);
+#ifdef NO_ARG_REGS
+ // Minor optimisation: there are no argument registers to load up,
+ // so we can just jump straight to the function's entry point.
+ jump %GET_ENTRY(R1);
+#else
+ W_ info;
+ W_ type;
+
+ info = %GET_FUN_INFO(R1);
+ type = TO_W_(StgFunInfoExtra_fun_type(info));
+ if (type == ARG_GEN || type == ARG_GEN_BIG) {
+ jump StgFunInfoExtra_slow_apply(info);
+ } else {
+ if (type == ARG_BCO) {
+ // cover this case just to be on the safe side
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_apply_interp_info;
+ jump stg_yield_to_interpreter;
+ } else {
+ jump W_[stg_ap_stack_entries + WDS(type)];
+ }
+ }
+#endif
+}
+
+/* -----------------------------------------------------------------------------
+ Generic Heap Check Code.
+
+ Called with Liveness mask in R9, Return address in R10.
+ Stack must be consistent (containing all necessary info pointers
+ to relevant SRTs).
+
+ See StgMacros.h for a description of the RET_DYN stack frame.
+
+ We also define an stg_gen_yield here, because it's very similar.
+ -------------------------------------------------------------------------- */
+
+// For simplicity, we assume that SIZEOF_DOUBLE == 2*SIZEOF_VOID_P
+// on a 64-bit machine, we'll end up wasting a couple of words, but
+// it's not a big deal.
+
+#define RESTORE_EVERYTHING \
+ L1 = L_[Sp + WDS(19)]; \
+ D2 = D_[Sp + WDS(17)]; \
+ D1 = D_[Sp + WDS(15)]; \
+ F4 = F_[Sp + WDS(14)]; \
+ F3 = F_[Sp + WDS(13)]; \
+ F2 = F_[Sp + WDS(12)]; \
+ F1 = F_[Sp + WDS(11)]; \
+ R8 = Sp(10); \
+ R7 = Sp(9); \
+ R6 = Sp(8); \
+ R5 = Sp(7); \
+ R4 = Sp(6); \
+ R3 = Sp(5); \
+ R2 = Sp(4); \
+ R1 = Sp(3); \
+ Sp_adj(21);
+
+#define RET_OFFSET (-19)
+
+#define SAVE_EVERYTHING \
+ Sp_adj(-21); \
+ L_[Sp + WDS(19)] = L1; \
+ D_[Sp + WDS(17)] = D2; \
+ D_[Sp + WDS(15)] = D1; \
+ F_[Sp + WDS(14)] = F4; \
+ F_[Sp + WDS(13)] = F3; \
+ F_[Sp + WDS(12)] = F2; \
+ F_[Sp + WDS(11)] = F1; \
+ Sp(10) = R8; \
+ Sp(9) = R7; \
+ Sp(8) = R6; \
+ Sp(7) = R5; \
+ Sp(6) = R4; \
+ Sp(5) = R3; \
+ Sp(4) = R2; \
+ Sp(3) = R1; \
+ Sp(2) = R10.w; /* return address */ \
+ Sp(1) = R9; /* liveness mask */ \
+ Sp(0) = stg_gc_gen_info;
+
+INFO_TABLE_RET( stg_gc_gen, 0/*framesize*/, 0/*bitmap*/, RET_DYN )
+/* bitmap in the above info table is unused, the real one is on the stack. */
+{
+ RESTORE_EVERYTHING;
+ jump Sp(RET_OFFSET); /* No %ENTRY_CODE( - this is an actual code ptr */
+}
+
+stg_gc_gen
+{
+ SAVE_EVERYTHING;
+ GC_GENERIC
+}
+
+// A heap check at an unboxed tuple return point. The return address
+// is on the stack, and we can find it by using the offsets given
+// to us in the liveness mask.
+stg_gc_ut
+{
+ R10 = %ENTRY_CODE(Sp(RET_DYN_NONPTRS(R9) + RET_DYN_PTRS(R9)));
+ SAVE_EVERYTHING;
+ GC_GENERIC
+}
+
+/*
+ * stg_gen_hp is used by MAYBE_GC, where we can't use GC_GENERIC
+ * because we've just failed doYouWantToGC(), not a standard heap
+ * check. GC_GENERIC would end up returning StackOverflow.
+ */
+stg_gc_gen_hp
+{
+ SAVE_EVERYTHING;
+ HP_GENERIC
+}
+
+/* -----------------------------------------------------------------------------
+ Yields
+ -------------------------------------------------------------------------- */
+
+stg_gen_yield
+{
+ SAVE_EVERYTHING;
+ YIELD_GENERIC
+}
+
+stg_yield_noregs
+{
+ YIELD_GENERIC;
+}
+
+/* -----------------------------------------------------------------------------
+ Yielding to the interpreter... top of stack says what to do next.
+ -------------------------------------------------------------------------- */
+
+stg_yield_to_interpreter
+{
+ YIELD_TO_INTERPRETER;
+}
+
+/* -----------------------------------------------------------------------------
+ Blocks
+ -------------------------------------------------------------------------- */
+
+stg_gen_block
+{
+ SAVE_EVERYTHING;
+ BLOCK_GENERIC;
+}
+
+stg_block_noregs
+{
+ BLOCK_GENERIC;
+}
+
+stg_block_1
+{
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_enter_info;
+ BLOCK_GENERIC;
+}
+
+/* -----------------------------------------------------------------------------
+ * takeMVar/putMVar-specific blocks
+ *
+ * Stack layout for a thread blocked in takeMVar:
+ *
+ * ret. addr
+ * ptr to MVar (R1)
+ * stg_block_takemvar_info
+ *
+ * Stack layout for a thread blocked in putMVar:
+ *
+ * ret. addr
+ * ptr to Value (R2)
+ * ptr to MVar (R1)
+ * stg_block_putmvar_info
+ *
+ * See PrimOps.hc for a description of the workings of take/putMVar.
+ *
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE_RET( stg_block_takemvar, 1/*framesize*/, 0/*bitmap*/, RET_SMALL )
+{
+ R1 = Sp(1);
+ Sp_adj(2);
+ jump takeMVarzh_fast;
+}
+
+stg_block_takemvar
+{
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_block_takemvar_info;
+ BLOCK_GENERIC;
+}
+
+INFO_TABLE_RET( stg_block_putmvar, 2/*framesize*/, 0/*bitmap*/, RET_SMALL )
+{
+ R2 = Sp(2);
+ R1 = Sp(1);
+ Sp_adj(3);
+ jump putMVarzh_fast;
+}
+
+stg_block_putmvar
+{
+ Sp_adj(-3);
+ Sp(2) = R2;
+ Sp(1) = R1;
+ Sp(0) = stg_block_putmvar_info;
+ BLOCK_GENERIC;
+}
+
+#ifdef mingw32_TARGET_OS
+INFO_TABLE_RET( stg_block_async, 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+{
+ W_ ares;
+ W_ len, errC;
+
+ ares = StgTSO_block_info(CurrentTSO);
+ len = StgAsyncIOResult_len(ares);
+ errC = StgAsyncIOResult_errC(ares);
+ StgTSO_block_info(CurrentTSO) = NULL;
+ foreign "C" free(ares);
+ R1 = len;
+ Sp(0) = errC;
+ jump %ENTRY_CODE(Sp(1));
+}
+
+stg_block_async
+{
+ Sp_adj(-1);
+ Sp(0) = stg_block_async_info;
+ BLOCK_GENERIC;
+}
+
+#endif
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: HeapStackCheck.hc,v 1.31 2003/05/14 09:13:59 simonmar Exp $
- *
- * (c) The GHC Team, 1998-2002
- *
- * Canned Heap-Check and Stack-Check sequences.
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Stg.h"
-#include "Rts.h"
-#include "Storage.h" /* for CurrentTSO */
-#include "StgRun.h" /* for StgReturn and register saving */
-#include "Schedule.h" /* for context_switch */
-#include "RtsFlags.h"
-#include "RtsUtils.h"
-#include "Apply.h"
-
-#include <stdio.h>
-
-#ifdef mingw32_TARGET_OS
-#include <stdlib.h>
-#endif
-
-/* Stack/Heap Check Failure
- * ------------------------
- *
- * On discovering that a stack or heap check has failed, we do the following:
- *
- * - If the context_switch flag is set, indicating that there are more
- * threads waiting to run, we yield to the scheduler
- * (return ThreadYielding).
- *
- * - If Hp > HpLim, we've had a heap check failure. This means we've
- * come to the end of the current heap block, so we try to chain
- * another block on with ExtendNursery().
- *
- * - If this succeeds, we carry on without returning to the
- * scheduler.
- *
- * - If it fails, we return to the scheduler claiming HeapOverflow
- * so that a garbage collection can be performed.
- *
- * - If Hp <= HpLim, it must have been a stack check that failed. In
- * which case, we return to the scheduler claiming StackOverflow, the
- * scheduler will either increase the size of our stack, or flag
- * an error if the stack is already too big.
- *
- * The effect of checking for context switch only in the heap/stack check
- * failure code is that we'll switch threads after the current thread has
- * reached the end of its heap block. If a thread isn't allocating
- * at all, it won't yield. Hopefully this won't be a problem in practice.
- */
-
-/* Remember that the return address is *removed* when returning to a
- * ThreadRunGHC thread.
- */
-
-#define GC_GENERIC \
- DEBUG_ONLY(heapCheckFail()); \
- if (Hp > HpLim) { \
- Hp -= HpAlloc; \
- if (HpAlloc <= BLOCK_SIZE_W && ExtendNursery(Hp,HpLim)) {\
- if (context_switch) { \
- R1.i = ThreadYielding; \
- } else { \
- JMP_(ENTRY_CODE(Sp[0])); \
- } \
- } else { \
- R1.i = HeapOverflow; \
- } \
- } else { \
- R1.i = StackOverflow; \
- } \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadRunGHC; \
- JMP_(StgReturn);
-
-#define HP_GENERIC \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadRunGHC; \
- R1.i = HeapOverflow; \
- JMP_(StgReturn);
-
-#define YIELD_GENERIC \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadRunGHC; \
- R1.i = ThreadYielding; \
- JMP_(StgReturn);
-
-#define YIELD_TO_INTERPRETER \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadInterpret; \
- R1.i = ThreadYielding; \
- JMP_(StgReturn);
-
-#define BLOCK_GENERIC \
- SaveThreadState(); \
- CurrentTSO->what_next = ThreadRunGHC; \
- R1.i = ThreadBlocked; \
- JMP_(StgReturn);
-
-/* -----------------------------------------------------------------------------
- Heap checks in thunks/functions.
-
- In these cases, node always points to the function closure. This gives
- us an easy way to return to the function: just leave R1 on the top of
- the stack, and have the scheduler enter it to return.
-
- There are canned sequences for 'n' pointer values in registers.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE_RET( stg_enter_info, stg_enter_ret,
- MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
-EXTFUN(stg_enter_ret)
-{
- FB_
- R1.w = Sp[1];
- Sp += 2;
- ENTER();
- FE_
-}
-
-EXTFUN(__stg_gc_enter_1)
-{
- FB_
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_enter_info;
- GC_GENERIC
- FE_
-}
-
-#ifdef SMP
-EXTFUN(stg_gc_enter_1_hponly)
-{
- FB_
- Sp -= 1;
- Sp[0] = R1.w;
- R1.i = HeapOverflow;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- JMP_(StgReturn);
- FE_
-}
-#endif
-
-#if defined(GRAN)
-/*
- ToDo: merge the block and yield macros, calling something like BLOCK(N)
- at the end;
-*/
-
-/*
- Should we actually ever do a yield in such a case?? -- HWL
-*/
-EXTFUN(gran_yield_0)
-{
- FB_
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-EXTFUN(gran_yield_1)
-{
- FB_
- Sp -= 1;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 2 Regs--------------------------------------------------------------------*/
-
-EXTFUN(gran_yield_2)
-{
- FB_
- Sp -= 2;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 3 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_yield_3)
-{
- FB_
- Sp -= 3;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 4 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_yield_4)
-{
- FB_
- Sp -= 4;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 5 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_yield_5)
-{
- FB_
- Sp -= 5;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 6 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_yield_6)
-{
- FB_
- Sp -= 6;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 7 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_yield_7)
-{
- FB_
- Sp -= 7;
- Sp[6] = R7.w;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 8 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_yield_8)
-{
- FB_
- Sp -= 8;
- Sp[7] = R8.w;
- Sp[6] = R7.w;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadYielding;
- JMP_(StgReturn);
- FE_
-}
-
-// the same routines but with a block rather than a yield
-
-EXTFUN(gran_block_1)
-{
- FB_
- Sp -= 1;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 2 Regs--------------------------------------------------------------------*/
-
-EXTFUN(gran_block_2)
-{
- FB_
- Sp -= 2;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 3 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_block_3)
-{
- FB_
- Sp -= 3;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 4 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_block_4)
-{
- FB_
- Sp -= 4;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 5 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_block_5)
-{
- FB_
- Sp -= 5;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 6 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_block_6)
-{
- FB_
- Sp -= 6;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 7 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_block_7)
-{
- FB_
- Sp -= 7;
- Sp[6] = R7.w;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-/*- 8 Regs -------------------------------------------------------------------*/
-
-EXTFUN(gran_block_8)
-{
- FB_
- Sp -= 8;
- Sp[7] = R8.w;
- Sp[6] = R7.w;
- Sp[5] = R6.w;
- Sp[4] = R5.w;
- Sp[3] = R4.w;
- Sp[2] = R3.w;
- Sp[1] = R2.w;
- Sp[0] = R1.w;
- SaveThreadState();
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-#endif
-
-#if 0 && defined(PAR)
-
-/*
- Similar to stg_block_1 (called via StgMacro BLOCK_NP) but separates the
- saving of the thread state from the actual jump via an StgReturn.
- We need this separation because we call RTS routines in blocking entry codes
- before jumping back into the RTS (see parallel/FetchMe.hc).
-*/
-
-EXTFUN(par_block_1_no_jump)
-{
- FB_
- Sp -= 1;
- Sp[0] = R1.w;
- SaveThreadState();
- FE_
-}
-
-EXTFUN(par_jump)
-{
- FB_
- CurrentTSO->what_next = ThreadRunGHC;
- R1.i = ThreadBlocked;
- JMP_(StgReturn);
- FE_
-}
-
-#endif
-
-/* -----------------------------------------------------------------------------
- Heap checks in Primitive case alternatives
-
- A primitive case alternative is entered with a value either in
- R1, FloatReg1 or D1 depending on the return convention. All the
- cases are covered below.
- -------------------------------------------------------------------------- */
-
-/*-- No Registers live ------------------------------------------------------ */
-
-EXTFUN(stg_gc_noregs)
-{
- FB_
- GC_GENERIC
- FE_
-}
-
-/*-- void return ------------------------------------------------------------ */
-
-INFO_TABLE_RET( stg_gc_void_info, stg_gc_void_ret,
- MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_gc_void_ret)
-{
- FB_
- Sp += 1;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-/*-- R1 is boxed/unpointed -------------------------------------------------- */
-
-INFO_TABLE_RET( stg_gc_unpt_r1_info, stg_gc_unpt_r1_ret,
- MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_gc_unpt_r1_ret)
-{
- FB_
- R1.w = Sp[1];
- Sp += 2;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-EXTFUN(stg_gc_unpt_r1)
-{
- FB_
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_gc_unpt_r1_info;
- GC_GENERIC
- FE_
-}
-
-/*-- R1 is unboxed -------------------------------------------------- */
-
-INFO_TABLE_RET( stg_gc_unbx_r1_info, stg_gc_unbx_r1_ret,
- MK_SMALL_BITMAP(1/*framesize*/, 1/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
-
-/* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */
-
-EXTFUN(stg_gc_unbx_r1_ret)
-{
- FB_
- R1.w = Sp[1];
- Sp += 2;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-EXTFUN(stg_gc_unbx_r1)
-{
- FB_
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_gc_unbx_r1_info;
- GC_GENERIC
- FE_
-}
-
-/*-- F1 contains a float ------------------------------------------------- */
-
-INFO_TABLE_RET( stg_gc_f1_info, stg_gc_f1_ret,
- MK_SMALL_BITMAP(1/*framesize*/, 1/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_gc_f1_ret)
-{
- FB_
- F1 = PK_FLT(Sp+1);
- Sp += 2;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-EXTFUN(stg_gc_f1)
-{
- FB_
- Sp -= 2;
- ASSIGN_FLT(Sp+1, F1);
- Sp[0] = (W_)&stg_gc_f1_info;
- GC_GENERIC
- FE_
-}
-
-/*-- D1 contains a double ------------------------------------------------- */
-
-/* we support doubles of either 1 or 2 words in size */
-
-#if SIZEOF_DOUBLE == SIZEOF_VOID_P
-# define DBL_BITMAP 1
-# define DBL_WORDS 1
-#else
-# define DBL_BITMAP 3
-# define DBL_WORDS 2
-#endif
-
-INFO_TABLE_RET( stg_gc_d1_info, stg_gc_d1_ret,
- MK_SMALL_BITMAP(DBL_WORDS/*framesize*/, DBL_BITMAP/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_gc_d1_ret)
-{
- FB_
- D1 = PK_DBL(Sp+1);
- Sp += 1 + sizeofW(StgDouble);
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-EXTFUN(stg_gc_d1)
-{
- FB_
- Sp -= 1 + sizeofW(StgDouble);
- ASSIGN_DBL(Sp+1,D1);
- Sp[0] = (W_)&stg_gc_d1_info;
- GC_GENERIC
- FE_
-}
-
-
-/*-- L1 contains an int64 ------------------------------------------------- */
-
-/* we support int64s of either 1 or 2 words in size */
-
-#if SIZEOF_VOID_P == 8
-# define LLI_BITMAP 1
-# define LLI_WORDS 1
-#else
-# define LLI_BITMAP 3
-# define LLI_WORDS 2
-#endif
-
-INFO_TABLE_RET( stg_gc_l1_info, stg_gc_l1_ret,
- MK_SMALL_BITMAP(LLI_WORDS/*framesize*/, LLI_BITMAP/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_gc_l1_ret)
-{
- FB_
- L1 = PK_Int64(Sp+1);
- Sp += 1 + sizeofW(StgWord64);
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-EXTFUN(stg_gc_l1)
-{
- FB_
- Sp -= 1 + sizeofW(StgWord64);
- ASSIGN_Int64(Sp+1,L1);
- Sp[0] = (W_)&stg_gc_l1_info;
- GC_GENERIC
- FE_
-}
-
-/*-- Unboxed tuple return, one pointer (unregisterised build only) ---------- */
-
-INFO_TABLE_RET( stg_ut_1_0_unreg_info, stg_ut_1_0_unreg_ret,
- MK_SMALL_BITMAP(1/*size*/, 0/*BITMAP*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
-
-EXTFUN(stg_ut_1_0_unreg_ret)
-{
- FB_
- Sp++;
- /* one ptr is on the stack (Sp[0]) */
- JMP_(ENTRY_CODE(Sp[1]));
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Generic function entry heap check code.
-
- At a function entry point, the arguments are as per the calling convention,
- i.e. some in regs and some on the stack. There may or may not be
- a pointer to the function closure in R1 - if there isn't, then the heap
- check failure code in the function will arrange to load it.
-
- The function's argument types are described in its info table, so we
- can just jump to this bit of generic code to save away all the
- registers and return to the scheduler.
-
- This code arranges the stack like this:
-
- | .... |
- | args |
- +---------------------+
- | f_closure |
- +---------------------+
- | size |
- +---------------------+
- | stg_gc_fun_info |
- +---------------------+
-
- The size is the number of words of arguments on the stack, and is cached
- in the frame in order to simplify stack walking: otherwise the size of
- this stack frame would have to be calculated by looking at f's info table.
-
- -------------------------------------------------------------------------- */
-
-EXTFUN(__stg_gc_fun)
-{
- StgWord size;
- StgFunInfoTable *info;
- FB_
-
- info = get_fun_itbl(R1.cl);
-
- // cache the size
- if (info->fun_type == ARG_GEN) {
- size = BITMAP_SIZE(info->bitmap);
- } else if (info->fun_type == ARG_GEN_BIG) {
- size = ((StgLargeBitmap *)info->bitmap)->size;
- } else {
- size = BITMAP_SIZE(stg_arg_bitmaps[info->fun_type]);
- }
-
-#ifdef NO_ARG_REGS
- // we don't have to save any registers away
- Sp -= 3;
- Sp[2] = R1.w;
- Sp[1] = size;
- Sp[0] = (W_)&stg_gc_fun_info;
- GC_GENERIC
-#else
- if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
- // regs already saved by the heap check code
- Sp -= 3;
- Sp[2] = R1.w;
- Sp[1] = size;
- Sp[0] = (W_)&stg_gc_fun_info;
- DEBUG_ONLY(fprintf(stderr, "stg_fun_gc_gen(ARG_GEN)"););
- GC_GENERIC
- } else {
- JMP_(stg_stack_save_entries[info->fun_type]);
- // jumps to stg_gc_noregs after saving stuff
- }
-#endif // !NO_ARG_REGS
-
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Generic Apply (return point)
-
- The dual to stg_fun_gc_gen (above): this fragment returns to the
- function, passing arguments in the stack and in registers
- appropriately. The stack layout is given above.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE_RET( stg_gc_fun_info,stg_gc_fun_ret,
- MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_FUN,, EF_, 0, 0);
-
-EXTFUN(stg_gc_fun_ret)
-{
- FB_
- R1.w = Sp[2];
- Sp += 3;
-#ifdef NO_ARG_REGS
- // there are no argument registers to load up, so we can just jump
- // straight to the function's entry point.
- JMP_(GET_ENTRY(R1.cl));
-#else
- {
- StgFunInfoTable *info;
-
- info = get_fun_itbl(R1.cl);
- if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
- // regs already saved by the heap check code
- DEBUG_ONLY(fprintf(stderr, "stg_gc_fun_ret(ARG_GEN)\n"););
- JMP_(info->slow_apply);
- } else if (info->fun_type == ARG_BCO) {
- // cover this case just to be on the safe side
- Sp -= 2;
- Sp[1] = R1.cl;
- Sp[0] = (W_)&stg_apply_interp_info;
- JMP_(stg_yield_to_interpreter);
- } else {
- JMP_(stg_ap_stack_entries[info->fun_type]);
- }
- }
-#endif
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Generic Heap Check Code.
-
- Called with Liveness mask in R9, Return address in R10.
- Stack must be consistent (containing all necessary info pointers
- to relevant SRTs).
-
- See StgMacros.h for a description of the RET_DYN stack frame.
-
- We also define an stg_gen_yield here, because it's very similar.
- -------------------------------------------------------------------------- */
-
-// For simplicity, we assume that SIZEOF_DOUBLE == 2*SIZEOF_VOID_P
-// on a 64-bit machine, we'll end up wasting a couple of words, but
-// it's not a big deal.
-
-#define RESTORE_EVERYTHING \
- L1 = PK_Word64(Sp+19); \
- D2 = PK_DBL(Sp+17); \
- D1 = PK_DBL(Sp+15); \
- F4 = PK_FLT(Sp+14); \
- F3 = PK_FLT(Sp+13); \
- F2 = PK_FLT(Sp+12); \
- F1 = PK_FLT(Sp+11); \
- R8.w = Sp[10]; \
- R7.w = Sp[9]; \
- R6.w = Sp[8]; \
- R5.w = Sp[7]; \
- R4.w = Sp[6]; \
- R3.w = Sp[5]; \
- R2.w = Sp[4]; \
- R1.w = Sp[3]; \
- Sp += 21;
-
-#define RET_OFFSET (-19)
-
-#define SAVE_EVERYTHING \
- Sp -= 21; \
- ASSIGN_Word64(Sp+19,L1); \
- ASSIGN_DBL(Sp+17,D2); \
- ASSIGN_DBL(Sp+15,D1); \
- ASSIGN_FLT(Sp+14,F4); \
- ASSIGN_FLT(Sp+13,F3); \
- ASSIGN_FLT(Sp+12,F2); \
- ASSIGN_FLT(Sp+11,F1); \
- Sp[10] = R8.w; \
- Sp[9] = R7.w; \
- Sp[8] = R6.w; \
- Sp[7] = R5.w; \
- Sp[6] = R4.w; \
- Sp[5] = R3.w; \
- Sp[4] = R2.w; \
- Sp[3] = R1.w; \
- Sp[2] = R10.w; /* return address */ \
- Sp[1] = R9.w; /* liveness mask */ \
- Sp[0] = (W_)&stg_gc_gen_info; \
-
-INFO_TABLE_RET( stg_gc_gen_info, stg_gc_gen_ret,
- 0/*bitmap*/,
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_DYN,, EF_, 0, 0);
-
-/* bitmap in the above info table is unused, the real one is on the stack.
- */
-
-FN_(stg_gc_gen_ret)
-{
- FB_
- RESTORE_EVERYTHING;
- JMP_(Sp[RET_OFFSET]); /* No ENTRY_CODE() - this is an actual code ptr */
- FE_
-}
-
-FN_(stg_gc_gen)
-{
- FB_
- SAVE_EVERYTHING;
- GC_GENERIC
- FE_
-}
-
-// A heap check at an unboxed tuple return point. The return address
-// is on the stack, and we can find it by using the offsets given
-// to us in the liveness mask.
-FN_(stg_gc_ut)
-{
- FB_
- R10.w = (W_)ENTRY_CODE(Sp[GET_NONPTRS(R9.w) + GET_PTRS(R9.w)]);
- SAVE_EVERYTHING;
- GC_GENERIC
- FE_
-}
-
-/*
- * stg_gen_hp is used by MAYBE_GC, where we can't use GC_GENERIC
- * because we've just failed doYouWantToGC(), not a standard heap
- * check. GC_GENERIC would end up returning StackOverflow.
- */
-FN_(stg_gc_gen_hp)
-{
- FB_
- SAVE_EVERYTHING;
- HP_GENERIC
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Yields
- -------------------------------------------------------------------------- */
-
-FN_(stg_gen_yield)
-{
- FB_
- SAVE_EVERYTHING;
- YIELD_GENERIC
- FE_
-}
-
-FN_(stg_yield_noregs)
-{
- FB_
- YIELD_GENERIC;
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Yielding to the interpreter... top of stack says what to do next.
- -------------------------------------------------------------------------- */
-
-FN_(stg_yield_to_interpreter)
-{
- FB_
- YIELD_TO_INTERPRETER;
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Blocks
- -------------------------------------------------------------------------- */
-
-FN_(stg_gen_block)
-{
- FB_
- SAVE_EVERYTHING;
- BLOCK_GENERIC
- FE_
-}
-
-FN_(stg_block_noregs)
-{
- FB_
- BLOCK_GENERIC;
- FE_
-}
-
-FN_(stg_block_1)
-{
- FB_
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_enter_info;
- BLOCK_GENERIC;
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- * takeMVar/putMVar-specific blocks
- *
- * Stack layout for a thread blocked in takeMVar:
- *
- * ret. addr
- * ptr to MVar (R1)
- * stg_block_takemvar_info
- *
- * Stack layout for a thread blocked in putMVar:
- *
- * ret. addr
- * ptr to Value (R2)
- * ptr to MVar (R1)
- * stg_block_putmvar_info
- *
- * See PrimOps.hc for a description of the workings of take/putMVar.
- *
- * -------------------------------------------------------------------------- */
-
-INFO_TABLE_RET( stg_block_takemvar_info, stg_block_takemvar_ret,
- MK_SMALL_BITMAP(1/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, IF_, 0, 0);
-
-IF_(stg_block_takemvar_ret)
-{
- FB_
- R1.w = Sp[1];
- Sp += 2;
- JMP_(takeMVarzh_fast);
- FE_
-}
-
-FN_(stg_block_takemvar)
-{
- FB_
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_block_takemvar_info;
- BLOCK_GENERIC;
- FE_
-}
-
-INFO_TABLE_RET( stg_block_putmvar_info, stg_block_putmvar_ret,
- MK_SMALL_BITMAP(2/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, IF_, 0, 0);
-
-IF_(stg_block_putmvar_ret)
-{
- FB_
- R2.w = Sp[2];
- R1.w = Sp[1];
- Sp += 3;
- JMP_(putMVarzh_fast);
- FE_
-}
-
-FN_(stg_block_putmvar)
-{
- FB_
- Sp -= 3;
- Sp[2] = R2.w;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_block_putmvar_info;
- BLOCK_GENERIC;
- FE_
-}
-
-#ifdef mingw32_TARGET_OS
-INFO_TABLE_RET( stg_block_async_info, stg_block_async_ret,
- MK_SMALL_BITMAP(0/*framesize*/, 0/*bitmap*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, IF_, 0, 0);
-
-IF_(stg_block_async_ret)
-{
- StgAsyncIOResult* ares;
- int len,errC;
- FB_
- ares = CurrentTSO->block_info.async_result;
- len = ares->len;
- errC = ares->errCode;
- CurrentTSO->block_info.async_result = NULL;
- STGCALL1(free,ares);
- R1.w = len;
- *Sp = (W_)errC;
- JMP_(ENTRY_CODE(Sp[1]));
- FE_
-}
-
-FN_(stg_block_async)
-{
- FB_
- Sp -= 1;
- Sp[0] = (W_)&stg_block_async_info;
- BLOCK_GENERIC;
- FE_
-}
-
-#endif
* Copyright (c) The GHC Team, 1994-2002.
* ---------------------------------------------------------------------------*/
-#if !defined(SMP)
#include "PosixSource.h"
-#else
-/* Hack and slash.. */
-#include "Stg.h"
-#endif
#include "Rts.h"
#include "RtsAPI.h"
#include "RtsUtils.h"
#include "Storage.h"
#include "Updates.h"
#include "Sanity.h"
+#include "Liveness.h"
#include "Bytecodes.h"
#include "Printer.h"
(W_)&stg_ap_pppp_info,
(W_)&stg_ap_ppppp_info,
(W_)&stg_ap_pppppp_info,
- (W_)&stg_ap_ppppppp_info
};
StgThreadReturnCode
if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
n = 6; m = 6; goto do_apply;
}
- if (info == (StgInfoTable *)&stg_ap_ppppppp_info) {
- n = 7; m = 7; goto do_apply;
- }
goto do_return_unrecognised;
}
case bci_PUSH_ALTS: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_R1p_info;
+ Sp[-2] = (W_)&stg_ctoi_R1p_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_P: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_R1unpt_info;
+ Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_N: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_R1n_info;
+ Sp[-2] = (W_)&stg_ctoi_R1n_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_F: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_F1_info;
+ Sp[-2] = (W_)&stg_ctoi_F1_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_D: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_D1_info;
+ Sp[-2] = (W_)&stg_ctoi_D1_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_L: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_L1_info;
+ Sp[-2] = (W_)&stg_ctoi_L1_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_V: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_V_info;
+ Sp[-2] = (W_)&stg_ctoi_V_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_APPLY_PPPPPP:
Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
goto nextInsn;
- case bci_PUSH_APPLY_PPPPPPP:
- Sp--; Sp[0] = (W_)&stg_ap_ppppppp_info;
- goto nextInsn;
case bci_PUSH_UBX: {
int i;
int discr = BCO_NEXT;
int failto = BCO_NEXT;
StgClosure* con = (StgClosure*)Sp[0];
- if (constrTag(con) >= discr) {
+ if (GET_TAG(con) >= discr) {
bciPtr = failto;
}
goto nextInsn;
int discr = BCO_NEXT;
int failto = BCO_NEXT;
StgClosure* con = (StgClosure*)Sp[0];
- if (constrTag(con) != discr) {
+ if (GET_TAG(con) != discr) {
bciPtr = failto;
}
goto nextInsn;
// on the stack frame to describe this chunk of stack.
//
Sp -= ret_dyn_size;
- ((StgRetDyn *)Sp)->liveness = ALL_NON_PTRS | N_NONPTRS(stk_offset);
+ ((StgRetDyn *)Sp)->liveness = NO_PTRS | N_NONPTRS(stk_offset);
((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
SAVE_STACK_POINTERS;
- tok = suspendThread(&cap->r,rtsFalse);
+ tok = suspendThread(&cap->r);
#ifndef RTS_SUPPORTS_THREADS
// Careful:
#endif
// And restart the thread again, popping the RET_DYN frame.
- cap = (Capability *)((void *)((unsigned char*)resumeThread(tok,rtsFalse) - sizeof(StgFunTable)));
+ cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - sizeof(StgFunTable)));
LOAD_STACK_POINTERS;
Sp += ret_dyn_size;
/* -----------------------------------------------------------------------------
- * $Id: LdvProfile.c,v 1.6 2003/11/12 17:49:08 sof Exp $
+ * $Id: LdvProfile.c,v 1.7 2004/08/13 13:10:05 simonmar Exp $
*
* (c) The GHC Team, 2001
* Author: Sungwoo Park
#ifdef PROFILING
-#include "Stg.h"
#include "Rts.h"
#include "LdvProfile.h"
#include "RtsFlags.h"
#include "Linker.h"
#include "LinkerInternals.h"
#include "RtsUtils.h"
-#include "StoragePriv.h"
#include "Schedule.h"
+#include "Storage.h"
#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
# define MAIN_CAP_SYM
#endif
+#ifdef TABLES_NEXT_TO_CODE
+#define RTS_RET_SYMBOLS /* nothing */
+#else
+#define RTS_RET_SYMBOLS \
+ SymX(stg_enter_ret) \
+ SymX(stg_gc_fun_ret) \
+ SymX(stg_ap_0_ret) \
+ SymX(stg_ap_v_ret) \
+ SymX(stg_ap_f_ret) \
+ SymX(stg_ap_d_ret) \
+ SymX(stg_ap_l_ret) \
+ SymX(stg_ap_n_ret) \
+ SymX(stg_ap_p_ret) \
+ SymX(stg_ap_pv_ret) \
+ SymX(stg_ap_pp_ret) \
+ SymX(stg_ap_ppv_ret) \
+ SymX(stg_ap_ppp_ret) \
+ SymX(stg_ap_pppv_ret) \
+ SymX(stg_ap_pppp_ret) \
+ SymX(stg_ap_ppppp_ret) \
+ SymX(stg_ap_pppppp_ret)
+#endif
+
#define RTS_SYMBOLS \
Maybe_ForeignObj \
Maybe_Stable_Names \
Sym(StgReturn) \
SymX(stg_enter_info) \
- SymX(stg_enter_ret) \
SymX(stg_gc_void_info) \
SymX(__stg_gc_enter_1) \
SymX(stg_gc_noregs) \
SymX(stg_gc_l1) \
SymX(__stg_gc_fun) \
SymX(stg_gc_fun_info) \
- SymX(stg_gc_fun_ret) \
SymX(stg_gc_gen) \
SymX(stg_gc_gen_info) \
SymX(stg_gc_gen_hp) \
SymX(stg_ap_pp_info) \
SymX(stg_ap_ppv_info) \
SymX(stg_ap_ppp_info) \
+ SymX(stg_ap_pppv_info) \
SymX(stg_ap_pppp_info) \
SymX(stg_ap_ppppp_info) \
SymX(stg_ap_pppppp_info) \
- SymX(stg_ap_ppppppp_info) \
- SymX(stg_ap_0_ret) \
- SymX(stg_ap_v_ret) \
- SymX(stg_ap_f_ret) \
- SymX(stg_ap_d_ret) \
- SymX(stg_ap_l_ret) \
- SymX(stg_ap_n_ret) \
- SymX(stg_ap_p_ret) \
- SymX(stg_ap_pv_ret) \
- SymX(stg_ap_pp_ret) \
- SymX(stg_ap_ppv_ret) \
- SymX(stg_ap_ppp_ret) \
- SymX(stg_ap_pppp_ret) \
- SymX(stg_ap_ppppp_ret) \
- SymX(stg_ap_pppppp_ret) \
- SymX(stg_ap_ppppppp_ret) \
SymX(stg_ap_1_upd_info) \
SymX(stg_ap_2_upd_info) \
SymX(stg_ap_3_upd_info) \
SymX(stg_ap_5_upd_info) \
SymX(stg_ap_6_upd_info) \
SymX(stg_ap_7_upd_info) \
- SymX(stg_ap_8_upd_info) \
SymX(stg_exit) \
SymX(stg_sel_0_upd_info) \
SymX(stg_sel_10_upd_info) \
#define SymX(vvv) /**/
#define SymX_redirect(vvv,xxx) /**/
RTS_SYMBOLS
+RTS_RET_SYMBOLS
RTS_LONG_LONG_SYMS
RTS_POSIX_ONLY_SYMBOLS
RTS_MINGW_ONLY_SYMBOLS
- relocateAddress(oc, nSections, sections, pair->r_value));
i++;
}
- else
+ else if(scat->r_type == PPC_RELOC_HI16
+ || scat->r_type == PPC_RELOC_LO16
+ || scat->r_type == PPC_RELOC_HA16
+ || scat->r_type == PPC_RELOC_LO14)
+ { // these are generated by label+offset things
+ struct relocation_info *pair = &relocs[i+1];
+ if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
+ barf("Invalid Mach-O file: "
+ "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
+
+ if(scat->r_type == PPC_RELOC_LO16)
+ {
+ word = ((unsigned short*) wordPtr)[1];
+ word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
+ }
+ else if(scat->r_type == PPC_RELOC_LO14)
+ {
+ barf("Unsupported Relocation: PPC_RELOC_LO14");
+ word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
+ word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
+ }
+ else if(scat->r_type == PPC_RELOC_HI16)
+ {
+ word = ((unsigned short*) wordPtr)[1] << 16;
+ word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
+ }
+ else if(scat->r_type == PPC_RELOC_HA16)
+ {
+ word = ((unsigned short*) wordPtr)[1] << 16;
+ word += ((short)relocs[i+1].r_address & (short)0xFFFF);
+ }
+
+
+ word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
+ - scat->r_value;
+
+ i++;
+ }
+ else
continue; // ignore the others
if(scat->r_type == GENERIC_RELOC_VANILLA
{
*wordPtr = word;
}
- else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF)
+ else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
{
((unsigned short*) wordPtr)[1] = word & 0xFFFF;
}
- else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF)
+ else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
{
((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
}
- else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF)
+ else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
{
((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
+ ((word & (1<<15)) ? 1 : 0);
{
struct nlist *symbol = &nlist[reloc->r_symbolnum];
char *nm = image + symLC->stroff + symbol->n_un.n_strx;
- word = (unsigned long) (lookupSymbol(nm));
- if(!word)
+ unsigned long symbolAddress = (unsigned long) (lookupSymbol(nm));
+ if(!symbolAddress)
{
belch("\nunknown symbol `%s'", nm);
return 0;
}
if(reloc->r_pcrel)
- {
+ {
+ ASSERT(word == 0);
+ word = symbolAddress;
jumpIsland = (long) makeJumpIsland(oc,reloc->r_symbolnum,(void*)word);
word -= ((long)image) + sect->offset + reloc->r_address;
if(jumpIsland != 0)
- (((long)image) + sect->offset + reloc->r_address);
}
}
+ else
+ {
+ word += symbolAddress;
+ }
}
if(reloc->r_type == GENERIC_RELOC_VANILLA)
/* -----------------------------------------------------------------------------
- * $Id: MBlock.h,v 1.19 2003/09/21 13:26:05 igloo Exp $
+ * $Id: MBlock.h,v 1.20 2004/08/13 13:10:10 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#ifndef __MBLOCK_H__
#define __MBLOCK_H__
-extern lnat mblocks_allocated;
+
+extern lnat RTS_VAR(mblocks_allocated);
extern void * getMBlock(void);
extern void * getMBlocks(nat n);
/* -----------------------------------------------------------------------------
- * $Id: Main.c,v 1.40 2003/09/21 22:20:55 wolfgang Exp $
+ * $Id: Main.c,v 1.41 2004/08/13 13:10:10 simonmar Exp $
*
* (c) The GHC Team 1998-2000
*
# include "Printer.h" /* for printing */
#endif
-#ifdef INTERPRETER
-# include "Assembler.h"
-#endif
-
#ifdef PAR
# include "Parallel.h"
# include "ParallelRts.h"
EXCLUDED_SRCS += parallel/SysMan.c
# The build system doesn't give us these
-HC_SRCS = $(filter %.hc, $(SRCS))
-HC_OBJS = $(patsubst %.hc,%.$(way_)o, $(HC_SRCS))
+CMM_SRCS = $(filter-out AutoApply%.cmm, $(wildcard *.cmm)) $(EXTRA_CMM_SRCS)
+CMM_OBJS = $(patsubst %.cmm,%.$(way_)o, $(CMM_SRCS))
-CLEAN_FILES += $(HC_OBJS)
+CLEAN_FILES += $(CMM_OBJS)
# Override the default $(LIBOBJS) (defaults to $(HS_OBJS))
-LIBOBJS = $(C_OBJS) $(HC_OBJS)
+LIBOBJS = $(C_OBJS) $(CMM_OBJS)
SplitObjs=NO
+H_FILES = $(wildcard ../includes/*.h) $(wildcard *.h)
+
#-----------------------------------------------------------------------------
# Flags for compiling RTS .c and .hc files
STANDARD_OPTS += -Iwin32
endif
-# HC_OPTS is included in both .c and .hc compilations, whereas CC_OPTS is
+# HC_OPTS is included in both .c and .cmm compilations, whereas CC_OPTS is
# only included in .c compilations. HC_OPTS included the WAY_* opts, which
# must be included in both types of compilations.
#-----------------------------------------------------------------------------
# make depend setup
-MKDEPENDC_SRCS = $(C_SRCS) $(HC_SRCS)
SRC_MKDEPENDC_OPTS += -I. -I../includes
# Hack: we define every way-related option here, so that we get (hopefully)
# -----------------------------------------------------------------------------
# The auto-generated apply code
-AUTO_APPLY = AutoApply.hc
+# We want a slightly different version for the unregisterised way, so we make
+# AutoApply on a per-way basis (eg. AutoApply_p.cmm).
+
+AUTO_APPLY_CMM = AutoApply$(_way).cmm
ifneq "$(BootingFromHc)" "YES"
-$(AUTO_APPLY): $(GHC_GENAPPLY)
+$(AUTO_APPLY_CMM): $(GHC_GENAPPLY)
@$(RM) $@
- $(GHC_GENAPPLY) >$@
+ $(GHC_GENAPPLY) $(if $(filter u,$(way)), -u) >$@
endif
-EXTRA_SRCS += $(AUTO_APPLY)
+EXTRA_CMM_SRCS += $(AUTO_APPLY_CMM)
-CLEAN_FILES += $(AUTO_APPLY)
+CLEAN_FILES += $(AUTO_APPLY_CMM)
# -----------------------------------------------------------------------------
#
endif
#-----------------------------------------------------------------------------
+# Compiling the cmm files
+
+# ToDo: should we really include Rts.h here? Required for GNU_ATTRIBUTE().
+SRC_HC_OPTS += \
+ -\#include Prelude.h \
+ -\#include Rts.h \
+ -\#include RtsFlags.h \
+ -\#include RtsUtils.h \
+ -\#include StgRun.h \
+ -\#include Schedule.h \
+ -\#include Printer.h \
+ -\#include Sanity.h \
+ -\#include Storage.h \
+ -\#include SchedAPI.h \
+ -\#include Timer.h \
+ -\#include Itimer.h \
+ -\#include ProfHeap.h \
+ -\#include LdvProfile.h \
+ -\#include Profiling.h \
+ -\#include Apply.h
+
+# Cmm must be compiled via-C for now, because the NCG can't handle loops
+SRC_HC_OPTS += -fvia-C
+
+# We *want* type-checking of hand-written cmm.
+SRC_HC_OPTS += -dcmm-lint
+
+# .cmm files depend on all the .h files, to a first approximation.
+%.$(way_)o : %.cmm $(H_FILES)
+ $(HC_PRE_OPTS)
+ $(HC) $(HC_OPTS) -c $< -o $@
+ $(HC_POST_OPTS)
+
+%.$(way_)hc : %.cmm $(H_FILES)
+ $(HC_PRE_OPTS)
+ $(HC) $(HC_OPTS) -C $< -o $@
+ $(HC_POST_OPTS)
+
+%.$(way_)s : %.cmm $(H_FILES)
+ $(HC_PRE_OPTS)
+ $(HC) $(HC_OPTS) -S $< -o $@
+ $(HC_POST_OPTS)
+
+#-----------------------------------------------------------------------------
#
# Files to install
#
/* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.25 2004/03/01 14:11:01 simonmar Exp $
+ * $Id: Prelude.h,v 1.26 2004/08/13 13:10:12 simonmar Exp $
*
- * (c) The GHC Team, 1998-2001
+ * (c) The GHC Team, 1998-2004
*
* Prelude identifiers that we sometimes need to refer to in the RTS.
*
#ifndef PRELUDE_H
#define PRELUDE_H
+/* These definitions are required by the RTS .cmm files too, so we
+ * need declarations that we can #include into the generated .hc files.
+ */
+#if IN_STG_CODE
+#define PRELUDE_INFO(i) extern W_(i)[]
+#define PRELUDE_CLOSURE(i) extern W_(i)[]
+#else
+#define PRELUDE_INFO(i) extern DLL_IMPORT const StgInfoTable i
+#define PRELUDE_CLOSURE(i) extern DLL_IMPORT StgClosure i
+#endif
+
/* Define canonical names so we can abstract away from the actual
* modules these names are defined in.
*/
-extern DLL_IMPORT StgClosure GHCziBase_True_closure;
-extern DLL_IMPORT StgClosure GHCziBase_False_closure;
-extern DLL_IMPORT StgClosure GHCziPack_unpackCString_closure;
-extern DLL_IMPORT StgClosure GHCziWeak_runFinalizzerBatch_closure;
+PRELUDE_CLOSURE(GHCziBase_True_closure);
+PRELUDE_CLOSURE(GHCziBase_False_closure);
+PRELUDE_CLOSURE(GHCziPack_unpackCString_closure);
+PRELUDE_CLOSURE(GHCziWeak_runFinalizzerBatch_closure);
+
+#ifdef IN_STG_CODE
+extern W_ ZCMain_main_closure[];
+#else
extern StgClosure ZCMain_main_closure;
-extern DLL_IMPORT StgClosure GHCziTopHandler_runIO_closure;
-extern DLL_IMPORT StgClosure GHCziTopHandler_runNonIO_closure;
+#endif
-extern DLL_IMPORT StgClosure GHCziIOBase_stackOverflow_closure;
-extern DLL_IMPORT StgClosure GHCziIOBase_heapOverflow_closure;
-extern DLL_IMPORT StgClosure GHCziIOBase_BlockedOnDeadMVar_closure;
-extern DLL_IMPORT StgClosure GHCziIOBase_NonTermination_closure;
+PRELUDE_CLOSURE(GHCziIOBase_stackOverflow_closure);
+PRELUDE_CLOSURE(GHCziIOBase_heapOverflow_closure);
+PRELUDE_CLOSURE(GHCziIOBase_BlockedOnDeadMVar_closure);
+PRELUDE_CLOSURE(GHCziIOBase_NonTermination_closure);
-extern DLL_IMPORT const StgInfoTable GHCziBase_Czh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziBase_Izh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziFloat_Fzh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziFloat_Dzh_static_info;
-extern DLL_IMPORT const StgInfoTable Addr_Azh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziPtr_Ptr_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziPtr_FunPtr_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziInt_I8zh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziInt_I16zh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziInt_I32zh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziInt_I64zh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_Wzh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_W8zh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_W16zh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_W32zh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_W64zh_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziBase_Czh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziBase_Izh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziFloat_Fzh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziFloat_Dzh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziPtr_Ptr_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziPtr_FunPtr_con_info;
-extern DLL_IMPORT const StgInfoTable Addr_Azh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_Wzh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziInt_I8zh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziInt_I16zh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziInt_I32zh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziInt_I64zh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_W8zh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_W16zh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_W32zh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziWord_W64zh_con_info;
-extern DLL_IMPORT const StgInfoTable GHCziStable_StablePtr_static_info;
-extern DLL_IMPORT const StgInfoTable GHCziStable_StablePtr_con_info;
+PRELUDE_INFO(GHCziBase_Czh_static_info);
+PRELUDE_INFO(GHCziBase_Izh_static_info);
+PRELUDE_INFO(GHCziFloat_Fzh_static_info);
+PRELUDE_INFO(GHCziFloat_Dzh_static_info);
+PRELUDE_INFO(Addr_Azh_static_info);
+PRELUDE_INFO(GHCziPtr_Ptr_static_info);
+PRELUDE_INFO(GHCziPtr_FunPtr_static_info);
+PRELUDE_INFO(GHCziInt_I8zh_static_info);
+PRELUDE_INFO(GHCziInt_I16zh_static_info);
+PRELUDE_INFO(GHCziInt_I32zh_static_info);
+PRELUDE_INFO(GHCziInt_I64zh_static_info);
+PRELUDE_INFO(GHCziWord_Wzh_static_info);
+PRELUDE_INFO(GHCziWord_W8zh_static_info);
+PRELUDE_INFO(GHCziWord_W16zh_static_info);
+PRELUDE_INFO(GHCziWord_W32zh_static_info);
+PRELUDE_INFO(GHCziWord_W64zh_static_info);
+PRELUDE_INFO(GHCziBase_Czh_con_info);
+PRELUDE_INFO(GHCziBase_Izh_con_info);
+PRELUDE_INFO(GHCziFloat_Fzh_con_info);
+PRELUDE_INFO(GHCziFloat_Dzh_con_info);
+PRELUDE_INFO(GHCziPtr_Ptr_con_info);
+PRELUDE_INFO(GHCziPtr_FunPtr_con_info);
+PRELUDE_INFO(Addr_Azh_con_info);
+PRELUDE_INFO(GHCziWord_Wzh_con_info);
+PRELUDE_INFO(GHCziInt_I8zh_con_info);
+PRELUDE_INFO(GHCziInt_I16zh_con_info);
+PRELUDE_INFO(GHCziInt_I32zh_con_info);
+PRELUDE_INFO(GHCziInt_I64zh_con_info);
+PRELUDE_INFO(GHCziWord_W8zh_con_info);
+PRELUDE_INFO(GHCziWord_W16zh_con_info);
+PRELUDE_INFO(GHCziWord_W32zh_con_info);
+PRELUDE_INFO(GHCziWord_W64zh_con_info);
+PRELUDE_INFO(GHCziStable_StablePtr_static_info);
+PRELUDE_INFO(GHCziStable_StablePtr_con_info);
#define True_closure (&GHCziBase_True_closure)
#define False_closure (&GHCziBase_False_closure)
#define unpackCString_closure (&GHCziPack_unpackCString_closure)
#define runFinalizerBatch_closure (&GHCziWeak_runFinalizzerBatch_closure)
#define mainIO_closure (&ZCMain_main_closure)
-#define runIO_closure (&GHCziTopHandler_runIO_closure)
-#define runNonIO_closure (&GHCziTopHandler_runNonIO_closure)
#define stackOverflow_closure (&GHCziIOBase_stackOverflow_closure)
#define heapOverflow_closure (&GHCziIOBase_heapOverflow_closure)
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Out-of-line primitive operations
+ *
+ * This file contains the implementations of all the primitive
+ * operations ("primops") which are not expanded inline. See
+ * ghc/compiler/prelude/primops.txt.pp for a list of all the primops;
+ * this file contains code for most of those with the attribute
+ * out_of_line=True.
+ *
+ * Entry convention: the entry convention for a primop is that all the
+ * args are in Stg registers (R1, R2, etc.). This is to make writing
+ * the primops easier. (see compiler/codeGen/CgCallConv.hs).
+ *
+ * Return convention: results from a primop are generally returned
+ * using the ordinary unboxed tuple return convention. The C-- parser
+ * implements the RET_xxxx() macros to perform unboxed-tuple returns
+ * based on the prevailing return convention.
+ *
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC. It is compiled by GHC directly. For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Cmm.h"
+
+/*-----------------------------------------------------------------------------
+ Array Primitives
+
+ Basically just new*Array - the others are all inline macros.
+
+ The size arg is always passed in R1, and the result returned in R1.
+
+ The slow entry point is for returning from a heap check, the saved
+ size argument must be re-loaded from the stack.
+ -------------------------------------------------------------------------- */
+
+/* for objects that are *less* than the size of a word, make sure we
+ * round up to the nearest word for the size of the array.
+ */
+
+newByteArrayzh_fast
+{
+ W_ words, payload_words, n, p;
+ MAYBE_GC(NO_PTRS,newByteArrayzh_fast);
+ n = R1;
+ payload_words = ROUNDUP_BYTES_TO_WDS(n);
+ words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
+ "ptr" p = foreign "C" allocate(words);
+ TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+ SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+ StgArrWords_words(p) = payload_words;
+ RET_P(p);
+}
+
+newPinnedByteArrayzh_fast
+{
+ W_ words, payload_words, n, p;
+
+ MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast);
+ n = R1;
+ payload_words = ROUNDUP_BYTES_TO_WDS(n);
+
+ // We want an 8-byte aligned array. allocatePinned() gives us
+ // 8-byte aligned memory by default, but we want to align the
+ // *goods* inside the ArrWords object, so we have to check the
+ // size of the ArrWords header and adjust our size accordingly.
+ words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
+ if ((SIZEOF_StgArrWords & 7) != 0) {
+ words = words + 1;
+ }
+
+ "ptr" p = foreign "C" allocatePinned(words);
+ TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+
+ // Again, if the ArrWords header isn't a multiple of 8 bytes, we
+ // have to push the object forward one word so that the goods
+ // fall on an 8-byte boundary.
+ if ((SIZEOF_StgArrWords & 7) != 0) {
+ p = p + WDS(1);
+ }
+
+ SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+ StgArrWords_words(p) = payload_words;
+ RET_P(p);
+}
+
+newArrayzh_fast
+{
+ W_ words, n, init, arr, p;
+ /* Args: R1 = words, R2 = initialisation value */
+
+ n = R1;
+ MAYBE_GC(R2_PTR,newArrayzh_fast);
+
+ words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + n;
+ "ptr" arr = foreign "C" allocate(words);
+ TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
+
+ SET_HDR(arr, stg_MUT_ARR_PTRS_info, W_[CCCS]);
+ StgMutArrPtrs_ptrs(arr) = n;
+
+ // Initialise all elements of the the array with the value in R2
+ init = R2;
+ p = arr + SIZEOF_StgMutArrPtrs;
+ for:
+ if (p < arr + WDS(words)) {
+ W_[p] = init;
+ p = p + WDS(1);
+ goto for;
+ }
+
+ RET_P(arr);
+}
+
+unsafeThawArrayzh_fast
+{
+ SET_INFO(R1,stg_MUT_ARR_PTRS_info);
+
+ // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
+ //
+ // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
+ // normally doesn't. However, when we freeze a MUT_ARR_PTRS, we leave
+ // it on the mutable list for the GC to remove (removing something from
+ // the mutable list is not easy, because the mut_list is only singly-linked).
+ //
+ // So, when we thaw a MUT_ARR_PTRS_FROZEN, we must cope with two cases:
+ // either it is on a mut_list, or it isn't. We adopt the convention that
+ // the mut_link field is NULL if it isn't on a mut_list, and the GC
+ // maintains this invariant.
+ //
+ if (StgMutClosure_mut_link(R1) == NULL) {
+ foreign "C" recordMutable(R1 "ptr");
+ }
+
+ RET_P(R1);
+}
+
+/* -----------------------------------------------------------------------------
+ MutVar primitives
+ -------------------------------------------------------------------------- */
+
+newMutVarzh_fast
+{
+ W_ mv;
+ /* Args: R1 = initialisation value */
+
+ ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, newMutVarzh_fast);
+
+ mv = Hp - SIZEOF_StgMutVar + WDS(1);
+ SET_HDR(mv,stg_MUT_VAR_info,W_[CCCS]);
+ StgMutVar_var(mv) = R1;
+
+ RET_P(mv);
+}
+
+atomicModifyMutVarzh_fast
+{
+ W_ mv, z, x, y, r;
+ /* Args: R1 :: MutVar#, R2 :: a -> (a,b) */
+
+ /* If x is the current contents of the MutVar#, then
+ We want to make the new contents point to
+
+ (sel_0 (f x))
+
+ and the return value is
+
+ (sel_1 (f x))
+
+ obviously we can share (f x).
+
+ z = [stg_ap_2 f x] (max (HS + 2) MIN_UPD_SIZE)
+ y = [stg_sel_0 z] (max (HS + 1) MIN_UPD_SIZE)
+ r = [stg_sel_1 z] (max (HS + 1) MIN_UPD_SIZE)
+ */
+
+#if MIN_UPD_SIZE > 1
+#define THUNK_1_SIZE (SIZEOF_StgHeader + WDS(MIN_UPD_SIZE))
+#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
+#else
+#define THUNK_1_SIZE (SIZEOF_StgHeader + WDS(1))
+#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
+#endif
+
+#if MIN_UPD_SIZE > 2
+#define THUNK_2_SIZE (SIZEOF_StgHeader + WDS(MIN_UPD_SIZE))
+#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
+#else
+#define THUNK_2_SIZE (SIZEOF_StgHeader + WDS(2))
+#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
+#endif
+
+#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)
+
+ HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, atomicModifyMutVarzh_fast);
+
+ x = StgMutVar_var(R1);
+
+ TICK_ALLOC_THUNK_2();
+ CCCS_ALLOC(THUNK_2_SIZE);
+ z = Hp - THUNK_2_SIZE + WDS(1);
+ SET_HDR(z, stg_ap_2_upd_info, W_[CCCS]);
+ LDV_RECORD_CREATE(z);
+ StgClosure_payload(z,0) = R2;
+ StgClosure_payload(z,1) = x;
+
+ TICK_ALLOC_THUNK_1();
+ CCCS_ALLOC(THUNK_1_SIZE);
+ y = z - THUNK_1_SIZE;
+ SET_HDR(y, stg_sel_0_upd_info, W_[CCCS]);
+ LDV_RECORD_CREATE(y);
+ StgClosure_payload(y,0) = z;
+
+ StgMutVar_var(R1) = y;
+
+ TICK_ALLOC_THUNK_1();
+ CCCS_ALLOC(THUNK_1_SIZE);
+ r = y - THUNK_1_SIZE;
+ SET_HDR(r, stg_sel_1_upd_info, W_[CCCS]);
+ LDV_RECORD_CREATE(r);
+ StgClosure_payload(r,0) = z;
+
+ RET_P(r);
+}
+
+/* -----------------------------------------------------------------------------
+ Foreign Object Primitives
+ -------------------------------------------------------------------------- */
+
+mkForeignObjzh_fast
+{
+ /* R1 = ptr to foreign object,
+ */
+ W_ result;
+
+ ALLOC_PRIM( SIZEOF_StgForeignObj, NO_PTRS, mkForeignObjzh_fast);
+
+ result = Hp - SIZEOF_StgForeignObj + WDS(1);
+ SET_HDR(result,stg_FOREIGN_info,W_[CCCS]);
+ StgForeignObj_data(result) = R1;
+
+ /* returns (# s#, ForeignObj# #) */
+ RET_P(result);
+}
+
+/* -----------------------------------------------------------------------------
+ Weak Pointer Primitives
+ -------------------------------------------------------------------------- */
+
+STRING(stg_weak_msg,"New weak pointer at %p\n")
+
+mkWeakzh_fast
+{
+ /* R1 = key
+ R2 = value
+ R3 = finalizer (or NULL)
+ */
+ W_ w;
+
+ if (R3 == NULL) {
+ R3 = stg_NO_FINALIZER_closure;
+ }
+
+ ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, mkWeakzh_fast );
+
+ w = Hp - SIZEOF_StgWeak + WDS(1);
+ SET_HDR(w, stg_WEAK_info, W_[CCCS]);
+
+ StgWeak_key(w) = R1;
+ StgWeak_value(w) = R2;
+ StgWeak_finalizer(w) = R3;
+
+ StgWeak_link(w) = W_[weak_ptr_list];
+ W_[weak_ptr_list] = w;
+
+ IF_DEBUG(weak, foreign "C" fprintf(stderr,stg_weak_msg,w));
+
+ RET_P(w);
+}
+
+
+finalizzeWeakzh_fast
+{
+ /* R1 = weak ptr
+ */
+ W_ w, f;
+
+ w = R1;
+
+ // already dead?
+ if (GET_INFO(w) == stg_DEAD_WEAK_info) {
+ RET_NP(0,stg_NO_FINALIZER_closure);
+ }
+
+ // kill it
+#ifdef PROFILING
+ // @LDV profiling
+ // A weak pointer is inherently used, so we do not need to call
+ // LDV_recordDead_FILL_SLOP_DYNAMIC():
+ // LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
+ // or, LDV_recordDead():
+ // LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
+ // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
+ // large as weak pointers, so there is no need to fill the slop, either.
+ // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
+#endif
+
+ //
+ // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
+ //
+ SET_INFO(w,stg_DEAD_WEAK_info);
+ LDV_RECORD_CREATE(w);
+
+ f = StgWeak_finalizer(w);
+
+ /* return the finalizer */
+ if (f == stg_NO_FINALIZER_closure) {
+ RET_NP(0,stg_NO_FINALIZER_closure);
+ } else {
+ RET_NP(1,f);
+ }
+}
+
+deRefWeakzh_fast
+{
+ /* R1 = weak ptr */
+ W_ w, code, val;
+
+ w = R1;
+ if (GET_INFO(w) == stg_WEAK_info) {
+ code = 1;
+ val = StgWeak_value(w);
+ } else {
+ code = 0;
+ val = w;
+ }
+ RET_NP(code,val);
+}
+
+/* -----------------------------------------------------------------------------
+ Arbitrary-precision Integer operations.
+
+ There are some assumptions in this code that mp_limb_t == W_. This is
+ the case for all the platforms that GHC supports, currently.
+ -------------------------------------------------------------------------- */
+
+int2Integerzh_fast
+{
+ /* arguments: R1 = Int# */
+
+ W_ val, s, p; /* to avoid aliasing */
+
+ val = R1;
+ ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, int2Integerzh_fast );
+
+ p = Hp - SIZEOF_StgArrWords;
+ SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+ StgArrWords_words(p) = 1;
+
+ /* mpz_set_si is inlined here, makes things simpler */
+ if (%lt(val,0)) {
+ s = -1;
+ Hp(0) = -val;
+ } else {
+ if (%gt(val,0)) {
+ s = 1;
+ Hp(0) = val;
+ } else {
+ s = 0;
+ }
+ }
+
+ /* returns (# size :: Int#,
+ data :: ByteArray#
+ #)
+ */
+ RET_NP(s,p);
+}
+
+word2Integerzh_fast
+{
+ /* arguments: R1 = Word# */
+
+ W_ val, s, p; /* to avoid aliasing */
+
+ val = R1;
+
+ ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, word2Integerzh_fast);
+
+ p = Hp - SIZEOF_StgArrWords;
+ SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+ StgArrWords_words(p) = 1;
+
+ if (val != 0) {
+ s = 1;
+ W_[Hp] = val;
+ } else {
+ s = 0;
+ }
+
+ /* returns (# size :: Int#,
+ data :: ByteArray# #)
+ */
+ RET_NP(s,p);
+}
+
+
+/*
+ * 'long long' primops for converting to/from Integers.
+ */
+
+#ifdef SUPPORT_LONG_LONGS
+
+int64ToIntegerzh_fast
+{
+ /* arguments: L1 = Int64# */
+
+ L_ val;
+ W_ hi, s, neg, words_needed, p;
+
+ val = L1;
+ neg = 0;
+
+ if ( %ge(val,0x100000000::L_) || %le(val,-0x100000000::L_) ) {
+ words_needed = 2;
+ } else {
+ // minimum is one word
+ words_needed = 1;
+ }
+
+ ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
+ NO_PTRS, int64ToIntegerzh_fast );
+
+ p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
+ SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+ StgArrWords_words(p) = words_needed;
+
+ if ( %lt(val,0::L_) ) {
+ neg = 1;
+ val = -val;
+ }
+
+ hi = TO_W_(val >> 32);
+
+ if ( words_needed == 2 ) {
+ s = 2;
+ Hp(-1) = TO_W_(val);
+ Hp(0) = hi;
+ } else {
+ if ( val != 0::L_ ) {
+ s = 1;
+ Hp(0) = TO_W_(val);
+ } else /* val==0 */ {
+ s = 0;
+ }
+ }
+ if ( neg != 0 ) {
+ s = -s;
+ }
+
+ /* returns (# size :: Int#,
+ data :: ByteArray# #)
+ */
+ RET_NP(s,p);
+}
+
+word64ToIntegerzh_fast
+{
+ /* arguments: L1 = Word64# */
+
+ L_ val;
+ W_ hi, s, words_needed, p;
+
+ val = L1;
+ if ( val >= 0x100000000::L_ ) {
+ words_needed = 2;
+ } else {
+ words_needed = 1;
+ }
+
+ ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
+ NO_PTRS, word64ToIntegerzh_fast );
+
+ p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
+ SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+ StgArrWords_words(p) = words_needed;
+
+ hi = TO_W_(val >> 32);
+ if ( val >= 0x100000000::L_ ) {
+ s = 2;
+ Hp(-1) = TO_W_(val);
+ Hp(0) = hi;
+ } else {
+ if ( val != 0::L_ ) {
+ s = 1;
+ Hp(0) = TO_W_(val);
+ } else /* val==0 */ {
+ s = 0;
+ }
+ }
+
+ /* returns (# size :: Int#,
+ data :: ByteArray# #)
+ */
+ RET_NP(s,p);
+}
+
+
+#endif /* SUPPORT_LONG_LONGS */
+
+/* ToDo: this is shockingly inefficient */
+
+section "bss" {
+ mp_tmp1:
+ bits8 [SIZEOF_MP_INT];
+}
+
+section "bss" {
+ mp_tmp2:
+ bits8 [SIZEOF_MP_INT];
+}
+
+section "bss" {
+ result1:
+ bits8 [SIZEOF_MP_INT];
+}
+
+section "bss" {
+ result2:
+ bits8 [SIZEOF_MP_INT];
+}
+
+#define GMP_TAKE2_RET1(name,mp_fun) \
+name \
+{ \
+ W_ s1, s2, d1, d2; \
+ \
+ /* call doYouWantToGC() */ \
+ MAYBE_GC(R2_PTR & R4_PTR, name); \
+ \
+ s1 = R1; \
+ d1 = R2; \
+ s2 = R3; \
+ d2 = R4; \
+ \
+ MP_INT__mp_alloc(mp_tmp1) = StgArrWords_words(d1); \
+ MP_INT__mp_size(mp_tmp1) = (s1); \
+ MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(d1); \
+ MP_INT__mp_alloc(mp_tmp2) = StgArrWords_words(d2); \
+ MP_INT__mp_size(mp_tmp2) = (s2); \
+ MP_INT__mp_d(mp_tmp2) = BYTE_ARR_CTS(d2); \
+ \
+ foreign "C" mpz_init(result1); \
+ \
+ /* Perform the operation */ \
+ foreign "C" mp_fun(result1,mp_tmp1,mp_tmp2); \
+ \
+ RET_NP(MP_INT__mp_size(result1), \
+ MP_INT__mp_d(result1) - SIZEOF_StgArrWords); \
+}
+
+#define GMP_TAKE1_RET1(name,mp_fun) \
+name \
+{ \
+ W_ s1, d1; \
+ \
+ /* call doYouWantToGC() */ \
+ MAYBE_GC(R2_PTR, name); \
+ \
+ d1 = R2; \
+ s1 = R1; \
+ \
+ MP_INT__mp_alloc(mp_tmp1) = StgArrWords_words(d1); \
+ MP_INT__mp_size(mp_tmp1) = (s1); \
+ MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(d1); \
+ \
+ foreign "C" mpz_init(result1); \
+ \
+ /* Perform the operation */ \
+ foreign "C" mp_fun(result1,mp_tmp1); \
+ \
+ RET_NP(MP_INT__mp_size(result1), \
+ MP_INT__mp_d(result1) - SIZEOF_StgArrWords); \
+}
+
+#define GMP_TAKE2_RET2(name,mp_fun) \
+name \
+{ \
+ W_ s1, s2, d1, d2; \
+ \
+ /* call doYouWantToGC() */ \
+ MAYBE_GC(R2_PTR & R4_PTR, name); \
+ \
+ s1 = R1; \
+ d1 = R2; \
+ s2 = R3; \
+ d2 = R4; \
+ \
+ MP_INT__mp_alloc(mp_tmp1) = StgArrWords_words(d1); \
+ MP_INT__mp_size(mp_tmp1) = (s1); \
+ MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(d1); \
+ MP_INT__mp_alloc(mp_tmp2) = StgArrWords_words(d2); \
+ MP_INT__mp_size(mp_tmp2) = (s2); \
+ MP_INT__mp_d(mp_tmp2) = BYTE_ARR_CTS(d2); \
+ \
+ foreign "C" mpz_init(result1); \
+ foreign "C" mpz_init(result2); \
+ \
+ /* Perform the operation */ \
+ foreign "C" mp_fun(result1,result2,mp_tmp1,mp_tmp2); \
+ \
+ RET_NPNP(MP_INT__mp_size(result1), \
+ MP_INT__mp_d(result1) - SIZEOF_StgArrWords, \
+ MP_INT__mp_size(result2), \
+ MP_INT__mp_d(result2) - SIZEOF_StgArrWords); \
+}
+
+GMP_TAKE2_RET1(plusIntegerzh_fast, mpz_add)
+GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub)
+GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul)
+GMP_TAKE2_RET1(gcdIntegerzh_fast, mpz_gcd)
+GMP_TAKE2_RET1(quotIntegerzh_fast, mpz_tdiv_q)
+GMP_TAKE2_RET1(remIntegerzh_fast, mpz_tdiv_r)
+GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact)
+GMP_TAKE2_RET1(andIntegerzh_fast, mpz_and)
+GMP_TAKE2_RET1(orIntegerzh_fast, mpz_ior)
+GMP_TAKE2_RET1(xorIntegerzh_fast, mpz_xor)
+GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com)
+
+GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr)
+GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr)
+
+section "bss" {
+ aa: W_; // NB. aa is really an mp_limb_t
+}
+
+gcdIntzh_fast
+{
+ /* R1 = the first Int#; R2 = the second Int# */
+ W_ r;
+
+ W_[aa] = R1;
+ r = foreign "C" mpn_gcd_1(aa, 1, R2);
+
+ R1 = r;
+ /* Result parked in R1, return via info-pointer at TOS */
+ jump %ENTRY_CODE(Sp(0));
+}
+
+
+gcdIntegerIntzh_fast
+{
+ /* R1 = s1; R2 = d1; R3 = the int */
+ R1 = foreign "C" mpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3);
+
+ /* Result parked in R1, return via info-pointer at TOS */
+ jump %ENTRY_CODE(Sp(0));
+}
+
+
+cmpIntegerIntzh_fast
+{
+ /* R1 = s1; R2 = d1; R3 = the int */
+ W_ usize, vsize, v_digit, u_digit;
+
+ usize = R1;
+ vsize = 0;
+ v_digit = R3;
+
+ // paraphrased from mpz_cmp_si() in the GMP sources
+ if (%gt(v_digit,0)) {
+ vsize = 1;
+ } else {
+ if (%lt(v_digit,0)) {
+ vsize = -1;
+ v_digit = -v_digit;
+ }
+ }
+
+ if (usize != vsize) {
+ R1 = usize - vsize;
+ jump %ENTRY_CODE(Sp(0));
+ }
+
+ if (usize == 0) {
+ R1 = 0;
+ jump %ENTRY_CODE(Sp(0));
+ }
+
+ u_digit = W_[BYTE_ARR_CTS(R2)];
+
+ if (u_digit == v_digit) {
+ R1 = 0;
+ jump %ENTRY_CODE(Sp(0));
+ }
+
+ if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
+ R1 = usize;
+ } else {
+ R1 = -usize;
+ }
+
+ jump %ENTRY_CODE(Sp(0));
+}
+
+cmpIntegerzh_fast
+{
+ /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
+ W_ usize, vsize, size, up, vp;
+ CInt cmp;
+
+ // paraphrased from mpz_cmp() in the GMP sources
+ usize = R1;
+ vsize = R3;
+
+ if (usize != vsize) {
+ R1 = usize - vsize;
+ jump %ENTRY_CODE(Sp(0));
+ }
+
+ if (usize == 0) {
+ R1 = 0;
+ jump %ENTRY_CODE(Sp(0));
+ }
+
+ if (%lt(usize,0)) { // NB. not <, which is unsigned
+ size = -usize;
+ } else {
+ size = usize;
+ }
+
+ up = BYTE_ARR_CTS(R2);
+ vp = BYTE_ARR_CTS(R4);
+
+ cmp = foreign "C" mpn_cmp(up "ptr", vp "ptr", size);
+
+ if (cmp == 0) {
+ R1 = 0;
+ jump %ENTRY_CODE(Sp(0));
+ }
+
+ if (%lt(cmp,0) == %lt(usize,0)) {
+ R1 = 1;
+ } else {
+ R1 = (-1);
+ }
+ /* Result parked in R1, return via info-pointer at TOS */
+ jump %ENTRY_CODE(Sp(0));
+}
+
+integer2Intzh_fast
+{
+ /* R1 = s; R2 = d */
+ W_ r, s;
+
+ s = R1;
+ if (s == 0) {
+ r = 0;
+ } else {
+ r = W_[R2 + SIZEOF_StgArrWords];
+ if (%lt(s,0)) {
+ r = -r;
+ }
+ }
+ /* Result parked in R1, return via info-pointer at TOS */
+ R1 = r;
+ jump %ENTRY_CODE(Sp(0));
+}
+
+integer2Wordzh_fast
+{
+ /* R1 = s; R2 = d */
+ W_ r, s;
+
+ s = R1;
+ if (s == 0) {
+ r = 0;
+ } else {
+ r = W_[R2 + SIZEOF_StgArrWords];
+ if (%lt(s,0)) {
+ r = -r;
+ }
+ }
+ /* Result parked in R1, return via info-pointer at TOS */
+ R1 = r;
+ jump %ENTRY_CODE(Sp(0));
+}
+
+section "bss" {
+ exponent: W_;
+}
+
+decodeFloatzh_fast
+{
+ W_ p;
+ F_ arg;
+
+ /* arguments: F1 = Float# */
+ arg = F1;
+
+ ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, decodeFloatzh_fast );
+
+ /* Be prepared to tell Lennart-coded __decodeFloat
+ where mantissa._mp_d can be put (it does not care about the rest) */
+ p = Hp - SIZEOF_StgArrWords;
+ SET_HDR(p,stg_ARR_WORDS_info,W_[CCCS]);
+ StgArrWords_words(p) = 1;
+ MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
+
+ /* Perform the operation */
+ foreign "C" __decodeFloat(mp_tmp1,exponent,arg);
+
+ /* returns: (Int# (expn), Int#, ByteArray#) */
+ RET_NNP(W_[exponent], MP_INT__mp_size(mp_tmp1), p);
+}
+
+#define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
+#define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
+
+decodeDoublezh_fast
+{
+ D_ arg;
+ W_ p;
+
+ /* arguments: D1 = Double# */
+ arg = D1;
+
+ ALLOC_PRIM( ARR_SIZE, NO_PTRS, decodeDoublezh_fast );
+
+ /* Be prepared to tell Lennart-coded __decodeDouble
+ where mantissa.d can be put (it does not care about the rest) */
+ p = Hp - ARR_SIZE + WDS(1);
+ SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+ StgArrWords_words(p) = BYTES_TO_WDS(DOUBLE_MANTISSA_SIZE);
+ MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
+
+ /* Perform the operation */
+ foreign "C" __decodeDouble(mp_tmp1,exponent,arg);
+
+ /* returns: (Int# (expn), Int#, ByteArray#) */
+ RET_NNP(W_[exponent], MP_INT__mp_size(mp_tmp1), p);
+}
+
+/* -----------------------------------------------------------------------------
+ * Concurrency primitives
+ * -------------------------------------------------------------------------- */
+
+forkzh_fast
+{
+ /* args: R1 = closure to spark */
+
+ MAYBE_GC(R1_PTR, forkzh_fast);
+
+ // create it right now, return ThreadID in R1
+ "ptr" R1 = foreign "C" createIOThread( RtsFlags_GcFlags_initialStkSize(RtsFlags),
+ R1 "ptr");
+ foreign "C" scheduleThread(R1 "ptr");
+
+ // switch at the earliest opportunity
+ CInt[context_switch] = 1;
+
+ RET_P(R1);
+}
+
+yieldzh_fast
+{
+ jump stg_yield_noregs;
+}
+
+myThreadIdzh_fast
+{
+ /* no args. */
+ RET_P(CurrentTSO);
+}
+
+labelThreadzh_fast
+{
+ /* args:
+ R1 = ThreadId#
+ R2 = Addr# */
+#ifdef DEBUG
+ foreign "C" labelThread(R1 "ptr", R2 "ptr");
+#endif
+ jump %ENTRY_CODE(Sp(0));
+}
+
+isCurrentThreadBoundzh_fast
+{
+ /* no args */
+ W_ r;
+ r = foreign "C" isThreadBound(CurrentTSO);
+ RET_N(r);
+}
+
+/* -----------------------------------------------------------------------------
+ * MVar primitives
+ *
+ * take & putMVar work as follows. Firstly, an important invariant:
+ *
+ * If the MVar is full, then the blocking queue contains only
+ * threads blocked on putMVar, and if the MVar is empty then the
+ * blocking queue contains only threads blocked on takeMVar.
+ *
+ * takeMvar:
+ * MVar empty : then add ourselves to the blocking queue
+ * MVar full : remove the value from the MVar, and
+ * blocking queue empty : return
+ * blocking queue non-empty : perform the first blocked putMVar
+ * from the queue, and wake up the
+ * thread (MVar is now full again)
+ *
+ * putMVar is just the dual of the above algorithm.
+ *
+ * How do we "perform a putMVar"? Well, we have to fiddle around with
+ * the stack of the thread waiting to do the putMVar. See
+ * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
+ * the stack layout, and the PerformPut and PerformTake macros below.
+ *
+ * It is important that a blocked take or put is woken up with the
+ * take/put already performed, because otherwise there would be a
+ * small window of vulnerability where the thread could receive an
+ * exception and never perform its take or put, and we'd end up with a
+ * deadlock.
+ *
+ * -------------------------------------------------------------------------- */
+
+isEmptyMVarzh_fast
+{
+ /* args: R1 = MVar closure */
+
+ if (GET_INFO(R1) == stg_EMPTY_MVAR_info) {
+ RET_N(0);
+ } else {
+ RET_N(1);
+ }
+}
+
+newMVarzh_fast
+{
+ /* args: none */
+ W_ mvar;
+
+ ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
+
+ mvar = Hp - SIZEOF_StgMVar + WDS(1);
+ SET_HDR(mvar,stg_EMPTY_MVAR_info,W_[CCCS]);
+ StgMVar_head(mvar) = stg_END_TSO_QUEUE_closure;
+ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+ StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
+ RET_P(mvar);
+}
+
+
+/* If R1 isn't available, pass it on the stack */
+#ifdef REG_R1
+#define PerformTake(tso, value) \
+ W_[StgTSO_sp(tso) + WDS(1)] = value; \
+ W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info;
+#else
+#define PerformTake(tso, value) \
+ W_[StgTSO_sp(tso) + WDS(1)] = value; \
+ W_[StgTSO_sp(tso) + WDS(0)] = stg_ut_1_0_unreg_info;
+#endif
+
+#define PerformPut(tso,lval) \
+ StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3); \
+ lval = W_[StgTSO_sp(tso) - WDS(1)];
+
+
+takeMVarzh_fast
+{
+ W_ mvar, val, info, tso;
+
+ /* args: R1 = MVar closure */
+ mvar = R1;
+
+ info = GET_INFO(mvar);
+
+ /* If the MVar is empty, put ourselves on its blocking queue,
+ * and wait until we're woken up.
+ */
+ if (info == stg_EMPTY_MVAR_info) {
+ if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+ StgMVar_head(mvar) = CurrentTSO;
+ } else {
+ StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
+ }
+ StgTSO_link(CurrentTSO) = stg_END_TSO_QUEUE_closure;
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
+ StgTSO_block_info(CurrentTSO) = mvar;
+ StgMVar_tail(mvar) = CurrentTSO;
+
+ jump stg_block_takemvar;
+ }
+
+ /* we got the value... */
+ val = StgMVar_value(mvar);
+
+ if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure)
+ {
+ /* There are putMVar(s) waiting...
+ * wake up the first thread on the queue
+ */
+ ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
+
+ /* actually perform the putMVar for the thread that we just woke up */
+ tso = StgMVar_head(mvar);
+ PerformPut(tso,StgMVar_value(mvar));
+
+#if defined(GRAN) || defined(PAR)
+ /* ToDo: check 2nd arg (mvar) is right */
+ "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar),mvar);
+ StgMVar_head(mvar) = tso;
+#else
+ "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
+ StgMVar_head(mvar) = tso;
+#endif
+ if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+ }
+ RET_P(val);
+ }
+ else
+ {
+ /* No further putMVars, MVar is now empty */
+
+ /* do this last... we might have locked the MVar in the SMP case,
+ * and writing the info pointer will unlock it.
+ */
+ SET_INFO(mvar,stg_EMPTY_MVAR_info);
+ StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
+ RET_P(val);
+ }
+}
+
+
+tryTakeMVarzh_fast
+{
+ W_ mvar, val, info, tso;
+
+ /* args: R1 = MVar closure */
+
+ mvar = R1;
+
+ info = GET_INFO(mvar);
+
+ if (info == stg_EMPTY_MVAR_info) {
+ /* HACK: we need a pointer to pass back,
+ * so we abuse NO_FINALIZER_closure
+ */
+ RET_NP(0, stg_NO_FINALIZER_closure);
+ }
+
+ /* we got the value... */
+ val = StgMVar_value(mvar);
+
+ if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
+ /* There are putMVar(s) waiting...
+ * wake up the first thread on the queue
+ */
+ ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
+
+ /* actually perform the putMVar for the thread that we just woke up */
+ tso = StgMVar_head(mvar);
+ PerformPut(tso,StgMVar_value(mvar));
+
+#if defined(GRAN) || defined(PAR)
+ /* ToDo: check 2nd arg (mvar) is right */
+ "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr");
+ StgMVar_head(mvar) = tso;
+#else
+ "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
+ StgMVar_head(mvar) = tso;
+#endif
+
+ if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+ }
+ }
+ else
+ {
+ /* No further putMVars, MVar is now empty */
+ StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
+
+ /* do this last... we might have locked the MVar in the SMP case,
+ * and writing the info pointer will unlock it.
+ */
+ SET_INFO(mvar,stg_EMPTY_MVAR_info);
+ }
+
+ RET_NP(1, val);
+}
+
+
+putMVarzh_fast
+{
+ W_ mvar, info, tso;
+
+ /* args: R1 = MVar, R2 = value */
+ mvar = R1;
+
+ info = GET_INFO(mvar);
+
+ if (info == stg_FULL_MVAR_info) {
+ if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+ StgMVar_head(mvar) = CurrentTSO;
+ } else {
+ StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
+ }
+ StgTSO_link(CurrentTSO) = stg_END_TSO_QUEUE_closure;
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
+ StgTSO_block_info(CurrentTSO) = mvar;
+ StgMVar_tail(mvar) = CurrentTSO;
+
+ jump stg_block_putmvar;
+ }
+
+ if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
+ /* There are takeMVar(s) waiting: wake up the first one
+ */
+ ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
+
+ /* actually perform the takeMVar */
+ tso = StgMVar_head(mvar);
+ PerformTake(tso, R2);
+
+#if defined(GRAN) || defined(PAR)
+ /* ToDo: check 2nd arg (mvar) is right */
+ "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr",mvar "ptr");
+ StgMVar_head(mvar) = tso;
+#else
+ "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
+ StgMVar_head(mvar) = tso;
+#endif
+
+ if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+ }
+
+ jump %ENTRY_CODE(Sp(0));
+ }
+ else
+ {
+ /* No further takes, the MVar is now full. */
+ StgMVar_value(mvar) = R2;
+ /* unlocks the MVar in the SMP case */
+ SET_INFO(mvar,stg_FULL_MVAR_info);
+ jump %ENTRY_CODE(Sp(0));
+ }
+
+ /* ToDo: yield afterward for better communication performance? */
+}
+
+
+tryPutMVarzh_fast
+{
+ W_ mvar, info, tso;
+
+ /* args: R1 = MVar, R2 = value */
+ mvar = R1;
+
+ info = GET_INFO(mvar);
+
+ if (info == stg_FULL_MVAR_info) {
+ RET_N(0);
+ }
+
+ if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
+ /* There are takeMVar(s) waiting: wake up the first one
+ */
+ ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
+
+ /* actually perform the takeMVar */
+ tso = StgMVar_head(mvar);
+ PerformTake(tso, R2);
+
+#if defined(GRAN) || defined(PAR)
+ /* ToDo: check 2nd arg (mvar) is right */
+ "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr",mvar "ptr");
+ StgMVar_head(mvar) = tso;
+#else
+ "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
+ StgMVar_head(mvar) = tso;
+#endif
+
+ if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+ }
+
+ jump %ENTRY_CODE(Sp(0));
+ }
+ else
+ {
+ /* No further takes, the MVar is now full. */
+ StgMVar_value(mvar) = R2;
+ /* unlocks the MVar in the SMP case */
+ SET_INFO(mvar,stg_FULL_MVAR_info);
+ jump %ENTRY_CODE(Sp(0));
+ }
+
+ /* ToDo: yield afterward for better communication performance? */
+}
+
+
+/* -----------------------------------------------------------------------------
+ Stable pointer primitives
+ ------------------------------------------------------------------------- */
+
+makeStableNamezh_fast
+{
+ W_ index, sn_obj;
+
+ ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast );
+
+ index = foreign "C" lookupStableName(R1 "ptr");
+
+ /* Is there already a StableName for this heap object?
+ * stable_ptr_table is an array of snEntry structs.
+ */
+ if ( snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry) == NULL ) {
+ sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
+ SET_HDR(sn_obj, stg_STABLE_NAME_info, W_[CCCS]);
+ StgStableName_sn(sn_obj) = index;
+ snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry) = sn_obj;
+ } else {
+ sn_obj = snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry);
+ }
+
+ RET_P(sn_obj);
+}
+
+
+makeStablePtrzh_fast
+{
+ /* Args: R1 = a */
+ W_ sp;
+ MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
+ "ptr" sp = foreign "C" getStablePtr(R1 "ptr");
+ RET_N(sp);
+}
+
+deRefStablePtrzh_fast
+{
+ /* Args: R1 = the stable ptr */
+ W_ r, sp;
+ sp = R1;
+ r = snEntry_addr(stable_ptr_table + sp*SIZEOF_snEntry);
+ RET_P(r);
+}
+
+/* -----------------------------------------------------------------------------
+ Bytecode object primitives
+ ------------------------------------------------------------------------- */
+
+newBCOzh_fast
+{
+ /* R1 = instrs
+ R2 = literals
+ R3 = ptrs
+ R4 = itbls
+ R5 = arity
+ R6 = bitmap array
+ */
+ W_ bco, bitmap_arr, bytes, words;
+
+ bitmap_arr = R6;
+ words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
+ bytes = WDS(words);
+
+ ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R4_PTR&R6_PTR, newBCOzh_fast );
+
+ bco = Hp - bytes + WDS(1);
+ SET_HDR(bco, stg_BCO_info, W_[CCCS]);
+
+ StgBCO_instrs(bco) = R1;
+ StgBCO_literals(bco) = R2;
+ StgBCO_ptrs(bco) = R3;
+ StgBCO_itbls(bco) = R4;
+ StgBCO_arity(bco) = HALF_W_(R5);
+ StgBCO_size(bco) = HALF_W_(words);
+
+ // Copy the arity/bitmap info into the BCO
+ W_ i;
+ i = 0;
+for:
+ if (i < StgArrWords_words(bitmap_arr)) {
+ StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
+ i = i + 1;
+ goto for;
+ }
+
+ RET_P(bco);
+}
+
+
+mkApUpd0zh_fast
+{
+ // R1 = the BCO# for the AP
+ //
+ W_ ap;
+
+ // This function is *only* used to wrap zero-arity BCOs in an
+ // updatable wrapper (see ByteCodeLink.lhs). An AP thunk is always
+ // saturated and always points directly to a FUN or BCO.
+ ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == BCO::I16 &&
+ StgBCO_arity(R1) == 0::I16);
+
+ HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, mkApUpd0zh_fast);
+ TICK_ALLOC_UP_THK(0, 0);
+ CCCS_ALLOC(SIZEOF_StgAP);
+
+ ap = Hp - SIZEOF_StgAP + WDS(1);
+ SET_HDR(ap, stg_AP_info, W_[CCCS]);
+
+ StgAP_n_args(ap) = 0::I16;
+ StgAP_fun(ap) = R1;
+
+ RET_P(ap);
+}
+
+/* -----------------------------------------------------------------------------
+ Thread I/O blocking primitives
+ -------------------------------------------------------------------------- */
+
+/* Add a thread to the end of the blocked queue. (C-- version of the C
+ * macro in Schedule.h).
+ */
+#define APPEND_TO_BLOCKED_QUEUE(tso) \
+ ASSERT(StgTSO_link(tso) == END_TSO_QUEUE); \
+ if (W_[blocked_queue_hd] == END_TSO_QUEUE) { \
+ W_[blocked_queue_hd] = tso; \
+ } else { \
+ StgTSO_link(W_[blocked_queue_tl]) = tso; \
+ } \
+ W_[blocked_queue_tl] = tso;
+
+waitReadzh_fast
+{
+ /* args: R1 */
+ ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
+ StgTSO_block_info(CurrentTSO) = R1;
+ // No locking - we're not going to use this interface in the
+ // threaded RTS anyway.
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ jump stg_block_noregs;
+}
+
+waitWritezh_fast
+{
+ /* args: R1 */
+ ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
+ StgTSO_block_info(CurrentTSO) = R1;
+ // No locking - we're not going to use this interface in the
+ // threaded RTS anyway.
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ jump stg_block_noregs;
+}
+
+
+STRING(stg_delayzh_malloc_str, "delayzh_fast")
+delayzh_fast
+{
+#ifdef mingw32_TARGET_OS
+ W_ ares;
+ CInt reqID;
+#else
+ W_ t, prev, target;
+#endif
+
+ /* args: R1 (microsecond delay amount) */
+ ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
+
+#ifdef mingw32_TARGET_OS
+
+ /* could probably allocate this on the heap instead */
+ "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
+ stg_delayzh_malloc_str);
+ reqID = foreign "C" addDelayRequest(R1);
+ StgAsyncIOResult_reqID(ares) = reqID;
+ StgAsyncIOResult_len(ares) = 0;
+ StgAsyncIOResult_errCode(ares) = 0;
+ StgTSO_block_info(CurrentTSO) = ares;
+
+ /* Having all async-blocked threads reside on the blocked_queue
+ * simplifies matters, so change the status to OnDoProc put the
+ * delayed thread on the blocked_queue.
+ */
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+
+#else
+
+ CInt time;
+ time = foreign "C" getourtimeofday();
+ target = (R1 / (TICK_MILLISECS*1000)) + TO_W_(time);
+ StgTSO_block_info(CurrentTSO) = target;
+
+ /* Insert the new thread in the sleeping queue. */
+ prev = NULL;
+ t = W_[sleeping_queue];
+while:
+ if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
+ prev = t;
+ t = StgTSO_link(t);
+ goto while;
+ }
+
+ StgTSO_link(CurrentTSO) = t;
+ if (prev == NULL) {
+ W_[sleeping_queue] = CurrentTSO;
+ } else {
+ StgTSO_link(prev) = CurrentTSO;
+ }
+#endif
+
+ jump stg_block_noregs;
+}
+
+
+#ifdef mingw32_TARGET_OS
+STRING(stg_asyncReadzh_malloc_str, "asyncReadzh_fast")
+asyncReadzh_fast
+{
+ W_ ares;
+ CInt reqID;
+
+ /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
+ ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
+
+ /* could probably allocate this on the heap instead */
+ "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
+ stg_asyncReadzh_malloc_str);
+ reqID = foreign "C" addIORequest(R1,FALSE,R2,R3,R4);
+ StgAsyncIOResult_reqID(ares) = reqID;
+ StgAsyncIOResult_len(ares) = 0;
+ StgAsyncIOResult_errCode(ares) = 0;
+ StgTSO_block_info(CurrentTSO) = ares;
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ jump stg_block_async;
+}
+
+STRING(asyncWritezh_malloc_str, "asyncWritezh_fast")
+asyncWritezh_fast
+{
+ W_ ares;
+ CInt reqID;
+
+ /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
+ ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
+
+ "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
+ asyncWritezh_malloc_str);
+ reqID = foreign "C" addIORequest(R1,TRUE,R2,R3,R4);
+
+ StgAsyncIOResult_reqID(ares) = reqID;
+ StgAsyncIOResult_len(ares) = 0;
+ StgAsyncIOResult_errCode(ares) = 0;
+ StgTSO_block_info(CurrentTSO) = ares;
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ jump stg_block_async;
+}
+
+STRING(asyncDoProczh_malloc_str, "asyncDoProczh_fast")
+asyncDoProczh_fast
+{
+ W_ ares;
+ CInt reqID;
+
+ /* args: R1 = proc, R2 = param */
+ ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
+
+ /* could probably allocate this on the heap instead */
+ "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
+ asyncDoProczh_malloc_str);
+ reqID = foreign "C" addDoProcRequest(R1,R2);
+ StgAsyncIOResult_reqID(ares) = reqID;
+ StgAsyncIOResult_len(ares) = 0;
+ StgAsyncIOResult_errCode(ares) = 0;
+ StgTSO_block_info(CurrentTSO) = ares;
+ APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ jump stg_block_async;
+}
+#endif
+
+/* -----------------------------------------------------------------------------
+ ** temporary **
+
+ classes CCallable and CReturnable don't really exist, but the
+ compiler insists on generating dictionaries containing references
+ to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
+ for these. Some C compilers can't cope with zero-length static arrays,
+ so we have to make these one element long.
+ --------------------------------------------------------------------------- */
+
+section "rodata" {
+ GHC_ZCCCallable_static_info: W_ 0;
+}
+
+section "rodata" {
+ GHC_ZCCReturnable_static_info: W_ 0;
+}
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.116 2004/01/08 15:26:44 simonmar Exp $
- *
- * (c) The GHC Team, 1998-2002
- *
- * Primitive functions / data
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Stg.h"
-#include "Rts.h"
-
-#include "RtsFlags.h"
-#include "StgStartup.h"
-#include "SchedAPI.h"
-#include "Schedule.h"
-#include "RtsUtils.h"
-#include "Storage.h"
-#include "BlockAlloc.h" /* tmp */
-#include "StablePriv.h"
-#include "StgRun.h"
-#include "Timer.h" /* TICK_MILLISECS */
-#include "Prelude.h"
-#ifndef mingw32_TARGET_OS
-#include "Itimer.h" /* getourtimeofday() */
-#endif
-
-#ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-#endif
-
-#include <stdlib.h>
-
-#ifdef mingw32_TARGET_OS
-#include <windows.h>
-#include "win32/AsyncIO.h"
-#endif
-
-/* ** temporary **
-
- classes CCallable and CReturnable don't really exist, but the
- compiler insists on generating dictionaries containing references
- to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
- for these. Some C compilers can't cope with zero-length static arrays,
- so we have to make these one element long.
-*/
-
-StgWord GHC_ZCCCallable_static_info[1];
-StgWord GHC_ZCCReturnable_static_info[1];
-
-/* -----------------------------------------------------------------------------
- Macros for Hand-written primitives.
- -------------------------------------------------------------------------- */
-
-/*
- * Horrible macros for returning unboxed tuples.
- *
- * How an unboxed tuple is returned depends on two factors:
- * - the number of real registers we have available
- * - the boxedness of the returned fields.
- *
- * To return an unboxed tuple from a primitive operation, we have macros
- * RET_<layout> where <layout> describes the boxedness of each field of the
- * unboxed tuple: N indicates a non-pointer field, and P indicates a pointer.
- *
- * We only define the cases actually used, to avoid having too much
- * garbage in this section. Warning: any bugs in here will be hard to
- * track down.
- *
- * The return convention for an unboxed tuple is as follows:
- * - fit as many fields as possible in registers (as per the
- * function fast-entry point calling convention).
- * - sort the rest of the fields into pointers and non-pointers.
- * push the pointers on the stack, followed by the non-pointers.
- * (so the pointers have higher addresses).
- */
-
-/*------ All Regs available */
-#if MAX_REAL_VANILLA_REG == 8
-# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
-# define RET_N(a) RET_P(a)
-
-# define RET_PP(a,b) R1.w = (W_)(a); R2.w = (W_)(b); JMP_(ENTRY_CODE(Sp[0]));
-# define RET_NN(a,b) RET_PP(a,b)
-# define RET_NP(a,b) RET_PP(a,b)
-
-# define RET_PPP(a,b,c) \
- R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); JMP_(ENTRY_CODE(Sp[0]));
-# define RET_NNP(a,b,c) RET_PPP(a,b,c)
-
-# define RET_NNNP(a,b,c,d) \
- R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)d; \
- JMP_(ENTRY_CODE(Sp[0]));
-
-# define RET_NPNP(a,b,c,d) \
- R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)(d); \
- JMP_(ENTRY_CODE(Sp[0]));
-
-#elif MAX_REAL_VANILLA_REG > 2 && MAX_REAL_VANILLA_REG < 8
-# error RET_n macros not defined for this setup.
-
-/*------ 2 Registers available */
-#elif MAX_REAL_VANILLA_REG == 2
-
-# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
-# define RET_N(a) RET_P(a)
-
-# define RET_PP(a,b) R1.w = (W_)(a); R2.w = (W_)(b); \
- JMP_(ENTRY_CODE(Sp[0]));
-# define RET_NN(a,b) RET_PP(a,b)
-# define RET_NP(a,b) RET_PP(a,b)
-
-# define RET_PPP(a,b,c) \
- R1.w = (W_)(a); \
- R2.w = (W_)(b); \
- Sp[-1] = (W_)(c); \
- Sp -= 1; \
- JMP_(ENTRY_CODE(Sp[1]));
-
-# define RET_NNP(a,b,c) \
- R1.w = (W_)(a); \
- R2.w = (W_)(b); \
- Sp[-1] = (W_)(c); \
- Sp -= 1; \
- JMP_(ENTRY_CODE(Sp[1]));
-
-# define RET_NNNP(a,b,c,d) \
- R1.w = (W_)(a); \
- R2.w = (W_)(b); \
- Sp[-2] = (W_)(c); \
- Sp[-1] = (W_)(d); \
- Sp -= 2; \
- JMP_(ENTRY_CODE(Sp[2]));
-
-# define RET_NPNP(a,b,c,d) \
- R1.w = (W_)(a); \
- R2.w = (W_)(b); \
- Sp[-2] = (W_)(c); \
- Sp[-1] = (W_)(d); \
- Sp -= 2; \
- JMP_(ENTRY_CODE(Sp[2]));
-
-/*------ 1 Register available */
-#elif MAX_REAL_VANILLA_REG == 1
-# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
-# define RET_N(a) RET_P(a)
-
-# define RET_PP(a,b) R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 1; \
- JMP_(ENTRY_CODE(Sp[1]));
-# define RET_NN(a,b) R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 2; \
- JMP_(ENTRY_CODE(Sp[2]));
-# define RET_NP(a,b) RET_PP(a,b)
-
-# define RET_PPP(a,b,c) \
- R1.w = (W_)(a); \
- Sp[-2] = (W_)(b); \
- Sp[-1] = (W_)(c); \
- Sp -= 2; \
- JMP_(ENTRY_CODE(Sp[2]));
-
-# define RET_NNP(a,b,c) \
- R1.w = (W_)(a); \
- Sp[-2] = (W_)(b); \
- Sp[-1] = (W_)(c); \
- Sp -= 2; \
- JMP_(ENTRY_CODE(Sp[2]));
-
-# define RET_NNNP(a,b,c,d) \
- R1.w = (W_)(a); \
- Sp[-3] = (W_)(b); \
- Sp[-2] = (W_)(c); \
- Sp[-1] = (W_)(d); \
- Sp -= 3; \
- JMP_(ENTRY_CODE(Sp[3]));
-
-# define RET_NPNP(a,b,c,d) \
- R1.w = (W_)(a); \
- Sp[-3] = (W_)(c); \
- Sp[-2] = (W_)(b); \
- Sp[-1] = (W_)(d); \
- Sp -= 3; \
- JMP_(ENTRY_CODE(Sp[3]));
-
-#else /* 0 Regs available */
-
-#define PUSH(o,x) Sp[-o] = (W_)(x)
-
-#define PUSHED(m) Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
-
-# define RET_P(a) PUSH(1,a); PUSHED(1)
-# define RET_N(a) PUSH(1,a); PUSHED(1)
-
-# define RET_PP(a,b) PUSH(2,a); PUSH(1,b); PUSHED(2)
-# define RET_NN(a,b) PUSH(2,a); PUSH(1,b); PUSHED(2)
-# define RET_NP(a,b) PUSH(2,a); PUSH(1,b); PUSHED(2)
-
-# define RET_PPP(a,b,c) PUSH(3,a); PUSH(2,b); PUSH(1,c); PUSHED(3)
-# define RET_NNP(a,b,c) PUSH(3,a); PUSH(2,b); PUSH(1,c); PUSHED(3)
-
-# define RET_NNNP(a,b,c,d) PUSH(4,a); PUSH(3,b); PUSH(2,c); PUSH(1,d); PUSHED(4)
-# define RET_NPNP(a,b,c,d) PUSH(4,a); PUSH(3,c); PUSH(2,b); PUSH(1,d); PUSHED(4)
-#endif
-
-/*-----------------------------------------------------------------------------
- Array Primitives
-
- Basically just new*Array - the others are all inline macros.
-
- The size arg is always passed in R1, and the result returned in R1.
-
- The slow entry point is for returning from a heap check, the saved
- size argument must be re-loaded from the stack.
- -------------------------------------------------------------------------- */
-
-/* for objects that are *less* than the size of a word, make sure we
- * round up to the nearest word for the size of the array.
- */
-
-#define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
-
-FN_(newByteArrayzh_fast)
- {
- W_ size, stuff_size, n;
- StgArrWords* p;
- FB_
- MAYBE_GC(NO_PTRS,newByteArrayzh_fast);
- n = R1.w;
- stuff_size = BYTES_TO_STGWORDS(n);
- size = sizeofW(StgArrWords)+ stuff_size;
- p = (StgArrWords *)RET_STGCALL1(P_,allocate,size);
- TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0);
- SET_HDR(p, &stg_ARR_WORDS_info, CCCS);
- p->words = stuff_size;
- TICK_RET_UNBOXED_TUP(1)
- RET_P(p);
- FE_
- }
-
-FN_(newPinnedByteArrayzh_fast)
- {
- W_ size, stuff_size, n;
- StgArrWords* p;
- FB_
- MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast);
- n = R1.w;
- stuff_size = BYTES_TO_STGWORDS(n);
-
- // We want an 8-byte aligned array. allocatePinned() gives us
- // 8-byte aligned memory by default, but we want to align the
- // *goods* inside the ArrWords object, so we have to check the
- // size of the ArrWords header and adjust our size accordingly.
- size = sizeofW(StgArrWords)+ stuff_size;
- if ((sizeof(StgArrWords) & 7) != 0) {
- size++;
- }
-
- p = (StgArrWords *)RET_STGCALL1(P_,allocatePinned,size);
- TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0);
-
- // Again, if the ArrWords header isn't a multiple of 8 bytes, we
- // have to push the object forward one word so that the goods
- // fall on an 8-byte boundary.
- if ((sizeof(StgArrWords) & 7) != 0) {
- ((StgPtr)p)++;
- }
-
- SET_HDR(p, &stg_ARR_WORDS_info, CCCS);
- p->words = stuff_size;
- TICK_RET_UNBOXED_TUP(1)
- RET_P(p);
- FE_
- }
-
-FN_(newArrayzh_fast)
-{
- W_ size, n, init;
- StgMutArrPtrs* arr;
- StgPtr p;
- FB_
- n = R1.w;
-
- MAYBE_GC(R2_PTR,newArrayzh_fast);
-
- size = sizeofW(StgMutArrPtrs) + n;
- arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
- TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
-
- SET_HDR(arr,&stg_MUT_ARR_PTRS_info,CCCS);
- arr->ptrs = n;
-
- init = R2.w;
- for (p = (P_)arr + sizeofW(StgMutArrPtrs);
- p < (P_)arr + size; p++) {
- *p = (W_)init;
- }
-
- TICK_RET_UNBOXED_TUP(1);
- RET_P(arr);
- FE_
-}
-
-FN_(newMutVarzh_fast)
-{
- StgMutVar* mv;
- /* Args: R1.p = initialisation value */
- FB_
-
- HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
- CCS_ALLOC(CCCS,sizeofW(StgMutVar));
-
- mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
- SET_HDR(mv,&stg_MUT_VAR_info,CCCS);
- mv->var = R1.cl;
-
- TICK_RET_UNBOXED_TUP(1);
- RET_P(mv);
- FE_
-}
-
-FN_(atomicModifyMutVarzh_fast)
-{
- StgMutVar* mv;
- StgClosure *z, *x, *y, *r;
- FB_
- /* Args: R1.p :: MutVar#, R2.p :: a -> (a,b) */
-
- /* If x is the current contents of the MutVar#, then
- We want to make the new contents point to
-
- (sel_0 (f x))
-
- and the return value is
-
- (sel_1 (f x))
-
- obviously we can share (f x).
-
- z = [stg_ap_2 f x] (max (HS + 2) MIN_UPD_SIZE)
- y = [stg_sel_0 z] (max (HS + 1) MIN_UPD_SIZE)
- r = [stg_sel_1 z] (max (HS + 1) MIN_UPD_SIZE)
- */
-
-#define THUNK_SIZE(n) (sizeofW(StgHeader) + stg_max((n), MIN_UPD_SIZE))
-#define SIZE (THUNK_SIZE(2) + THUNK_SIZE(1) + THUNK_SIZE(1))
-
- HP_CHK_GEN_TICKY(SIZE, R1_PTR|R2_PTR, atomicModifyMutVarzh_fast);
- CCS_ALLOC(CCCS,SIZE);
-
- x = ((StgMutVar *)R1.cl)->var;
-
- TICK_ALLOC_UP_THK(2,0); // XXX
- z = (StgClosure *) Hp - THUNK_SIZE(2) + 1;
- SET_HDR(z, (StgInfoTable *)&stg_ap_2_upd_info, CCCS);
- z->payload[0] = R2.cl;
- z->payload[1] = x;
-
- TICK_ALLOC_UP_THK(1,1); // XXX
- y = (StgClosure *) (StgPtr)z - THUNK_SIZE(1);
- SET_HDR(y, &stg_sel_0_upd_info, CCCS);
- y->payload[0] = z;
-
- ((StgMutVar *)R1.cl)->var = y;
-
- TICK_ALLOC_UP_THK(1,1); // XXX
- r = (StgClosure *) (StgPtr)y - THUNK_SIZE(1);
- SET_HDR(r, &stg_sel_1_upd_info, CCCS);
- r->payload[0] = z;
-
- RET_P(r);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Foreign Object Primitives
- -------------------------------------------------------------------------- */
-
-FN_(mkForeignObjzh_fast)
-{
- /* R1.p = ptr to foreign object,
- */
- StgForeignObj *result;
- FB_
-
- HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, mkForeignObjzh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgHeader),
- sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
- CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
-
- result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
- SET_HDR(result,&stg_FOREIGN_info,CCCS);
- result->data = R1.p;
-
- /* returns (# s#, ForeignObj# #) */
- TICK_RET_UNBOXED_TUP(1);
- RET_P(result);
- FE_
-}
-
-/* These two are out-of-line for the benefit of the NCG */
-FN_(unsafeThawArrayzh_fast)
-{
- FB_
- SET_INFO((StgClosure *)R1.cl,&stg_MUT_ARR_PTRS_info);
-
- // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
- //
- // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
- // normally doesn't. However, when we freeze a MUT_ARR_PTRS, we leave
- // it on the mutable list for the GC to remove (removing something from
- // the mutable list is not easy, because the mut_list is only singly-linked).
- //
- // So, when we thaw a MUT_ARR_PTRS_FROZEN, we must cope with two cases:
- // either it is on a mut_list, or it isn't. We adopt the convention that
- // the mut_link field is NULL if it isn't on a mut_list, and the GC
- // maintains this invariant.
- //
- if (((StgMutArrPtrs *)R1.cl)->mut_link == NULL) {
- recordMutable((StgMutClosure*)R1.cl);
- }
-
- TICK_RET_UNBOXED_TUP(1);
- RET_P(R1.p);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Weak Pointer Primitives
- -------------------------------------------------------------------------- */
-
-FN_(mkWeakzh_fast)
-{
- /* R1.p = key
- R2.p = value
- R3.p = finalizer (or NULL)
- */
- StgWeak *w;
- FB_
-
- if (R3.cl == NULL) {
- R3.cl = &stg_NO_FINALIZER_closure;
- }
-
- HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgHeader)+1, // +1 is for the link field
- sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
- CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
-
- w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
- SET_HDR(w, &stg_WEAK_info, CCCS);
-
- w->key = R1.cl;
- w->value = R2.cl;
- w->finalizer = R3.cl;
-
- w->link = weak_ptr_list;
- weak_ptr_list = w;
- IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
-
- TICK_RET_UNBOXED_TUP(1);
- RET_P(w);
- FE_
-}
-
-FN_(finalizzeWeakzh_fast)
-{
- /* R1.p = weak ptr
- */
- StgDeadWeak *w;
- StgClosure *f;
- FB_
- TICK_RET_UNBOXED_TUP(0);
- w = (StgDeadWeak *)R1.p;
-
- /* already dead? */
- if (w->header.info == &stg_DEAD_WEAK_info) {
- RET_NP(0,&stg_NO_FINALIZER_closure);
- }
-
- /* kill it */
-#ifdef PROFILING
- // @LDV profiling
- // A weak pointer is inherently used, so we do not need to call
- // LDV_recordDead_FILL_SLOP_DYNAMIC():
- // LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
- // or, LDV_recordDead():
- // LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
- // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
- // large as weak pointers, so there is no need to fill the slop, either.
- // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
-#endif
- //
- // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
- //
- w->header.info = &stg_DEAD_WEAK_info;
-#ifdef PROFILING
- // @LDV profiling
- LDV_recordCreate((StgClosure *)w);
-#endif
- f = ((StgWeak *)w)->finalizer;
- w->link = ((StgWeak *)w)->link;
-
- /* return the finalizer */
- if (f == &stg_NO_FINALIZER_closure) {
- RET_NP(0,&stg_NO_FINALIZER_closure);
- } else {
- RET_NP(1,f);
- }
- FE_
-}
-
-FN_(deRefWeakzh_fast)
-{
- /* R1.p = weak ptr */
- StgWeak* w;
- I_ code;
- P_ val;
- FB_
- w = (StgWeak*)R1.p;
- if (w->header.info == &stg_WEAK_info) {
- code = 1;
- val = (P_)((StgWeak *)w)->value;
- } else {
- code = 0;
- val = (P_)w;
- }
- RET_NP(code,val);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Arbitrary-precision Integer operations.
- -------------------------------------------------------------------------- */
-
-FN_(int2Integerzh_fast)
-{
- /* arguments: R1 = Int# */
-
- I_ val, s; /* to avoid aliasing */
- StgArrWords* p; /* address of array result */
- FB_
-
- val = R1.i;
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
- CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
-
- p = (StgArrWords *)Hp - 1;
- SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
-
- /* mpz_set_si is inlined here, makes things simpler */
- if (val < 0) {
- s = -1;
- *Hp = -val;
- } else if (val > 0) {
- s = 1;
- *Hp = val;
- } else {
- s = 0;
- }
-
- /* returns (# size :: Int#,
- data :: ByteArray#
- #)
- */
- TICK_RET_UNBOXED_TUP(2);
- RET_NP(s,p);
- FE_
-}
-
-FN_(word2Integerzh_fast)
-{
- /* arguments: R1 = Word# */
-
- W_ val; /* to avoid aliasing */
- I_ s;
- StgArrWords* p; /* address of array result */
- FB_
-
- val = R1.w;
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast)
- TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
- CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
-
- p = (StgArrWords *)Hp - 1;
- SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
-
- if (val != 0) {
- s = 1;
- *Hp = val;
- } else {
- s = 0;
- }
-
- /* returns (# size :: Int#,
- data :: ByteArray#
- #)
- */
- TICK_RET_UNBOXED_TUP(2);
- RET_NP(s,p);
- FE_
-}
-
-
-/*
- * 'long long' primops for converting to/from Integers.
- */
-
-#ifdef SUPPORT_LONG_LONGS
-
-FN_(int64ToIntegerzh_fast)
-{
- /* arguments: L1 = Int64# */
-
- StgInt64 val; /* to avoid aliasing */
- W_ hi;
- I_ s, neg, words_needed;
- StgArrWords* p; /* address of array result */
- FB_
-
- val = (LI_)L1;
- neg = 0;
-
- if ( val >= 0x100000000LL || val <= -0x100000000LL ) {
- words_needed = 2;
- } else {
- /* minimum is one word */
- words_needed = 1;
- }
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast)
- TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
- CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
-
- p = (StgArrWords *)(Hp-words_needed+1) - 1;
- SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
-
- if ( val < 0LL ) {
- neg = 1;
- val = -val;
- }
-
- hi = (W_)((LW_)val / 0x100000000ULL);
-
- if ( words_needed == 2 ) {
- s = 2;
- Hp[-1] = (W_)val;
- Hp[0] = hi;
- } else if ( val != 0 ) {
- s = 1;
- Hp[0] = (W_)val;
- } else /* val==0 */ {
- s = 0;
- }
- s = ( neg ? -s : s );
-
- /* returns (# size :: Int#,
- data :: ByteArray#
- #)
- */
- TICK_RET_UNBOXED_TUP(2);
- RET_NP(s,p);
- FE_
-}
-
-FN_(word64ToIntegerzh_fast)
-{
- /* arguments: L1 = Word64# */
-
- StgWord64 val; /* to avoid aliasing */
- StgWord hi;
- I_ s, words_needed;
- StgArrWords* p; /* address of array result */
- FB_
-
- val = (LW_)L1;
- if ( val >= 0x100000000ULL ) {
- words_needed = 2;
- } else {
- words_needed = 1;
- }
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast)
- TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
- CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
-
- p = (StgArrWords *)(Hp-words_needed+1) - 1;
- SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
-
- hi = (W_)((LW_)val / 0x100000000ULL);
- if ( val >= 0x100000000ULL ) {
- s = 2;
- Hp[-1] = ((W_)val);
- Hp[0] = (hi);
- } else if ( val != 0 ) {
- s = 1;
- Hp[0] = ((W_)val);
- } else /* val==0 */ {
- s = 0;
- }
-
- /* returns (# size :: Int#,
- data :: ByteArray#
- #)
- */
- TICK_RET_UNBOXED_TUP(2);
- RET_NP(s,p);
- FE_
-}
-
-
-#endif /* SUPPORT_LONG_LONGS */
-
-/* ToDo: this is shockingly inefficient */
-
-#define GMP_TAKE2_RET1(name,mp_fun) \
-FN_(name) \
-{ \
- MP_INT arg1, arg2, result; \
- I_ s1, s2; \
- StgArrWords* d1; \
- StgArrWords* d2; \
- FB_ \
- \
- /* call doYouWantToGC() */ \
- MAYBE_GC(R2_PTR | R4_PTR, name); \
- \
- d1 = (StgArrWords *)R2.p; \
- s1 = R1.i; \
- d2 = (StgArrWords *)R4.p; \
- s2 = R3.i; \
- \
- arg1._mp_alloc = d1->words; \
- arg1._mp_size = (s1); \
- arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- arg2._mp_alloc = d2->words; \
- arg2._mp_size = (s2); \
- arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
- \
- STGCALL1(mpz_init,&result); \
- \
- /* Perform the operation */ \
- STGCALL3(mp_fun,&result,&arg1,&arg2); \
- \
- TICK_RET_UNBOXED_TUP(2); \
- RET_NP(result._mp_size, \
- result._mp_d-sizeofW(StgArrWords)); \
- FE_ \
-}
-
-#define GMP_TAKE1_RET1(name,mp_fun) \
-FN_(name) \
-{ \
- MP_INT arg1, result; \
- I_ s1; \
- StgArrWords* d1; \
- FB_ \
- \
- /* call doYouWantToGC() */ \
- MAYBE_GC(R2_PTR, name); \
- \
- d1 = (StgArrWords *)R2.p; \
- s1 = R1.i; \
- \
- arg1._mp_alloc = d1->words; \
- arg1._mp_size = (s1); \
- arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- \
- STGCALL1(mpz_init,&result); \
- \
- /* Perform the operation */ \
- STGCALL2(mp_fun,&result,&arg1); \
- \
- TICK_RET_UNBOXED_TUP(2); \
- RET_NP(result._mp_size, \
- result._mp_d-sizeofW(StgArrWords)); \
- FE_ \
-}
-
-#define GMP_TAKE2_RET2(name,mp_fun) \
-FN_(name) \
-{ \
- MP_INT arg1, arg2, result1, result2; \
- I_ s1, s2; \
- StgArrWords* d1; \
- StgArrWords* d2; \
- FB_ \
- \
- /* call doYouWantToGC() */ \
- MAYBE_GC(R2_PTR | R4_PTR, name); \
- \
- d1 = (StgArrWords *)R2.p; \
- s1 = R1.i; \
- d2 = (StgArrWords *)R4.p; \
- s2 = R3.i; \
- \
- arg1._mp_alloc = d1->words; \
- arg1._mp_size = (s1); \
- arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- arg2._mp_alloc = d2->words; \
- arg2._mp_size = (s2); \
- arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
- \
- STGCALL1(mpz_init,&result1); \
- STGCALL1(mpz_init,&result2); \
- \
- /* Perform the operation */ \
- STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2); \
- \
- TICK_RET_UNBOXED_TUP(4); \
- RET_NPNP(result1._mp_size, \
- result1._mp_d-sizeofW(StgArrWords), \
- result2._mp_size, \
- result2._mp_d-sizeofW(StgArrWords)); \
- FE_ \
-}
-
-GMP_TAKE2_RET1(plusIntegerzh_fast, mpz_add);
-GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub);
-GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul);
-GMP_TAKE2_RET1(gcdIntegerzh_fast, mpz_gcd);
-GMP_TAKE2_RET1(quotIntegerzh_fast, mpz_tdiv_q);
-GMP_TAKE2_RET1(remIntegerzh_fast, mpz_tdiv_r);
-GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
-GMP_TAKE2_RET1(andIntegerzh_fast, mpz_and);
-GMP_TAKE2_RET1(orIntegerzh_fast, mpz_ior);
-GMP_TAKE2_RET1(xorIntegerzh_fast, mpz_xor);
-GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com);
-
-GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
-GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr);
-
-
-FN_(gcdIntzh_fast)
-{
- /* R1 = the first Int#; R2 = the second Int# */
- mp_limb_t aa;
- I_ r;
- FB_
- aa = (mp_limb_t)(R1.i);
- r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(R2.i));
-
- R1.i = r;
- /* Result parked in R1, return via info-pointer at TOS */
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-FN_(gcdIntegerIntzh_fast)
-{
- /* R1 = s1; R2 = d1; R3 = the int */
- I_ r;
- FB_
- r = RET_STGCALL3(StgInt,mpn_gcd_1,(mp_limb_t *)(BYTE_ARR_CTS(R2.p)), R1.i, R3.i);
-
- R1.i = r;
- /* Result parked in R1, return via info-pointer at TOS */
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-FN_(cmpIntegerIntzh_fast)
-{
- /* R1 = s1; R2 = d1; R3 = the int */
- I_ usize;
- I_ vsize;
- I_ v_digit;
- mp_limb_t u_digit;
- FB_
-
- usize = R1.i;
- vsize = 0;
- v_digit = R3.i;
-
- // paraphrased from mpz_cmp_si() in the GMP sources
- if (v_digit > 0) {
- vsize = 1;
- } else if (v_digit < 0) {
- vsize = -1;
- v_digit = -v_digit;
- }
-
- if (usize != vsize) {
- R1.i = usize - vsize; JMP_(ENTRY_CODE(Sp[0]));
- }
-
- if (usize == 0) {
- R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
- }
-
- u_digit = *(mp_limb_t *)(BYTE_ARR_CTS(R2.p));
-
- if (u_digit == (mp_limb_t) (unsigned long) v_digit) {
- R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
- }
-
- if (u_digit > (mp_limb_t) (unsigned long) v_digit) {
- R1.i = usize;
- } else {
- R1.i = -usize;
- }
-
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-FN_(cmpIntegerzh_fast)
-{
- /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
- I_ usize;
- I_ vsize;
- I_ size;
- StgPtr up, vp;
- int cmp;
- FB_
-
- // paraphrased from mpz_cmp() in the GMP sources
- usize = R1.i;
- vsize = R3.i;
-
- if (usize != vsize) {
- R1.i = usize - vsize; JMP_(ENTRY_CODE(Sp[0]));
- }
-
- if (usize == 0) {
- R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
- }
-
- size = abs(usize);
-
- up = BYTE_ARR_CTS(R2.p);
- vp = BYTE_ARR_CTS(R4.p);
-
- cmp = RET_STGCALL3(I_, mpn_cmp, (mp_limb_t *)up, (mp_limb_t *)vp, size);
-
- if (cmp == 0) {
- R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
- }
-
- if ((cmp < 0) == (usize < 0)) {
- R1.i = 1;
- } else {
- R1.i = (-1);
- }
- /* Result parked in R1, return via info-pointer at TOS */
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-FN_(integer2Intzh_fast)
-{
- /* R1 = s; R2 = d */
- I_ r, s;
- FB_
- s = R1.i;
- if (s == 0)
- r = 0;
- else {
- r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
- if (s < 0) r = -r;
- }
- /* Result parked in R1, return via info-pointer at TOS */
- R1.i = r;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-FN_(integer2Wordzh_fast)
-{
- /* R1 = s; R2 = d */
- I_ s;
- W_ r;
- FB_
- s = R1.i;
- if (s == 0)
- r = 0;
- else {
- r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
- if (s < 0) r = -r;
- }
- /* Result parked in R1, return via info-pointer at TOS */
- R1.w = r;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-
-FN_(decodeFloatzh_fast)
-{
- MP_INT mantissa;
- I_ exponent;
- StgArrWords* p;
- StgFloat arg;
- FB_
-
- /* arguments: F1 = Float# */
- arg = F1;
-
- HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
- CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
-
- /* Be prepared to tell Lennart-coded __decodeFloat */
- /* where mantissa._mp_d can be put (it does not care about the rest) */
- p = (StgArrWords *)Hp - 1;
- SET_ARR_HDR(p,&stg_ARR_WORDS_info,CCCS,1)
- mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
-
- /* Perform the operation */
- STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
-
- /* returns: (Int# (expn), Int#, ByteArray#) */
- TICK_RET_UNBOXED_TUP(3);
- RET_NNP(exponent,mantissa._mp_size,p);
- FE_
-}
-
-#define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
-#define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
-
-FN_(decodeDoublezh_fast)
-{ MP_INT mantissa;
- I_ exponent;
- StgDouble arg;
- StgArrWords* p;
- FB_
-
- /* arguments: D1 = Double# */
- arg = D1;
-
- HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
- CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
-
- /* Be prepared to tell Lennart-coded __decodeDouble */
- /* where mantissa.d can be put (it does not care about the rest) */
- p = (StgArrWords *)(Hp-ARR_SIZE+1);
- SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
- mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
-
- /* Perform the operation */
- STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
-
- /* returns: (Int# (expn), Int#, ByteArray#) */
- TICK_RET_UNBOXED_TUP(3);
- RET_NNP(exponent,mantissa._mp_size,p);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- * Concurrency primitives
- * -------------------------------------------------------------------------- */
-
-FN_(forkzh_fast)
-{
- FB_
- /* args: R1 = closure to spark */
-
- MAYBE_GC(R1_PTR, forkzh_fast);
-
- /* create it right now, return ThreadID in R1 */
- R1.t = RET_STGCALL2(StgTSO *, createIOThread,
- RtsFlags.GcFlags.initialStkSize, R1.cl);
- STGCALL1(scheduleThread, R1.t);
-
- /* switch at the earliest opportunity */
- context_switch = 1;
-
- RET_P(R1.t);
- FE_
-}
-
-FN_(yieldzh_fast)
-{
- FB_
- JMP_(stg_yield_noregs);
- FE_
-}
-
-FN_(myThreadIdzh_fast)
-{
- /* no args. */
- FB_
- RET_P((P_)CurrentTSO);
- FE_
-}
-
-FN_(labelThreadzh_fast)
-{
- FB_
- /* args:
- R1.p = ThreadId#
- R2.p = Addr# */
-#ifdef DEBUG
- STGCALL2(labelThread,R1.p,(char *)R2.p);
-#endif
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-
-FN_(isCurrentThreadBoundzh_fast)
-{
- /* no args */
- I_ r;
- FB_
- r = (I_)(RET_STGCALL1(StgBool, isThreadBound, CurrentTSO));
- RET_N(r);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- * MVar primitives
- *
- * take & putMVar work as follows. Firstly, an important invariant:
- *
- * If the MVar is full, then the blocking queue contains only
- * threads blocked on putMVar, and if the MVar is empty then the
- * blocking queue contains only threads blocked on takeMVar.
- *
- * takeMvar:
- * MVar empty : then add ourselves to the blocking queue
- * MVar full : remove the value from the MVar, and
- * blocking queue empty : return
- * blocking queue non-empty : perform the first blocked putMVar
- * from the queue, and wake up the
- * thread (MVar is now full again)
- *
- * putMVar is just the dual of the above algorithm.
- *
- * How do we "perform a putMVar"? Well, we have to fiddle around with
- * the stack of the thread waiting to do the putMVar. See
- * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
- * the stack layout, and the PerformPut and PerformTake macros below.
- *
- * It is important that a blocked take or put is woken up with the
- * take/put already performed, because otherwise there would be a
- * small window of vulnerability where the thread could receive an
- * exception and never perform its take or put, and we'd end up with a
- * deadlock.
- *
- * -------------------------------------------------------------------------- */
-
-FN_(isEmptyMVarzh_fast)
-{
- /* args: R1 = MVar closure */
- I_ r;
- FB_
- r = (I_)((GET_INFO((StgMVar*)(R1.p))) == &stg_EMPTY_MVAR_info);
- RET_N(r);
- FE_
-}
-
-
-FN_(newMVarzh_fast)
-{
- StgMVar *mvar;
-
- FB_
- /* args: none */
-
- HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
- 1, 0);
- CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
-
- mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
- SET_HDR(mvar,&stg_EMPTY_MVAR_info,CCCS);
- mvar->head = mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
- mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
-
- TICK_RET_UNBOXED_TUP(1);
- RET_P(mvar);
- FE_
-}
-
-/* If R1 isn't available, pass it on the stack */
-#ifdef REG_R1
-#define PerformTake(tso, value) ({ \
- (tso)->sp[1] = (W_)value; \
- (tso)->sp[0] = (W_)&stg_gc_unpt_r1_info; \
- })
-#else
-#define PerformTake(tso, value) ({ \
- (tso)->sp[1] = (W_)value; \
- (tso)->sp[0] = (W_)&stg_ut_1_0_unreg_info; \
- })
-#endif
-
-
-#define PerformPut(tso) ({ \
- StgClosure *val = (StgClosure *)(tso)->sp[2]; \
- (tso)->sp += 3; \
- val; \
- })
-
-FN_(takeMVarzh_fast)
-{
- StgMVar *mvar;
- StgClosure *val;
- const StgInfoTable *info;
-
- FB_
- /* args: R1 = MVar closure */
-
- mvar = (StgMVar *)R1.p;
-
-#ifdef SMP
- info = LOCK_CLOSURE(mvar);
-#else
- info = GET_INFO(mvar);
-#endif
-
- /* If the MVar is empty, put ourselves on its blocking queue,
- * and wait until we're woken up.
- */
- if (info == &stg_EMPTY_MVAR_info) {
- if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- mvar->head = CurrentTSO;
- } else {
- mvar->tail->link = CurrentTSO;
- }
- CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
- CurrentTSO->why_blocked = BlockedOnMVar;
- CurrentTSO->block_info.closure = (StgClosure *)mvar;
- mvar->tail = CurrentTSO;
-
-#ifdef SMP
- /* unlock the MVar */
- mvar->header.info = &stg_EMPTY_MVAR_info;
-#endif
- JMP_(stg_block_takemvar);
- }
-
- /* we got the value... */
- val = mvar->value;
-
- if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- /* There are putMVar(s) waiting...
- * wake up the first thread on the queue
- */
- ASSERT(mvar->head->why_blocked == BlockedOnMVar);
-
- /* actually perform the putMVar for the thread that we just woke up */
- mvar->value = PerformPut(mvar->head);
-
-#if defined(GRAN) || defined(PAR)
- /* ToDo: check 2nd arg (mvar) is right */
- mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
-#else
- mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
-#endif
- if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
- }
-#ifdef SMP
- /* unlock in the SMP case */
- SET_INFO(mvar,&stg_FULL_MVAR_info);
-#endif
- TICK_RET_UNBOXED_TUP(1);
- RET_P(val);
- } else {
- /* No further putMVars, MVar is now empty */
-
- /* do this last... we might have locked the MVar in the SMP case,
- * and writing the info pointer will unlock it.
- */
- SET_INFO(mvar,&stg_EMPTY_MVAR_info);
- mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
- TICK_RET_UNBOXED_TUP(1);
- RET_P(val);
- }
- FE_
-}
-
-FN_(tryTakeMVarzh_fast)
-{
- StgMVar *mvar;
- StgClosure *val;
- const StgInfoTable *info;
-
- FB_
- /* args: R1 = MVar closure */
-
- mvar = (StgMVar *)R1.p;
-
-#ifdef SMP
- info = LOCK_CLOSURE(mvar);
-#else
- info = GET_INFO(mvar);
-#endif
-
- if (info == &stg_EMPTY_MVAR_info) {
-
-#ifdef SMP
- /* unlock the MVar */
- SET_INFO(mvar,&stg_EMPTY_MVAR_info);
-#endif
-
- /* HACK: we need a pointer to pass back,
- * so we abuse NO_FINALIZER_closure
- */
- RET_NP(0, &stg_NO_FINALIZER_closure);
- }
-
- /* we got the value... */
- val = mvar->value;
-
- if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- /* There are putMVar(s) waiting...
- * wake up the first thread on the queue
- */
- ASSERT(mvar->head->why_blocked == BlockedOnMVar);
-
- /* actually perform the putMVar for the thread that we just woke up */
- mvar->value = PerformPut(mvar->head);
-
-#if defined(GRAN) || defined(PAR)
- /* ToDo: check 2nd arg (mvar) is right */
- mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
-#else
- mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
-#endif
- if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
- }
-#ifdef SMP
- /* unlock in the SMP case */
- SET_INFO(mvar,&stg_FULL_MVAR_info);
-#endif
- } else {
- /* No further putMVars, MVar is now empty */
- mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
-
- /* do this last... we might have locked the MVar in the SMP case,
- * and writing the info pointer will unlock it.
- */
- SET_INFO(mvar,&stg_EMPTY_MVAR_info);
- }
-
- TICK_RET_UNBOXED_TUP(1);
- RET_NP((I_)1, val);
- FE_
-}
-
-FN_(putMVarzh_fast)
-{
- StgMVar *mvar;
- const StgInfoTable *info;
-
- FB_
- /* args: R1 = MVar, R2 = value */
-
- mvar = (StgMVar *)R1.p;
-
-#ifdef SMP
- info = LOCK_CLOSURE(mvar);
-#else
- info = GET_INFO(mvar);
-#endif
-
- if (info == &stg_FULL_MVAR_info) {
- if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- mvar->head = CurrentTSO;
- } else {
- mvar->tail->link = CurrentTSO;
- }
- CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
- CurrentTSO->why_blocked = BlockedOnMVar;
- CurrentTSO->block_info.closure = (StgClosure *)mvar;
- mvar->tail = CurrentTSO;
-
-#ifdef SMP
- /* unlock the MVar */
- SET_INFO(mvar,&stg_FULL_MVAR_info);
-#endif
- JMP_(stg_block_putmvar);
- }
-
- if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- /* There are takeMVar(s) waiting: wake up the first one
- */
- ASSERT(mvar->head->why_blocked == BlockedOnMVar);
-
- /* actually perform the takeMVar */
- PerformTake(mvar->head, R2.cl);
-
-#if defined(GRAN) || defined(PAR)
- /* ToDo: check 2nd arg (mvar) is right */
- mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
-#else
- mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
-#endif
- if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
- }
-#ifdef SMP
- /* unlocks the MVar in the SMP case */
- SET_INFO(mvar,&stg_EMPTY_MVAR_info);
-#endif
- JMP_(ENTRY_CODE(Sp[0]));
- } else {
- /* No further takes, the MVar is now full. */
- mvar->value = R2.cl;
- /* unlocks the MVar in the SMP case */
- SET_INFO(mvar,&stg_FULL_MVAR_info);
- JMP_(ENTRY_CODE(Sp[0]));
- }
-
- /* ToDo: yield afterward for better communication performance? */
- FE_
-}
-
-FN_(tryPutMVarzh_fast)
-{
- StgMVar *mvar;
- const StgInfoTable *info;
-
- FB_
- /* args: R1 = MVar, R2 = value */
-
- mvar = (StgMVar *)R1.p;
-
-#ifdef SMP
- info = LOCK_CLOSURE(mvar);
-#else
- info = GET_INFO(mvar);
-#endif
-
- if (info == &stg_FULL_MVAR_info) {
-
-#ifdef SMP
- /* unlock the MVar */
- mvar->header.info = &stg_FULL_MVAR_info;
-#endif
-
- RET_N(0);
- }
-
- if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- /* There are takeMVar(s) waiting: wake up the first one
- */
- ASSERT(mvar->head->why_blocked == BlockedOnMVar);
-
- /* actually perform the takeMVar */
- PerformTake(mvar->head, R2.cl);
-
-#if defined(GRAN) || defined(PAR)
- /* ToDo: check 2nd arg (mvar) is right */
- mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
-#else
- mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
-#endif
- if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
- mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
- }
-#ifdef SMP
- /* unlocks the MVar in the SMP case */
- SET_INFO(mvar,&stg_EMPTY_MVAR_info);
-#endif
- JMP_(ENTRY_CODE(Sp[0]));
- } else {
- /* No further takes, the MVar is now full. */
- mvar->value = R2.cl;
- /* unlocks the MVar in the SMP case */
- SET_INFO(mvar,&stg_FULL_MVAR_info);
- JMP_(ENTRY_CODE(Sp[0]));
- }
-
- /* ToDo: yield afterward for better communication performance? */
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Stable pointer primitives
- ------------------------------------------------------------------------- */
-
-FN_(makeStableNamezh_fast)
-{
- StgWord index;
- StgStableName *sn_obj;
- FB_
-
- HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgHeader),
- sizeofW(StgStableName)-sizeofW(StgHeader), 0);
- CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
-
- index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
-
- /* Is there already a StableName for this heap object? */
- if (stable_ptr_table[index].sn_obj == NULL) {
- sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
- SET_HDR(sn_obj,&stg_STABLE_NAME_info,CCCS);
- sn_obj->sn = index;
- stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
- } else {
- (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
- }
-
- TICK_RET_UNBOXED_TUP(1);
- RET_P(sn_obj);
-}
-
-
-FN_(makeStablePtrzh_fast)
-{
- /* Args: R1 = a */
- StgStablePtr sp;
- FB_
- MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
- sp = RET_STGCALL1(StgStablePtr,getStablePtr,R1.p);
- RET_N(sp);
- FE_
-}
-
-FN_(deRefStablePtrzh_fast)
-{
- /* Args: R1 = the stable ptr */
- P_ r;
- StgStablePtr sp;
- FB_
- sp = (StgStablePtr)R1.w;
- r = stable_ptr_table[(StgWord)sp].addr;
- RET_P(r);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Bytecode object primitives
- ------------------------------------------------------------------------- */
-
-FN_(newBCOzh_fast)
-{
- /* R1.p = instrs
- R2.p = literals
- R3.p = ptrs
- R4.p = itbls
- R5.i = arity
- R6.p = bitmap array
- */
- StgBCO *bco;
- nat size;
- StgArrWords *bitmap_arr;
- FB_
-
- bitmap_arr = (StgArrWords *)R6.cl;
- size = sizeofW(StgBCO) + bitmap_arr->words;
- HP_CHK_GEN_TICKY(size,R1_PTR|R2_PTR|R3_PTR|R4_PTR|R6_PTR, newBCOzh_fast);
- TICK_ALLOC_PRIM(size, size-sizeofW(StgHeader), 0);
- CCS_ALLOC(CCCS,size); /* ccs prof */
- bco = (StgBCO *) (Hp + 1 - size);
- SET_HDR(bco, (const StgInfoTable *)&stg_BCO_info, CCCS);
-
- bco->instrs = (StgArrWords*)R1.cl;
- bco->literals = (StgArrWords*)R2.cl;
- bco->ptrs = (StgMutArrPtrs*)R3.cl;
- bco->itbls = (StgArrWords*)R4.cl;
- bco->arity = R5.w;
- bco->size = size;
-
- // Copy the arity/bitmap info into the BCO
- {
- int i;
- for (i = 0; i < bitmap_arr->words; i++) {
- bco->bitmap[i] = bitmap_arr->payload[i];
- }
- }
-
- TICK_RET_UNBOXED_TUP(1);
- RET_P(bco);
- FE_
-}
-
-FN_(mkApUpd0zh_fast)
-{
- // R1.p = the BCO# for the AP
- //
- StgPAP* ap;
- FB_
-
- // This function is *only* used to wrap zero-arity BCOs in an
- // updatable wrapper (see ByteCodeLink.lhs). An AP thunk is always
- // saturated and always points directly to a FUN or BCO.
- ASSERT(get_itbl(R1.cl)->type == BCO && ((StgBCO *)R1.p)->arity == 0);
-
- HP_CHK_GEN_TICKY(PAP_sizeW(0), R1_PTR, mkApUpd0zh_fast);
- TICK_ALLOC_PRIM(sizeofW(StgHeader), PAP_sizeW(0)-sizeofW(StgHeader), 0);
- CCS_ALLOC(CCCS,PAP_sizeW(0)); /* ccs prof */
- ap = (StgPAP *) (Hp + 1 - PAP_sizeW(0));
- SET_HDR(ap, &stg_AP_info, CCCS);
-
- ap->n_args = 0;
- ap->fun = R1.cl;
-
- TICK_RET_UNBOXED_TUP(1);
- RET_P(ap);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Thread I/O blocking primitives
- -------------------------------------------------------------------------- */
-
-FN_(waitReadzh_fast)
-{
- FB_
- /* args: R1.i */
- ASSERT(CurrentTSO->why_blocked == NotBlocked);
- CurrentTSO->why_blocked = BlockedOnRead;
- CurrentTSO->block_info.fd = R1.i;
- ACQUIRE_LOCK(&sched_mutex);
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
- RELEASE_LOCK(&sched_mutex);
- JMP_(stg_block_noregs);
- FE_
-}
-
-FN_(waitWritezh_fast)
-{
- FB_
- /* args: R1.i */
- ASSERT(CurrentTSO->why_blocked == NotBlocked);
- CurrentTSO->why_blocked = BlockedOnWrite;
- CurrentTSO->block_info.fd = R1.i;
- ACQUIRE_LOCK(&sched_mutex);
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
- RELEASE_LOCK(&sched_mutex);
- JMP_(stg_block_noregs);
- FE_
-}
-
-FN_(delayzh_fast)
-{
-#ifdef mingw32_TARGET_OS
- StgAsyncIOResult* ares;
- unsigned int reqID;
-#else
- StgTSO *t, *prev;
- nat target;
-#endif
- FB_
- /* args: R1.i (microsecond delay amount) */
- ASSERT(CurrentTSO->why_blocked == NotBlocked);
- CurrentTSO->why_blocked = BlockedOnDelay;
-
- ACQUIRE_LOCK(&sched_mutex);
-#ifdef mingw32_TARGET_OS
- /* could probably allocate this on the heap instead */
- ares = (StgAsyncIOResult*)RET_STGCALL2(P_,stgMallocBytes,sizeof(StgAsyncIOResult), "delayzh_fast");
- reqID = RET_STGCALL1(W_,addDelayRequest,R1.i);
- ares->reqID = reqID;
- ares->len = 0;
- ares->errCode = 0;
- CurrentTSO->block_info.async_result = ares;
- /* Having all async-blocked threads reside on the blocked_queue simplifies matters, so
- * change the status to OnDoProc & put the delayed thread on the blocked_queue.
- */
- CurrentTSO->why_blocked = BlockedOnDoProc;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
-#else
- target = ((R1.i + TICK_MILLISECS*1000-1) / (TICK_MILLISECS*1000)) + getourtimeofday();
- CurrentTSO->block_info.target = target;
-
- /* Insert the new thread in the sleeping queue. */
- prev = NULL;
- t = sleeping_queue;
- while (t != END_TSO_QUEUE && t->block_info.target < target) {
- prev = t;
- t = t->link;
- }
-
- CurrentTSO->link = t;
- if (prev == NULL) {
- sleeping_queue = CurrentTSO;
- } else {
- prev->link = CurrentTSO;
- }
-#endif
- RELEASE_LOCK(&sched_mutex);
- JMP_(stg_block_noregs);
- FE_
-}
-
-#ifdef mingw32_TARGET_OS
-FN_(asyncReadzh_fast)
-{
- StgAsyncIOResult* ares;
- unsigned int reqID;
- FB_
- /* args: R1.i = fd, R2.i = isSock, R3.i = len, R4.p = buf */
- ASSERT(CurrentTSO->why_blocked == NotBlocked);
- CurrentTSO->why_blocked = BlockedOnRead;
- ACQUIRE_LOCK(&sched_mutex);
- /* could probably allocate this on the heap instead */
- ares = (StgAsyncIOResult*)RET_STGCALL2(P_,stgMallocBytes,sizeof(StgAsyncIOResult), "asyncReadzh_fast");
- reqID = RET_STGCALL5(W_,addIORequest,R1.i,FALSE,R2.i,R3.i,(char*)R4.p);
- ares->reqID = reqID;
- ares->len = 0;
- ares->errCode = 0;
- CurrentTSO->block_info.async_result = ares;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
- RELEASE_LOCK(&sched_mutex);
- JMP_(stg_block_async);
- FE_
-}
-
-FN_(asyncWritezh_fast)
-{
- StgAsyncIOResult* ares;
- unsigned int reqID;
- FB_
- /* args: R1.i */
- /* args: R1.i = fd, R2.i = isSock, R3.i = len, R4.p = buf */
- ASSERT(CurrentTSO->why_blocked == NotBlocked);
- CurrentTSO->why_blocked = BlockedOnWrite;
- ACQUIRE_LOCK(&sched_mutex);
- ares = (StgAsyncIOResult*)RET_STGCALL2(P_,stgMallocBytes,sizeof(StgAsyncIOResult), "asyncWritezh_fast");
- reqID = RET_STGCALL5(W_,addIORequest,R1.i,TRUE,R2.i,R3.i,(char*)R4.p);
- ares->reqID = reqID;
- ares->len = 0;
- ares->errCode = 0;
- CurrentTSO->block_info.async_result = ares;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
- RELEASE_LOCK(&sched_mutex);
- JMP_(stg_block_async);
- FE_
-}
-
-FN_(asyncDoProczh_fast)
-{
- StgAsyncIOResult* ares;
- unsigned int reqID;
- FB_
- /* args: R1.i = proc, R2.i = param */
- ASSERT(CurrentTSO->why_blocked == NotBlocked);
- CurrentTSO->why_blocked = BlockedOnDoProc;
- ACQUIRE_LOCK(&sched_mutex);
- /* could probably allocate this on the heap instead */
- ares = (StgAsyncIOResult*)RET_STGCALL2(P_,stgMallocBytes,sizeof(StgAsyncIOResult), "asyncDoProczh_fast");
- reqID = RET_STGCALL2(W_,addDoProcRequest,R1.p,R2.p);
- ares->reqID = reqID;
- ares->len = 0;
- ares->errCode = 0;
- CurrentTSO->block_info.async_result = ares;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
- RELEASE_LOCK(&sched_mutex);
- JMP_(stg_block_async);
- FE_
-}
-#endif
-
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.62 2003/11/12 17:49:08 sof Exp $
+ * $Id: Printer.c,v 1.63 2004/08/13 13:10:23 simonmar Exp $
*
* (c) The GHC Team, 1994-2000.
*
#if defined(GRAN) || defined(PAR)
// HWL: explicit fixed header size to make debugging easier
-int fixed_hs = FIXED_HS, itbl_sz = sizeofW(StgInfoTable),
+int fixed_hs = sizeof(StgHeader), itbl_sz = sizeofW(StgInfoTable),
uf_sz=sizeofW(StgUpdateFrame);
#endif
case FUN_1_0: case FUN_0_1:
case FUN_1_1: case FUN_0_2: case FUN_2_0:
case FUN_STATIC:
- fprintf(stderr,"FUN/%d(",itbl_to_fun_itbl(info)->arity);
+ fprintf(stderr,"FUN/%d(",itbl_to_fun_itbl(info)->f.arity);
printPtr((StgPtr)obj->header.info);
#ifdef PROFILING
fprintf(stderr,", %s", obj->header.prof.ccs->cc->label);
StgClosure* c = (StgClosure*)(*sp);
printPtr((StgPtr)*sp);
- if (c == (StgClosure*)&stg_ctoi_ret_R1p_info) {
+ if (c == (StgClosure*)&stg_ctoi_R1p_info) {
fprintf(stderr, "\t\t\tstg_ctoi_ret_R1p_info\n" );
} else
- if (c == (StgClosure*)&stg_ctoi_ret_R1n_info) {
+ if (c == (StgClosure*)&stg_ctoi_R1n_info) {
fprintf(stderr, "\t\t\tstg_ctoi_ret_R1n_info\n" );
} else
- if (c == (StgClosure*)&stg_ctoi_ret_F1_info) {
+ if (c == (StgClosure*)&stg_ctoi_F1_info) {
fprintf(stderr, "\t\t\tstg_ctoi_ret_F1_info\n" );
} else
- if (c == (StgClosure*)&stg_ctoi_ret_D1_info) {
+ if (c == (StgClosure*)&stg_ctoi_D1_info) {
fprintf(stderr, "\t\t\tstg_ctoi_ret_D1_info\n" );
} else
- if (c == (StgClosure*)&stg_ctoi_ret_V_info) {
+ if (c == (StgClosure*)&stg_ctoi_V_info) {
fprintf(stderr, "\t\t\tstg_ctoi_ret_V_info\n" );
} else
if (get_itbl(c)->type == BCO) {
p = (P_)(r->payload);
printSmallBitmap(spBottom, sp,
- GET_LIVENESS(r->liveness), RET_DYN_BITMAP_SIZE);
+ RET_DYN_LIVENESS(r->liveness),
+ RET_DYN_BITMAP_SIZE);
p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
- for (size = GET_NONPTRS(dyn); size > 0; size--) {
+ for (size = RET_DYN_NONPTRS(dyn); size > 0; size--) {
fprintf(stderr," stk[%ld] (%p) = ", (long)(spBottom-p), p);
fprintf(stderr,"Word# %ld\n", (long)*p);
p++;
}
- for (size = GET_PTRS(dyn); size > 0; size--) {
+ for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
fprintf(stderr," stk[%ld] (%p) = ", (long)(spBottom-p), p);
printPtr(p);
p++;
ret_fun = (StgRetFun *)sp;
fun_info = get_fun_itbl(ret_fun->fun);
size = ret_fun->size;
- fprintf(stderr,"RET_FUN (%p) (type=%d)\n", ret_fun, fun_info->fun_type);
- switch (fun_info->fun_type) {
+ fprintf(stderr,"RET_FUN (%p) (type=%d)\n", ret_fun, fun_info->f.fun_type);
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
printSmallBitmap(spBottom, sp+1,
- BITMAP_BITS(fun_info->bitmap),
- BITMAP_SIZE(fun_info->bitmap));
+ BITMAP_BITS(fun_info->f.bitmap),
+ BITMAP_SIZE(fun_info->f.bitmap));
break;
case ARG_GEN_BIG:
printLargeBitmap(spBottom, sp+2,
- (StgLargeBitmap *)fun_info->bitmap,
- BITMAP_SIZE(fun_info->bitmap));
+ (StgLargeBitmap *)fun_info->f.bitmap,
+ BITMAP_SIZE(fun_info->f.bitmap));
break;
default:
printSmallBitmap(spBottom, sp+1,
- BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]),
- BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]));
+ BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
+ BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]));
break;
}
continue;
#endif /* HAVE_BFD_H */
-#include "StoragePriv.h"
-
void findPtr(P_ p, int); /* keep gcc -Wall happy */
void
/* -----------------------------------------------------------------------------
- * $Id: ProfHeap.c,v 1.52 2004/05/11 18:36:10 panne Exp $
+ * $Id: ProfHeap.c,v 1.53 2004/08/13 13:10:25 simonmar Exp $
*
* (c) The GHC Team, 1998-2003
*
if (era > 0 && closureSatisfiesConstraints(c)) {
size -= sizeofW(StgProfHeader);
+ ASSERT(LDVW(c) != 0);
if ((LDVW((c)) & LDV_STATE_MASK) == LDV_STATE_CREATE) {
t = (LDVW((c)) & LDV_CREATE_MASK) >> LDV_SHIFT;
if (t < era) {
/* -----------------------------------------------------------------------------
- * $Id: Profiling.c,v 1.37 2003/08/22 22:24:13 sof Exp $
+ * $Id: Profiling.c,v 1.38 2004/08/13 13:10:26 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
-------------------------------------------------------------------------- */
rtsBool entering_PAP;
-CostCentreStack *
-EnterFunCCS ( CostCentreStack *cccs, CostCentreStack *ccsfn )
+void
+EnterFunCCS ( CostCentreStack *ccsfn )
{
/* PAP_entry has already set CCCS for us */
if (entering_PAP) {
entering_PAP = rtsFalse;
- return CCCS;
+ return;
}
if (ccsfn->root->is_caf == CC_IS_CAF) {
- return AppendCCS(cccs,ccsfn);
+ CCCS = AppendCCS(CCCS,ccsfn);
} else {
- return ccsfn;
+ CCCS = ccsfn;
}
}
/* -----------------------------------------------------------------------------
- * $Id: Profiling.h,v 1.5 2002/07/18 09:12:03 simonmar Exp $
+ * $Id: Profiling.h,v 1.6 2004/08/13 13:10:28 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
void PrintNewStackDecls ( void );
-extern lnat total_prof_ticks;
+extern lnat RTS_VAR(total_prof_ticks);
extern void fprintCCS( FILE *f, CostCentreStack *ccs );
/* -----------------------------------------------------------------------------
- * $Id: RetainerProfile.c,v 1.10 2003/05/16 14:39:29 simonmar Exp $
+ * $Id: RetainerProfile.c,v 1.11 2004/08/13 13:10:28 simonmar Exp $
*
* (c) The GHC Team, 2001
* Author: Sungwoo Park
#include "Schedule.h"
#include "Printer.h"
#include "Storage.h"
-#include "StoragePriv.h"
#include "RtsFlags.h"
#include "Weak.h"
#include "Sanity.h"
-#include "StablePriv.h"
#include "Profiling.h"
#include "Stats.h"
#include "BlockAlloc.h"
{
if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
info->type = posTypeLargeSRT;
- info->next.large_srt.srt = (StgLargeSRT *)infoTable->srt;
+ info->next.large_srt.srt = (StgLargeSRT *)infoTable->f.srt;
info->next.large_srt.offset = 0;
} else {
info->type = posTypeSRT;
- info->next.srt.srt = (StgClosure **)(infoTable->srt);
+ info->next.srt.srt = (StgClosure **)(infoTable->f.srt);
info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
}
}
dyn = ((StgRetDyn *)p)->liveness;
// traverse the bitmap first
- bitmap = GET_LIVENESS(dyn);
+ bitmap = RET_DYN_LIVENESS(dyn);
p = (P_)&((StgRetDyn *)p)->payload[0];
size = RET_DYN_BITMAP_SIZE;
p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
// skip over the non-ptr words
- p += GET_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
+ p += RET_DYN_NONPTRS(dyn) + RET_DYN_NONPTR_REGS_SIZE;
// follow the ptr words
- for (size = GET_PTRS(dyn); size > 0; size--) {
+ for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
retainClosure((StgClosure *)*p, c, c_child_r);
p++;
}
fun_info = get_fun_itbl(ret_fun->fun);
p = (P_)&ret_fun->payload;
- switch (fun_info->fun_type) {
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
- bitmap = BITMAP_BITS(fun_info->bitmap);
- size = BITMAP_SIZE(fun_info->bitmap);
+ bitmap = BITMAP_BITS(fun_info->f.bitmap);
+ size = BITMAP_SIZE(fun_info->f.bitmap);
p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
break;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->bitmap)->size;
- retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
+ size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
+ retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
size, c, c_child_r);
p += size;
break;
default:
- bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
- size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->fun_type]);
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+ size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
break;
}
p = (StgPtr)pap->payload;
size = pap->n_args;
- switch (fun_info->fun_type) {
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
- bitmap = BITMAP_BITS(fun_info->bitmap);
+ bitmap = BITMAP_BITS(fun_info->f.bitmap);
p = retain_small_bitmap(p, pap->n_args, bitmap,
(StgClosure *)pap, c_child_r);
break;
case ARG_GEN_BIG:
- retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
+ retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
size, (StgClosure *)pap, c_child_r);
p += size;
break;
p += size;
break;
default:
- bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]);
+ bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
p = retain_small_bitmap(p, pap->n_args, bitmap,
(StgClosure *)pap, c_child_r);
break;
/* -----------------------------------------------------------------------------
- * $Id: RetainerProfile.h,v 1.3 2003/03/21 16:18:38 sof Exp $
+ * $Id: RetainerProfile.h,v 1.4 2004/08/13 13:10:29 simonmar Exp $
*
* (c) The GHC Team, 2001
* Author: Sungwoo Park
extern void retainerProfile ( void );
extern void resetStaticObjectForRetainerProfiling ( void );
-extern StgWord flip;
+extern StgWord RTS_VAR(flip);
// extract the retainer set field from c
#define RSET(c) ((c)->header.prof.hp.rs)
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.74 2004/03/22 11:48:30 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.75 2004/08/13 13:10:29 simonmar Exp $
*
* (c) The AQUA Project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
#include <stdlib.h>
#include <string.h>
-extern struct RTS_FLAGS RtsFlags;
+// Flag Structure
+RTS_FLAGS RtsFlags;
/*
* Split argument lists
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.80 2004/03/19 23:17:06 panne Exp $
+ * $Id: RtsStartup.c,v 1.81 2004/08/13 13:10:32 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "Storage.h" /* initStorage, exitStorage */
-#include "StablePriv.h" /* initStablePtrTable */
#include "Schedule.h" /* initScheduler */
#include "Stats.h" /* initStats */
#include "Signals.h"
#include "Weak.h"
#include "Ticky.h"
#include "StgRun.h"
-#include "StgStartup.h"
#include "Prelude.h" /* fixupRTStoPreludeRefs */
#include "HsFFI.h"
#include "Linker.h"
#include "ThreadLabels.h"
+#include "BlockAlloc.h"
#if defined(RTS_GTK_FRONTPANEL)
#include "FrontPanel.h"
#include <signal.h>
#endif
-// Flag Structure
-struct RTS_FLAGS RtsFlags;
-
// Count of how many outstanding hs_init()s there have been.
static int hs_init_count = 0;
}
}
+#if i386_TARGET_ARCH
+static void x86_init_fpu ( void );
+#endif
+
/* -----------------------------------------------------------------------------
Starting up the RTS
-------------------------------------------------------------------------- */
setlocale(LC_CTYPE,"");
#endif
+#if i386_TARGET_ARCH
+// x86_init_fpu();
+#endif
+
/* Record initialization times */
stat_endInit();
}
barf("hs_add_root() must be called after hs_init()");
}
- init_sp = 0;
+ /* The initialisation stack grows downward, with sp pointing
+ to the last occupied word */
+ init_sp = INIT_STACK_BLOCKS*BLOCK_SIZE_W;
bd = allocGroup(INIT_STACK_BLOCKS);
init_stack = (F_ *)bd->start;
- init_stack[init_sp++] = (F_)stg_init_ret;
+ init_stack[--init_sp] = (F_)stg_init_finish;
if (init_root != NULL) {
- init_stack[init_sp++] = (F_)init_root;
+ init_stack[--init_sp] = (F_)init_root;
}
cap.r.rSp = (P_)(init_stack + init_sp);
exit(n);
}
+/* -----------------------------------------------------------------------------
+ Initialise floating point unit on x86
+ -------------------------------------------------------------------------- */
+
+#if i386_TARGET_ARCH
+static void
+x86_init_fpu ( void )
+{
+ __volatile unsigned short int fpu_cw;
+
+ // Grab the control word
+ __asm __volatile ("fnstcw %0" : "=m" (fpu_cw));
+
+#if 0
+ printf("fpu_cw: %x\n", fpu_cw);
+#endif
+
+ // Set bits 8-9 to 10 (64-bit precision).
+ fpu_cw = (fpu_cw & 0xfcff) | 0x0200;
+
+ // Store the new control word back
+ __asm __volatile ("fldcw %0" : : "m" (fpu_cw));
+}
+#endif
+
/* -----------------------------------------------------------------------------
- * $Id: RtsUtils.h,v 1.21 2004/03/23 10:04:18 simonmar Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
* General utility functions used in the RTS.
*
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.34 2003/07/03 15:14:58 sof Exp $
*
* (c) The GHC Team, 1998-2001
*
#include "MBlock.h"
#include "Storage.h"
#include "Schedule.h"
-#include "StoragePriv.h" // for END_OF_STATIC_LIST
#include "Apply.h"
/* -----------------------------------------------------------------------------
dyn = r->liveness;
p = (P_)(r->payload);
- checkSmallBitmap(p,GET_LIVENESS(r->liveness),RET_DYN_BITMAP_SIZE);
+ checkSmallBitmap(p,RET_DYN_LIVENESS(r->liveness),RET_DYN_BITMAP_SIZE);
p += RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE;
// skip over the non-pointers
- p += GET_NONPTRS(dyn);
+ p += RET_DYN_NONPTRS(dyn);
// follow the ptr words
- for (size = GET_PTRS(dyn); size > 0; size--) {
+ for (size = RET_DYN_PTRS(dyn); size > 0; size--) {
checkClosureShallow((StgClosure *)*p);
p++;
}
return sizeofW(StgRetDyn) + RET_DYN_BITMAP_SIZE +
RET_DYN_NONPTR_REGS_SIZE +
- GET_NONPTRS(dyn) + GET_PTRS(dyn);
+ RET_DYN_NONPTRS(dyn) + RET_DYN_PTRS(dyn);
}
case UPDATE_FRAME:
ret_fun = (StgRetFun *)c;
fun_info = get_fun_itbl(ret_fun->fun);
size = ret_fun->size;
- switch (fun_info->fun_type) {
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
checkSmallBitmap((StgPtr)ret_fun->payload,
- BITMAP_BITS(fun_info->bitmap), size);
+ BITMAP_BITS(fun_info->f.bitmap), size);
break;
case ARG_GEN_BIG:
checkLargeBitmap((StgPtr)ret_fun->payload,
- (StgLargeBitmap *)fun_info->bitmap, size);
+ (StgLargeBitmap *)fun_info->f.bitmap, size);
break;
default:
checkSmallBitmap((StgPtr)ret_fun->payload,
- BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]),
+ BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
size);
break;
}
fun_info = get_fun_itbl(pap->fun);
p = (StgClosure *)pap->payload;
- switch (fun_info->fun_type) {
+ switch (fun_info->f.fun_type) {
case ARG_GEN:
checkSmallBitmap( (StgPtr)pap->payload,
- BITMAP_BITS(fun_info->bitmap), pap->n_args );
+ BITMAP_BITS(fun_info->f.bitmap), pap->n_args );
break;
case ARG_GEN_BIG:
checkLargeBitmap( (StgPtr)pap->payload,
- (StgLargeBitmap *)fun_info->bitmap,
+ (StgLargeBitmap *)fun_info->f.bitmap,
pap->n_args );
break;
case ARG_BCO:
break;
default:
checkSmallBitmap( (StgPtr)pap->payload,
- BITMAP_BITS(stg_arg_bitmaps[fun_info->fun_type]),
+ BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]),
pap->n_args );
break;
}
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.199 2004/08/09 14:27:53 simonmar Exp $
*
- * (c) The GHC Team, 1998-2003
+ * (c) The GHC Team, 1998-2004
*
* Scheduler
*
#include "SchedAPI.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
+#include "BlockAlloc.h"
#include "Storage.h"
#include "StgRun.h"
-#include "StgStartup.h"
#include "Hooks.h"
#define COMPILING_SCHEDULER
#include "Schedule.h"
#include "Timer.h"
#include "Prelude.h"
#include "ThreadLabels.h"
+#include "LdvProfile.h"
+#include "Updates.h"
#ifdef PROFILING
#include "Proftimer.h"
#include "ProfHeap.h"
#if DEBUG
static char *whatNext_strs[] = {
+ "(unknown)",
"ThreadRunGHC",
"ThreadInterpret",
"ThreadKilled",
# endif
#endif
rtsBool was_interrupted = rtsFalse;
- StgTSOWhatNext prev_what_next;
+ nat prev_what_next;
// Pre-condition: sched_mutex is held.
// We might have a capability, passed in as initialCapability.
#endif
// did the task ask for a large block?
- if (cap->r.rHpAlloc > BLOCK_SIZE_W) {
+ if (cap->r.rHpAlloc > BLOCK_SIZE) {
// if so, get one and push it on the front of the nursery.
bdescr *bd;
nat blocks;
- blocks = (nat)BLOCK_ROUND_UP(cap->r.rHpAlloc * sizeof(W_)) / BLOCK_SIZE;
+ blocks = (nat)BLOCK_ROUND_UP(cap->r.rHpAlloc) / BLOCK_SIZE;
IF_DEBUG(scheduler,belch("--<< thread %ld (%s) stopped: requesting a large block (size %d)",
t->id, whatNext_strs[t->what_next], blocks));
* ------------------------------------------------------------------------- */
StgInt
-suspendThread( StgRegTable *reg,
- rtsBool concCall
-#if !defined(DEBUG)
- STG_UNUSED
-#endif
- )
+suspendThread( StgRegTable *reg )
{
nat tok;
Capability *cap;
ACQUIRE_LOCK(&sched_mutex);
IF_DEBUG(scheduler,
- sched_belch("thread %d did a _ccall_gc (is_concurrent: %d)", cap->r.rCurrentTSO->id,concCall));
+ sched_belch("thread %d did a _ccall_gc", cap->r.rCurrentTSO->id));
// XXX this might not be necessary --SDM
cap->r.rCurrentTSO->what_next = ThreadRunGHC;
}
StgRegTable *
-resumeThread( StgInt tok,
- rtsBool concCall STG_UNUSED )
+resumeThread( StgInt tok )
{
StgTSO *tso, **prev;
Capability *cap;
//
if (!closure_IND(((StgUpdateFrame *)frame)->updatee)) {
// revert the black hole
- UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,ap);
+ UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,
+ (StgClosure *)ap);
}
sp += sizeofW(StgUpdateFrame) - 1;
sp[0] = (W_)ap; // push onto stack
}
/* -----------------------------------------------------------------------------
+ raiseExceptionHelper
+
+ This function is called by the raise# primitve, just so that we can
+ move some of the tricky bits of raising an exception from C-- into
+ C. Who knows, it might be a useful re-useable thing here too.
+ -------------------------------------------------------------------------- */
+
+StgWord
+raiseExceptionHelper (StgTSO *tso, StgClosure *exception)
+{
+ StgClosure *raise_closure = NULL;
+ StgPtr p, next;
+ StgRetInfoTable *info;
+ //
+ // This closure represents the expression 'raise# E' where E
+ // is the exception raise. It is used to overwrite all the
+ // thunks which are currently under evaluataion.
+ //
+
+ //
+ // LDV profiling: stg_raise_info has THUNK as its closure
+ // type. Since a THUNK takes at least MIN_UPD_SIZE words in its
+ // payload, MIN_UPD_SIZE is more approprate than 1. It seems that
+ // 1 does not cause any problem unless profiling is performed.
+ // However, when LDV profiling goes on, we need to linearly scan
+ // small object pool, where raise_closure is stored, so we should
+ // use MIN_UPD_SIZE.
+ //
+ // raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
+ // sizeofW(StgClosure)+1);
+ //
+
+ //
+ // Walk up the stack, looking for the catch frame. On the way,
+ // we update any closures pointed to from update frames with the
+ // raise closure that we just built.
+ //
+ p = tso->sp;
+ while(1) {
+ info = get_ret_itbl((StgClosure *)p);
+ next = p + stack_frame_sizeW((StgClosure *)p);
+ switch (info->i.type) {
+
+ case UPDATE_FRAME:
+ // Only create raise_closure if we need to.
+ if (raise_closure == NULL) {
+ raise_closure =
+ (StgClosure *)allocate(sizeofW(StgClosure)+MIN_UPD_SIZE);
+ SET_HDR(raise_closure, &stg_raise_info, CCCS);
+ raise_closure->payload[0] = exception;
+ }
+ UPD_IND(((StgUpdateFrame *)p)->updatee,raise_closure);
+ p = next;
+ continue;
+
+ case CATCH_FRAME:
+ tso->sp = p;
+ return CATCH_FRAME;
+
+ case STOP_FRAME:
+ tso->sp = p;
+ return STOP_FRAME;
+
+ default:
+ p = next;
+ continue;
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
resurrectThreads is called after garbage collection on the list of
threads found to be garbage. Each of these threads will be woken
up and sent a signal: BlockedOnDeadMVar if the thread was blocked
/* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.45 2004/03/01 14:18:36 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
void raiseAsync(StgTSO *tso, StgClosure *exception);
void raiseAsyncWithLock(StgTSO *tso, StgClosure *exception);
+/* raiseExceptionHelper */
+StgWord raiseExceptionHelper (StgTSO *tso, StgClosure *exception);
+
/* awaitEvent(rtsBool wait)
*
* Checks for blocked threads that need to be woken.
/* Context switch flag.
* Locks required : sched_mutex
*/
-extern nat context_switch;
-extern rtsBool interrupted;
+extern nat RTS_VAR(context_switch);
+extern rtsBool RTS_VAR(interrupted);
/* In Select.c */
-extern nat timestamp;
+extern nat RTS_VAR(timestamp);
/* Thread queues.
* Locks required : sched_mutex
#if defined(GRAN)
// run_queue_hds defined in GranSim.h
#else
-extern StgTSO *run_queue_hd, *run_queue_tl;
-extern StgTSO *blocked_queue_hd, *blocked_queue_tl;
-extern StgTSO *sleeping_queue;
+extern StgTSO *RTS_VAR(run_queue_hd), *RTS_VAR(run_queue_tl);
+extern StgTSO *RTS_VAR(blocked_queue_hd), *RTS_VAR(blocked_queue_tl);
+extern StgTSO *RTS_VAR(sleeping_queue);
#endif
/* Linked list of all threads. */
-extern StgTSO *all_threads;
+extern StgTSO *RTS_VAR(all_threads);
#if defined(RTS_SUPPORTS_THREADS)
/* Schedule.c has detailed info on what these do */
-extern Mutex sched_mutex;
-extern Condition returning_worker_cond;
-extern nat rts_n_waiting_workers;
-extern nat rts_n_waiting_tasks;
+extern Mutex RTS_VAR(sched_mutex);
+extern Condition RTS_VAR(returning_worker_cond);
+extern nat RTS_VAR(rts_n_waiting_workers);
+extern nat RTS_VAR(rts_n_waiting_tasks);
#endif
StgBool rtsSupportsBoundThreads(void);
/* -----------------------------------------------------------------------------
- * $Id: Signals.c,v 1.40 2003/10/31 23:24:47 sof Exp $
+ * $Id: Signals.c,v 1.41 2004/08/13 13:10:44 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Signals.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
-#include "StablePriv.h"
#ifdef alpha_TARGET_ARCH
# if defined(linux_TARGET_OS)
/* -----------------------------------------------------------------------------
- * $Id: Stable.c,v 1.27 2003/11/12 17:49:11 sof Exp $
+ * $Id: Stable.c,v 1.28 2004/08/13 13:10:45 simonmar Exp $
*
* (c) The GHC Team, 1998-2002
*
#include "PosixSource.h"
#include "Rts.h"
#include "Hash.h"
-#include "StablePriv.h"
#include "RtsUtils.h"
#include "Storage.h"
#include "RtsAPI.h"
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StablePriv.h,v 1.3 2001/07/23 17:23:20 simonmar Exp $
- *
- * (c) The GHC Team, 1998-1999
- *
- * Internal RTS API for stable names and stable ptrs.
- *
- * ---------------------------------------------------------------------------*/
-
-extern void initStablePtrTable ( void );
-extern void enlargeStablePtrTable ( void );
-extern StgWord lookupStableName ( StgPtr p );
-
-extern void markStablePtrTable ( evac_fn evac );
-extern void threadStablePtrTable ( evac_fn evac );
-extern void gcStablePtrTable ( void );
-extern void updateStablePtrTable ( rtsBool full );
/* -----------------------------------------------------------------------------
- * $Id: Stats.c,v 1.47 2004/05/27 09:29:28 simonmar Exp $
+ * $Id: Stats.c,v 1.48 2004/08/13 13:10:45 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Rts.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
-#include "StoragePriv.h"
#include "MBlock.h"
#include "Schedule.h"
#include "Stats.h"
#include "ParTicky.h" /* ToDo: move into Rts.h */
#include "Profiling.h"
+#include "Storage.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
/* -----------------------------------------------------------------------------
- * $Id: StgCRun.c,v 1.41 2003/12/10 11:35:26 wolfgang Exp $
+ * $Id: StgCRun.c,v 1.42 2004/08/13 13:10:46 simonmar Exp $
*
* (c) The GHC Team, 1998-2003
*
* that we don't use but which are callee-save registers. The __divq() routine
* in libc.a clobbers $s6.
*/
-#include "config.h"
+#include "ghcconfig.h"
#ifdef alpha_TARGET_ARCH
#define alpha_EXTRA_CAREFUL
register long fake_ra __asm__("$26");
#include "Stg.h"
#include "Rts.h"
#include "StgRun.h"
+#include "RtsFlags.h"
+#include "Capability.h"
#ifdef DEBUG
-#include "RtsFlags.h"
#include "RtsUtils.h"
#include "Printer.h"
#endif
any architecture (using miniinterpreter)
-------------------------------------------------------------------------- */
-extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg STG_UNUSED)
+StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg STG_UNUSED)
{
- while (f) {
- IF_DEBUG(interpreter,
- fprintf(stderr,"Jumping to ");
- printPtr((P_)f); fflush(stdout);
- fprintf(stderr,"\n");
- );
- f = (StgFunPtr) (f)();
- }
- return (StgThreadReturnCode)R1.i;
+ while (f) {
+ if (RtsFlags[0].DebugFlags.interpreter) {
+ fprintf(stderr,"Jumping to ");
+ printPtr((P_)f); fflush(stdout);
+ fprintf(stderr,"\n");
+ }
+ f = (StgFunPtr) (f)();
+ }
+ return (StgThreadReturnCode)R1.i;
}
-EXTFUN(StgReturn)
+StgFunPtr StgReturn(void)
{
- return 0;
+ return 0;
}
#else /* !USE_MINIINTERPRETER */
"\tbl saveFP # f14\n"
"\tstmw r13,-220(r1)\n"
"\tstwu r1,-%0(r1)\n"
+ "\tmr r27,r4\n" // BaseReg == r27
"\tmtctr r3\n"
"\tmr r12,r3\n"
"\tbctr\n"
"\tstfd 29,-24(5)\n"
"\tstfd 30,-16(5)\n"
"\tstfd 31,-8(5)\n"
+ "\tmr 27,4\n" // BaseReg == r27
"\tmtctr 3\n"
"\tmr 12,3\n"
"\tbctr\n"
--- /dev/null
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Entry code for various built-in closure types.
+ *
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC. It is compiled by GHC directly. For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * --------------------------------------------------------------------------*/
+
+#include "Cmm.h"
+
+/* ----------------------------------------------------------------------------
+ Support for the bytecode interpreter.
+ ------------------------------------------------------------------------- */
+
+/* 9 bits of return code for constructors created by the interpreter. */
+stg_interp_constr_entry
+{
+ /* R1 points at the constructor */
+ jump %ENTRY_CODE(Sp(0));
+}
+
+stg_interp_constr1_entry { jump %RET_VEC(Sp(0),0); }
+stg_interp_constr2_entry { jump %RET_VEC(Sp(0),1); }
+stg_interp_constr3_entry { jump %RET_VEC(Sp(0),2); }
+stg_interp_constr4_entry { jump %RET_VEC(Sp(0),3); }
+stg_interp_constr5_entry { jump %RET_VEC(Sp(0),4); }
+stg_interp_constr6_entry { jump %RET_VEC(Sp(0),5); }
+stg_interp_constr7_entry { jump %RET_VEC(Sp(0),6); }
+stg_interp_constr8_entry { jump %RET_VEC(Sp(0),7); }
+
+/* Some info tables to be used when compiled code returns a value to
+ the interpreter, i.e. the interpreter pushes one of these onto the
+ stack before entering a value. What the code does is to
+ impedance-match the compiled return convention (in R1p/R1n/F1/D1 etc) to
+ the interpreter's convention (returned value is on top of stack),
+ and then cause the scheduler to enter the interpreter.
+
+ On entry, the stack (growing down) looks like this:
+
+ ptr to BCO holding return continuation
+ ptr to one of these info tables.
+
+ The info table code, both direct and vectored, must:
+ * push R1/F1/D1 on the stack, and its tag if necessary
+ * push the BCO (so it's now on the stack twice)
+ * Yield, ie, go to the scheduler.
+
+ Scheduler examines the t.o.s, discovers it is a BCO, and proceeds
+ directly to the bytecode interpreter. That pops the top element
+ (the BCO, containing the return continuation), and interprets it.
+ Net result: return continuation gets interpreted, with the
+ following stack:
+
+ ptr to this BCO
+ ptr to the info table just jumped thru
+ return value
+
+ which is just what we want -- the "standard" return layout for the
+ interpreter. Hurrah!
+
+ Don't ask me how unboxed tuple returns are supposed to work. We
+ haven't got a good story about that yet.
+*/
+
+INFO_TABLE_RET( stg_ctoi_R1p,
+ 0/*size*/, 0/*bitmap*/, /* special layout! */
+ RET_BCO,
+ RET_LBL(stg_ctoi_R1p),
+ RET_LBL(stg_ctoi_R1p),
+ RET_LBL(stg_ctoi_R1p),
+ RET_LBL(stg_ctoi_R1p),
+ RET_LBL(stg_ctoi_R1p),
+ RET_LBL(stg_ctoi_R1p),
+ RET_LBL(stg_ctoi_R1p),
+ RET_LBL(stg_ctoi_R1p))
+{
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_enter_info;
+ jump stg_yield_to_interpreter;
+}
+
+#if MAX_VECTORED_RTN != 8
+#error MAX_VECTORED_RTN has changed: please modify stg_ctoi_R1p too.
+#endif
+
+/*
+ * When the returned value is a pointer, but unlifted, in R1 ...
+ */
+INFO_TABLE_RET( stg_ctoi_R1unpt,
+ 0/*size*/, 0/*bitmap*/, /* special layout! */
+ RET_BCO )
+{
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_gc_unpt_r1_info;
+ jump stg_yield_to_interpreter;
+}
+
+/*
+ * When the returned value is a non-pointer in R1 ...
+ */
+INFO_TABLE_RET( stg_ctoi_R1n,
+ 0/*size*/, 0/*bitmap*/, /* special layout! */
+ RET_BCO )
+{
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_gc_unbx_r1_info;
+ jump stg_yield_to_interpreter;
+}
+
+/*
+ * When the returned value is in F1
+ */
+INFO_TABLE_RET( stg_ctoi_F1,
+ 0/*size*/, 0/*bitmap*/, /* special layout! */
+ RET_BCO )
+{
+ Sp_adj(-2);
+ F_[Sp + WDS(1)] = F1;
+ Sp(0) = stg_gc_f1_info;
+ jump stg_yield_to_interpreter;
+}
+
+/*
+ * When the returned value is in D1
+ */
+INFO_TABLE_RET( stg_ctoi_D1,
+ 0/*size*/, 0/*bitmap*/, /* special layout! */
+ RET_BCO )
+{
+ Sp_adj(-1) - SIZEOF_DOUBLE;
+ D_[Sp + WDS(1)] = D1;
+ Sp(0) = stg_gc_d1_info;
+ jump stg_yield_to_interpreter;
+}
+
+/*
+ * When the returned value is in L1
+ */
+INFO_TABLE_RET( stg_ctoi_L1,
+ 0/*size*/, 0/*bitmap*/, /* special layout! */
+ RET_BCO )
+{
+ Sp_adj(-1) - 8;
+ L_[Sp + WDS(1)] = L1;
+ Sp(0) = stg_gc_l1_info;
+ jump stg_yield_to_interpreter;
+}
+
+/*
+ * When the returned value is a void
+ */
+INFO_TABLE_RET( stg_ctoi_V,
+ 0/*size*/, 0/*bitmap*/, /* special layout! */
+ RET_BCO )
+{
+ Sp_adj(-1);
+ Sp(0) = stg_gc_void_info;
+ jump stg_yield_to_interpreter;
+}
+
+/*
+ * Dummy info table pushed on the top of the stack when the interpreter
+ * should apply the BCO on the stack to its arguments, also on the
+ * stack.
+ */
+INFO_TABLE_RET( stg_apply_interp,
+ 0/*size*/, 0/*bitmap*/, /* special layout! */
+ RET_BCO )
+{
+ /* Just in case we end up in here... (we shouldn't) */
+ jump stg_yield_to_interpreter;
+}
+
+/* ----------------------------------------------------------------------------
+ Entry code for a BCO
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE_FUN( stg_BCO, 4, 0, BCO, "BCO", "BCO", ARG_BCO )
+{
+ /* entering a BCO means "apply it", same as a function */
+ Sp_adj(-2);
+ Sp(1) = R1;
+ Sp(0) = stg_apply_interp_info;
+ jump stg_yield_to_interpreter;
+}
+
+/* ----------------------------------------------------------------------------
+ Info tables for indirections.
+
+ SPECIALISED INDIRECTIONS: we have a specialised indirection for each
+ kind of return (direct, vectored 0-7), so that we can avoid entering
+ the object when we know what kind of return it will do. The update
+ code (Updates.hc) updates objects with the appropriate kind of
+ indirection. We only do this for young-gen indirections.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_IND,1,0,IND,"IND","IND")
+{
+ TICK_ENT_DYN_IND(); /* tick */
+ R1 = StgInd_indirectee(R1);
+ TICK_ENT_VIA_NODE();
+ jump %GET_ENTRY(R1);
+}
+
+#define IND_SPEC(label,ret) \
+INFO_TABLE(label,1,0,IND,"IND","IND") \
+{ \
+ TICK_ENT_DYN_IND(); /* tick */ \
+ R1 = StgInd_indirectee(R1); \
+ TICK_ENT_VIA_NODE(); \
+ jump ret; \
+}
+
+IND_SPEC(stg_IND_direct, %ENTRY_CODE(Sp(0)))
+IND_SPEC(stg_IND_0, %RET_VEC(Sp(0),0))
+IND_SPEC(stg_IND_1, %RET_VEC(Sp(0),1))
+IND_SPEC(stg_IND_2, %RET_VEC(Sp(0),2))
+IND_SPEC(stg_IND_3, %RET_VEC(Sp(0),3))
+IND_SPEC(stg_IND_4, %RET_VEC(Sp(0),4))
+IND_SPEC(stg_IND_5, %RET_VEC(Sp(0),5))
+IND_SPEC(stg_IND_6, %RET_VEC(Sp(0),6))
+IND_SPEC(stg_IND_7, %RET_VEC(Sp(0),7))
+
+INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC")
+{
+ TICK_ENT_STATIC_IND(); /* tick */
+ R1 = StgInd_indirectee(R1);
+ TICK_ENT_VIA_NODE();
+ jump %GET_ENTRY(R1);
+}
+
+INFO_TABLE(stg_IND_PERM,1,1,IND_PERM,"IND_PERM","IND_PERM")
+{
+ /* Don't add INDs to granularity cost */
+
+ /* Don't: TICK_ENT_STATIC_IND(Node); for ticky-ticky; this ind is
+ here only to help profiling */
+
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+ /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than
+ being extra */
+ TICK_ENT_PERM_IND();
+#endif
+
+ LDV_ENTER(R1);
+
+ /* Enter PAP cost centre */
+ ENTER_CCS_PAP_CL(R1);
+
+ /* For ticky-ticky, change the perm_ind to a normal ind on first
+ * entry, so the number of ent_perm_inds is the number of *thunks*
+ * entered again, not the number of subsequent entries.
+ *
+ * Since this screws up cost centres, we die if profiling and
+ * ticky_ticky are on at the same time. KSW 1999-01.
+ */
+#ifdef TICKY_TICKY
+# ifdef PROFILING
+# error Profiling and ticky-ticky do not mix at present!
+# endif /* PROFILING */
+ StgHeader_info(R1) = stg_IND_info;
+#endif /* TICKY_TICKY */
+
+ R1 = StgInd_indirectee(R1);
+
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+ TICK_ENT_VIA_NODE();
+#endif
+
+ jump %GET_ENTRY(R1);
+}
+
+
+INFO_TABLE(stg_IND_OLDGEN,1,1,IND_OLDGEN,"IND_OLDGEN","IND_OLDGEN")
+{
+ TICK_ENT_STATIC_IND(); /* tick */
+ R1 = StgInd_indirectee(R1);
+ TICK_ENT_VIA_NODE();
+ jump %GET_ENTRY(R1);
+}
+
+INFO_TABLE(stg_IND_OLDGEN_PERM,1,1,IND_OLDGEN_PERM,"IND_OLDGEN_PERM","IND_OLDGEN_PERM")
+{
+ /* Don't: TICK_ENT_STATIC_IND(Node); for ticky-ticky;
+ this ind is here only to help profiling */
+
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+ /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND,
+ rather than being extra */
+ TICK_ENT_PERM_IND(R1); /* tick */
+#endif
+
+ LDV_ENTER(R1);
+
+ /* Enter PAP cost centre -- lexical scoping only */
+ ENTER_CCS_PAP_CL(R1);
+
+ /* see comment in IND_PERM */
+#ifdef TICKY_TICKY
+# ifdef PROFILING
+# error Profiling and ticky-ticky do not mix at present!
+# endif /* PROFILING */
+ StgHeader_info(R1) = stg_IND_OLDGEN_info;
+#endif /* TICKY_TICKY */
+
+ R1 = StgInd_indirectee(R1);
+
+ TICK_ENT_VIA_NODE();
+ jump %GET_ENTRY(R1);
+}
+
+/* ----------------------------------------------------------------------------
+ Black holes.
+
+ Entering a black hole normally causes a cyclic data dependency, but
+ in the concurrent world, black holes are synchronization points,
+ and they are turned into blocking queues when there are threads
+ waiting for the evaluation of the closure to finish.
+ ------------------------------------------------------------------------- */
+
+/* Note: a BLACKHOLE and BLACKHOLE_BQ must be big enough to be
+ * overwritten with an indirection/evacuee/catch. Thus we claim it
+ * has 1 non-pointer word of payload (in addition to the pointer word
+ * for the blocking queue in a BQ), which should be big enough for an
+ * old-generation indirection.
+ */
+INFO_TABLE(stg_BLACKHOLE,0,2,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+{
+#if defined(GRAN)
+ /* Before overwriting TSO_LINK */
+ STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1 /*Node*/);
+#endif
+
+ TICK_ENT_BH();
+
+ /* Actually this is not necessary because R1 is about to be destroyed. */
+ LDV_ENTER(R1);
+
+ /* Put ourselves on the blocking queue for this black hole */
+ StgTSO_link(CurrentTSO) = stg_END_TSO_QUEUE_closure;
+ StgBlockingQueue_blocking_queue(R1) = CurrentTSO;
+
+ /* jot down why and on what closure we are blocked */
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16;
+ StgTSO_block_info(CurrentTSO) = R1;
+
+ /* Change the BLACKHOLE into a BLACKHOLE_BQ */
+#ifdef PROFILING
+ /* The size remains the same, so we call LDV_recordDead() -
+ no need to fill slop. */
+ foreign "C" LDV_recordDead(R1 "ptr", BYTES_TO_WDS(SIZEOF_StgBlockingQueue));
+#endif
+ /*
+ * Todo: maybe use SET_HDR() and remove LDV_RECORD_CREATE()?
+ */
+ StgHeader_info(R1) = stg_BLACKHOLE_BQ_info;
+#ifdef PROFILING
+ foreign "C" LDV_RECORD_CREATE(R1);
+#endif
+
+ /* closure is mutable since something has just been added to its BQ */
+ foreign "C" recordMutable(R1 "ptr");
+
+ /* PAR: dumping of event now done in blockThread -- HWL */
+
+ /* stg_gen_block is too heavyweight, use a specialised one */
+ jump stg_block_1;
+}
+
+INFO_TABLE(stg_BLACKHOLE_BQ,1,1,BLACKHOLE_BQ,"BLACKHOLE_BQ","BLACKHOLE_BQ")
+{
+#if defined(GRAN)
+ /* Before overwriting TSO_LINK */
+ STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1 /*Node*/);
+#endif
+
+ TICK_ENT_BH();
+ LDV_ENTER(R1);
+
+ /* Put ourselves on the blocking queue for this black hole */
+ StgTSO_link(CurrentTSO) = StgBlockingQueue_blocking_queue(R1);
+ StgBlockingQueue_blocking_queue(R1) = CurrentTSO;
+
+ /* jot down why and on what closure we are blocked */
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16;
+ StgTSO_block_info(CurrentTSO) = R1;
+
+ /* PAR: dumping of event now done in blockThread -- HWL */
+
+ /* stg_gen_block is too heavyweight, use a specialised one */
+ jump stg_block_1;
+}
+
+/*
+ Revertible black holes are needed in the parallel world, to handle
+ negative acknowledgements of messages containing updatable closures.
+ The idea is that when the original message is transmitted, the closure
+ is turned into a revertible black hole...an object which acts like a
+ black hole when local threads try to enter it, but which can be reverted
+ back to the original closure if necessary.
+
+ It's actually a lot like a blocking queue (BQ) entry, because revertible
+ black holes are initially set up with an empty blocking queue.
+*/
+
+#if defined(PAR) || defined(GRAN)
+
+INFO_TABLE(stg_RBH,1,1,RBH,"RBH","RBH")
+{
+# if defined(GRAN)
+ /* mainly statistics gathering for GranSim simulation */
+ STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1 /*Node*/);
+# endif
+
+ /* exactly the same as a BLACKHOLE_BQ_entry -- HWL */
+ /* Put ourselves on the blocking queue for this black hole */
+ TSO_link(CurrentTSO) = StgBlockingQueue_blocking_queue(R1);
+ StgBlockingQueue_blocking_queue(R1) = CurrentTSO;
+ /* jot down why and on what closure we are blocked */
+ TSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16;
+ TSO_block_info(CurrentTSO) = R1;
+
+ /* PAR: dumping of event now done in blockThread -- HWL */
+
+ /* stg_gen_block is too heavyweight, use a specialised one */
+ jump stg_block_1;
+}
+
+INFO_TABLE(stg_RBH_Save_0,0,2,CONSTR,"RBH_Save_0","RBH_Save_0")
+{ foreign "C" barf("RBH_Save_0 object entered!"); }
+
+INFO_TABLE(stg_RBH_Save_1,1,1,CONSTR,"RBH_Save_1","RBH_Save_1");
+{ foreign "C" barf("RBH_Save_1 object entered!"); }
+
+INFO_TABLE(stg_RBH_Save_2,2,0,CONSTR,"RBH_Save_2","RBH_Save_2");
+{ foreign "C" barf("RBH_Save_2 object entered!"); }
+
+#endif /* defined(PAR) || defined(GRAN) */
+
+/* identical to BLACKHOLEs except for the infotag */
+INFO_TABLE(stg_CAF_BLACKHOLE,0,2,CAF_BLACKHOLE,"CAF_BLACKHOLE","CAF_BLACKHOLE")
+{
+#if defined(GRAN)
+ /* mainly statistics gathering for GranSim simulation */
+ STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1 /*Node*/);
+#endif
+
+ TICK_ENT_BH();
+ LDV_ENTER(R1);
+
+ /* Put ourselves on the blocking queue for this black hole */
+ StgTSO_link(CurrentTSO) = stg_END_TSO_QUEUE_closure;
+ StgBlockingQueue_blocking_queue(R1) = CurrentTSO;
+
+ /* jot down why and on what closure we are blocked */
+ StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16;
+ StgTSO_block_info(CurrentTSO) = R1;
+
+ /* Change the CAF_BLACKHOLE into a BLACKHOLE_BQ_STATIC */
+ StgHeader_info(R1) = stg_BLACKHOLE_BQ_info;
+
+ /* closure is mutable since something has just been added to its BQ */
+ foreign "C" recordMutable(R1 "ptr");
+
+ /* PAR: dumping of event now done in blockThread -- HWL */
+
+ /* stg_gen_block is too heavyweight, use a specialised one */
+ jump stg_block_1;
+}
+
+#ifdef EAGER_BLACKHOLING
+INFO_TABLE(stg_SE_BLACKHOLE_info, stg_SE_BLACKHOLE_entry,0,2,SE_BLACKHOLE,,IF_,"SE_BLACKHOLE","SE_BLACKHOLE");
+IF_(stg_SE_BLACKHOLE_entry)
+{
+ STGCALL3(fprintf,stderr,"SE_BLACKHOLE at %p entered!\n",R1);
+ STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
+}
+
+INFO_TABLE(stg_SE_CAF_BLACKHOLE_info, SE_CAF_BLACKHOLE_entry,0,2,SE_CAF_BLACKHOLE,,IF_,"CAF_BLACKHOLE","CAF_BLACKHOLE");
+IF_(stg_SE_CAF_BLACKHOLE_entry)
+{
+ STGCALL3(fprintf,stderr,"SE_CAF_BLACKHOLE at %p entered!\n",R1);
+ STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
+}
+#endif
+
+/* ----------------------------------------------------------------------------
+ Some static info tables for things that don't get entered, and
+ therefore don't need entry code (i.e. boxed but unpointed objects)
+ NON_ENTERABLE_ENTRY_CODE now defined at the beginning of the file
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_TSO, 0,0,TSO, "TSO", "TSO")
+{ foreign "C" barf("TSO object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ Evacuees are left behind by the garbage collector. Any attempt to enter
+ one is a real bug.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_EVACUATED,1,0,EVACUATED,"EVACUATED","EVACUATED")
+{ foreign "C" barf("EVACUATED object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ Weak pointers
+
+ Live weak pointers have a special closure type. Dead ones are just
+ nullary constructors (although they live on the heap - we overwrite
+ live weak pointers with dead ones).
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_WEAK,0,4,WEAK,"WEAK","WEAK")
+{ foreign "C" barf("WEAK object entered!"); }
+
+/*
+ * It's important when turning an existing WEAK into a DEAD_WEAK
+ * (which is what finalizeWeak# does) that we don't lose the link
+ * field and break the linked list of weak pointers. Hence, we give
+ * DEAD_WEAK 4 non-pointer fields, the same as WEAK.
+ */
+INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,4,0,CONSTR,"DEAD_WEAK","DEAD_WEAK")
+{ foreign "C" barf("DEAD_WEAK object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ NO_FINALIZER
+
+ This is a static nullary constructor (like []) that we use to mark an empty
+ finalizer in a weak pointer object.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_NO_FINALIZER,0,0,0,CONSTR_NOCAF_STATIC,"NO_FINALIZER","NO_FINALIZER")
+{ foreign "C" barf("NO_FINALIZER object entered!"); }
+
+CLOSURE(stg_NO_FINALIZER_closure,stg_NO_FINALIZER);
+
+/* ----------------------------------------------------------------------------
+ Foreign Objects are unlifted and therefore never entered.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_FOREIGN,0,1,FOREIGN,"FOREIGN","FOREIGN")
+{ foreign "C" barf("FOREIGN object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ Stable Names are unlifted too.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_STABLE_NAME,0,1,STABLE_NAME,"STABLE_NAME","STABLE_NAME")
+{ foreign "C" barf("STABLE_NAME object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ MVars
+
+ There are two kinds of these: full and empty. We need an info table
+ and entry code for each type.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_FULL_MVAR,4,0,MVAR,"MVAR","MVAR")
+{ foreign "C" barf("FULL_MVAR object entered!"); }
+
+INFO_TABLE(stg_EMPTY_MVAR,4,0,MVAR,"MVAR","MVAR")
+{ foreign "C" barf("EMPTY_MVAR object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ END_TSO_QUEUE
+
+ This is a static nullary constructor (like []) that we use to mark the
+ end of a linked TSO queue.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_END_TSO_QUEUE,0,0,0,CONSTR_NOCAF_STATIC,"END_TSO_QUEUE","END_TSO_QUEUE")
+{ foreign "C" barf("END_TSO_QUEUE object entered!"); }
+
+CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE);
+
+/* ----------------------------------------------------------------------------
+ Mutable lists
+
+ Mutable lists (used by the garbage collector) consist of a chain of
+ StgMutClosures connected through their mut_link fields, ending in
+ an END_MUT_LIST closure.
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_END_MUT_LIST,0,0,0,CONSTR_NOCAF_STATIC,"END_MUT_LIST","END_MUT_LIST")
+{ foreign "C" barf("END_MUT_LIST object entered!"); }
+
+CLOSURE(stg_END_MUT_LIST_closure,stg_END_MUT_LIST);
+
+INFO_TABLE(stg_MUT_CONS, 1, 1, MUT_CONS, "MUT_CONS", "MUT_CONS")
+{ foreign "C" barf("MUT_CONS object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ Exception lists
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_END_EXCEPTION_LIST,0,0,0,CONSTR_NOCAF_STATIC,"END_EXCEPTION_LIST","END_EXCEPTION_LIST")
+{ foreign "C" barf("END_EXCEPTION_LIST object entered!"); }
+
+CLOSURE(stg_END_EXCEPTION_LIST_closure,stg_END_EXCEPTION_LIST);
+
+INFO_TABLE(stg_EXCEPTION_CONS,1,1,CONSTR,"EXCEPTION_CONS","EXCEPTION_CONS")
+{ foreign "C" barf("EXCEPTION_CONS object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ Arrays
+
+ These come in two basic flavours: arrays of data (StgArrWords) and arrays of
+ pointers (StgArrPtrs). They all have a similar layout:
+
+ ___________________________
+ | Info | No. of | data....
+ | Ptr | Words |
+ ---------------------------
+
+ These are *unpointed* objects: i.e. they cannot be entered.
+
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_ARR_WORDS, 0, 0, ARR_WORDS, "ARR_WORDS", "ARR_WORDS")
+{ foreign "C" barf("ARR_WORDS object entered!"); }
+
+INFO_TABLE(stg_MUT_ARR_PTRS, 0, 0, MUT_ARR_PTRS, "MUT_ARR_PTRS", "MUT_ARR_PTRS")
+{ foreign "C" barf("MUT_ARR_PTRS object entered!"); }
+
+INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN, 0, 0, MUT_ARR_PTRS_FROZEN, "MUT_ARR_PTRS_FROZEN", "MUT_ARR_PTRS_FROZEN")
+{ foreign "C" barf("MUT_ARR_PTRS_FROZEN object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ Mutable Variables
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_MUT_VAR, 1, 1, MUT_VAR, "MUT_VAR", "MUT_VAR")
+{ foreign "C" barf("MUT_VAR object entered!"); }
+
+/* ----------------------------------------------------------------------------
+ Dummy return closure
+
+ Entering this closure will just return to the address on the top of the
+ stack. Useful for getting a thread in a canonical form where we can
+ just enter the top stack word to start the thread. (see deleteThread)
+ * ------------------------------------------------------------------------- */
+
+INFO_TABLE( stg_dummy_ret, 0, 0, CONSTR_NOCAF_STATIC, "DUMMY_RET", "DUMMY_RET")
+{
+ jump %ENTRY_CODE(Sp(0));
+}
+CLOSURE(stg_dummy_ret_closure,stg_dummy_ret);
+
+/* ----------------------------------------------------------------------------
+ CHARLIKE and INTLIKE closures.
+
+ These are static representations of Chars and small Ints, so that
+ we can remove dynamic Chars and Ints during garbage collection and
+ replace them with references to the static objects.
+ ------------------------------------------------------------------------- */
+
+#if defined(ENABLE_WIN32_DLL_SUPPORT)
+/*
+ * When sticking the RTS in a DLL, we delay populating the
+ * Charlike and Intlike tables until load-time, which is only
+ * when we've got the real addresses to the C# and I# closures.
+ *
+ */
+static INFO_TBL_CONST StgInfoTable czh_static_info;
+static INFO_TBL_CONST StgInfoTable izh_static_info;
+#define Char_hash_static_info czh_static_info
+#define Int_hash_static_info izh_static_info
+#else
+#define Char_hash_static_info GHCziBase_Czh_static
+#define Int_hash_static_info GHCziBase_Izh_static
+#endif
+
+
+#define CHARLIKE_HDR(n) CLOSURE(Char_hash_static_info, n)
+#define INTLIKE_HDR(n) CLOSURE(Int_hash_static_info, n)
+
+/* put these in the *data* section, since the garbage collector relies
+ * on the fact that static closures live in the data section.
+ */
+
+/* end the name with _closure, to convince the mangler this is a closure */
+
+section "data" {
+ stg_CHARLIKE_closure:
+ CHARLIKE_HDR(0)
+ CHARLIKE_HDR(1)
+ CHARLIKE_HDR(2)
+ CHARLIKE_HDR(3)
+ CHARLIKE_HDR(4)
+ CHARLIKE_HDR(5)
+ CHARLIKE_HDR(6)
+ CHARLIKE_HDR(7)
+ CHARLIKE_HDR(8)
+ CHARLIKE_HDR(9)
+ CHARLIKE_HDR(10)
+ CHARLIKE_HDR(11)
+ CHARLIKE_HDR(12)
+ CHARLIKE_HDR(13)
+ CHARLIKE_HDR(14)
+ CHARLIKE_HDR(15)
+ CHARLIKE_HDR(16)
+ CHARLIKE_HDR(17)
+ CHARLIKE_HDR(18)
+ CHARLIKE_HDR(19)
+ CHARLIKE_HDR(20)
+ CHARLIKE_HDR(21)
+ CHARLIKE_HDR(22)
+ CHARLIKE_HDR(23)
+ CHARLIKE_HDR(24)
+ CHARLIKE_HDR(25)
+ CHARLIKE_HDR(26)
+ CHARLIKE_HDR(27)
+ CHARLIKE_HDR(28)
+ CHARLIKE_HDR(29)
+ CHARLIKE_HDR(30)
+ CHARLIKE_HDR(31)
+ CHARLIKE_HDR(32)
+ CHARLIKE_HDR(33)
+ CHARLIKE_HDR(34)
+ CHARLIKE_HDR(35)
+ CHARLIKE_HDR(36)
+ CHARLIKE_HDR(37)
+ CHARLIKE_HDR(38)
+ CHARLIKE_HDR(39)
+ CHARLIKE_HDR(40)
+ CHARLIKE_HDR(41)
+ CHARLIKE_HDR(42)
+ CHARLIKE_HDR(43)
+ CHARLIKE_HDR(44)
+ CHARLIKE_HDR(45)
+ CHARLIKE_HDR(46)
+ CHARLIKE_HDR(47)
+ CHARLIKE_HDR(48)
+ CHARLIKE_HDR(49)
+ CHARLIKE_HDR(50)
+ CHARLIKE_HDR(51)
+ CHARLIKE_HDR(52)
+ CHARLIKE_HDR(53)
+ CHARLIKE_HDR(54)
+ CHARLIKE_HDR(55)
+ CHARLIKE_HDR(56)
+ CHARLIKE_HDR(57)
+ CHARLIKE_HDR(58)
+ CHARLIKE_HDR(59)
+ CHARLIKE_HDR(60)
+ CHARLIKE_HDR(61)
+ CHARLIKE_HDR(62)
+ CHARLIKE_HDR(63)
+ CHARLIKE_HDR(64)
+ CHARLIKE_HDR(65)
+ CHARLIKE_HDR(66)
+ CHARLIKE_HDR(67)
+ CHARLIKE_HDR(68)
+ CHARLIKE_HDR(69)
+ CHARLIKE_HDR(70)
+ CHARLIKE_HDR(71)
+ CHARLIKE_HDR(72)
+ CHARLIKE_HDR(73)
+ CHARLIKE_HDR(74)
+ CHARLIKE_HDR(75)
+ CHARLIKE_HDR(76)
+ CHARLIKE_HDR(77)
+ CHARLIKE_HDR(78)
+ CHARLIKE_HDR(79)
+ CHARLIKE_HDR(80)
+ CHARLIKE_HDR(81)
+ CHARLIKE_HDR(82)
+ CHARLIKE_HDR(83)
+ CHARLIKE_HDR(84)
+ CHARLIKE_HDR(85)
+ CHARLIKE_HDR(86)
+ CHARLIKE_HDR(87)
+ CHARLIKE_HDR(88)
+ CHARLIKE_HDR(89)
+ CHARLIKE_HDR(90)
+ CHARLIKE_HDR(91)
+ CHARLIKE_HDR(92)
+ CHARLIKE_HDR(93)
+ CHARLIKE_HDR(94)
+ CHARLIKE_HDR(95)
+ CHARLIKE_HDR(96)
+ CHARLIKE_HDR(97)
+ CHARLIKE_HDR(98)
+ CHARLIKE_HDR(99)
+ CHARLIKE_HDR(100)
+ CHARLIKE_HDR(101)
+ CHARLIKE_HDR(102)
+ CHARLIKE_HDR(103)
+ CHARLIKE_HDR(104)
+ CHARLIKE_HDR(105)
+ CHARLIKE_HDR(106)
+ CHARLIKE_HDR(107)
+ CHARLIKE_HDR(108)
+ CHARLIKE_HDR(109)
+ CHARLIKE_HDR(110)
+ CHARLIKE_HDR(111)
+ CHARLIKE_HDR(112)
+ CHARLIKE_HDR(113)
+ CHARLIKE_HDR(114)
+ CHARLIKE_HDR(115)
+ CHARLIKE_HDR(116)
+ CHARLIKE_HDR(117)
+ CHARLIKE_HDR(118)
+ CHARLIKE_HDR(119)
+ CHARLIKE_HDR(120)
+ CHARLIKE_HDR(121)
+ CHARLIKE_HDR(122)
+ CHARLIKE_HDR(123)
+ CHARLIKE_HDR(124)
+ CHARLIKE_HDR(125)
+ CHARLIKE_HDR(126)
+ CHARLIKE_HDR(127)
+ CHARLIKE_HDR(128)
+ CHARLIKE_HDR(129)
+ CHARLIKE_HDR(130)
+ CHARLIKE_HDR(131)
+ CHARLIKE_HDR(132)
+ CHARLIKE_HDR(133)
+ CHARLIKE_HDR(134)
+ CHARLIKE_HDR(135)
+ CHARLIKE_HDR(136)
+ CHARLIKE_HDR(137)
+ CHARLIKE_HDR(138)
+ CHARLIKE_HDR(139)
+ CHARLIKE_HDR(140)
+ CHARLIKE_HDR(141)
+ CHARLIKE_HDR(142)
+ CHARLIKE_HDR(143)
+ CHARLIKE_HDR(144)
+ CHARLIKE_HDR(145)
+ CHARLIKE_HDR(146)
+ CHARLIKE_HDR(147)
+ CHARLIKE_HDR(148)
+ CHARLIKE_HDR(149)
+ CHARLIKE_HDR(150)
+ CHARLIKE_HDR(151)
+ CHARLIKE_HDR(152)
+ CHARLIKE_HDR(153)
+ CHARLIKE_HDR(154)
+ CHARLIKE_HDR(155)
+ CHARLIKE_HDR(156)
+ CHARLIKE_HDR(157)
+ CHARLIKE_HDR(158)
+ CHARLIKE_HDR(159)
+ CHARLIKE_HDR(160)
+ CHARLIKE_HDR(161)
+ CHARLIKE_HDR(162)
+ CHARLIKE_HDR(163)
+ CHARLIKE_HDR(164)
+ CHARLIKE_HDR(165)
+ CHARLIKE_HDR(166)
+ CHARLIKE_HDR(167)
+ CHARLIKE_HDR(168)
+ CHARLIKE_HDR(169)
+ CHARLIKE_HDR(170)
+ CHARLIKE_HDR(171)
+ CHARLIKE_HDR(172)
+ CHARLIKE_HDR(173)
+ CHARLIKE_HDR(174)
+ CHARLIKE_HDR(175)
+ CHARLIKE_HDR(176)
+ CHARLIKE_HDR(177)
+ CHARLIKE_HDR(178)
+ CHARLIKE_HDR(179)
+ CHARLIKE_HDR(180)
+ CHARLIKE_HDR(181)
+ CHARLIKE_HDR(182)
+ CHARLIKE_HDR(183)
+ CHARLIKE_HDR(184)
+ CHARLIKE_HDR(185)
+ CHARLIKE_HDR(186)
+ CHARLIKE_HDR(187)
+ CHARLIKE_HDR(188)
+ CHARLIKE_HDR(189)
+ CHARLIKE_HDR(190)
+ CHARLIKE_HDR(191)
+ CHARLIKE_HDR(192)
+ CHARLIKE_HDR(193)
+ CHARLIKE_HDR(194)
+ CHARLIKE_HDR(195)
+ CHARLIKE_HDR(196)
+ CHARLIKE_HDR(197)
+ CHARLIKE_HDR(198)
+ CHARLIKE_HDR(199)
+ CHARLIKE_HDR(200)
+ CHARLIKE_HDR(201)
+ CHARLIKE_HDR(202)
+ CHARLIKE_HDR(203)
+ CHARLIKE_HDR(204)
+ CHARLIKE_HDR(205)
+ CHARLIKE_HDR(206)
+ CHARLIKE_HDR(207)
+ CHARLIKE_HDR(208)
+ CHARLIKE_HDR(209)
+ CHARLIKE_HDR(210)
+ CHARLIKE_HDR(211)
+ CHARLIKE_HDR(212)
+ CHARLIKE_HDR(213)
+ CHARLIKE_HDR(214)
+ CHARLIKE_HDR(215)
+ CHARLIKE_HDR(216)
+ CHARLIKE_HDR(217)
+ CHARLIKE_HDR(218)
+ CHARLIKE_HDR(219)
+ CHARLIKE_HDR(220)
+ CHARLIKE_HDR(221)
+ CHARLIKE_HDR(222)
+ CHARLIKE_HDR(223)
+ CHARLIKE_HDR(224)
+ CHARLIKE_HDR(225)
+ CHARLIKE_HDR(226)
+ CHARLIKE_HDR(227)
+ CHARLIKE_HDR(228)
+ CHARLIKE_HDR(229)
+ CHARLIKE_HDR(230)
+ CHARLIKE_HDR(231)
+ CHARLIKE_HDR(232)
+ CHARLIKE_HDR(233)
+ CHARLIKE_HDR(234)
+ CHARLIKE_HDR(235)
+ CHARLIKE_HDR(236)
+ CHARLIKE_HDR(237)
+ CHARLIKE_HDR(238)
+ CHARLIKE_HDR(239)
+ CHARLIKE_HDR(240)
+ CHARLIKE_HDR(241)
+ CHARLIKE_HDR(242)
+ CHARLIKE_HDR(243)
+ CHARLIKE_HDR(244)
+ CHARLIKE_HDR(245)
+ CHARLIKE_HDR(246)
+ CHARLIKE_HDR(247)
+ CHARLIKE_HDR(248)
+ CHARLIKE_HDR(249)
+ CHARLIKE_HDR(250)
+ CHARLIKE_HDR(251)
+ CHARLIKE_HDR(252)
+ CHARLIKE_HDR(253)
+ CHARLIKE_HDR(254)
+ CHARLIKE_HDR(255)
+}
+
+section "data" {
+ stg_INTLIKE_closure:
+ INTLIKE_HDR(-16) /* MIN_INTLIKE == -16 */
+ INTLIKE_HDR(-15)
+ INTLIKE_HDR(-14)
+ INTLIKE_HDR(-13)
+ INTLIKE_HDR(-12)
+ INTLIKE_HDR(-11)
+ INTLIKE_HDR(-10)
+ INTLIKE_HDR(-9)
+ INTLIKE_HDR(-8)
+ INTLIKE_HDR(-7)
+ INTLIKE_HDR(-6)
+ INTLIKE_HDR(-5)
+ INTLIKE_HDR(-4)
+ INTLIKE_HDR(-3)
+ INTLIKE_HDR(-2)
+ INTLIKE_HDR(-1)
+ INTLIKE_HDR(0)
+ INTLIKE_HDR(1)
+ INTLIKE_HDR(2)
+ INTLIKE_HDR(3)
+ INTLIKE_HDR(4)
+ INTLIKE_HDR(5)
+ INTLIKE_HDR(6)
+ INTLIKE_HDR(7)
+ INTLIKE_HDR(8)
+ INTLIKE_HDR(9)
+ INTLIKE_HDR(10)
+ INTLIKE_HDR(11)
+ INTLIKE_HDR(12)
+ INTLIKE_HDR(13)
+ INTLIKE_HDR(14)
+ INTLIKE_HDR(15)
+ INTLIKE_HDR(16) /* MAX_INTLIKE == 16 */
+}
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.85 2003/05/14 09:14:00 simonmar Exp $
- *
- * (c) The GHC Team, 1998-2002
- *
- * Entry code for various built-in closure types.
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Stg.h"
-#include "Rts.h"
-#include "RtsUtils.h"
-#include "RtsFlags.h"
-#include "StgMiscClosures.h"
-#include "Storage.h"
-#include "StoragePriv.h"
-#include "Profiling.h"
-#include "Prelude.h"
-#include "Schedule.h"
-#include "SMP.h"
-#if defined(GRAN) || defined(PAR)
-# include "GranSimRts.h" /* for DumpRawGranEvent */
-# include "StgRun.h" /* for StgReturn and register saving */
-#endif
-
-#ifdef HAVE_STDLIB_H
-#include <stdlib.h>
-#endif
-
-/* ToDo: make the printing of panics more win32-friendly, i.e.,
- * pop up some lovely message boxes (as well).
- */
-#define DUMP_ERRMSG(msg) STGCALL2(fprintf,stderr,msg)
-
-/*
- Template for the entry code of non-enterable closures.
-*/
-
-#define NON_ENTERABLE_ENTRY_CODE(type) \
-IF_(stg_##type##_entry) \
-{ \
- FB_ \
- STGCALL1(barf, #type " object entered!"); \
- FE_ \
-}
-
-
-/* -----------------------------------------------------------------------------
- Support for the bytecode interpreter.
- -------------------------------------------------------------------------- */
-
-/* 9 bits of return code for constructors created by the interpreter. */
-FN_(stg_interp_constr_entry)
-{
- /* R1 points at the constructor */
- FB_
- /* STGCALL2(fprintf,stderr,"stg_interp_constr_entry (direct return)!\n"); */
- /* Pointless, since SET_TAG doesn't do anything */
- SET_TAG( GET_TAG(GET_INFO(R1.cl)));
- JMP_(ENTRY_CODE((P_)(*Sp)));
- FE_
-}
-
-FN_(stg_interp_constr1_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),0)); FE_ }
-FN_(stg_interp_constr2_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),1)); FE_ }
-FN_(stg_interp_constr3_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),2)); FE_ }
-FN_(stg_interp_constr4_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),3)); FE_ }
-FN_(stg_interp_constr5_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),4)); FE_ }
-FN_(stg_interp_constr6_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),5)); FE_ }
-FN_(stg_interp_constr7_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),6)); FE_ }
-FN_(stg_interp_constr8_entry) { FB_ JMP_(RET_VEC((P_)(*Sp),7)); FE_ }
-
-/* Some info tables to be used when compiled code returns a value to
- the interpreter, i.e. the interpreter pushes one of these onto the
- stack before entering a value. What the code does is to
- impedance-match the compiled return convention (in R1p/R1n/F1/D1 etc) to
- the interpreter's convention (returned value is on top of stack),
- and then cause the scheduler to enter the interpreter.
-
- On entry, the stack (growing down) looks like this:
-
- ptr to BCO holding return continuation
- ptr to one of these info tables.
-
- The info table code, both direct and vectored, must:
- * push R1/F1/D1 on the stack, and its tag if necessary
- * push the BCO (so it's now on the stack twice)
- * Yield, ie, go to the scheduler.
-
- Scheduler examines the t.o.s, discovers it is a BCO, and proceeds
- directly to the bytecode interpreter. That pops the top element
- (the BCO, containing the return continuation), and interprets it.
- Net result: return continuation gets interpreted, with the
- following stack:
-
- ptr to this BCO
- ptr to the info table just jumped thru
- return value
-
- which is just what we want -- the "standard" return layout for the
- interpreter. Hurrah!
-
- Don't ask me how unboxed tuple returns are supposed to work. We
- haven't got a good story about that yet.
-*/
-
-// When the returned value is a pointer in R1...
-#define STG_CtoI_RET_R1p_Template(label) \
- IF_(label) \
- { \
- FB_ \
- Sp -= 2; \
- Sp[1] = R1.w; \
- Sp[0] = (W_)&stg_enter_info; \
- JMP_(stg_yield_to_interpreter); \
- FE_ \
- }
-
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_ret);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_0_ret);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_1_ret);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_2_ret);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_3_ret);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_4_ret);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_5_ret);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_6_ret);
-STG_CtoI_RET_R1p_Template(stg_ctoi_ret_R1p_7_ret);
-
-VEC_POLY_INFO_TABLE( stg_ctoi_ret_R1p, 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/,
- RET_BCO,, EF_);
-
-// When the returned value is a pointer, but unlifted, in R1 ...
-INFO_TABLE_RET( stg_ctoi_ret_R1unpt_info, stg_ctoi_ret_R1unpt_entry,
- 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
-IF_(stg_ctoi_ret_R1unpt_entry)
-{
- FB_
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_gc_unpt_r1_info;
- JMP_(stg_yield_to_interpreter);
- FE_
-}
-
-// When the returned value is a non-pointer in R1 ...
-INFO_TABLE_RET( stg_ctoi_ret_R1n_info, stg_ctoi_ret_R1n_entry,
- 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
-IF_(stg_ctoi_ret_R1n_entry)
-{
- FB_
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_gc_unbx_r1_info;
- JMP_(stg_yield_to_interpreter);
- FE_
-}
-
-
-// When the returned value is in F1 ...
-INFO_TABLE_RET( stg_ctoi_ret_F1_info, stg_ctoi_ret_F1_entry,
- 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
-IF_(stg_ctoi_ret_F1_entry)
-{
- FB_
- Sp -= 2;
- ASSIGN_FLT(Sp+1, F1);
- Sp[0] = (W_)&stg_gc_f1_info;
- JMP_(stg_yield_to_interpreter);
- FE_
-}
-
-// When the returned value is in D1 ...
-INFO_TABLE_RET( stg_ctoi_ret_D1_info, stg_ctoi_ret_D1_entry,
- 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
-IF_(stg_ctoi_ret_D1_entry)
-{
- FB_
- Sp -= 1 + sizeofW(StgDouble);
- ASSIGN_DBL(Sp+1, D1);
- Sp[0] = (W_)&stg_gc_d1_info;
- JMP_(stg_yield_to_interpreter);
- FE_
-}
-
-// When the returned value is in L1 ...
-INFO_TABLE_RET( stg_ctoi_ret_L1_info, stg_ctoi_ret_L1_entry,
- 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
-IF_(stg_ctoi_ret_L1_entry)
-{
- FB_
- Sp -= 1 + sizeofW(StgInt64);
- ASSIGN_Word64(Sp+1, L1);
- Sp[0] = (W_)&stg_gc_l1_info;
- JMP_(stg_yield_to_interpreter);
- FE_
-}
-
-// When the returned value a VoidRep ...
-INFO_TABLE_RET( stg_ctoi_ret_V_info, stg_ctoi_ret_V_entry,
- 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
-IF_(stg_ctoi_ret_V_entry)
-{
- FB_
- Sp--;
- Sp[0] = (W_)&stg_gc_void_info;
- JMP_(stg_yield_to_interpreter);
- FE_
-}
-
-// Dummy info table pushed on the top of the stack when the interpreter
-// should apply the BCO on the stack to its arguments, also on the stack.
-INFO_TABLE_RET( stg_apply_interp_info, stg_apply_interp_entry,
- 0/* special layout */,
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/, RET_BCO,, IF_, 0, 0);
-IF_(stg_apply_interp_entry)
-{
- FB_
- // Just in case we end up in here... (we shouldn't)
- JMP_(stg_yield_to_interpreter);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Entry code for a BCO
- -------------------------------------------------------------------------- */
-
-INFO_TABLE_FUN_GEN(stg_BCO_info,stg_BCO_entry,4,0,
- 0,0,0, /* no SRT */
- ARG_BCO, 0/*dummy arity*/, 0/*dummy bitmap*/, NULL/*slow_apply*/,
- BCO,,EF_,"BCO","BCO");
-FN_(stg_BCO_entry) {
- FB_
- // entering a BCO means "apply it", same as a function
- Sp -= 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_apply_interp_info;
- JMP_(stg_yield_to_interpreter);
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Info tables for indirections.
-
- SPECIALISED INDIRECTIONS: we have a specialised indirection for each
- kind of return (direct, vectored 0-7), so that we can avoid entering
- the object when we know what kind of return it will do. The update
- code (Updates.hc) updates objects with the appropriate kind of
- indirection. We only do this for young-gen indirections.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_IND_info,stg_IND_entry,1,0,IND,,IF_,"IND","IND");
-IF_(stg_IND_entry)
-{
- FB_
- TICK_ENT_DYN_IND(Node); /* tick */
- R1.p = (P_) ((StgInd*)R1.p)->indirectee;
- TICK_ENT_VIA_NODE();
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-
-#define IND_SPEC(n,ret) \
-INFO_TABLE(stg_IND_##n##_info,stg_IND_##n##_entry,1,0,IND,,IF_,"IND","IND"); \
-IF_(stg_IND_##n##_entry) \
-{ \
- FB_ \
- TICK_ENT_DYN_IND(Node); /* tick */ \
- R1.p = (P_) ((StgInd*)R1.p)->indirectee; \
- TICK_ENT_VIA_NODE(); \
- JMP_(ret); \
- FE_ \
-}
-
-IND_SPEC(direct, ENTRY_CODE(Sp[0]))
-IND_SPEC(0, RET_VEC(Sp[0],0))
-IND_SPEC(1, RET_VEC(Sp[0],1))
-IND_SPEC(2, RET_VEC(Sp[0],2))
-IND_SPEC(3, RET_VEC(Sp[0],3))
-IND_SPEC(4, RET_VEC(Sp[0],4))
-IND_SPEC(5, RET_VEC(Sp[0],5))
-IND_SPEC(6, RET_VEC(Sp[0],6))
-IND_SPEC(7, RET_VEC(Sp[0],7))
-
-INFO_TABLE(stg_IND_STATIC_info,stg_IND_STATIC_entry,1,0,IND_STATIC,,IF_,"IND_STATIC","IND_STATIC");
-IF_(stg_IND_STATIC_entry)
-{
- FB_
- TICK_ENT_STATIC_IND(Node); /* tick */
- R1.p = (P_) ((StgIndStatic*)R1.p)->indirectee;
- TICK_ENT_VIA_NODE();
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-
-INFO_TABLE(stg_IND_PERM_info,stg_IND_PERM_entry,1,1,IND_PERM,,IF_,"IND_PERM","IND_PERM");
-IF_(stg_IND_PERM_entry)
-{
- FB_
- /* Don't add INDs to granularity cost */
- /* Dont: TICK_ENT_STATIC_IND(Node); for ticky-ticky; this ind is here only to help profiling */
-
-#if defined(TICKY_TICKY) && !defined(PROFILING)
- /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than being extra */
- TICK_ENT_PERM_IND(R1.p); /* tick */
-#endif
-
- LDV_ENTER((StgInd *)R1.p);
-
- /* Enter PAP cost centre -- lexical scoping only */
- ENTER_CCS_PAP_CL(R1.cl);
-
- /* For ticky-ticky, change the perm_ind to a normal ind on first
- * entry, so the number of ent_perm_inds is the number of *thunks*
- * entered again, not the number of subsequent entries.
- *
- * Since this screws up cost centres, we die if profiling and
- * ticky_ticky are on at the same time. KSW 1999-01.
- */
-
-#ifdef TICKY_TICKY
-# ifdef PROFILING
-# error Profiling and ticky-ticky do not mix at present!
-# endif /* PROFILING */
- SET_INFO((StgInd*)R1.p,&stg_IND_info);
-#endif /* TICKY_TICKY */
-
- R1.p = (P_) ((StgInd*)R1.p)->indirectee;
-
- /* Dont: TICK_ENT_VIA_NODE(); for ticky-ticky; as above */
-
-#if defined(TICKY_TICKY) && !defined(PROFILING)
- TICK_ENT_VIA_NODE();
-#endif
-
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-
-INFO_TABLE(stg_IND_OLDGEN_info,stg_IND_OLDGEN_entry,1,1,IND_OLDGEN,,IF_,"IND_OLDGEN","IND_OLDGEN");
-IF_(stg_IND_OLDGEN_entry)
-{
- FB_
- TICK_ENT_STATIC_IND(Node); /* tick */
- R1.p = (P_) ((StgInd*)R1.p)->indirectee;
- TICK_ENT_VIA_NODE();
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-
-INFO_TABLE(stg_IND_OLDGEN_PERM_info,stg_IND_OLDGEN_PERM_entry,1,1,IND_OLDGEN_PERM,,IF_,"IND_OLDGEN_PERM","IND_OLDGEN_PERM");
-IF_(stg_IND_OLDGEN_PERM_entry)
-{
- FB_
- /* Dont: TICK_ENT_STATIC_IND(Node); for ticky-ticky; this ind is here only to help profiling */
-
-#if defined(TICKY_TICKY) && !defined(PROFILING)
- /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than being extra */
- TICK_ENT_PERM_IND(R1.p); /* tick */
-#endif
-
- LDV_ENTER((StgInd *)R1.p);
-
- /* Enter PAP cost centre -- lexical scoping only */
- ENTER_CCS_PAP_CL(R1.cl);
-
- /* see comment in IND_PERM */
-#ifdef TICKY_TICKY
-# ifdef PROFILING
-# error Profiling and ticky-ticky do not mix at present!
-# endif /* PROFILING */
- SET_INFO((StgInd*)R1.p,&stg_IND_OLDGEN_info);
-#endif /* TICKY_TICKY */
-
- R1.p = (P_) ((StgInd*)R1.p)->indirectee;
- TICK_ENT_VIA_NODE();
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-
-/* -----------------------------------------------------------------------------
- Entry code for a black hole.
-
- Entering a black hole normally causes a cyclic data dependency, but
- in the concurrent world, black holes are synchronization points,
- and they are turned into blocking queues when there are threads
- waiting for the evaluation of the closure to finish.
- -------------------------------------------------------------------------- */
-
-/* Note: a BLACKHOLE and BLACKHOLE_BQ must be big enough to be
- * overwritten with an indirection/evacuee/catch. Thus we claim it
- * has 1 non-pointer word of payload (in addition to the pointer word
- * for the blocking queue in a BQ), which should be big enough for an
- * old-generation indirection.
- */
-
-INFO_TABLE(stg_BLACKHOLE_info, stg_BLACKHOLE_entry,0,2,BLACKHOLE,,IF_,"BLACKHOLE","BLACKHOLE");
-IF_(stg_BLACKHOLE_entry)
-{
- FB_
-#if defined(GRAN)
- /* Before overwriting TSO_LINK */
- STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
-#endif
-
-#ifdef SMP
- {
- bdescr *bd = Bdescr(R1.p);
- if (bd->u.back != (bdescr *)BaseReg) {
- if (bd->gen_no >= 1 || bd->step->no >= 1) {
- CMPXCHG(R1.cl->header.info, &stg_BLACKHOLE_info, &stg_WHITEHOLE_info);
- } else {
- EXTFUN_RTS(stg_gc_enter_1_hponly);
- JMP_(stg_gc_enter_1_hponly);
- }
- }
- }
-#endif
- TICK_ENT_BH();
-
- // Actually this is not necessary because R1.p is about to be destroyed.
- LDV_ENTER((StgClosure *)R1.p);
-
- /* Put ourselves on the blocking queue for this black hole */
-#if defined(GRAN) || defined(PAR)
- // in fact, only difference is the type of the end-of-queue marker!
- CurrentTSO->link = END_BQ_QUEUE;
- ((StgBlockingQueue *)R1.p)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
-#else
- CurrentTSO->link = END_TSO_QUEUE;
- ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
-#endif
- // jot down why and on what closure we are blocked
- CurrentTSO->why_blocked = BlockedOnBlackHole;
- CurrentTSO->block_info.closure = R1.cl;
-
- /* Change the BLACKHOLE into a BLACKHOLE_BQ */
-#ifdef PROFILING
-
- // The size remains the same, so we call LDV_recordDead() - no need to fill slop.
- LDV_recordDead((StgClosure *)R1.p, BLACKHOLE_sizeW());
-#endif
- //
- // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
- //
- ((StgBlockingQueue *)R1.p)->header.info = &stg_BLACKHOLE_BQ_info;
-#ifdef PROFILING
- LDV_recordCreate((StgClosure *)R1.p);
-#endif
-
- // closure is mutable since something has just been added to its BQ
- recordMutable((StgMutClosure *)R1.cl);
-
- // PAR: dumping of event now done in blockThread -- HWL
-
- // stg_gen_block is too heavyweight, use a specialised one
- BLOCK_NP(1);
- FE_
-}
-
-INFO_TABLE(stg_BLACKHOLE_BQ_info, stg_BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,,IF_,"BLACKHOLE","BLACKHOLE");
-IF_(stg_BLACKHOLE_BQ_entry)
-{
- FB_
-#if defined(GRAN)
- /* Before overwriting TSO_LINK */
- STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
-#endif
-
-#ifdef SMP
- {
- bdescr *bd = Bdescr(R1.p);
- if (bd->u.back != (bdescr *)BaseReg) {
- if (bd->gen_no >= 1 || bd->step->no >= 1) {
- CMPXCHG(R1.cl->header.info, &stg_BLACKHOLE_info, &stg_WHITEHOLE_info);
- } else {
- EXTFUN_RTS(stg_gc_enter_1_hponly);
- JMP_(stg_gc_enter_1_hponly);
- }
- }
- }
-#endif
-
- TICK_ENT_BH();
- LDV_ENTER((StgClosure *)R1.p);
-
- /* Put ourselves on the blocking queue for this black hole */
- CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
- ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
- /* jot down why and on what closure we are blocked */
- CurrentTSO->why_blocked = BlockedOnBlackHole;
- CurrentTSO->block_info.closure = R1.cl;
-#ifdef SMP
- ((StgBlockingQueue *)R1.p)->header.info = &stg_BLACKHOLE_BQ_info;
-#endif
-
- /* PAR: dumping of event now done in blockThread -- HWL */
-
- /* stg_gen_block is too heavyweight, use a specialised one */
- BLOCK_NP(1);
- FE_
-}
-
-/*
- Revertible black holes are needed in the parallel world, to handle
- negative acknowledgements of messages containing updatable closures.
- The idea is that when the original message is transmitted, the closure
- is turned into a revertible black hole...an object which acts like a
- black hole when local threads try to enter it, but which can be reverted
- back to the original closure if necessary.
-
- It's actually a lot like a blocking queue (BQ) entry, because revertible
- black holes are initially set up with an empty blocking queue.
-*/
-
-#if defined(PAR) || defined(GRAN)
-
-INFO_TABLE(stg_RBH_info, stg_RBH_entry,1,1,RBH,,IF_,"RBH","RBH");
-IF_(stg_RBH_entry)
-{
- FB_
-# if defined(GRAN)
- /* mainly statistics gathering for GranSim simulation */
- STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
-# endif
-
- /* exactly the same as a BLACKHOLE_BQ_entry -- HWL */
- /* Put ourselves on the blocking queue for this black hole */
- CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
- ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
- /* jot down why and on what closure we are blocked */
- CurrentTSO->why_blocked = BlockedOnBlackHole;
- CurrentTSO->block_info.closure = R1.cl;
-
- /* PAR: dumping of event now done in blockThread -- HWL */
-
- /* stg_gen_block is too heavyweight, use a specialised one */
- BLOCK_NP(1);
- FE_
-}
-
-INFO_TABLE(stg_RBH_Save_0_info, stg_RBH_Save_0_entry,0,2,CONSTR,,IF_,"RBH_Save_0","RBH_Save_0");
-NON_ENTERABLE_ENTRY_CODE(RBH_Save_0);
-
-INFO_TABLE(stg_RBH_Save_1_info, stg_RBH_Save_1_entry,1,1,CONSTR,,IF_,"RBH_Save_1","RBH_Save_1");
-NON_ENTERABLE_ENTRY_CODE(RBH_Save_1);
-
-INFO_TABLE(stg_RBH_Save_2_info, stg_RBH_Save_2_entry,2,0,CONSTR,,IF_,"RBH_Save_2","RBH_Save_2");
-NON_ENTERABLE_ENTRY_CODE(RBH_Save_2);
-#endif /* defined(PAR) || defined(GRAN) */
-
-/* identical to BLACKHOLEs except for the infotag */
-INFO_TABLE(stg_CAF_BLACKHOLE_info, stg_CAF_BLACKHOLE_entry,0,2,CAF_BLACKHOLE,,IF_,"CAF_BLACKHOLE","CAF_BLACKHOLE");
-IF_(stg_CAF_BLACKHOLE_entry)
-{
- FB_
-#if defined(GRAN)
- /* mainly statistics gathering for GranSim simulation */
- STGCALL3(GranSimBlock,CurrentTSO,CurrentProc,(StgClosure *)R1.p /*Node*/);
-#endif
-
-#ifdef SMP
- {
- bdescr *bd = Bdescr(R1.p);
- if (bd->u.back != (bdescr *)BaseReg) {
- if (bd->gen_no >= 1 || bd->step->no >= 1) {
- CMPXCHG(R1.cl->header.info, &stg_CAF_BLACKHOLE_info, &stg_WHITEHOLE_info);
- } else {
- EXTFUN_RTS(stg_gc_enter_1_hponly);
- JMP_(stg_gc_enter_1_hponly);
- }
- }
- }
-#endif
-
- TICK_ENT_BH();
- LDV_ENTER((StgClosure *)R1.p);
-
- // Put ourselves on the blocking queue for this black hole
-#if defined(GRAN) || defined(PAR)
- // in fact, only difference is the type of the end-of-queue marker!
- CurrentTSO->link = END_BQ_QUEUE;
- ((StgBlockingQueue *)R1.p)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
-#else
- CurrentTSO->link = END_TSO_QUEUE;
- ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
-#endif
- // jot down why and on what closure we are blocked
- CurrentTSO->why_blocked = BlockedOnBlackHole;
- CurrentTSO->block_info.closure = R1.cl;
-
- // Change the CAF_BLACKHOLE into a BLACKHOLE_BQ_STATIC
- ((StgBlockingQueue *)R1.p)->header.info = &stg_BLACKHOLE_BQ_info;
-
- // closure is mutable since something has just been added to its BQ
- recordMutable((StgMutClosure *)R1.cl);
-
- // PAR: dumping of event now done in blockThread -- HWL
-
- // stg_gen_block is too heavyweight, use a specialised one
- BLOCK_NP(1);
- FE_
-}
-
-#ifdef EAGER_BLACKHOLING
-INFO_TABLE(stg_SE_BLACKHOLE_info, stg_SE_BLACKHOLE_entry,0,2,SE_BLACKHOLE,,IF_,"SE_BLACKHOLE","SE_BLACKHOLE");
-IF_(stg_SE_BLACKHOLE_entry)
-{
- FB_
- STGCALL3(fprintf,stderr,"SE_BLACKHOLE at %p entered!\n",R1.p);
- STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
- FE_
-}
-
-INFO_TABLE(stg_SE_CAF_BLACKHOLE_info, SE_CAF_BLACKHOLE_entry,0,2,SE_CAF_BLACKHOLE,,IF_,"CAF_BLACKHOLE","CAF_BLACKHOLE");
-IF_(stg_SE_CAF_BLACKHOLE_entry)
-{
- FB_
- STGCALL3(fprintf,stderr,"SE_CAF_BLACKHOLE at %p entered!\n",R1.p);
- STGCALL1(shutdownHaskellAndExit,EXIT_FAILURE);
- FE_
-}
-#endif
-
-#ifdef SMP
-INFO_TABLE(stg_WHITEHOLE_info, stg_WHITEHOLE_entry,0,2,CONSTR_NOCAF_STATIC,,IF_,"WHITEHOLE","WHITEHOLE");
-IF_(stg_WHITEHOLE_entry)
-{
- FB_
- JMP_(GET_ENTRY(R1.cl));
- FE_
-}
-#endif
-
-/* -----------------------------------------------------------------------------
- Some static info tables for things that don't get entered, and
- therefore don't need entry code (i.e. boxed but unpointed objects)
- NON_ENTERABLE_ENTRY_CODE now defined at the beginning of the file
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_TSO_info, stg_TSO_entry, 0,0,TSO,,IF_,"TSO","TSO");
-NON_ENTERABLE_ENTRY_CODE(TSO);
-
-/* -----------------------------------------------------------------------------
- Evacuees are left behind by the garbage collector. Any attempt to enter
- one is a real bug.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_EVACUATED_info,stg_EVACUATED_entry,1,0,EVACUATED,,IF_,"EVACUATED","EVACUATED");
-NON_ENTERABLE_ENTRY_CODE(EVACUATED);
-
-/* -----------------------------------------------------------------------------
- Weak pointers
-
- Live weak pointers have a special closure type. Dead ones are just
- nullary constructors (although they live on the heap - we overwrite
- live weak pointers with dead ones).
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_WEAK_info,stg_WEAK_entry,0,4,WEAK,,IF_,"WEAK","WEAK");
-NON_ENTERABLE_ENTRY_CODE(WEAK);
-
-// It's important when turning an existing WEAK into a DEAD_WEAK
-// (which is what finalizeWeak# does) that we don't lose the link
-// field and break the linked list of weak pointers. Hence, we give
-// DEAD_WEAK 4 non-pointer fields, the same as WEAK.
-
-INFO_TABLE_CONSTR(stg_DEAD_WEAK_info,stg_DEAD_WEAK_entry,0,4,0,CONSTR,,IF_,"DEAD_WEAK","DEAD_WEAK");
-NON_ENTERABLE_ENTRY_CODE(DEAD_WEAK);
-
-/* -----------------------------------------------------------------------------
- NO_FINALIZER
-
- This is a static nullary constructor (like []) that we use to mark an empty
- finalizer in a weak pointer object.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE_CONSTR(stg_NO_FINALIZER_info,stg_NO_FINALIZER_entry,0,0,0,CONSTR_NOCAF_STATIC,,IF_,"NO_FINALIZER","NO_FINALIZER");
-NON_ENTERABLE_ENTRY_CODE(NO_FINALIZER);
-
-SET_STATIC_HDR(stg_NO_FINALIZER_closure,stg_NO_FINALIZER_info,0/*CC*/,,extern const StgInfoTable)
-, /*payload*/{} };
-
-/* -----------------------------------------------------------------------------
- Foreign Objects are unlifted and therefore never entered.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_FOREIGN_info,stg_FOREIGN_entry,0,1,FOREIGN,,IF_,"FOREIGN","FOREIGN");
-NON_ENTERABLE_ENTRY_CODE(FOREIGN);
-
-/* -----------------------------------------------------------------------------
- Stable Names are unlifted too.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_STABLE_NAME_info,stg_STABLE_NAME_entry,0,1,STABLE_NAME,,IF_,"STABLE_NAME","STABLE_NAME");
-NON_ENTERABLE_ENTRY_CODE(STABLE_NAME);
-
-/* -----------------------------------------------------------------------------
- MVars
-
- There are two kinds of these: full and empty. We need an info table
- and entry code for each type.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_FULL_MVAR_info,stg_FULL_MVAR_entry,4,0,MVAR,,IF_,"MVAR","MVAR");
-NON_ENTERABLE_ENTRY_CODE(FULL_MVAR);
-
-INFO_TABLE(stg_EMPTY_MVAR_info,stg_EMPTY_MVAR_entry,4,0,MVAR,,IF_,"MVAR","MVAR");
-NON_ENTERABLE_ENTRY_CODE(EMPTY_MVAR);
-
-/* -----------------------------------------------------------------------------
- END_TSO_QUEUE
-
- This is a static nullary constructor (like []) that we use to mark the
- end of a linked TSO queue.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE_CONSTR(stg_END_TSO_QUEUE_info,stg_END_TSO_QUEUE_entry,0,0,0,CONSTR_NOCAF_STATIC,,IF_,"END_TSO_QUEUE","END_TSO_QUEUE");
-NON_ENTERABLE_ENTRY_CODE(END_TSO_QUEUE);
-
-SET_STATIC_HDR(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE_info,0/*CC*/,,extern const StgInfoTable)
-, /*payload*/{} };
-
-/* -----------------------------------------------------------------------------
- Mutable lists
-
- Mutable lists (used by the garbage collector) consist of a chain of
- StgMutClosures connected through their mut_link fields, ending in
- an END_MUT_LIST closure.
- -------------------------------------------------------------------------- */
-
-INFO_TABLE_CONSTR(stg_END_MUT_LIST_info,stg_END_MUT_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,IF_,"END_MUT_LIST","END_MUT_LIST");
-NON_ENTERABLE_ENTRY_CODE(END_MUT_LIST);
-
-SET_STATIC_HDR(stg_END_MUT_LIST_closure,stg_END_MUT_LIST_info,0/*CC*/,,extern const StgInfoTable)
-, /*payload*/{} };
-
-INFO_TABLE(stg_MUT_CONS_info, stg_MUT_CONS_entry, 1, 1, MUT_CONS, , IF_, "MUT_CONS", "MUT_CONS");
-NON_ENTERABLE_ENTRY_CODE(MUT_CONS);
-
-/* -----------------------------------------------------------------------------
- Exception lists
- -------------------------------------------------------------------------- */
-
-INFO_TABLE_CONSTR(stg_END_EXCEPTION_LIST_info,stg_END_EXCEPTION_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,IF_,"END_EXCEPTION_LIST","END_EXCEPTION_LIST");
-NON_ENTERABLE_ENTRY_CODE(END_EXCEPTION_LIST);
-
-SET_STATIC_HDR(stg_END_EXCEPTION_LIST_closure,stg_END_EXCEPTION_LIST_info,0/*CC*/,,extern const StgInfoTable)
-, /*payload*/{} };
-
-INFO_TABLE(stg_EXCEPTION_CONS_info, stg_EXCEPTION_CONS_entry, 1, 1, CONSTR, , IF_, "EXCEPTION_CONS", "EXCEPTION_CONS");
-NON_ENTERABLE_ENTRY_CODE(EXCEPTION_CONS);
-
-/* -----------------------------------------------------------------------------
- Arrays
-
- These come in two basic flavours: arrays of data (StgArrWords) and arrays of
- pointers (StgArrPtrs). They all have a similar layout:
-
- ___________________________
- | Info | No. of | data....
- | Ptr | Words |
- ---------------------------
-
- These are *unpointed* objects: i.e. they cannot be entered.
-
- -------------------------------------------------------------------------- */
-
-#define ArrayInfo(type) \
-INFO_TABLE(stg_##type##_info, stg_##type##_entry, 0, 0, type, , IF_,"" # type "","" # type "");
-
-ArrayInfo(ARR_WORDS);
-NON_ENTERABLE_ENTRY_CODE(ARR_WORDS);
-ArrayInfo(MUT_ARR_PTRS);
-NON_ENTERABLE_ENTRY_CODE(MUT_ARR_PTRS);
-ArrayInfo(MUT_ARR_PTRS_FROZEN);
-NON_ENTERABLE_ENTRY_CODE(MUT_ARR_PTRS_FROZEN);
-
-#undef ArrayInfo
-
-/* -----------------------------------------------------------------------------
- Mutable Variables
- -------------------------------------------------------------------------- */
-
-INFO_TABLE(stg_MUT_VAR_info, stg_MUT_VAR_entry, 1, 1, MUT_VAR, , IF_, "MUT_VAR", "MUT_VAR");
-NON_ENTERABLE_ENTRY_CODE(MUT_VAR);
-
-/* -----------------------------------------------------------------------------
- Dummy return closure
-
- Entering this closure will just return to the address on the top of the
- stack. Useful for getting a thread in a canonical form where we can
- just enter the top stack word to start the thread. (see deleteThread)
- * -------------------------------------------------------------------------- */
-
-INFO_TABLE( stg_dummy_ret_info, stg_dummy_ret_entry,
- 0, 0, CONSTR_NOCAF_STATIC, , EF_, "DUMMY_RET", "DUMMY_RET");
-
-STGFUN(stg_dummy_ret_entry)
-{
- FB_
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
-}
-SET_STATIC_HDR(stg_dummy_ret_closure,stg_dummy_ret_info,CCS_DONT_CARE,,extern const StgInfoTable)
-, /*payload*/{} };
-
-/* -----------------------------------------------------------------------------
- CHARLIKE and INTLIKE closures.
-
- These are static representations of Chars and small Ints, so that
- we can remove dynamic Chars and Ints during garbage collection and
- replace them with references to the static objects.
- -------------------------------------------------------------------------- */
-
-#if defined(INTERPRETER) || defined(ENABLE_WIN32_DLL_SUPPORT)
-/*
- * When sticking the RTS in a DLL, we delay populating the
- * Charlike and Intlike tables until load-time, which is only
- * when we've got the real addresses to the C# and I# closures.
- *
- */
-static INFO_TBL_CONST StgInfoTable czh_static_info;
-static INFO_TBL_CONST StgInfoTable izh_static_info;
-#define Char_hash_static_info czh_static_info
-#define Int_hash_static_info izh_static_info
-#else
-#define Char_hash_static_info GHCziBase_Czh_static_info
-#define Int_hash_static_info GHCziBase_Izh_static_info
-#endif
-
-#define CHARLIKE_HDR(n) \
- { \
- STATIC_HDR(Char_hash_static_info, /* C# */ \
- CCS_DONT_CARE), \
- data : n \
- }
-
-#define INTLIKE_HDR(n) \
- { \
- STATIC_HDR(Int_hash_static_info, /* I# */ \
- CCS_DONT_CARE), \
- data : n \
- }
-
-/* put these in the *data* section, since the garbage collector relies
- * on the fact that static closures live in the data section.
- */
-
-/* end the name with _closure, to convince the mangler this is a closure */
-
-StgIntCharlikeClosure stg_CHARLIKE_closure[] = {
- CHARLIKE_HDR(0),
- CHARLIKE_HDR(1),
- CHARLIKE_HDR(2),
- CHARLIKE_HDR(3),
- CHARLIKE_HDR(4),
- CHARLIKE_HDR(5),
- CHARLIKE_HDR(6),
- CHARLIKE_HDR(7),
- CHARLIKE_HDR(8),
- CHARLIKE_HDR(9),
- CHARLIKE_HDR(10),
- CHARLIKE_HDR(11),
- CHARLIKE_HDR(12),
- CHARLIKE_HDR(13),
- CHARLIKE_HDR(14),
- CHARLIKE_HDR(15),
- CHARLIKE_HDR(16),
- CHARLIKE_HDR(17),
- CHARLIKE_HDR(18),
- CHARLIKE_HDR(19),
- CHARLIKE_HDR(20),
- CHARLIKE_HDR(21),
- CHARLIKE_HDR(22),
- CHARLIKE_HDR(23),
- CHARLIKE_HDR(24),
- CHARLIKE_HDR(25),
- CHARLIKE_HDR(26),
- CHARLIKE_HDR(27),
- CHARLIKE_HDR(28),
- CHARLIKE_HDR(29),
- CHARLIKE_HDR(30),
- CHARLIKE_HDR(31),
- CHARLIKE_HDR(32),
- CHARLIKE_HDR(33),
- CHARLIKE_HDR(34),
- CHARLIKE_HDR(35),
- CHARLIKE_HDR(36),
- CHARLIKE_HDR(37),
- CHARLIKE_HDR(38),
- CHARLIKE_HDR(39),
- CHARLIKE_HDR(40),
- CHARLIKE_HDR(41),
- CHARLIKE_HDR(42),
- CHARLIKE_HDR(43),
- CHARLIKE_HDR(44),
- CHARLIKE_HDR(45),
- CHARLIKE_HDR(46),
- CHARLIKE_HDR(47),
- CHARLIKE_HDR(48),
- CHARLIKE_HDR(49),
- CHARLIKE_HDR(50),
- CHARLIKE_HDR(51),
- CHARLIKE_HDR(52),
- CHARLIKE_HDR(53),
- CHARLIKE_HDR(54),
- CHARLIKE_HDR(55),
- CHARLIKE_HDR(56),
- CHARLIKE_HDR(57),
- CHARLIKE_HDR(58),
- CHARLIKE_HDR(59),
- CHARLIKE_HDR(60),
- CHARLIKE_HDR(61),
- CHARLIKE_HDR(62),
- CHARLIKE_HDR(63),
- CHARLIKE_HDR(64),
- CHARLIKE_HDR(65),
- CHARLIKE_HDR(66),
- CHARLIKE_HDR(67),
- CHARLIKE_HDR(68),
- CHARLIKE_HDR(69),
- CHARLIKE_HDR(70),
- CHARLIKE_HDR(71),
- CHARLIKE_HDR(72),
- CHARLIKE_HDR(73),
- CHARLIKE_HDR(74),
- CHARLIKE_HDR(75),
- CHARLIKE_HDR(76),
- CHARLIKE_HDR(77),
- CHARLIKE_HDR(78),
- CHARLIKE_HDR(79),
- CHARLIKE_HDR(80),
- CHARLIKE_HDR(81),
- CHARLIKE_HDR(82),
- CHARLIKE_HDR(83),
- CHARLIKE_HDR(84),
- CHARLIKE_HDR(85),
- CHARLIKE_HDR(86),
- CHARLIKE_HDR(87),
- CHARLIKE_HDR(88),
- CHARLIKE_HDR(89),
- CHARLIKE_HDR(90),
- CHARLIKE_HDR(91),
- CHARLIKE_HDR(92),
- CHARLIKE_HDR(93),
- CHARLIKE_HDR(94),
- CHARLIKE_HDR(95),
- CHARLIKE_HDR(96),
- CHARLIKE_HDR(97),
- CHARLIKE_HDR(98),
- CHARLIKE_HDR(99),
- CHARLIKE_HDR(100),
- CHARLIKE_HDR(101),
- CHARLIKE_HDR(102),
- CHARLIKE_HDR(103),
- CHARLIKE_HDR(104),
- CHARLIKE_HDR(105),
- CHARLIKE_HDR(106),
- CHARLIKE_HDR(107),
- CHARLIKE_HDR(108),
- CHARLIKE_HDR(109),
- CHARLIKE_HDR(110),
- CHARLIKE_HDR(111),
- CHARLIKE_HDR(112),
- CHARLIKE_HDR(113),
- CHARLIKE_HDR(114),
- CHARLIKE_HDR(115),
- CHARLIKE_HDR(116),
- CHARLIKE_HDR(117),
- CHARLIKE_HDR(118),
- CHARLIKE_HDR(119),
- CHARLIKE_HDR(120),
- CHARLIKE_HDR(121),
- CHARLIKE_HDR(122),
- CHARLIKE_HDR(123),
- CHARLIKE_HDR(124),
- CHARLIKE_HDR(125),
- CHARLIKE_HDR(126),
- CHARLIKE_HDR(127),
- CHARLIKE_HDR(128),
- CHARLIKE_HDR(129),
- CHARLIKE_HDR(130),
- CHARLIKE_HDR(131),
- CHARLIKE_HDR(132),
- CHARLIKE_HDR(133),
- CHARLIKE_HDR(134),
- CHARLIKE_HDR(135),
- CHARLIKE_HDR(136),
- CHARLIKE_HDR(137),
- CHARLIKE_HDR(138),
- CHARLIKE_HDR(139),
- CHARLIKE_HDR(140),
- CHARLIKE_HDR(141),
- CHARLIKE_HDR(142),
- CHARLIKE_HDR(143),
- CHARLIKE_HDR(144),
- CHARLIKE_HDR(145),
- CHARLIKE_HDR(146),
- CHARLIKE_HDR(147),
- CHARLIKE_HDR(148),
- CHARLIKE_HDR(149),
- CHARLIKE_HDR(150),
- CHARLIKE_HDR(151),
- CHARLIKE_HDR(152),
- CHARLIKE_HDR(153),
- CHARLIKE_HDR(154),
- CHARLIKE_HDR(155),
- CHARLIKE_HDR(156),
- CHARLIKE_HDR(157),
- CHARLIKE_HDR(158),
- CHARLIKE_HDR(159),
- CHARLIKE_HDR(160),
- CHARLIKE_HDR(161),
- CHARLIKE_HDR(162),
- CHARLIKE_HDR(163),
- CHARLIKE_HDR(164),
- CHARLIKE_HDR(165),
- CHARLIKE_HDR(166),
- CHARLIKE_HDR(167),
- CHARLIKE_HDR(168),
- CHARLIKE_HDR(169),
- CHARLIKE_HDR(170),
- CHARLIKE_HDR(171),
- CHARLIKE_HDR(172),
- CHARLIKE_HDR(173),
- CHARLIKE_HDR(174),
- CHARLIKE_HDR(175),
- CHARLIKE_HDR(176),
- CHARLIKE_HDR(177),
- CHARLIKE_HDR(178),
- CHARLIKE_HDR(179),
- CHARLIKE_HDR(180),
- CHARLIKE_HDR(181),
- CHARLIKE_HDR(182),
- CHARLIKE_HDR(183),
- CHARLIKE_HDR(184),
- CHARLIKE_HDR(185),
- CHARLIKE_HDR(186),
- CHARLIKE_HDR(187),
- CHARLIKE_HDR(188),
- CHARLIKE_HDR(189),
- CHARLIKE_HDR(190),
- CHARLIKE_HDR(191),
- CHARLIKE_HDR(192),
- CHARLIKE_HDR(193),
- CHARLIKE_HDR(194),
- CHARLIKE_HDR(195),
- CHARLIKE_HDR(196),
- CHARLIKE_HDR(197),
- CHARLIKE_HDR(198),
- CHARLIKE_HDR(199),
- CHARLIKE_HDR(200),
- CHARLIKE_HDR(201),
- CHARLIKE_HDR(202),
- CHARLIKE_HDR(203),
- CHARLIKE_HDR(204),
- CHARLIKE_HDR(205),
- CHARLIKE_HDR(206),
- CHARLIKE_HDR(207),
- CHARLIKE_HDR(208),
- CHARLIKE_HDR(209),
- CHARLIKE_HDR(210),
- CHARLIKE_HDR(211),
- CHARLIKE_HDR(212),
- CHARLIKE_HDR(213),
- CHARLIKE_HDR(214),
- CHARLIKE_HDR(215),
- CHARLIKE_HDR(216),
- CHARLIKE_HDR(217),
- CHARLIKE_HDR(218),
- CHARLIKE_HDR(219),
- CHARLIKE_HDR(220),
- CHARLIKE_HDR(221),
- CHARLIKE_HDR(222),
- CHARLIKE_HDR(223),
- CHARLIKE_HDR(224),
- CHARLIKE_HDR(225),
- CHARLIKE_HDR(226),
- CHARLIKE_HDR(227),
- CHARLIKE_HDR(228),
- CHARLIKE_HDR(229),
- CHARLIKE_HDR(230),
- CHARLIKE_HDR(231),
- CHARLIKE_HDR(232),
- CHARLIKE_HDR(233),
- CHARLIKE_HDR(234),
- CHARLIKE_HDR(235),
- CHARLIKE_HDR(236),
- CHARLIKE_HDR(237),
- CHARLIKE_HDR(238),
- CHARLIKE_HDR(239),
- CHARLIKE_HDR(240),
- CHARLIKE_HDR(241),
- CHARLIKE_HDR(242),
- CHARLIKE_HDR(243),
- CHARLIKE_HDR(244),
- CHARLIKE_HDR(245),
- CHARLIKE_HDR(246),
- CHARLIKE_HDR(247),
- CHARLIKE_HDR(248),
- CHARLIKE_HDR(249),
- CHARLIKE_HDR(250),
- CHARLIKE_HDR(251),
- CHARLIKE_HDR(252),
- CHARLIKE_HDR(253),
- CHARLIKE_HDR(254),
- CHARLIKE_HDR(255)
-};
-
-StgIntCharlikeClosure stg_INTLIKE_closure[] = {
- INTLIKE_HDR(-16), /* MIN_INTLIKE == -16 */
- INTLIKE_HDR(-15),
- INTLIKE_HDR(-14),
- INTLIKE_HDR(-13),
- INTLIKE_HDR(-12),
- INTLIKE_HDR(-11),
- INTLIKE_HDR(-10),
- INTLIKE_HDR(-9),
- INTLIKE_HDR(-8),
- INTLIKE_HDR(-7),
- INTLIKE_HDR(-6),
- INTLIKE_HDR(-5),
- INTLIKE_HDR(-4),
- INTLIKE_HDR(-3),
- INTLIKE_HDR(-2),
- INTLIKE_HDR(-1),
- INTLIKE_HDR(0),
- INTLIKE_HDR(1),
- INTLIKE_HDR(2),
- INTLIKE_HDR(3),
- INTLIKE_HDR(4),
- INTLIKE_HDR(5),
- INTLIKE_HDR(6),
- INTLIKE_HDR(7),
- INTLIKE_HDR(8),
- INTLIKE_HDR(9),
- INTLIKE_HDR(10),
- INTLIKE_HDR(11),
- INTLIKE_HDR(12),
- INTLIKE_HDR(13),
- INTLIKE_HDR(14),
- INTLIKE_HDR(15),
- INTLIKE_HDR(16) /* MAX_INTLIKE == 16 */
-};
/* -----------------------------------------------------------------------------
- * $Id: StgRun.h,v 1.6 2001/05/25 18:33:46 sof Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
* Tiny assembler 'layer' between the C and STG worlds.
*
extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg);
-EXTFUN(StgReturn);
+RTS_FUN(StgReturn);
#endif /* STGRUN_H */
-
/* -----------------------------------------------------------------------------
- * $Id: StgStartup.hc,v 1.21 2003/05/14 09:14:00 simonmar Exp $
*
- * (c) The GHC Team, 1998-2002
+ * (c) The GHC Team, 1998-2004
*
* Code for starting, stopping and restarting threads.
*
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC. It is compiled by GHC directly. For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
* ---------------------------------------------------------------------------*/
-#include "Stg.h"
-#include "Rts.h"
-#include "StgRun.h" /* StgReturn */
-#include "StgStartup.h"
+#include "Cmm.h"
/*
* This module contains the two entry points and the final exit point
*/
#define CHECK_SENSIBLE_REGS() \
- ASSERT(Hp != (P_)0); \
- ASSERT(Sp != (P_)0); \
- ASSERT(SpLim != (P_)0); \
- ASSERT(HpLim != (P_)0); \
+ ASSERT(Hp != 0); \
+ ASSERT(Sp != 0); \
+ ASSERT(SpLim != 0); \
+ ASSERT(HpLim != 0); \
ASSERT(SpLim - RESERVED_STACK_WORDS <= Sp); \
ASSERT(HpLim >= Hp);
slot 0).
-------------------------------------------------------------------------- */
-EXTFUN(stg_stop_thread_ret);
-
#if defined(PROFILING)
#define STOP_THREAD_BITMAP 3
#define STOP_THREAD_WORDS 2
#define STOP_THREAD_WORDS 0
#endif
-/* VEC_POLY_INFO expects to see these names - but they should all be the same. */
-#define stg_stop_thread_0_ret stg_stop_thread_ret
-#define stg_stop_thread_1_ret stg_stop_thread_ret
-#define stg_stop_thread_2_ret stg_stop_thread_ret
-#define stg_stop_thread_3_ret stg_stop_thread_ret
-#define stg_stop_thread_4_ret stg_stop_thread_ret
-#define stg_stop_thread_5_ret stg_stop_thread_ret
-#define stg_stop_thread_6_ret stg_stop_thread_ret
-#define stg_stop_thread_7_ret stg_stop_thread_ret
-
-VEC_POLY_INFO_TABLE( stg_stop_thread,
- MK_SMALL_BITMAP(STOP_THREAD_WORDS, STOP_THREAD_BITMAP),
- 0,0,0,STOP_FRAME,,EF_);
-
-STGFUN(stg_stop_thread_ret)
+/* A polymorhpic return address, where all the vector slots point to the
+ direct entry point. */
+INFO_TABLE_RET( stg_stop_thread, STOP_THREAD_WORDS, STOP_THREAD_BITMAP,
+ STOP_FRAME,
+ RET_LBL(stg_stop_thread),
+ RET_LBL(stg_stop_thread),
+ RET_LBL(stg_stop_thread),
+ RET_LBL(stg_stop_thread),
+ RET_LBL(stg_stop_thread),
+ RET_LBL(stg_stop_thread),
+ RET_LBL(stg_stop_thread),
+ RET_LBL(stg_stop_thread) )
{
- FB_
- //
- // The final exit.
- //
- // The top-top-level closures (e.g., "main") are of type "IO a".
- // When entered, they perform an IO action and return an 'a' in R1.
- //
- // We save R1 on top of the stack where the scheduler can find it,
- // tidy up the registers and return to the scheduler.
- //
- // We Leave the stack looking like this:
- //
- // +----------------+
- // | -------------------> return value
- // +----------------+
- // | stg_enter_info |
- // +----------------+
- //
- // The stg_enter_info is just a dummy info table so that the
- // garbage collector can understand the stack (there must always
- // be an info table on top of the stack).
- //
-
- Sp += sizeofW(StgStopFrame) - 2;
- Sp[1] = R1.w;
- Sp[0] = (W_)&stg_enter_info;
-
- CurrentTSO->what_next = ThreadComplete;
-
- SaveThreadState(); // inline!
-
- // R1 contains the return value of the thread
- R1.i = ThreadFinished;
-
- JMP_(StgReturn);
- FE_
+ /*
+ The final exit.
+
+ The top-top-level closures (e.g., "main") are of type "IO a".
+ When entered, they perform an IO action and return an 'a' in R1.
+
+ We save R1 on top of the stack where the scheduler can find it,
+ tidy up the registers and return to the scheduler.
+
+ We Leave the stack looking like this:
+
+ +----------------+
+ | -------------------> return value
+ +----------------+
+ | stg_enter_info |
+ +----------------+
+
+ The stg_enter_info is just a dummy info table so that the
+ garbage collector can understand the stack (there must always
+ be an info table on top of the stack).
+ */
+
+ Sp = Sp + SIZEOF_StgStopFrame - WDS(2);
+ Sp(1) = R1;
+ Sp(0) = stg_enter_info;
+
+ StgTSO_what_next(CurrentTSO) = ThreadComplete::I16;
+
+ SAVE_THREAD_STATE();
+
+ /* R1 contains the return value of the thread */
+ R1 = ThreadFinished;
+
+ jump StgReturn;
}
/* -----------------------------------------------------------------------------
from C land.
-------------------------------------------------------------------------- */
-STGFUN(stg_returnToStackTop)
+stg_returnToStackTop
{
- FB_
- LoadThreadState();
+ LOAD_THREAD_STATE();
CHECK_SENSIBLE_REGS();
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
+ jump %ENTRY_CODE(Sp(0));
}
/* -----------------------------------------------------------------------------
results that comes back.
------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_forceIO_info,stg_forceIO_ret,
- MK_SMALL_BITMAP(0/*size*/, 0/*BITMAP*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
+INFO_TABLE_RET( stg_forceIO, 0/*size*/, 0/*bitmap*/, RET_SMALL)
#ifdef REG_R1
-STGFUN(stg_forceIO_ret)
{
- FB_
- Sp++;
+ Sp_adj(1);
ENTER();
- FE_
}
#else
-STGFUN(stg_forceIO_ret)
{
- FB_
- R1.w = Sp[0];
- Sp += 2;
+ R1 = Sp(0);
+ Sp_adj(2);
ENTER();
- FE_
}
#endif
is a register or not.
------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_noforceIO_info,stg_noforceIO_ret,
- MK_SMALL_BITMAP(0/*size*/, 0/*BITMAP*/),
- 0/*SRT*/, 0/*SRT_OFF*/, 0/*SRT_BITMAP*/,
- RET_SMALL,, EF_, 0, 0);
+INFO_TABLE_RET( stg_noforceIO, 0/*size*/, 0/*bitmap*/, RET_SMALL )
#ifdef REG_R1
-STGFUN(stg_noforceIO_ret)
{
- FB_
- Sp++;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
+ Sp_adj(1);
+ jump %ENTRY_CODE(Sp(0));
}
#else
-STGFUN(stg_noforceIO_ret)
{
- FB_
- R1.w = Sp[0];
- Sp += 2;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
+ R1 = Sp(0);
+ Sp_adj(2);
+ jump %ENTRY_CODE(Sp(0));
}
#endif
Special STG entry points for module registration.
-------------------------------------------------------------------------- */
-extern F_ *init_stack;
-
-STGFUN(stg_init_ret)
+stg_init_finish
{
- FB_
- JMP_(StgReturn);
- FE_
+ jump StgReturn;
}
/* On entry to stg_init:
* init_stack[0] = &stg_init_ret;
* init_stack[1] = __stginit_Something;
*/
-STGFUN(stg_init)
+stg_init
{
- FB_
- Sp = BaseReg->rSp;
- JMP_(POP_INIT_STACK());
- FE_
+ W_ next;
+ Sp = W_[MainCapability + OFFSET_Capability_r + OFFSET_StgRegTable_rSp];
+ next = W_[Sp];
+ Sp_adj(1);
+ jump next;
}
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StgStartup.h,v 1.6 2002/02/12 15:17:23 simonmar Exp $
- *
- * (c) The GHC Team, 1998-1999
- *
- * Code for starting, stopping and restarting threads.
- *
- * ---------------------------------------------------------------------------*/
-
-extern const StgPolyInfoTable stg_stop_thread_info;
-EXTFUN(stg_stop_thread_entry);
-EXTFUN(stg_returnToStackTop);
-EXTFUN(stg_enterStackTop);
-
-EXTFUN(stg_init_ret);
-EXTFUN(stg_init);
-EXTFUN(__stginit_GHCziPrim);
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow, 1998-2004
+ *
+ * Canned "Standard Form" Thunks
+ *
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC. It is compiled by GHC directly. For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Cmm.h"
+
+/* -----------------------------------------------------------------------------
+ The code for a thunk that simply extracts a field from a
+ single-constructor datatype depends only on the offset of the field
+ to be selected.
+
+ Here we define some canned "selector" thunks that do just that; any
+ selector thunk appearing in a program will refer to one of these
+ instead of being compiled independently.
+
+ The garbage collector spots selector thunks and reduces them if
+ possible, in order to avoid space leaks resulting from lazy pattern
+ matching.
+ -------------------------------------------------------------------------- */
+
+#define WITHUPD_FRAME_SIZE (SIZEOF_StgUpdateFrame + SIZEOF_StgHeader)
+#define NOUPD_FRAME_SIZE (SIZEOF_StgHeader)
+
+#ifdef PROFILING
+#define SAVE_CCCS(fs) StgHeader_ccs(Sp-fs) = W_[CCCS]
+#define GET_SAVED_CCCS W_[CCCS] = StgHeader_ccs(Sp)
+#define RET_BITMAP 3
+#define RET_FRAMESIZE 2
+#else
+#define SAVE_CCCS(fs) /* empty */
+#define GET_SAVED_CCCS /* empty */
+#define RET_BITMAP 0
+#define RET_FRAMESIZE 0
+#endif
+
+#define SELECTOR_CODE_UPD(offset) \
+ INFO_TABLE_RET(stg_sel_ret_##offset##_upd, RET_FRAMESIZE, RET_BITMAP, RET_SMALL) \
+ { \
+ R1 = StgClosure_payload(R1,offset); \
+ GET_SAVED_CCCS; \
+ Sp = Sp + SIZEOF_StgHeader; \
+ ENTER(); \
+ } \
+ \
+ INFO_TABLE_SELECTOR(stg_sel_##offset##_upd, offset, THUNK_SELECTOR, "stg_sel_upd", "stg_sel_upd") \
+ { \
+ TICK_ENT_DYN_THK(); \
+ STK_CHK_NP(WITHUPD_FRAME_SIZE); \
+ UPD_BH_UPDATABLE(); \
+ LDV_ENTER(R1); \
+ PUSH_UPD_FRAME(Sp - SIZEOF_StgUpdateFrame, R1); \
+ ENTER_CCS_THUNK(R1); \
+ SAVE_CCCS(WITHUPD_FRAME_SIZE); \
+ W_[Sp-WITHUPD_FRAME_SIZE] = stg_sel_ret_##offset##_upd_info; \
+ R1 = StgClosure_payload(R1,0); \
+ Sp = Sp - WITHUPD_FRAME_SIZE; \
+ ENTER(); \
+ }
+
+SELECTOR_CODE_UPD(0)
+SELECTOR_CODE_UPD(1)
+SELECTOR_CODE_UPD(2)
+SELECTOR_CODE_UPD(3)
+SELECTOR_CODE_UPD(4)
+SELECTOR_CODE_UPD(5)
+SELECTOR_CODE_UPD(6)
+SELECTOR_CODE_UPD(7)
+SELECTOR_CODE_UPD(8)
+SELECTOR_CODE_UPD(9)
+SELECTOR_CODE_UPD(10)
+SELECTOR_CODE_UPD(11)
+SELECTOR_CODE_UPD(12)
+SELECTOR_CODE_UPD(13)
+SELECTOR_CODE_UPD(14)
+SELECTOR_CODE_UPD(15)
+
+#define SELECTOR_CODE_NOUPD(offset) \
+ INFO_TABLE_RET(stg_sel_ret_##offset##_noupd, RET_FRAMESIZE, RET_BITMAP, RET_SMALL) \
+ { \
+ R1 = StgClosure_payload(R1,offset); \
+ GET_SAVED_CCCS; \
+ Sp = Sp + SIZEOF_StgHeader; \
+ jump %GET_ENTRY(R1); \
+ } \
+ \
+ INFO_TABLE_SELECTOR(stg_sel_##offset##_noupd, offset, THUNK_SELECTOR, "stg_sel_noupd", "stg_sel_noupd")\
+ { \
+ TICK_ENT_DYN_THK(); \
+ STK_CHK_NP(NOUPD_FRAME_SIZE); \
+ UPD_BH_SINGLE_ENTRY(); \
+ LDV_ENTER(R1); \
+ TICK_UPDF_OMITTED(); \
+ ENTER_CCS_THUNK(R1); \
+ SAVE_CCCS(NOUPD_FRAME_SIZE); \
+ W_[Sp-NOUPD_FRAME_SIZE] = stg_sel_ret_##offset##_noupd_info; \
+ R1 = StgClosure_payload(R1,0); \
+ Sp = Sp - NOUPD_FRAME_SIZE; \
+ jump %GET_ENTRY(R1); \
+ }
+
+SELECTOR_CODE_NOUPD(0)
+SELECTOR_CODE_NOUPD(1)
+SELECTOR_CODE_NOUPD(2)
+SELECTOR_CODE_NOUPD(3)
+SELECTOR_CODE_NOUPD(4)
+SELECTOR_CODE_NOUPD(5)
+SELECTOR_CODE_NOUPD(6)
+SELECTOR_CODE_NOUPD(7)
+SELECTOR_CODE_NOUPD(8)
+SELECTOR_CODE_NOUPD(9)
+SELECTOR_CODE_NOUPD(10)
+SELECTOR_CODE_NOUPD(11)
+SELECTOR_CODE_NOUPD(12)
+SELECTOR_CODE_NOUPD(13)
+SELECTOR_CODE_NOUPD(14)
+SELECTOR_CODE_NOUPD(15)
+
+/* -----------------------------------------------------------------------------
+ Apply thunks
+
+ An apply thunk is a thunk of the form
+
+ let z = [x1...xn] \u x1...xn
+ in ...
+
+ We pre-compile some of these because the code is always the same.
+
+ These have to be independent of the update frame size, so the code
+ works when profiling etc.
+ -------------------------------------------------------------------------- */
+
+/* stg_ap_1_upd_info is a bit redundant, but there appears to be a bug
+ * in the compiler that means stg_ap_1 is generated occasionally (ToDo)
+ */
+
+INFO_TABLE(stg_ap_1_upd,1,1,THUNK_1_0,"stg_ap_1_upd_info","stg_ap_1_upd_info")
+{
+ TICK_ENT_DYN_THK();
+ STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(1));
+ UPD_BH_UPDATABLE();
+ LDV_ENTER(R1);
+ ENTER_CCS_THUNK(R1);
+ PUSH_UPD_FRAME(Sp-SIZEOF_StgUpdateFrame,R1);
+ R1 = StgClosure_payload(R1,0);
+ Sp = Sp - SIZEOF_StgUpdateFrame;
+ Sp_adj(-1); // for stg_ap_0_ret
+ jump RET_LBL(stg_ap_0);
+}
+
+INFO_TABLE(stg_ap_2_upd,2,0,THUNK_2_0,"stg_ap_2_upd_info","stg_ap_2_upd_info")
+{
+ TICK_ENT_DYN_THK();
+ STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(2));
+ UPD_BH_UPDATABLE();
+ LDV_ENTER(R1);
+ ENTER_CCS_THUNK(R1);
+ PUSH_UPD_FRAME(Sp-SIZEOF_StgUpdateFrame,R1);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(1)] = StgClosure_payload(R1,1);
+ R1 = StgClosure_payload(R1,0);
+ Sp = Sp - SIZEOF_StgUpdateFrame - WDS(1);
+ Sp_adj(-1); // for stg_ap_0_ret
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_p();
+ jump RET_LBL(stg_ap_p);
+}
+
+INFO_TABLE(stg_ap_3_upd,3,0,THUNK,"stg_ap_3_upd_info","stg_ap_3_upd_info")
+{
+ TICK_ENT_DYN_THK();
+ STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(3));
+ UPD_BH_UPDATABLE();
+ LDV_ENTER(R1);
+ ENTER_CCS_THUNK(R1);
+ PUSH_UPD_FRAME(Sp-SIZEOF_StgUpdateFrame,R1);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(1)] = StgClosure_payload(R1,2);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(2)] = StgClosure_payload(R1,1);
+ R1 = StgClosure_payload(R1,0);
+ Sp = Sp - SIZEOF_StgUpdateFrame - WDS(2);
+ Sp_adj(-1); // for stg_ap_0_ret
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_pp();
+ jump RET_LBL(stg_ap_pp);
+}
+
+INFO_TABLE(stg_ap_4_upd,4,0,THUNK,"stg_ap_4_upd_info","stg_ap_4_upd_info")
+{
+ TICK_ENT_DYN_THK();
+ STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(4));
+ UPD_BH_UPDATABLE();
+ LDV_ENTER(R1);
+ ENTER_CCS_THUNK(R1);
+ PUSH_UPD_FRAME(Sp-SIZEOF_StgUpdateFrame,R1);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(1)] = StgClosure_payload(R1,3);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(2)] = StgClosure_payload(R1,2);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(3)] = StgClosure_payload(R1,1);
+ R1 = StgClosure_payload(R1,0);
+ Sp = Sp - SIZEOF_StgUpdateFrame - WDS(3);
+ Sp_adj(-1); // for stg_ap_0_ret
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_ppp();
+ jump RET_LBL(stg_ap_ppp);
+}
+
+INFO_TABLE(stg_ap_5_upd,5,0,THUNK,"stg_ap_5_upd_info","stg_ap_5_upd_info")
+{
+ TICK_ENT_DYN_THK();
+ STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(5));
+ UPD_BH_UPDATABLE();
+ LDV_ENTER(R1);
+ ENTER_CCS_THUNK(R1);
+ PUSH_UPD_FRAME(Sp-SIZEOF_StgUpdateFrame,R1);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(1)] = StgClosure_payload(R1,4);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(2)] = StgClosure_payload(R1,3);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(3)] = StgClosure_payload(R1,2);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(4)] = StgClosure_payload(R1,1);
+ R1 = StgClosure_payload(R1,0);
+ Sp = Sp - SIZEOF_StgUpdateFrame - WDS(4);
+ Sp_adj(-1); // for stg_ap_0_ret
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_pppp();
+ jump RET_LBL(stg_ap_pppp);
+}
+
+INFO_TABLE(stg_ap_6_upd,6,0,THUNK,"stg_ap_6_upd_info","stg_ap_6_upd_info")
+{
+ TICK_ENT_DYN_THK();
+ STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(6));
+ UPD_BH_UPDATABLE();
+ LDV_ENTER(R1);
+ ENTER_CCS_THUNK(R1);
+ PUSH_UPD_FRAME(Sp-SIZEOF_StgUpdateFrame,R1);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(1)] = StgClosure_payload(R1,5);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(2)] = StgClosure_payload(R1,4);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(3)] = StgClosure_payload(R1,3);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(4)] = StgClosure_payload(R1,2);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(5)] = StgClosure_payload(R1,1);
+ R1 = StgClosure_payload(R1,0);
+ Sp = Sp - SIZEOF_StgUpdateFrame - WDS(5);
+ Sp_adj(-1); // for stg_ap_0_ret
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_ppppp();
+ jump RET_LBL(stg_ap_ppppp);
+}
+
+INFO_TABLE(stg_ap_7_upd,7,0,THUNK,"stg_ap_7_upd_info","stg_ap_7_upd_info")
+{
+ TICK_ENT_DYN_THK();
+ STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(7));
+ UPD_BH_UPDATABLE();
+ LDV_ENTER(R1);
+ ENTER_CCS_THUNK(R1);
+ PUSH_UPD_FRAME(Sp-SIZEOF_StgUpdateFrame,R1);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(1)] = StgClosure_payload(R1,6);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(2)] = StgClosure_payload(R1,5);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(3)] = StgClosure_payload(R1,4);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(4)] = StgClosure_payload(R1,3);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(5)] = StgClosure_payload(R1,2);
+ W_[Sp-SIZEOF_StgUpdateFrame-WDS(6)] = StgClosure_payload(R1,1);
+ R1 = StgClosure_payload(R1,0);
+ Sp = Sp - SIZEOF_StgUpdateFrame - WDS(6);
+ Sp_adj(-1); // for stg_ap_0_ret
+ TICK_UNKNOWN_CALL();
+ TICK_SLOW_CALL_pppppp();
+ jump RET_LBL(stg_ap_pppppp);
+}
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StgStdThunks.hc,v 1.22 2003/04/18 09:40:10 simonmar Exp $
- *
- * (c) The GHC Team, 1998-2000
- *
- * Canned "Standard Form" Thunks
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Stg.h"
-#include "Rts.h"
-#include "StoragePriv.h"
-
-/* -----------------------------------------------------------------------------
- The code for a thunk that simply extracts a field from a
- single-constructor datatype depends only on the offset of the field
- to be selected.
-
- Here we define some canned "selector" thunks that do just that; any
- selector thunk appearing in a program will refer to one of these
- instead of being compiled independently.
-
- The garbage collector spots selector thunks and reduces them if
- possible, in order to avoid space leaks resulting from lazy pattern
- matching.
- -------------------------------------------------------------------------- */
-
-#define UPD_FRAME_SIZE (sizeofW(StgUpdateFrame)+sizeofW(StgHeader))
-#define NOUPD_FRAME_SIZE (sizeofW(StgHeader))
-
-#ifdef PROFILING
-#define SAVE_CCCS(fs) CCS_HDR(Sp-fs)=CCCS
-#define GET_SAVED_CCCS RESTORE_CCCS(CCS_HDR(Sp))
-#define ENTER_CCS(p) ENTER_CCS_TCL(p)
-#define RET_BITMAP 3
-#define RET_FRAMESIZE 2
-#else
-#define SAVE_CCCS(fs) /* empty */
-#define GET_SAVED_CCCS /* empty */
-#define ENTER_CCS(p) /* empty */
-#define RET_BITMAP 0
-#define RET_FRAMESIZE 0
-#endif
-
-#define SELECTOR_CODE_UPD(offset) \
- IF_(stg_sel_ret_##offset##_upd_ret); \
- INFO_TABLE_RET(stg_sel_ret_##offset##_upd_info,stg_sel_ret_##offset##_upd_ret, MK_SMALL_BITMAP(RET_FRAMESIZE, RET_BITMAP), 0, 0, 0, RET_SMALL, static, EF_, 0, 0); \
- EF_(stg_sel_ret_##offset##_upd_ret) { \
- FB_ \
- R1.p=(P_)R1.cl->payload[offset]; \
- GET_SAVED_CCCS; \
- Sp=Sp+sizeofW(StgHeader); \
- ENTER(); \
- FE_ \
- } \
- \
- EF_(stg_sel_##offset##_upd_entry); \
- INFO_TABLE_SELECTOR(stg_sel_##offset##_upd_info, stg_sel_##offset##_upd_entry, offset,, EF_, "stg_sel" #offset "_upd_entry", "stg_sel" #offset "_upd_entry");\
- EF_(stg_sel_##offset##_upd_entry) { \
- FB_ \
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */ \
- STK_CHK_NP(UPD_FRAME_SIZE,); \
- UPD_BH_UPDATABLE(&stg_sel_##offset##_upd_info); \
- LDV_ENTER(R1.cl); \
- PUSH_UPD_FRAME(R1.p,0); \
- ENTER_CCS(R1.p); \
- SAVE_CCCS(UPD_FRAME_SIZE); \
- Sp[-UPD_FRAME_SIZE]=(W_)&stg_sel_ret_##offset##_upd_info; \
- R1.p = (P_)R1.cl->payload[0]; \
- Sp=Sp-UPD_FRAME_SIZE; \
- ENTER(); \
- FE_ \
- }
-
-SELECTOR_CODE_UPD(0);
-SELECTOR_CODE_UPD(1);
-SELECTOR_CODE_UPD(2);
-SELECTOR_CODE_UPD(3);
-SELECTOR_CODE_UPD(4);
-SELECTOR_CODE_UPD(5);
-SELECTOR_CODE_UPD(6);
-SELECTOR_CODE_UPD(7);
-SELECTOR_CODE_UPD(8);
-SELECTOR_CODE_UPD(9);
-SELECTOR_CODE_UPD(10);
-SELECTOR_CODE_UPD(11);
-SELECTOR_CODE_UPD(12);
-SELECTOR_CODE_UPD(13);
-SELECTOR_CODE_UPD(14);
-SELECTOR_CODE_UPD(15);
-
-#define SELECTOR_CODE_NOUPD(offset) \
- IF_(stg_sel_ret_##offset##_noupd_ret); \
- INFO_TABLE_RET(stg_sel_ret_##offset##_noupd_info, stg_sel_ret_##offset##_noupd_ret, MK_SMALL_BITMAP(RET_FRAMESIZE, RET_BITMAP), 0, 0, 0, RET_SMALL, static, EF_, 0, 0); \
- IF_(stg_sel_ret_##offset##_noupd_ret) { \
- FB_ \
- R1.p=(P_)R1.cl->payload[offset]; \
- GET_SAVED_CCCS; \
- Sp=Sp+sizeofW(StgHeader); \
- JMP_(ENTRY_CODE(*R1.p)); \
- FE_ \
- } \
- \
- EF_(stg_sel_##offset##_noupd_entry); \
- INFO_TABLE_SELECTOR(stg_sel_##offset##_noupd_info, stg_sel_##offset##_noupd_entry, offset,, EF_, "stg_sel" #offset "_noupd_entry", "stg_sel" #offset "_noupd_entry");\
- EF_(stg_sel_##offset##_noupd_entry) { \
- FB_ \
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */ \
- STK_CHK_NP(NOUPD_FRAME_SIZE,) \
- UPD_BH_SINGLE_ENTRY(&stg_sel_##offset##_noupd_info); \
- LDV_ENTER(R1.cl); \
- TICK_UPDF_OMITTED(); \
- ENTER_CCS(R1.p); \
- SAVE_CCCS(NOUPD_FRAME_SIZE); \
- Sp[-NOUPD_FRAME_SIZE]=(W_)&stg_sel_ret_##offset##_noupd_info; \
- R1.p = (P_)R1.cl->payload[0]; \
- Sp=Sp-NOUPD_FRAME_SIZE; \
- JMP_(ENTRY_CODE(*R1.p)); \
- FE_ \
- }
-
-SELECTOR_CODE_NOUPD(0);
-SELECTOR_CODE_NOUPD(1);
-SELECTOR_CODE_NOUPD(2);
-SELECTOR_CODE_NOUPD(3);
-SELECTOR_CODE_NOUPD(4);
-SELECTOR_CODE_NOUPD(5);
-SELECTOR_CODE_NOUPD(6);
-SELECTOR_CODE_NOUPD(7);
-SELECTOR_CODE_NOUPD(8);
-SELECTOR_CODE_NOUPD(9);
-SELECTOR_CODE_NOUPD(10);
-SELECTOR_CODE_NOUPD(11);
-SELECTOR_CODE_NOUPD(12);
-SELECTOR_CODE_NOUPD(13);
-SELECTOR_CODE_NOUPD(14);
-SELECTOR_CODE_NOUPD(15);
-
-/* -----------------------------------------------------------------------------
- Apply thunks
-
- An apply thunk is a thunk of the form
-
- let z = [x1...xn] \u x1...xn
- in ...
-
- We pre-compile some of these because the code is always the same.
-
- These have to be independent of the update frame size, so the code
- works when profiling etc.
- -------------------------------------------------------------------------- */
-
-FN_(stg_ap_1_upd_entry);
-FN_(stg_ap_2_upd_entry);
-FN_(stg_ap_3_upd_entry);
-FN_(stg_ap_4_upd_entry);
-FN_(stg_ap_5_upd_entry);
-FN_(stg_ap_6_upd_entry);
-FN_(stg_ap_7_upd_entry);
-FN_(stg_ap_8_upd_entry);
-
-#define UF_SIZE (sizeofW(StgUpdateFrame))
-
-/* stg_ap_1_upd_info is a bit redundant, but there appears to be a bug
- * in the compiler that means stg_ap_1 is generated occasionally (ToDo)
- */
-
-INFO_TABLE_THUNK(stg_ap_1_upd_info,stg_ap_1_upd_entry,1,1,0,0,0,THUNK_1_0,,EF_,"stg_ap_1_upd_info","stg_ap_1_upd_info");
-FN_(stg_ap_1_upd_entry) {
- FB_
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+1,);
- UPD_BH_UPDATABLE(&stg_ap_1_upd_info);
- LDV_ENTER(R1.cl);
- ENTER_CCS(R1.p);
- PUSH_UPD_FRAME(R1.p,0);
- R1.p=(P_)(R1.cl->payload[0]);
- Sp -= sizeofW(StgUpdateFrame);
- Sp--; // for stg_ap_0_ret
- JMP_(stg_ap_0_ret);
- FE_
-}
-
-INFO_TABLE_THUNK(stg_ap_2_upd_info,stg_ap_2_upd_entry,2,0,0,0,0,THUNK_2_0,,EF_,"stg_ap_2_upd_info","stg_ap_2_upd_info");
-FN_(stg_ap_2_upd_entry) {
- FB_
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+2,);
- UPD_BH_UPDATABLE(&stg_ap_2_upd_info);
- LDV_ENTER(R1.cl);
- ENTER_CCS(R1.p);
- PUSH_UPD_FRAME(R1.p,0);
- Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[1]);
- R1.p=(P_)(R1.cl->payload[0]);
- Sp -= sizeofW(StgUpdateFrame)+1;
- Sp--; // for stg_ap_1_ret
- JMP_(stg_ap_p_ret);
- FE_
-}
-
-INFO_TABLE_THUNK(stg_ap_3_upd_info,stg_ap_3_upd_entry,3,0,0,0,0,THUNK,,EF_,"stg_ap_3_upd_info","stg_ap_3_upd_info");
-FN_(stg_ap_3_upd_entry) {
- FB_
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+3,);
- UPD_BH_UPDATABLE(&stg_ap_3_upd_info);
- LDV_ENTER(R1.cl);
- ENTER_CCS(R1.p);
- PUSH_UPD_FRAME(R1.p,0);
- Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[2]);
- Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[1]);
- R1.p=(P_)(R1.cl->payload[0]);
- Sp -= sizeofW(StgUpdateFrame)+2;
- Sp--; // for stg_ap_pp_ret
- JMP_(stg_ap_pp_ret);
- FE_
-}
-
-INFO_TABLE_THUNK(stg_ap_4_upd_info,stg_ap_4_upd_entry,4,0,0,0,0,THUNK,,EF_,"stg_ap_4_upd_info","stg_ap_4_upd_info");
-FN_(stg_ap_4_upd_entry) {
- FB_
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+4,);
- UPD_BH_UPDATABLE(&stg_ap_4_upd_info);
- LDV_ENTER(R1.cl);
- ENTER_CCS(R1.p);
- PUSH_UPD_FRAME(R1.p,0);
- Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[3]);
- Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[2]);
- Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[1]);
- R1.p=(P_)(R1.cl->payload[0]);
- Sp = Sp - (sizeofW(StgUpdateFrame)+3);
- Sp--; // for stg_ap_ppp_ret
- JMP_(stg_ap_ppp_ret);
- FE_
-}
-
-INFO_TABLE_THUNK(stg_ap_5_upd_info,stg_ap_5_upd_entry,5,0,0,0,0,THUNK,,EF_,"stg_ap_5_upd_info","stg_ap_5_upd_info");
-FN_(stg_ap_5_upd_entry) {
- FB_
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+5,);
- UPD_BH_UPDATABLE(&stg_ap_5_upd_info);
- LDV_ENTER(R1.cl);
- ENTER_CCS(R1.p);
- PUSH_UPD_FRAME(R1.p,0);
- Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[4]);
- Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[3]);
- Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[2]);
- Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[1]);
- R1.p=(P_)(R1.cl->payload[0]);
- Sp = Sp - (sizeofW(StgUpdateFrame)+4);
- Sp--; // for stg_ap_pppp_ret
- JMP_(stg_ap_pppp_ret);
- FE_
-}
-
-INFO_TABLE_THUNK(stg_ap_6_upd_info,stg_ap_6_upd_entry,6,0,0,0,0,THUNK,,EF_,"stg_ap_6_upd_info","stg_ap_6_upd_info");
-FN_(stg_ap_6_upd_entry) {
- FB_
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+6,);
- UPD_BH_UPDATABLE(&stg_ap_6_upd_info);
- LDV_ENTER(R1.cl);
- ENTER_CCS(R1.p);
- PUSH_UPD_FRAME(R1.p,0);
- Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[5]);
- Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[4]);
- Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[3]);
- Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[2]);
- Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[1]);
- R1.p=(P_)(R1.cl->payload[0]);
- Sp = Sp - (sizeofW(StgUpdateFrame)+5);
- Sp--; // for stg_ap_ppppp_ret
- JMP_(stg_ap_ppppp_ret);
- FE_
-}
-
-INFO_TABLE_THUNK(stg_ap_7_upd_info,stg_ap_7_upd_entry,7,0,0,0,0,THUNK,,EF_,"stg_ap_7_upd_info","stg_ap_7_upd_info");
-FN_(stg_ap_7_upd_entry) {
- FB_
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+7,);
- UPD_BH_UPDATABLE(&stg_ap_7_upd_info);
- LDV_ENTER(R1.cl);
- ENTER_CCS(R1.p);
- PUSH_UPD_FRAME(R1.p,0);
- Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[6]);
- Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[5]);
- Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[4]);
- Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[3]);
- Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[2]);
- Sp[-UF_SIZE-6]=(W_)(R1.cl->payload[1]);
- R1.p=(P_)(R1.cl->payload[0]);
- Sp = Sp - (sizeofW(StgUpdateFrame)+6);
- Sp--; // for stg_ap_pppppp_ret
- JMP_(stg_ap_pppppp_ret);
- FE_
-}
-
-INFO_TABLE_THUNK(stg_ap_8_upd_info,stg_ap_8_upd_entry,8,0,0,0,0,THUNK,,EF_,"stg_ap_8_upd_info","stg_ap_8_upd_info");
-FN_(stg_ap_8_upd_entry) {
- FB_
- TICK_ENT_DYN_THK(); /* is it static or dynamic?? */
- STK_CHK_NP(sizeofW(StgUpdateFrame)+8,);
- UPD_BH_UPDATABLE(&stg_ap_8_upd_info);
- LDV_ENTER(R1.cl);
- ENTER_CCS(R1.p);
- PUSH_UPD_FRAME(R1.p,0);
- Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[7]);
- Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[6]);
- Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[5]);
- Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[4]);
- Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[3]);
- Sp[-UF_SIZE-6]=(W_)(R1.cl->payload[2]);
- Sp[-UF_SIZE-7]=(W_)(R1.cl->payload[1]);
- R1.p=(P_)(R1.cl->payload[0]);
- Sp = Sp - (sizeofW(StgUpdateFrame)+7);
- Sp--; // for stg_ap_ppppppp_ret
- JMP_(stg_ap_ppppppp_ret);
- FE_
-}
/* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.83 2004/07/21 10:47:28 simonmar Exp $
+ * $Id: Storage.c,v 1.84 2004/08/13 13:11:01 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Storage.h"
#include "Schedule.h"
#include "OSThreads.h"
-#include "StoragePriv.h"
#include "RetainerProfile.h" // for counting memory blocks (memInventory)
SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
/* and return a ptr to the goods inside the array */
- return(BYTE_ARR_CTS(arr));
+ return arr->payload;
}
static void *
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StoragePriv.h,v 1.26 2004/07/21 10:47:29 simonmar Exp $
- *
- * (c) The GHC Team, 1998-1999
- *
- * Internal Storage Manger Interface
- *
- * ---------------------------------------------------------------------------*/
-
-#ifndef STORAGEPRIV_H
-#define STORAGEPRIV_H
-
-#include <stddef.h>
-
-#define END_OF_STATIC_LIST stgCast(StgClosure*,1)
-
-extern generation *generations;
-
-extern generation *g0;
-extern step *g0s0;
-extern generation *oldest_gen;
-
-extern void newCAF(StgClosure*);
-extern void newDynCAF(StgClosure *);
-
-extern void move_TSO(StgTSO *src, StgTSO *dest);
-extern StgTSO *relocate_stack(StgTSO *dest, ptrdiff_t diff);
-
-extern StgClosure *static_objects;
-extern StgClosure *scavenged_static_objects;
-
-extern StgWeak *old_weak_ptr_list;
-
-extern StgWeak *weak_ptr_list;
-extern StgClosure *caf_list;
-
-extern StgTSO *resurrected_threads;
-
-extern bdescr *small_alloc_list;
-extern bdescr *large_alloc_list;
-extern bdescr *pinned_object_block;
-
-extern StgPtr alloc_Hp;
-extern StgPtr alloc_HpLim;
-
-extern bdescr *nursery;
-
-extern nat alloc_blocks;
-extern nat alloc_blocks_lim;
-
-extern ullong total_allocated;
-
-/* Nursery manipulation */
-extern void allocNurseries ( void );
-extern void resetNurseries ( void );
-extern bdescr * allocNursery ( bdescr *last_bd, nat blocks );
-extern void resizeNursery ( nat blocks );
-extern void tidyAllocateLists ( void );
-
-/* Stats 'n' stuff */
-extern lnat calcAllocated ( void );
-extern lnat calcLive ( void );
-extern lnat calcNeeded ( void );
-
-INLINE_HEADER void
-dbl_link_onto(bdescr *bd, bdescr **list)
-{
- bd->link = *list;
- bd->u.back = NULL;
- if (*list) {
- (*list)->u.back = bd; /* double-link the list */
- }
- *list = bd;
-}
-
-/* MUTABLE LISTS
- * A mutable list is ended with END_MUT_LIST, so that we can use NULL
- * as an indication that an object is not on a mutable list.
- */
-#define END_MUT_LIST ((StgMutClosure *)(void *)&stg_END_MUT_LIST_closure)
-
-#ifdef DEBUG
-extern void memInventory(void);
-extern void checkSanity(void);
-extern nat countBlocks(bdescr *);
-#endif
-
-/* Functions from GC.c
- */
-extern void threadPaused ( StgTSO * );
-extern StgClosure * isAlive ( StgClosure *p );
-extern void markCAFs ( evac_fn evac );
-
-#endif /* STORAGEPRIV_H */
/* -----------------------------------------------------------------------------
- * $Id: Ticky.c,v 1.17 2002/12/11 15:36:54 simonmar Exp $
+ * $Id: Ticky.c,v 1.18 2004/08/13 13:11:08 simonmar Exp $
*
* (c) The AQUA project, Glasgow University, 1992-1997
* (c) The GHC Team, 1998-1999
unsigned long i;
unsigned long tot_allocs = /* total number of things allocated */
ALLOC_FUN_ctr + ALLOC_SE_THK_ctr + ALLOC_UP_THK_ctr + ALLOC_CON_ctr + ALLOC_TUP_ctr +
- ALLOC_TSO_ctr +
+ + ALLOC_TSO_ctr + ALLOC_BH_ctr + ALLOC_PAP_ctr + ALLOC_PRIM_ctr
#ifdef PAR
- ALLOC_FMBQ_ctr + ALLOC_FME_ctr + ALLOC_BF_ctr +
+ + ALLOC_FMBQ_ctr + ALLOC_FME_ctr + ALLOC_BF_ctr
#endif
- ALLOC_BH_ctr + ALLOC_PAP_ctr + ALLOC_PRIM_ctr;
+ ;
unsigned long tot_adm_wds = /* total number of admin words allocated */
- ALLOC_FUN_adm + ALLOC_THK_adm + ALLOC_CON_adm + ALLOC_TUP_adm +
- ALLOC_TSO_adm +
+ ALLOC_FUN_adm + ALLOC_THK_adm + ALLOC_CON_adm + ALLOC_TUP_adm
+ + ALLOC_TSO_adm + ALLOC_BH_adm + ALLOC_PAP_adm + ALLOC_PRIM_adm
#ifdef PAR
- ALLOC_FMBQ_adm + ALLOC_FME_adm + ALLOC_BF_adm +
+ + ALLOC_FMBQ_adm + ALLOC_FME_adm + ALLOC_BF_adm
#endif
- ALLOC_BH_adm + ALLOC_PAP_adm + ALLOC_PRIM_adm;
+ ;
unsigned long tot_gds_wds = /* total number of words of ``good stuff'' allocated */
- ALLOC_FUN_gds + ALLOC_THK_gds + ALLOC_CON_gds + ALLOC_TUP_gds +
- ALLOC_TSO_gds +
+ ALLOC_FUN_gds + ALLOC_THK_gds + ALLOC_CON_gds + ALLOC_TUP_gds
+ + ALLOC_TSO_gds + ALLOC_BH_gds + ALLOC_PAP_gds + ALLOC_PRIM_gds
#ifdef PAR
- ALLOC_FMBQ_gds + ALLOC_FME_gds + ALLOC_BF_gds +
+ + ALLOC_FMBQ_gds + ALLOC_FME_gds + ALLOC_BF_gds
#endif
-
- ALLOC_BH_gds + ALLOC_PAP_gds + ALLOC_PRIM_gds;
+ ;
unsigned long tot_slp_wds = /* total number of ``slop'' words allocated */
- ALLOC_FUN_slp + ALLOC_THK_slp + ALLOC_CON_slp + ALLOC_TUP_slp +
- ALLOC_TSO_slp +
+ ALLOC_FUN_slp + ALLOC_THK_slp + ALLOC_CON_slp + ALLOC_TUP_slp
+ + ALLOC_TSO_slp + ALLOC_BH_slp + ALLOC_PAP_slp + ALLOC_PRIM_slp
#ifdef PAR
- ALLOC_FMBQ_slp + ALLOC_FME_slp + ALLOC_BF_slp +
+ + ALLOC_FMBQ_slp + ALLOC_FME_slp + ALLOC_BF_slp
#endif
- ALLOC_BH_slp + ALLOC_PAP_slp + ALLOC_PRIM_slp;
+ ;
unsigned long tot_wds = /* total words */
tot_adm_wds + tot_gds_wds + tot_slp_wds;
unsigned long tot_fun_direct_enters = ENT_STATIC_FUN_DIRECT_ctr + ENT_DYN_FUN_DIRECT_ctr;
unsigned long tot_ind_enters = ENT_STATIC_IND_ctr + ENT_DYN_IND_ctr;
- // This is the number of function calls which went via a
- // slow/unknown application (one of the stg_ap_ functions).
- unsigned long tot_fun_slow_enters =
- SLOW_CALL_ctr - SLOW_CALL_BUILT_PAP_ctr - SLOW_CALL_NEW_PAP_ctr;
+ // This is the number of times we entered a function via some kind
+ // of slow call. It amounts to all the slow applications, not
+ // counting those that were to too few arguments.
+ unsigned long tot_fun_slow_enters =
+ SLOW_CALL_ctr -
+ SLOW_CALL_FUN_TOO_FEW_ctr -
+ SLOW_CALL_PAP_TOO_FEW_ctr;
+
+ unsigned long tot_known_calls =
+ KNOWN_CALL_ctr + KNOWN_CALL_TOO_FEW_ARGS_ctr +
+ + KNOWN_CALL_EXTRA_ARGS_ctr;
+ unsigned long tot_tail_calls =
+ UNKNOWN_CALL_ctr + tot_known_calls;
unsigned long tot_enters =
tot_con_enters + tot_fun_direct_enters +
ENT_PERM_IND_ctr,
PC(INTAVG(ENT_PERM_IND_ctr,tot_enters)));
- fprintf(tf,"\nCALLS: %ld of which %ld (%.lf%%) were slow/unknown calls\n\t\t [the rest went direct to the fast entry point]\n",
- tot_fun_direct_enters,
- tot_fun_slow_enters,
- PC(INTAVG(tot_fun_slow_enters,tot_fun_direct_enters))
- );
+ fprintf(tf,"\nFUNCTION ENTRIES: %ld\n", tot_fun_direct_enters);
+
+ fprintf(tf, "\nTAIL CALLS: %ld, of which %ld (%.lf%%) were to known functions\n",
+ tot_tail_calls, tot_known_calls,
+ PC(INTAVG(tot_known_calls,tot_tail_calls)));
+
+ fprintf(tf, "\nSLOW APPLICATIONS: %ld evaluated, %ld unevaluated\n",
+ SLOW_CALL_ctr, SLOW_CALL_UNEVALD_ctr);
+ fprintf(tf, "\n");
+ fprintf(tf, " Too few args Correct args Too many args\n");
+ fprintf(tf, " FUN %8ld %8ld %8ld\n",
+ SLOW_CALL_FUN_TOO_FEW_ctr, SLOW_CALL_FUN_CORRECT_ctr, SLOW_CALL_FUN_TOO_MANY_ctr);
+ fprintf(tf, " PAP %8ld %8ld %8ld\n",
+ SLOW_CALL_PAP_TOO_FEW_ctr, SLOW_CALL_PAP_CORRECT_ctr, SLOW_CALL_PAP_TOO_MANY_ctr);
+ fprintf(tf, "\n");
fprintf(tf,"\nRETURNS: %ld\n", tot_returns);
fprintf(tf,"%7ld (%5.1f%%) from entering a new constructor\n\t\t [the rest from entering an existing constructor]\n",
PR_CTR(ENT_STATIC_THK_ctr);
PR_CTR(ENT_DYN_THK_ctr);
+ PR_CTR(SLOW_CALL_v_ctr);
+ PR_CTR(SLOW_CALL_f_ctr);
+ PR_CTR(SLOW_CALL_d_ctr);
+ PR_CTR(SLOW_CALL_l_ctr);
+ PR_CTR(SLOW_CALL_n_ctr);
+ PR_CTR(SLOW_CALL_p_ctr);
+ PR_CTR(SLOW_CALL_pv_ctr);
+ PR_CTR(SLOW_CALL_pp_ctr);
+ PR_CTR(SLOW_CALL_ppv_ctr);
+ PR_CTR(SLOW_CALL_ppp_ctr);
+ PR_CTR(SLOW_CALL_pppv_ctr);
+ PR_CTR(SLOW_CALL_pppp_ctr);
+ PR_CTR(SLOW_CALL_ppppp_ctr);
+ PR_CTR(SLOW_CALL_pppppp_ctr);
+ PR_CTR(SLOW_CALL_OTHER_ctr);
+
+ PR_CTR(UNKNOWN_CALL_ctr);
+ PR_CTR(KNOWN_CALL_ctr);
+ PR_CTR(KNOWN_CALL_TOO_FEW_ARGS_ctr);
+ PR_CTR(KNOWN_CALL_EXTRA_ARGS_ctr);
+ PR_CTR(MULTI_CHUNK_SLOW_CALL_ctr);
+ PR_CTR(MULTI_CHUNK_SLOW_CALL_CHUNKS_ctr);
PR_CTR(SLOW_CALL_ctr);
- PR_CTR(SLOW_CALL_BUILT_PAP_ctr);
- PR_CTR(SLOW_CALL_NEW_PAP_ctr);
+ PR_CTR(SLOW_CALL_FUN_TOO_FEW_ctr);
+ PR_CTR(SLOW_CALL_FUN_CORRECT_ctr);
+ PR_CTR(SLOW_CALL_FUN_TOO_MANY_ctr);
+ PR_CTR(SLOW_CALL_PAP_TOO_FEW_ctr);
+ PR_CTR(SLOW_CALL_PAP_CORRECT_ctr);
+ PR_CTR(SLOW_CALL_PAP_TOO_MANY_ctr);
+ PR_CTR(SLOW_CALL_UNEVALD_ctr);
PR_HST(SLOW_CALL_hst,0);
PR_HST(SLOW_CALL_hst,1);
PR_HST(SLOW_CALL_hst,2);
if ( ticky_entry_ctrs != NULL ) {
fprintf(tf,"\n**************************************************\n\n");
}
- fprintf(tf, "%11s%11s%11s %6s%6s %-11s%-30s\n",
- "Entries", "Slow ent", "Allocs", "Arity", "Stack", "Kinds", "Function");
+ fprintf(tf, "%11s%11s %6s%6s %-11s%-30s\n",
+ "Entries", "Allocs", "Arity", "Stack", "Kinds", "Function");
fprintf(tf, "--------------------------------------------------------------------------------\n");
/* Function name at the end so it doesn't mess up the tabulation */
/* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.41 2003/07/28 15:57:40 simonmar Exp $
*
- * (c) The GHC Team, 1998-2002
+ * (c) The GHC Team, 1998-2004
*
* Code to perform updates.
*
+ * This file is written in a subset of C--, extended with various
+ * features specific to GHC. It is compiled by GHC directly. For the
+ * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
* ---------------------------------------------------------------------------*/
-#include "Stg.h"
-#include "Rts.h"
-#include "RtsUtils.h"
-#include "RtsFlags.h"
-#include "Storage.h"
-#if defined(GRAN) || defined(PAR)
-# include "FetchMe.h"
-#endif
+#include "Cmm.h"
+#include "Updates.h"
+#include "StgLdvProf.h"
/*
The update frame return address must be *polymorphic*, that means
/* on entry to the update code
(1) R1 points to the closure being returned
(2) Sp points to the update frame
- */
+*/
-/* The update fragment has been tuned so as to generate reasonable
+/* The update fragment has been tuned so as to generate good
code with gcc, which accounts for some of the strangeness in the
way it is written.
*/
#define UPD_FRAME_ENTRY_TEMPLATE(label,ind_info,ret) \
- STGFUN(label); \
- STGFUN(label) \
+ label \
{ \
- StgClosure *updatee; \
- FB_ \
+ W_ updatee; \
\
- updatee = ((StgUpdateFrame *)Sp)->updatee; \
+ updatee = StgUpdateFrame_updatee(Sp); \
\
/* remove the update frame from the stack */ \
- Sp += sizeofW(StgUpdateFrame); \
+ Sp = Sp + SIZEOF_StgUpdateFrame; \
\
/* ToDo: it might be a PAP, so we should check... */ \
- TICK_UPD_CON_IN_NEW(sizeW_fromITBL(get_itbl(updatee))); \
+ TICK_UPD_CON_IN_NEW(sizeW_fromITBL(%GET_STD_INFO(updatee))); \
\
- UPD_SPEC_IND(updatee, ind_info, R1.cl, JMP_(ret)); \
- FE_ \
+ UPD_SPEC_IND(updatee, ind_info, R1, jump (ret)); \
}
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_ret,&stg_IND_direct_info,ENTRY_CODE(Sp[0]));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_0_ret,&stg_IND_0_info,RET_VEC(Sp[0],0));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_1_ret,&stg_IND_1_info,RET_VEC(Sp[0],1));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_2_ret,&stg_IND_2_info,RET_VEC(Sp[0],2));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_3_ret,&stg_IND_3_info,RET_VEC(Sp[0],3));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_4_ret,&stg_IND_4_info,RET_VEC(Sp[0],4));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_5_ret,&stg_IND_5_info,RET_VEC(Sp[0],5));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_6_ret,&stg_IND_6_info,RET_VEC(Sp[0],6));
-UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_7_ret,&stg_IND_7_info,RET_VEC(Sp[0],7));
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_0_ret,stg_IND_0_info,%RET_VEC(Sp(0),0))
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_1_ret,stg_IND_1_info,%RET_VEC(Sp(0),1))
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_2_ret,stg_IND_2_info,%RET_VEC(Sp(0),2))
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_3_ret,stg_IND_3_info,%RET_VEC(Sp(0),3))
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_4_ret,stg_IND_4_info,%RET_VEC(Sp(0),4))
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_5_ret,stg_IND_5_info,%RET_VEC(Sp(0),5))
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_6_ret,stg_IND_6_info,%RET_VEC(Sp(0),6))
+UPD_FRAME_ENTRY_TEMPLATE(stg_upd_frame_7_ret,stg_IND_7_info,%RET_VEC(Sp(0),7))
+
+#if MAX_VECTORED_RTN > 8
+#error MAX_VECTORED_RTN has changed: please modify stg_upd_frame too.
+#endif
/*
Make sure this table is big enough to handle the maximum vectored
* there's a cost-centre-stack in there too).
*/
-VEC_POLY_INFO_TABLE( stg_upd_frame,
- MK_SMALL_BITMAP(UPD_FRAME_WORDS, UPD_FRAME_BITMAP),
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/,
- UPDATE_FRAME,, EF_);
+INFO_TABLE_RET( stg_upd_frame,
+ UPD_FRAME_WORDS, UPD_FRAME_BITMAP, UPDATE_FRAME,
+ stg_upd_frame_0_ret,
+ stg_upd_frame_1_ret,
+ stg_upd_frame_2_ret,
+ stg_upd_frame_3_ret,
+ stg_upd_frame_4_ret,
+ stg_upd_frame_5_ret,
+ stg_upd_frame_6_ret,
+ stg_upd_frame_7_ret
+ )
+UPD_FRAME_ENTRY_TEMPLATE(,stg_IND_direct_info,%ENTRY_CODE(Sp(0)))
/*-----------------------------------------------------------------------------
Seq frames
into a direct one.
-------------------------------------------------------------------------- */
-IF_(stg_seq_frame_ret);
-
-#define stg_seq_frame_0_ret stg_seq_frame_ret
-#define stg_seq_frame_1_ret stg_seq_frame_ret
-#define stg_seq_frame_2_ret stg_seq_frame_ret
-#define stg_seq_frame_3_ret stg_seq_frame_ret
-#define stg_seq_frame_4_ret stg_seq_frame_ret
-#define stg_seq_frame_5_ret stg_seq_frame_ret
-#define stg_seq_frame_6_ret stg_seq_frame_ret
-#define stg_seq_frame_7_ret stg_seq_frame_ret
-
-VEC_POLY_INFO_TABLE( stg_seq_frame,
- MK_SMALL_BITMAP(0, 0),
- 0/*srt*/, 0/*srt_off*/, 0/*srt_bitmap*/,
- RET_SMALL,, EF_);
+#if MAX_VECTORED_RTN > 8
+#error MAX_VECTORED_RTN has changed: please modify stg_seq_frame too.
+#endif
-IF_(stg_seq_frame_ret)
+INFO_TABLE_RET( stg_seq_frame, 0/* words */, 0/* bitmap */, RET_SMALL,
+ RET_LBL(stg_seq_frame), /* 0 */
+ RET_LBL(stg_seq_frame), /* 1 */
+ RET_LBL(stg_seq_frame), /* 2 */
+ RET_LBL(stg_seq_frame), /* 3 */
+ RET_LBL(stg_seq_frame), /* 4 */
+ RET_LBL(stg_seq_frame), /* 5 */
+ RET_LBL(stg_seq_frame), /* 6 */
+ RET_LBL(stg_seq_frame) /* 7 */
+ )
{
- FB_
- Sp ++;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
+ Sp_adj(1);
+ jump %ENTRY_CODE(Sp(0));
}
/* -----------------------------------------------------------------------------
- * $Id: Weak.c,v 1.31 2003/10/24 09:00:59 simonmar Exp $
+ * $Id: Weak.c,v 1.32 2004/08/13 13:11:13 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
while ((w = weak_ptr_list)) {
weak_ptr_list = w->link;
if (w->header.info != &stg_DEAD_WEAK_info) {
- w->header.info = &stg_DEAD_WEAK_info;
+ SET_HDR(w, &stg_DEAD_WEAK_info, w->header.prof.ccs);
IF_DEBUG(weak,fprintf(stderr,"Finalising weak pointer at %p -> %p\n", w, w->key));
if (w->finalizer != &stg_NO_FINALIZER_closure) {
rts_evalLazyIO(w->finalizer,NULL);
/* -----------------------------------------------------------------------------
- * $Id: Weak.h,v 1.4 1999/02/11 17:40:28 simonm Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2004
*
* Weak pointers / finalizers
*
* ---------------------------------------------------------------------------*/
-extern StgWeak *weak_ptr_list;
+#ifndef WEAK_H
+#define WEAK_H
void finalizeWeakPointersNow(void);
void scheduleFinalizers(StgWeak *w);
void markWeakList(void);
-
+#endif
-#include "config.h"
-#include "Derived.h"
+#include "ghcconfig.h"
+#include "RtsConfig.h"
/* The RTS is just another package! */
Package {
{-# OPTIONS -cpp #-}
module Main(main) where
-#include "../../includes/config.h"
+#include "../../includes/ghcconfig.h"
#include "../../includes/MachRegs.h"
+#include "../../includes/Constants.h"
+
#if __GLASGOW_HASKELL__ >= 504
import Text.PrettyPrint
import Data.Word
import Data.Bits
import Data.List ( intersperse )
-import Data.Char ( toUpper )
+import System.Exit
+import System.Environment
+import System.IO
#else
+import System
+import IO
import Bits
import Word
import Pretty
import List ( intersperse )
-import Char ( toUpper )
#endif
-
-- -----------------------------------------------------------------------------
-- Argument kinds (rougly equivalent to PrimRep)
-- -----------------------------------------------------------------------------
-- Registers
+data RegStatus = Registerised | Unregisterised
+
type Reg = String
-availableRegs :: ([Reg],[Reg],[Reg],[Reg])
-availableRegs =
+availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
+availableRegs Unregisterised = ([],[],[],[])
+availableRegs Registerised =
( vanillaRegs MAX_REAL_VANILLA_REG,
floatRegs MAX_REAL_FLOAT_REG,
doubleRegs MAX_REAL_DOUBLE_REG,
)
vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
-vanillaRegs n = [ "R" ++ show m ++ ".w" | m <- [2..n] ] -- never use R1
+vanillaRegs n = [ "R" ++ show m | m <- [2..n] ] -- never use R1
floatRegs n = [ "F" ++ show m | m <- [1..n] ]
doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
longRegs n = [ "L" ++ show m | m <- [1..n] ]
-- -----------------------------------------------------------------------------
-- Loading/saving register arguments to the stack
-loadRegArgs :: Int -> [ArgRep] -> (Doc,Int)
-loadRegArgs sp args = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp')
+loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
+loadRegArgs regstatus sp args
+ = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp')
where
- (reg_locs, sp') = assignRegs sp args
+ (reg_locs, _leftovers, sp') = assignRegs regstatus sp args
-- a bit like assignRegs in CgRetConv.lhs
assignRegs
- :: Int -- Sp of first arg
+ :: RegStatus -- are we registerised?
+ -> Int -- Sp of first arg
-> [ArgRep] -- args
- -> ([(Reg,Int)], Int) -- Sp and rest of args
-assignRegs sp args = assign sp args availableRegs []
+ -> ([(Reg,Int)], -- regs and offsets to load
+ [ArgRep], -- left-over args
+ Int) -- Sp of left-over args
+assignRegs regstatus sp args = assign sp args (availableRegs regstatus) []
-assign sp [] regs doc = (doc, sp)
+assign sp [] regs doc = (doc, [], sp)
assign sp (V : args) regs doc = assign sp args regs doc
assign sp (arg : args) regs doc
= case findAvailableReg arg regs of
Just (reg, regs') -> assign (sp + argSize arg) args regs'
((reg, sp) : doc)
- Nothing -> (doc, sp)
+ Nothing -> (doc, (arg:args), sp)
findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
Just (vreg, (vregs,fregs,dregs,lregs))
Just (lreg, (vregs,fregs,dregs,lregs))
findAvailableReg _ _ = Nothing
-assign_reg_to_stk reg@('F':_) sp
- = text "ASSIGN_FLT(Sp+" <> int sp <> comma <> text reg <> text ");"
-assign_reg_to_stk reg@('D':_) sp
- = text "ASSIGN_DBL(Sp+" <> int sp <> comma <> text reg <> text ");"
-assign_reg_to_stk reg@('L':_) sp
- = text "ASSIGN_Word64(Sp+" <> int sp <> comma <> text reg <> text ");"
assign_reg_to_stk reg sp
- = text "Sp[" <> int sp <> text "] = " <> text reg <> semi
-
-assign_stk_to_reg reg@('F':_) sp
- = text reg <> text " = " <> text "PK_FLT(Sp+" <> int sp <> text ");"
-assign_stk_to_reg reg@('D':_) sp
- = text reg <> text " = " <> text "PK_DBL(Sp+" <> int sp <> text ");"
-assign_stk_to_reg reg@('L':_) sp
- = text reg <> text " = " <> text "PK_Word64(Sp+" <> int sp <> text ");"
+ = loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi
+
assign_stk_to_reg reg sp
- = text reg <> text " = Sp[" <> int sp <> text "];"
+ = text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi
+
+regRep ('F':_) = "F_"
+regRep ('D':_) = "D_"
+regRep ('L':_) = "L_"
+regRep _ = "W_"
+loadSpWordOff :: String -> Int -> Doc
+loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
-- make a ptr/non-ptr bitmap from a list of argument types
mkBitmap :: [ArgRep] -> Word32
-- the args anyway (this might not be true of register-rich machines
-- when we start passing args to stg_ap_* in regs).
+mkApplyName args
+ = text "stg_ap_" <> text (map showArg args)
+
mkApplyRetName args
- = text "stg_ap_" <> text (map showArg args) <> text "_ret"
+ = mkApplyName args <> text "_ret"
mkApplyInfoName args
- = text "stg_ap_" <> text (map showArg args) <> text "_info"
+ = mkApplyName args <> text "_info"
-genMkPAP macro jump stack_apply is_pap args all_args_size fun_info_label
+genMkPAP regstatus macro jump ticker disamb stack_apply
+ is_pap args all_args_size fun_info_label
= smaller_arity_cases
$$ exact_arity_case
$$ larger_arity_case
let
(reg_doc, sp')
| stack_apply = (empty, arg_sp_offset)
- | otherwise = loadRegArgs arg_sp_offset these_args
+ | otherwise = loadRegArgs regstatus arg_sp_offset these_args
in
nest 4 (vcat [
+ text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
reg_doc,
vcat [ shuffle_down j | j <- [sp'..these_args_size] ],
- text "Sp[" <> int these_args_size <> text "] = (W_)&" <>
+ loadSpWordOff "W_" these_args_size <> text " = " <>
mkApplyInfoName rest_args <> semi,
- text "Sp += " <> int (sp' - 1) <> semi,
+ text "Sp_adj(" <> int (sp' - 1) <> text ");",
-- for a PAP, we have to arrange that the stack contains a
-- return address in the even that stg_PAP_entry fails its
-- heap check. See stg_PAP_entry in Apply.hc for details.
if is_pap
- then text "R2.w = (W_)&" <> mkApplyInfoName these_args <> semi
+ then text "R2 = " <> mkApplyInfoName these_args <> semi
else empty,
- text "JMP_" <> parens (text jump) <> semi
+ text "jump " <> text jump <> semi
]) $$
text "}"
where
these_args_size = sum (map argSize these_args)
shuffle_down i =
- text "Sp[" <> int (i-1) <> text "] = Sp["
- <> int i <> text "];"
+ loadSpWordOff "W_" (i-1) <> text " = " <>
+ loadSpWordOff "W_" i <> semi
-- The EXACT ARITY case
--
let
(reg_doc, sp')
| stack_apply = (empty, arg_sp_offset)
- | otherwise = loadRegArgs arg_sp_offset args
+ | otherwise = loadRegArgs regstatus arg_sp_offset args
in
nest 4 (vcat [
+ text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
reg_doc,
- text "Sp += " <> int sp' <> semi,
+ text "Sp_adj(" <> int sp' <> text ");",
if is_pap
- then text "R2.w = (W_)&" <> fun_info_label <> semi
+ then text "R2 = " <> fun_info_label <> semi
else empty,
- text "JMP_" <> parens (text jump) <> semi
+ text "jump " <> text jump <> semi
])
-- The LARGER ARITY cases:
larger_arity_case =
text "} else {" $$
- nest 4 (
+ nest 4 (vcat [
+ text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
text macro <> char '(' <> int n_args <> comma <>
int all_args_size <>
- text ",(W_)&" <> fun_info_label <>
+ text "," <> fun_info_label <>
+ text "," <> text disamb <>
text ");"
- ) $$
+ ]) $$
char '}'
-- -----------------------------------------------------------------------------
-- args is a list of 'p', 'n', 'f', 'd' or 'l'
-genApply args =
+genApply regstatus args =
let
fun_ret_label = mkApplyRetName args
fun_info_label = mkApplyInfoName args
all_args_size = sum (map argSize args)
in
vcat [
- text "INFO_TABLE_RET(" <> fun_info_label <> text "," <>
- fun_ret_label <> text "," <>
- text "MK_SMALL_BITMAP(" <> int all_args_size <> text "/*framsize*/," <>
- int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/), " <>
- text "0,0,0,RET_SMALL,,EF_,0,0);",
- text "",
- text "F_ " <> fun_ret_label <> text "( void )\n{",
+ text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
+ int all_args_size <> text "/*framsize*/," <>
+ int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/, " <>
+ text "RET_SMALL)\n{",
nest 4 (vcat [
- text "StgInfoTable *info;",
- text "nat arity;",
+ text "W_ info;",
+ text "W_ arity;",
-- if fast == 1:
-- print "static void *lbls[] ="
-- print " [IND_OLDGEN_PERM] &&ind_lbl"
-- print " };"
- text "FB_",
text "",
- text "IF_DEBUG(apply,fprintf(stderr, \"" <> fun_ret_label <>
- text "... \"); printClosure(R1.cl));",
+ text "IF_DEBUG(apply,foreign \"C\" fprintf(stderr, \"" <> fun_ret_label <>
+ text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",
- text "IF_DEBUG(sanity,checkStackFrame(Sp+" <> int (1 + all_args_size)
- <> text "));",
+ text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
+ <> text ")\"ptr\"));",
-- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
-- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
do_assert (arg:args) offset
| isPtr arg = this : rest
| otherwise = rest
- where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp["
- <> int offset <> text "]));"
+ where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
+ <> int offset <> text ")));"
rest = do_assert args (offset + argSize arg)
in
vcat (do_assert args 1),
-
+
text "again:",
- text "info = get_itbl(R1.cl);",
+ text "info = %GET_STD_INFO(R1);",
-- if fast == 1:
-- print " goto *lbls[info->type];";
-- else:
- text "switch (info->type) {" $$
- nest 4 (vcat [
+ text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(info)) {",
+ nest 4 (vcat [
-- if fast == 1:
-- print " bco_lbl:"
-- else:
- text "case BCO:",
+ text "case BCO: {",
nest 4 (vcat [
- text "arity = ((StgBCO *)R1.p)->arity;",
+ text "arity = TO_W_(StgBCO_arity(R1));",
text "ASSERT(arity > 0);",
- genMkPAP "BUILD_PAP" "stg_BCO_entry"
+ genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO"
True{-stack apply-} False{-not a PAP-}
args all_args_size fun_info_label
]),
+ text "}",
-- if fast == 1:
-- print " fun_lbl:"
-- else:
- text "case FUN:",
- text "case FUN_1_0:",
- text "case FUN_0_1:",
- text "case FUN_2_0:",
- text "case FUN_1_1:",
- text "case FUN_0_2:",
- text "case FUN_STATIC:",
+ text "case FUN,",
+ text " FUN_1_0,",
+ text " FUN_0_1,",
+ text " FUN_2_0,",
+ text " FUN_1_1,",
+ text " FUN_0_2,",
+ text " FUN_STATIC: {",
nest 4 (vcat [
- text "arity = itbl_to_fun_itbl(info)->arity;",
+ text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
text "ASSERT(arity > 0);",
- genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)"
+ genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN"
False{-reg apply-} False{-not a PAP-}
args all_args_size fun_info_label
]),
+ text "}",
-- if fast == 1:
-- print " pap_lbl:"
-- else:
- text "case PAP:",
+ text "case PAP: {",
nest 4 (vcat [
- text "arity = ((StgPAP *)R1.p)->arity;",
+ text "arity = TO_W_(StgPAP_arity(R1));",
text "ASSERT(arity > 0);",
- genMkPAP "NEW_PAP" "stg_PAP_entry"
+ genMkPAP regstatus "NEW_PAP" "ENTRY_LBL(stg_PAP)" "PAP" "PAP"
True{-stack apply-} True{-is a PAP-}
args all_args_size fun_info_label
]),
+ text "}",
text "",
-- if fast == 1:
-- print " thunk_lbl:"
-- else:
- text "case AP:",
- text "case AP_STACK:",
- text "case CAF_BLACKHOLE:",
- text "case BLACKHOLE:",
- text "case BLACKHOLE_BQ:",
- text "case SE_BLACKHOLE:",
- text "case SE_CAF_BLACKHOLE:",
- text "case THUNK:",
- text "case THUNK_1_0:",
- text "case THUNK_0_1:",
- text "case THUNK_2_0:",
- text "case THUNK_1_1:",
- text "case THUNK_0_2:",
- text "case THUNK_STATIC:",
- text "case THUNK_SELECTOR:",
+ text "case AP,",
+ text " AP_STACK,",
+ text " CAF_BLACKHOLE,",
+ text " BLACKHOLE,",
+ text " BLACKHOLE_BQ,",
+ text " SE_BLACKHOLE,",
+ text " SE_CAF_BLACKHOLE,",
+ text " THUNK,",
+ text " THUNK_1_0,",
+ text " THUNK_0_1,",
+ text " THUNK_2_0,",
+ text " THUNK_1_1,",
+ text " THUNK_0_2,",
+ text " THUNK_STATIC,",
+ text " THUNK_SELECTOR: {",
nest 4 (vcat [
- text "Sp[0] = (W_)&" <> fun_info_label <> text ";",
- text "JMP_(GET_ENTRY(R1.cl));",
+ text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
+ text "Sp(0) = " <> fun_info_label <> text ";",
+ text "jump %GET_ENTRY(R1);",
text ""
]),
+ text "}",
-- if fast == 1:
-- print " ind_lbl:"
-- else:
- text "case IND:",
- text "case IND_OLDGEN:",
- text "case IND_STATIC:",
- text "case IND_PERM:",
- text "case IND_OLDGEN_PERM:",
+ text "case IND,",
+ text " IND_OLDGEN,",
+ text " IND_STATIC,",
+ text " IND_PERM,",
+ text " IND_OLDGEN_PERM: {",
nest 4 (vcat [
- text "R1.cl = ((StgInd *)R1.p)->indirectee;",
+ text "R1 = StgInd_indirectee(R1);",
text "goto again;"
]),
+ text "}",
text "",
-- if fast == 0:
- text "default:",
+ text "default: {",
nest 4 (
- text "barf(\"" <> fun_ret_label <> text "\");"
+ text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\");"
),
text "}"
- ])
+ ]),
+ text "}"
]),
- text "FE_",
text "}"
]
mkStackApplyEntryLabel:: [ArgRep] -> Doc
mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
-genStackApply :: [ArgRep] -> Doc
-genStackApply args =
+genStackApply :: RegStatus -> [ArgRep] -> Doc
+genStackApply regstatus args =
let fn_entry_label = mkStackApplyEntryLabel args in
vcat [
- text "IF_" <> parens fn_entry_label,
- text "{",
- nest 4 (text "FB_" $$ body $$ text "FE_"),
- text "}"
+ fn_entry_label,
+ text "{", nest 4 body, text "}"
]
where
- (assign_regs, sp') = loadRegArgs 0 args
+ (assign_regs, sp') = loadRegArgs regstatus 0 args
body = vcat [assign_regs,
- text "Sp += " <> int sp' <> semi,
- text "JMP_(GET_ENTRY(R1.cl));"
+ text "Sp_adj" <> parens (int sp') <> semi,
+ text "jump %GET_ENTRY(R1);"
]
-- -----------------------------------------------------------------------------
mkStackSaveEntryLabel :: [ArgRep] -> Doc
mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
-genStackSave :: [ArgRep] -> Doc
-genStackSave args =
+genStackSave :: RegStatus -> [ArgRep] -> Doc
+genStackSave regstatus args =
let fn_entry_label= mkStackSaveEntryLabel args in
vcat [
- text "IF_" <> parens fn_entry_label,
- text "{",
- nest 4 (text "FB_" $$ body $$ text "FE_"),
- text "}"
+ fn_entry_label,
+ text "{", nest 4 body, text "}"
]
where
- body = vcat [text "Sp -= " <> int sp_offset <> semi,
+ body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
vcat (map (uncurry assign_reg_to_stk) reg_locs),
- text "Sp[2] = R1.w;",
- text "Sp[1] =" <+> int (sp_offset - std_frame_size) <> semi,
- text "Sp[0] = (W_)&stg_gc_fun_info;",
- text "JMP_(stg_gc_noregs);"
+ text "Sp(2) = R1;",
+ text "Sp(1) =" <+> int stk_args <> semi,
+ text "Sp(0) = stg_gc_fun_info;",
+ text "jump stg_gc_noregs;"
]
std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
-- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
- (reg_locs, sp_offset) = assignRegs std_frame_size args
+ (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
+
+ -- number of words of arguments on the stack.
+ stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
-- -----------------------------------------------------------------------------
-- The prologue...
-main = putStr (render the_code)
- where the_code = vcat [
+main = do
+ args <- getArgs
+ regstatus <- case args of
+ [] -> return Registerised
+ ["-u"] -> return Unregisterised
+ _other -> do hPutStrLn stderr "syntax: genapply [-u]"
+ exitWith (ExitFailure 1)
+ let the_code = vcat [
text "// DO NOT EDIT!",
text "// Automatically generated by GenApply.hs",
text "",
- text "#include \"Stg.h\"",
- text "#include \"Rts.h\"",
- text "#include \"RtsFlags.h\"",
- text "#include \"Storage.h\"",
- text "#include \"RtsUtils.h\"",
- text "#include \"Printer.h\"",
- text "#include \"Sanity.h\"",
- text "#include \"Apply.h\"",
+ text "#include \"Cmm.h\"",
+ text "#include \"AutoApply.h\"",
text "",
- text "#include <stdio.h>",
- vcat (intersperse (text "") $ map genApply applyTypes),
- vcat (intersperse (text "") $ map genStackFns stackApplyTypes),
+ vcat (intersperse (text "") $
+ map (genApply regstatus) applyTypes),
+ vcat (intersperse (text "") $
+ map (genStackFns regstatus) stackApplyTypes),
genStackApplyArray stackApplyTypes,
genStackSaveArray stackApplyTypes,
text "" -- add a newline at the end of the file
]
+ -- in
+ putStr (render the_code)
-- These have been shown to cover about 99% of cases in practice...
applyTypes = [
[P,P],
[P,P,V],
[P,P,P],
+ [P,P,P,V],
[P,P,P,P],
[P,P,P,P,P],
- [P,P,P,P,P,P],
- [P,P,P,P,P,P,P]
+ [P,P,P,P,P,P]
]
-- No need for V args in the stack apply cases.
[P,P,P,P,P,P,P,P]
]
-genStackFns args = genStackApply args $$ genStackSave args
+genStackFns regstatus args
+ = genStackApply regstatus args
+ $$ genStackSave regstatus args
genStackApplyArray types =
- text "StgFun *stg_ap_stack_entries[] = {" $$
- vcat (map arr_ent types) $$
- text "};"
+ vcat [
+ text "section \"rodata\" {",
+ text "stg_ap_stack_entries:",
+ text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
+ vcat (map arr_ent types),
+ text "}"
+ ]
where
- arr_ent ty = brackets (arg_const ty) <+> mkStackApplyEntryLabel ty <> comma
+ arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
genStackSaveArray types =
- text "StgFun *stg_stack_save_entries[] = {" $$
- vcat (map arr_ent types) $$
- text "};"
+ vcat [
+ text "section \"rodata\" {",
+ text "stg_stack_save_entries:",
+ text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
+ vcat (map arr_ent types),
+ text "}"
+ ]
where
- arr_ent ty = brackets (arg_const ty) <+> mkStackSaveEntryLabel ty <> comma
+ arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
genBitmapArray :: [[ArgRep]] -> Doc
genBitmapArray types =
vcat [
- text "StgWord stg_arg_bitmaps[] = {",
+ text "section \"rodata\" {",
+ text "stg_arg_bitmaps:",
+ text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
vcat (map gen_bitmap types),
- text "};"
+ text "}"
]
where
- gen_bitmap ty = brackets (arg_const ty) <+>
- text "MK_SMALL_BITMAP" <> parens (
- int (sum (map argSize ty)) <> comma <>
- text (show (mkBitmap ty))) <>
- comma
-
-arg_const ty = text "ARG_" <> text (map toUpper (map showArg ty))
+ gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
+ where bitmap_val =
+ (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
+ .|. sum (map argSize ty)
import ParsePkgConfLite
-#include "../../includes/config.h"
+#include "../../includes/ghcconfig.h"
#ifdef mingw32_HOST_OS
import Foreign
#ifndef MAIN_H
#define MAIN_H
-#include "config.h"
+#include "../includes/ghcconfig.h"
#ifdef __STDC__
#define PROTO(x) x
{-# OPTIONS -fffi -cpp #-}
------------------------------------------------------------------------
--- $Id: Main.hs,v 1.59 2004/08/12 12:12:54 simonmar Exp $
+-- $Id: Main.hs,v 1.60 2004/08/13 13:11:21 simonmar Exp $
--
-- Program for converting .hsc files to .hs files, by converting the
-- file into a C program which is run to generate the Haskell source.
/* ------------------------------------------------------------------------
- * $Id: cgprof.c,v 1.5 2004/07/09 16:47:59 sof Exp $
+ * $Id: cgprof.c,v 1.6 2004/08/13 13:11:22 simonmar Exp $
*
* Copyright (C) 1995-2000 University of Oxford
*
* form, be without fee and subject to these same conditions.
* --------------------------------------------------------------------- */
-#include "config.h"
+#include "ghcconfig.h"
#if HAVE_STRING_H
#include <string.h>
#endif
/* ------------------------------------------------------------------------
- * $Id: main.c,v 1.2 2003/08/01 14:50:50 panne Exp $
+ * $Id: main.c,v 1.3 2004/08/13 13:11:23 simonmar Exp $
*
* Copyright (C) 1995-2000 University of Oxford
*
* form, be without fee and subject to these same conditions.
* --------------------------------------------------------------------- */
-#include "config.h"
+#include "ghcconfig.h"
#include <stdio.h>
projects / ghc-hetmet.git / commitdiff