diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index aecfcbd1b03eae198ca01125e380f68ee2a3b21e..55a455e0b8493bb94d56493ecf24e34248a93091 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -95,17 +95,19 @@ hsSyn/HsTypes.lhs \
hsSyn/HsSyn.lhs
#define NOT_SO_BASICSRCS_LHS \
-basicTypes/Unique.lhs \
-basicTypes/UniqSupply.lhs \
-basicTypes/ProtoName.lhs \
-basicTypes/Name.lhs \
-basicTypes/NameTypes.lhs \
-basicTypes/SrcLoc.lhs \
+basicTypes/FieldLabel.lhs \
basicTypes/Id.lhs \
basicTypes/IdInfo.lhs \
basicTypes/IdUtils.lhs \
-basicTypes/PragmaInfo.lhs \
basicTypes/Literal.lhs \
+basicTypes/Name.lhs \
+basicTypes/NameTypes.lhs \
+basicTypes/PprEnv.lhs \
+basicTypes/PragmaInfo.lhs \
+basicTypes/ProtoName.lhs \
+basicTypes/SrcLoc.lhs \
+basicTypes/UniqSupply.lhs \
+basicTypes/Unique.lhs \
\
types/Class.lhs \
types/Kind.lhs \
@@ -181,6 +183,22 @@ deSugar/DsUtils.lhs \
coreSyn/CoreLift.lhs \
coreSyn/CoreLint.lhs
+#if GhcWithDeforester != YES
+#define __omit_deforester_flag -DOMIT_DEFORESTER=1
+#define DEFORESTER_SRCS_LHS /*none*/
+#else
+#define __omit_deforester_flag /*nope*/
+#define DEFORESTER_SRCS_LHS \
+deforest/DefSyn.lhs \
+deforest/Core2Def.lhs \
+deforest/Def2Core.lhs \
+deforest/Deforest.lhs \
+deforest/DefUtils.lhs \
+deforest/DefExpr.lhs \
+deforest/Cyclic.lhs \
+deforest/TreelessForm.lhs
+#endif /* GhcWithDeforester */
+
#define SIMPL_SRCS_LHS \
coreSyn/AnnCoreSyn.lhs \
coreSyn/FreeVars.lhs \
@@ -215,30 +233,14 @@ stranal/SaAbsInt.lhs \
stranal/WwLib.lhs \
stranal/WorkWrap.lhs \
\
-profiling/SCCauto.lhs \
-profiling/SCCfinal.lhs
+profiling/SCCauto.lhs DEFORESTER_SRCS_LHS
-#if GhcWithDeforester != YES
-#define __omit_deforester_flag -DOMIT_DEFORESTER=1
-#define DEFORESTER_SRCS_LHS /*none*/
-#else
-#define __omit_deforester_flag /*nope*/
-#define DEFORESTER_SRCS_LHS \
-deforest/DefSyn.lhs \
-deforest/Core2Def.lhs \
-deforest/Def2Core.lhs \
-deforest/Deforest.lhs \
-deforest/DefUtils.lhs \
-deforest/DefExpr.lhs \
-deforest/Cyclic.lhs \
-deforest/TreelessForm.lhs
-#endif /* GhcWithDeforester */
-
-#define BACKSRCS_LHS \
+#define STG_SRCS_LHS \
stgSyn/CoreToStg.lhs \
stgSyn/StgSyn.lhs \
stgSyn/StgUtils.lhs \
stgSyn/StgLint.lhs \
+profiling/SCCfinal.lhs \
\
simplStg/SatStgRhs.lhs \
simplStg/LambdaLift.lhs \
@@ -247,8 +249,9 @@ simplStg/UpdAnal.lhs \
simplStg/StgStats.lhs \
simplStg/StgSATMonad.lhs \
simplStg/StgSAT.lhs \
-simplStg/SimplStg.lhs \
-\
+simplStg/SimplStg.lhs
+
+#define BACKSRCS_LHS \
absCSyn/AbsCUtils.lhs \
absCSyn/AbsCSyn.lhs \
absCSyn/CLabel.lhs \
@@ -283,36 +286,21 @@ codeGen/CgUpdate.lhs
# define NATIVEGEN_SRCS_LHS /*none*/
#else
# define __omit_ncg_maybe /*none*/
-# if i386_TARGET_ARCH
-# define __machdep_nativegen_lhs \
-nativeGen/I386Desc.lhs \
-nativeGen/I386Code.lhs \
-nativeGen/I386Gen.lhs
-# endif
-# if sparc_TARGET_ARCH
-# define __machdep_nativegen_lhs \
-nativeGen/SparcDesc.lhs \
-nativeGen/SparcCode.lhs \
-nativeGen/SparcGen.lhs
-# endif
-# if alpha_TARGET_ARCH
-# define __machdep_nativegen_lhs \
-nativeGen/AlphaDesc.lhs \
-nativeGen/AlphaCode.lhs \
-nativeGen/AlphaGen.lhs
-# endif
# define NATIVEGEN_SRCS_LHS \
nativeGen/AbsCStixGen.lhs \
nativeGen/AsmCodeGen.lhs \
nativeGen/AsmRegAlloc.lhs \
-nativeGen/MachDesc.lhs \
+nativeGen/MachCode.lhs \
+nativeGen/MachMisc.lhs \
+nativeGen/MachRegs.lhs \
+nativeGen/PprMach.lhs \
+nativeGen/RegAllocInfo.lhs \
nativeGen/Stix.lhs \
nativeGen/StixInfo.lhs \
nativeGen/StixInteger.lhs \
nativeGen/StixPrim.lhs \
-nativeGen/StixMacro.lhs \
-__machdep_nativegen_lhs /*arch-specific ones */
+nativeGen/StixMacro.lhs
#endif
#define UTILSRCS_LHS \
@@ -366,22 +354,20 @@ simplCore/MagicUFs.lhs
ALLSRCS_HS = READERSRCS_HS
ALLSRCS_LHS = /* all pieces of the compiler */ \
-VBASICSRCS_LHS \
-NOT_SO_BASICSRCS_LHS \
-UTILSRCS_LHS \
-MAIN_SRCS_LHS \
-READERSRCS_LHS \
-RENAMERSRCS_LHS \
-TCSRCS_LHS \
-DSSRCS_LHS
+VBASICSRCS_LHS \
+NOT_SO_BASICSRCS_LHS \
+UTILSRCS_LHS \
+MAIN_SRCS_LHS \
+READERSRCS_LHS \
+RENAMERSRCS_LHS \
+TCSRCS_LHS \
+DSSRCS_LHS \
+SIMPL_SRCS_LHS \
+STG_SRCS_LHS \
+BACKSRCS_LHS NATIVEGEN_SRCS_LHS
/*
-SIMPL_SRCS_LHS
-BACKSRCS_LHS
*/
-
-/*
-NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS */
/* NB: all the ones that may be empty (e.g., NATIVEGEN_SRCS_LHS)
need to be on the last line.
*/
@@ -405,13 +391,6 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
#define __version_sensitive_flags -fomit-reexported-instances
#endif
-#if GhcWithRegisterised == NO
- /* doing a raw boot from .hc files, presumably */
-#define __unreg_opts_maybe -O -unregisterised
-#else
-#define __unreg_opts_maybe /*none*/
-#endif
-
/* avoid use of AllProjectsHcOpts; then put in HcMaxHeapFlag "by hand" */
#undef AllProjectsHcOpts
#define AllProjectsHcOpts /**/
@@ -419,10 +398,9 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
HC_OPTS = -cpp HcMaxHeapFlag -fhaskell-1.3 -fglasgow-exts -DCOMPILING_GHC \
-fomit-derived-read \
-I. -i$(SUBDIR_LIST) \
- use_DDEBUG __version_sensitive_flags __unreg_opts_maybe __omit_ncg_maybe
+ use_DDEBUG __version_sensitive_flags __omit_ncg_maybe __omit_deforester_flag
#undef __version_sensitive_flags
-#undef __unreg_opts_maybe
#undef __omit_ncg_maybe
#undef __omit_deforester_flag
@@ -505,14 +483,22 @@ HaskellCompileWithExtraFlags_Recursive(module,isuf,o,-c,extra_flags)
utils/Ubiq.hi : utils/Ubiq.lhi
$(GHC_UNLIT) utils/Ubiq.lhi utils/Ubiq.hi
+absCSyn/AbsCLoop.hi : absCSyn/AbsCLoop.lhi
+ $(GHC_UNLIT) absCSyn/AbsCLoop.lhi absCSyn/AbsCLoop.hi
basicTypes/IdLoop.hi : basicTypes/IdLoop.lhi
$(GHC_UNLIT) basicTypes/IdLoop.lhi basicTypes/IdLoop.hi
basicTypes/NameLoop.hi : basicTypes/NameLoop.lhi
$(GHC_UNLIT) basicTypes/NameLoop.lhi basicTypes/NameLoop.hi
+codeGen/CgLoop1.hi : codeGen/CgLoop1.lhi
+ $(GHC_UNLIT) codeGen/CgLoop1.lhi codeGen/CgLoop1.hi
+codeGen/CgLoop2.hi : codeGen/CgLoop2.lhi
+ $(GHC_UNLIT) codeGen/CgLoop2.lhi codeGen/CgLoop2.hi
deSugar/DsLoop.hi : deSugar/DsLoop.lhi
$(GHC_UNLIT) deSugar/DsLoop.lhi deSugar/DsLoop.hi
hsSyn/HsLoop.hi : hsSyn/HsLoop.lhi
$(GHC_UNLIT) hsSyn/HsLoop.lhi hsSyn/HsLoop.hi
+nativeGen/NcgLoop.hi : nativeGen/NcgLoop.lhi
+ $(GHC_UNLIT) nativeGen/NcgLoop.lhi nativeGen/NcgLoop.hi
prelude/PrelLoop.hi : prelude/PrelLoop.lhi
$(GHC_UNLIT) prelude/PrelLoop.lhi prelude/PrelLoop.hi
reader/RdrLoop.hi : reader/RdrLoop.lhi
@@ -548,12 +534,14 @@ compile(hsSyn/HsPragmas,lhs,)
compile(hsSyn/HsTypes,lhs,)
compile(hsSyn/HsSyn,lhs,if_ghc(-fno-omit-reexported-instances))
+compile(basicTypes/FieldLabel,lhs,)
compile(basicTypes/Id,lhs,)
compile(basicTypes/IdInfo,lhs,-K2m)
compile(basicTypes/IdUtils,lhs,)
compile(basicTypes/Literal,lhs,)
compile(basicTypes/Name,lhs,)
compile(basicTypes/NameTypes,lhs,)
+compile(basicTypes/PprEnv,lhs,)
compile(basicTypes/PragmaInfo,lhs,)
compile(basicTypes/ProtoName,lhs,)
compile(basicTypes/SrcLoc,lhs,)
@@ -611,27 +599,16 @@ compile(main/MkIface,lhs,)
compile(nativeGen/AbsCStixGen,lhs,)
compile(nativeGen/AsmCodeGen,lhs,-I$(COMPINFO_DIR))
compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR))
-compile(nativeGen/MachDesc,lhs,)
+compile(nativeGen/MachCode,lhs,)
+compile(nativeGen/MachMisc,lhs,)
+compile(nativeGen/MachRegs,lhs,)
+compile(nativeGen/PprMach,lhs,)
+compile(nativeGen/RegAllocInfo,lhs,)
compile(nativeGen/Stix,lhs,)
compile(nativeGen/StixInfo,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/StixInteger,lhs,)
compile(nativeGen/StixMacro,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/StixPrim,lhs,)
-# if i386_TARGET_ARCH
-compile(nativeGen/I386Desc,lhs,)
-compile(nativeGen/I386Code,lhs,-I$(NATIVEGEN_DIR) if_ghc(-monly-4-regs))
-compile(nativeGen/I386Gen,lhs,)
-# endif
-# if sparc_TARGET_ARCH
-compile(nativeGen/SparcDesc,lhs,)
-compile(nativeGen/SparcCode,lhs,-I$(NATIVEGEN_DIR))
-compile(nativeGen/SparcGen,lhs,)
-# endif
-# if alpha_TARGET_ARCH
-compile(nativeGen/AlphaDesc,lhs,)
-compile(nativeGen/AlphaCode,lhs,-I$(NATIVEGEN_DIR))
-compile(nativeGen/AlphaGen,lhs,)
-# endif
#endif
compile(prelude/PrelInfo,lhs,)
@@ -923,7 +900,7 @@ compile(parser/U_ttype,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
/* *** misc *************************************************** */
-DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS) SIMPL_SRCS_LHS
+DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS)
#if GhcWithHscBuiltViaC == NO
MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
diff --git a/ghc/compiler/absCSyn/AbsCLoop.lhi b/ghc/compiler/absCSyn/AbsCLoop.lhi
new file mode 100644
index 0000000000000000000000000000000000000000..2d5f61d85da8e56020bd8cbe36ec07936d3abe04
--- /dev/null
+++ b/ghc/compiler/absCSyn/AbsCLoop.lhi
@@ -0,0 +1,50 @@
+Breaks the loop caused by PprAbsC needing to
+see big swathes of ClosureInfo.
+
+Also from CLabel needing a couple of CgRetConv things.
+
+Also from HeapOffs needing some MachMisc things.
+
+\begin{code}
+interface AbsCLoop where
+import PreludeStdIO ( Maybe )
+
+import CgRetConv ( ctrlReturnConvAlg,
+ CtrlReturnConvention(..)
+ )
+import ClosureInfo ( closureKind, closureLabelFromCI,
+ closureNonHdrSize, closurePtrsSize,
+ closureSMRep, closureSemiTag,
+ closureSizeWithoutFixedHdr,
+ closureTypeDescr, closureUpdReqd,
+ infoTableLabelFromCI, maybeSelectorInfo,
+ entryLabelFromCI,fastLabelFromCI,
+ ClosureInfo
+ )
+import CLabel ( CLabel )
+import HeapOffs ( HeapOffset )
+import Id ( Id(..) )
+import MachMisc ( fixedHdrSizeInWords, varHdrSizeInWords )
+import SMRep ( SMRep )
+import TyCon ( TyCon )
+
+closureKind :: ClosureInfo -> [Char]
+closureLabelFromCI :: ClosureInfo -> CLabel
+closureNonHdrSize :: ClosureInfo -> Int
+closurePtrsSize :: ClosureInfo -> Int
+closureSMRep :: ClosureInfo -> SMRep
+closureSemiTag :: ClosureInfo -> Int
+closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
+closureTypeDescr :: ClosureInfo -> [Char]
+closureUpdReqd :: ClosureInfo -> Bool
+entryLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI :: ClosureInfo -> CLabel
+infoTableLabelFromCI :: ClosureInfo -> CLabel
+maybeSelectorInfo :: ClosureInfo -> Maybe (Id, Int)
+
+ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
+data CtrlReturnConvention = VectoredReturn Int | UnvectoredReturn Int
+
+fixedHdrSizeInWords :: Int
+varHdrSizeInWords :: SMRep -> Int
+\end{code}
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index f23614d5aaf674111fa7abbf8efbc5a3ad4e04ee..c36e26e6ff31d2fef3a7adec7fd24118005f092e 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -14,7 +14,7 @@ raw assembler/machine code.
\begin{code}
#include "HsVersions.h"
-module AbsCSyn (
+module AbsCSyn {- (
-- export everything
AbstractC(..),
CStmtMacro(..),
@@ -26,68 +26,37 @@ module AbsCSyn (
mkAbsCStmtList,
mkCCostCentre,
- -- HeapOffsets, plus some convenient synonyms...
- HeapOffset,
- zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize,
- maxOff, addOff, subOff, intOffsetIntoGoods,
- isZeroOff, possiblyEqualHeapOffset,
- pprHeapOffset,
- VirtualHeapOffset(..), HpRelOffset(..),
- VirtualSpAOffset(..), VirtualSpBOffset(..),
- SpARelOffset(..), SpBRelOffset(..),
-
-- RegRelatives
RegRelative(..),
-- registers
MagicId(..), node, infoptr,
- isVolatileReg,
-
- -- closure info
- ClosureInfo, LambdaFormInfo, UpdateFlag, SMRep,
-
- -- stuff from AbsCUtils and PprAbsC...
- nonemptyAbsC, flattenAbsC, getAmodeRep,
- mixedTypeLocn, mixedPtrLocn,
- writeRealC,
- dumpRealC,
- kindFromMagicId,
- amodeCanSurviveGC
+ isVolatileReg, noLiveRegsMask, mkLiveRegsMask
#ifdef GRAN
, CostRes(Cost)
#endif
+ )-} where
- -- and stuff to make the interface self-sufficient
- ) where
-
-import AbsCUtils -- used, and re-exported
-import ClosureInfo -- ditto
-import Costs
-import PprAbsC -- ditto
-import HeapOffs hiding ( hpRelToInt )
+import Ubiq{-uitous-}
-import PrelInfo ( PrimOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG,
+ mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
+ lIVENESS_R3, lIVENESS_R4, lIVENESS_R5,
+ lIVENESS_R6, lIVENESS_R7, lIVENESS_R8
)
-import Literal ( mkMachInt, mkMachWord, Literal(..) )
-import CLabel
-import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG )
-import CostCentre -- for CostCentre type
-import Id ( Id, ConTag(..), DataCon(..) )
-import Maybes ( Maybe )
-import Outputable
-import PrimRep ( PrimRep(..) )
-import StgSyn ( GenStgExpr, GenStgArg, StgBinderInfo )
-import UniqSet ( UniqSet(..), UniqFM )
-import Unpretty -- ********** NOTE **********
-import Util
+import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..),
+ VirtualHeapOffset(..)
+ )
+import Literal ( mkMachInt )
+import PrimRep ( isFollowableRep, PrimRep(..) )
\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}
+absCNop = AbsCNop
+
data AbstractC
= AbsCNop
| AbsCStmts AbstractC AbstractC
@@ -436,7 +405,6 @@ data ReturnInfo
= DirectReturn -- Jump directly, if possible
| StaticVectoredReturn Int -- Fixed tag, starting at zero
| DynamicVectoredReturn CAddrMode -- Dynamic tag given by amode, starting at zero
-
\end{code}
%************************************************************************
@@ -512,6 +480,27 @@ data MagicId
node = VanillaReg PtrRep ILIT(1) -- A convenient alias for Node
infoptr = VanillaReg DataPtrRep ILIT(2) -- An alias for InfoPtr
+
+--------------------
+noLiveRegsMask :: Int -- Mask indicating nothing live
+noLiveRegsMask = 0
+
+mkLiveRegsMask
+ :: [MagicId] -- Candidate live regs; depends what they have in them
+ -> Int
+
+mkLiveRegsMask regs
+ = foldl do_reg noLiveRegsMask regs
+ where
+ do_reg acc (VanillaReg kind reg_no)
+ | isFollowableRep kind
+ = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1)))
+
+ do_reg acc anything_else = acc
+
+ reg_tbl -- ToDo: mk Array!
+ = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
+ lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
\end{code}
We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index a9789c8b9612d4ffe2e88ed00a95ab40c67a2d88..e25ce5d5ae099891a03b477136db464c423592bf 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -10,31 +10,28 @@ module AbsCUtils (
nonemptyAbsC,
mkAbstractCs, mkAbsCStmts,
mkAlgAltsCSwitch,
- kindFromMagicId,
+ magicIdPrimRep,
getAmodeRep, amodeCanSurviveGC,
mixedTypeLocn, mixedPtrLocn,
flattenAbsC,
mkAbsCStmtList
-- printing/forcing stuff comes from PprAbsC
-
- -- and for interface self-sufficiency...
) where
+import Ubiq{-uitous-}
+
import AbsCSyn
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Literal ( literalPrimRep )
-import CLabel ( CLabel, mkReturnPtLabel, mkVecTblLabel )
+import CLabel ( mkReturnPtLabel )
import Digraph ( stronglyConnComp )
-import Id ( fIRST_TAG, ConTag(..), DataCon(..), Id )
-import Maybes ( Maybe(..) )
-import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) )
-import UniqSupply
-import StgSyn ( GenStgArg )
+import HeapOffs ( possiblyEqualHeapOffset )
+import Id ( fIRST_TAG, ConTag(..) )
+import Literal ( literalPrimRep, Literal(..) )
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import Unique ( Unique{-instance Eq-} )
+import UniqSupply ( getUnique, getUniques, splitUniqSupply )
+import Util ( panic )
infixr 9 `thenFlt`
\end{code}
@@ -148,24 +145,24 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
%************************************************************************
\begin{code}
-kindFromMagicId BaseReg = PtrRep
-kindFromMagicId StkOReg = PtrRep
-kindFromMagicId (VanillaReg kind _) = kind
-kindFromMagicId (FloatReg _) = FloatRep
-kindFromMagicId (DoubleReg _) = DoubleRep
-kindFromMagicId TagReg = IntRep
-kindFromMagicId RetReg = RetRep
-kindFromMagicId SpA = PtrRep
-kindFromMagicId SuA = PtrRep
-kindFromMagicId SpB = PtrRep
-kindFromMagicId SuB = PtrRep
-kindFromMagicId Hp = PtrRep
-kindFromMagicId HpLim = PtrRep
-kindFromMagicId LivenessReg = IntRep
-kindFromMagicId StdUpdRetVecReg = PtrRep
-kindFromMagicId StkStubReg = PtrRep
-kindFromMagicId CurCostCentre = CostCentreRep
-kindFromMagicId VoidReg = VoidRep
+magicIdPrimRep BaseReg = PtrRep
+magicIdPrimRep StkOReg = PtrRep
+magicIdPrimRep (VanillaReg kind _) = kind
+magicIdPrimRep (FloatReg _) = FloatRep
+magicIdPrimRep (DoubleReg _) = DoubleRep
+magicIdPrimRep TagReg = IntRep
+magicIdPrimRep RetReg = RetRep
+magicIdPrimRep SpA = PtrRep
+magicIdPrimRep SuA = PtrRep
+magicIdPrimRep SpB = PtrRep
+magicIdPrimRep SuB = PtrRep
+magicIdPrimRep Hp = PtrRep
+magicIdPrimRep HpLim = PtrRep
+magicIdPrimRep LivenessReg = IntRep
+magicIdPrimRep StdUpdRetVecReg = PtrRep
+magicIdPrimRep StkStubReg = PtrRep
+magicIdPrimRep CurCostCentre = CostCentreRep
+magicIdPrimRep VoidReg = VoidRep
\end{code}
%************************************************************************
@@ -183,7 +180,7 @@ getAmodeRep :: CAddrMode -> PrimRep
getAmodeRep (CVal _ kind) = kind
getAmodeRep (CAddr _) = PtrRep
-getAmodeRep (CReg magic_id) = kindFromMagicId magic_id
+getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
getAmodeRep (CTemp uniq kind) = kind
getAmodeRep (CLbl label kind) = kind
getAmodeRep (CUnVecLbl _ _) = PtrRep
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index 2ecbd17348025e9cc23a2aa0151be5b6a1a913cc..a6df00937bfb3fac5ec3a88a3910fd9760146024 100644
--- a/ghc/compiler/absCSyn/CLabel.lhs
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -39,40 +39,35 @@ module CLabel (
needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
- pprCLabel
+ pprCLabel, pprCLabel_asm
#ifdef GRAN
, isSlowEntryCCodeBlock
#endif
-
- -- and to make the interface self-sufficient...
) where
import Ubiq{-uitous-}
+import AbsCLoop ( CtrlReturnConvention(..),
+ ctrlReturnConvAlg
+ )
+import NcgLoop ( underscorePrefix, fmtAsmLbl )
+import CStrings ( pp_cSEP )
import Id ( externallyVisibleId, cmpId_withSpecDataCon,
isDataCon, isDictFunId,
- isConstMethodId_maybe, isClassOpId,
+ isConstMethodId_maybe,
isDefaultMethodId_maybe,
isSuperDictSelId_maybe, fIRST_TAG,
- DataCon(..), ConTag(..), Id
+ ConTag(..), GenId{-instance Outputable-}
)
import Maybes ( maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( showTyCon, GenType{-instance Outputable-} )
+import Pretty ( prettyToUn )
+import TyCon ( TyCon{-instance Eq-} )
+import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
import Unpretty -- NOTE!! ********************
-{-
-import Outputable
-import Pretty ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
- ppInteger, ppBeside, ppIntersperse, prettyToUn
- )
-#ifdef USE_ATTACK_PRAGMAS
-import CharSeq
-#endif
-import Unique ( pprUnique, showUnique, Unique )
-import Util
-
--- Sigh... Shouldn't this file (CLabel) live in codeGen?
-import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
--}
+import Util ( assertPanic )
\end{code}
things we want to find out:
@@ -290,14 +285,13 @@ externallyVisibleCLabel (IdLabel (CLabelId id) _)
| isDataCon id = True
| is_ConstMethodId id = True -- These are here to ensure splitting works
| isDictFunId id = True -- when these values have not been exported
- | isClassOpId id = True
| is_DefaultMethodId id = True
| is_SuperDictSelId id = True
| otherwise = externallyVisibleId id
where
- is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id)
+ is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id)
is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
- is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
+ is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
\end{code}
These GRAN functions are needed for spitting out GRAN_FETCH() at the
@@ -319,17 +313,20 @@ duplicate declarations in generating C (see @labelSeenTE@ in
@PprAbsC@).
\begin{code}
+-- specialised for PprAsm: saves lots of arg passing in NCG
+pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
+
pprCLabel :: PprStyle -> CLabel -> Unpretty
-pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u)
+pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
= uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
-pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl
+pprCLabel (PprForAsm prepend_cSEP _) lbl
= if prepend_cSEP
then uppBeside pp_cSEP prLbl
else prLbl
where
- prLbl = pprCLabel (PprForC sw_chker) lbl
+ prLbl = pprCLabel PprForC lbl
pprCLabel sty (TyConLabel tc UnvecConUpdCode)
= uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
@@ -399,4 +396,3 @@ ppFlavor x = uppBeside pp_cSEP
RednCounts -> uppPStr SLIT("ct")
)
\end{code}
-
diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs
index 7a2d9dca84e57dd3cb6b68ad7849533ecb72e2c0..fd803f6b967506c6ca02109746603d794c24321d 100644
--- a/ghc/compiler/absCSyn/Costs.lhs
+++ b/ghc/compiler/absCSyn/Costs.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1994-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1994-1996
% Hans Wolfgang Loidl
%
% ---------------------------------------------------------------------------
@@ -57,12 +57,9 @@ module Costs( costs,
addrModeCosts, CostRes(Cost), nullCosts, Side(..)
) where
-import AbsCUtils
+import Ubiq{-uitous-}
+
import AbsCSyn
-import PrelInfo
-import PrimOp
-import TyCon
-import Util
-- --------------------------------------------------------------------------
#ifndef GRAN
diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs
index d27645ed787e71ce99a03dc745413c29eaab6227..e37b4b2e3cf7fc893783c56cea5567e8a4852394 100644
--- a/ghc/compiler/absCSyn/HeapOffs.lhs
+++ b/ghc/compiler/absCSyn/HeapOffs.lhs
@@ -22,10 +22,8 @@ module HeapOffs (
intOffsetIntoGoods,
-#if 0
#if ! OMIT_NATIVE_CODEGEN
hpRelToInt,
-#endif
#endif
VirtualHeapOffset(..), HpRelOffset(..),
@@ -34,15 +32,14 @@ module HeapOffs (
) where
import Ubiq{-uitous-}
+#if ! OMIT_NATIVE_CODEGEN
+import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords )
+#endif
-import ClosureInfo ( isSpecRep )
import Maybes ( catMaybes )
import SMRep
import Unpretty -- ********** NOTE **********
import Util ( panic )
-#if ! OMIT_NATIVE_CODEGEN
---import MachDesc ( Target )
-#endif
\end{code}
%************************************************************************
@@ -272,15 +269,15 @@ pprHeapOffset :: PprStyle -> HeapOffset -> Unpretty
pprHeapOffset sty ZeroHeapOffset = uppChar '0'
pprHeapOffset sty (MaxHeapOffset off1 off2)
- = uppBesides [uppPStr SLIT("STG_MAX"), uppLparen,
- pprHeapOffset sty off1, uppComma, pprHeapOffset sty off2,
- uppRparen]
+ = uppBeside (uppPStr SLIT("STG_MAX"))
+ (uppParens (uppBesides [pprHeapOffset sty off1, uppComma, pprHeapOffset sty off2]))
+
pprHeapOffset sty (AddHeapOffset off1 off2)
- = uppBesides [uppLparen, pprHeapOffset sty off1, uppChar '+',
- pprHeapOffset sty off2, uppRparen]
+ = uppParens (uppBesides [pprHeapOffset sty off1, uppChar '+',
+ pprHeapOffset sty off2])
pprHeapOffset sty (SubHeapOffset off1 off2)
- = uppBesides [uppLparen, pprHeapOffset sty off1, uppChar '-',
- pprHeapOffset sty off2, uppRparen]
+ = uppParens (uppBesides [pprHeapOffset sty off1, uppChar '-',
+ pprHeapOffset sty off2])
pprHeapOffset sty (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs)
= pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs
@@ -317,14 +314,12 @@ pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs
case (catMaybes [pp_tothdr_offs, pp_varhdr_offs, pp_fxdhdr_offs, pp_int_offs]) of
[] -> uppChar '0'
[pp] -> pp -- Each blob is parenthesised if necessary
- pps -> uppBesides [ uppLparen, uppIntersperse (uppChar '+') pps, uppRparen ]
+ pps -> uppParens (uppIntersperse (uppChar '+') pps)
where
pp_hdrs hdr_pp [] = Nothing
pp_hdrs hdr_pp [SMRI(rep, n)] | n _EQ_ ILIT(1) = Just (uppBeside (uppStr (show rep)) hdr_pp)
- pp_hdrs hdr_pp hdrs = Just (uppBesides [ uppLparen,
- uppInterleave (uppChar '+')
- (map (pp_hdr hdr_pp) hdrs),
- uppRparen ])
+ pp_hdrs hdr_pp hdrs = Just (uppParens (uppInterleave (uppChar '+')
+ (map (pp_hdr hdr_pp) hdrs)))
pp_hdr :: Unpretty -> SMRep__Int -> Unpretty
pp_hdr pp_str (SMRI(rep, n))
@@ -360,23 +355,22 @@ intOffsetIntoGoods anything_else = Nothing
\end{code}
\begin{code}
-#if 0
#if ! OMIT_NATIVE_CODEGEN
-hpRelToInt :: Target -> HeapOffset -> Int
+hpRelToInt :: HeapOffset -> Int
-hpRelToInt target (MaxHeapOffset left right)
- = (hpRelToInt target left) `max` (hpRelToInt target right)
+hpRelToInt ZeroHeapOffset = 0
-hpRelToInt target (SubHeapOffset left right)
- = (hpRelToInt target left) - (hpRelToInt target right)
+hpRelToInt (MaxHeapOffset left right)
+ = hpRelToInt left `max` hpRelToInt right
-hpRelToInt target (AddHeapOffset left right)
- = (hpRelToInt target left) + (hpRelToInt target right)
+hpRelToInt (SubHeapOffset left right)
+ = hpRelToInt left - hpRelToInt right
-hpRelToInt target ZeroHeapOffset = 0
+hpRelToInt (AddHeapOffset left right)
+ = hpRelToInt left + hpRelToInt right
-hpRelToInt target (MkHeapOffset base fhs vhs ths)
+hpRelToInt (MkHeapOffset base fhs vhs ths)
= let
vhs_pieces, ths_pieces :: [Int]
fhs_off, vhs_off, ths_off :: Int
@@ -390,9 +384,8 @@ hpRelToInt target (MkHeapOffset base fhs vhs ths)
in
IBOX(base) + fhs_off + vhs_off + ths_off
where
- fhs_size = (fixedHeaderSize target) :: Int
- vhs_size r = (varHeaderSize target r) :: Int
+ fhs_size = fixedHdrSizeInWords
+ vhs_size r = varHdrSizeInWords r
#endif
-#endif {-0-}
\end{code}
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 4b5dc298f9e9d026e11ca4d1f8a596add8c0d0de..d763bc70ccaa19b9a01ce185b65d0dcb5732e4dc 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
@@ -12,39 +12,46 @@
module PprAbsC (
writeRealC,
- dumpRealC,
+ dumpRealC
#if defined(DEBUG)
- pprAmode, -- otherwise, not exported
+ , pprAmode -- otherwise, not exported
#endif
-
- -- and for interface self-sufficiency...
- AbstractC, CAddrMode, MagicId,
- PprStyle, CSeq
) where
-IMPORT_Trace -- ToDo: rm (debugging only)
+import Ubiq{-uitous-}
+import AbsCLoop -- break its dependence on ClosureInfo
import AbsCSyn
-import PrelInfo ( pprPrimOp, primOpNeedsWrapper, PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
+import AbsCUtils ( getAmodeRep, nonemptyAbsC,
+ mixedPtrLocn, mixedTypeLocn
)
-import Literal ( literalPrimRep, showLiteral )
-import CLabel -- lots of things
import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
-import CgRetConv ( noLiveRegsMask )
-import ClosureInfo -- quite a few things
-import Costs -- for GrAnSim; cost counting function -- HWL
-import CostCentre
-import FiniteMap
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Outputable
-import Pretty ( codeStyle, prettyToUn )
-import PrimRep ( showPrimRep, isFloatingRep, PrimRep(..) )
-import StgSyn
-import UniqFM
+import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
+ isReadOnly, needsCDecl, pprCLabel,
+ CLabel{-instance Ord-}
+ )
+import CmdLineOpts ( opt_SccProfilingOn )
+import CostCentre ( uppCostCentre, uppCostCentreDecl )
+import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
+import CStrings ( stringToC )
+import FiniteMap ( addToFM, emptyFM, lookupFM )
+import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
+import Literal ( showLiteral, Literal(..) )
+import Maybes ( maybeToBool, catMaybes )
+import PprStyle ( PprStyle(..) )
+import Pretty ( prettyToUn )
+import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
+import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) )
+import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
+ isConstantRep, isSpecRep, isPhantomRep
+ )
+import Unique ( pprUnique, Unique{-instance NamedThing-} )
+import UniqSet ( emptyUniqSet, elementOfUniqSet,
+ addOneToUniqSet, UniqSet(..)
+ )
import Unpretty -- ********** NOTE **********
-import Util
+import Util ( nOfThem, panic, assertPanic )
infixr 9 `thenTE`
\end{code}
@@ -55,18 +62,18 @@ call to a cost evaluation function @GRAN_EXEC@. For that,
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-writeRealC :: _FILE -> AbstractC -> PrimIO ()
+writeRealC :: _FILE -> AbstractC -> IO ()
-writeRealC sw_chker file absC
+writeRealC file absC
= uppAppendFile file 80 (
- uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
+ uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
)
dumpRealC :: AbstractC -> String
-dumpRealC sw_chker absC
+dumpRealC absC
= uppShow 80 (
- uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
+ uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
)
\end{code}
@@ -246,7 +253,7 @@ pprAbsC sty (CCodeBlock label abs_C) _
else "IFN_("),
pprCLabel sty label, uppStr ") {"],
case sty of
- PprForC _ -> uppAbove pp_exts pp_temps
+ PprForC -> uppAbove pp_exts pp_temps
_ -> uppNil,
uppNest 8 (uppPStr SLIT("FB_")),
uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
@@ -275,7 +282,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
= BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
uppAboves [
case sty of
- PprForC _ -> pp_exts
+ PprForC -> pp_exts
_ -> uppNil,
uppBesides [
uppStr "SET_STATIC_HDR(",
@@ -416,7 +423,7 @@ pprAbsC sty stmt@(CFlatRetVector label amodes) _
= BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
uppAboves [
case sty of
- PprForC _ -> pp_exts
+ PprForC -> pp_exts
_ -> uppNil,
uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
pprCLabel sty label, uppStr "[] = {"],
@@ -504,9 +511,9 @@ pp_basic_restores
\begin{code}
if_profiling sty pretty
= case sty of
- PprForC sw_chker -> if sw_chker SccProfilingOn
- then pretty
- else uppChar '0' -- leave it out!
+ PprForC -> if opt_SccProfilingOn
+ then pretty
+ else uppChar '0' -- leave it out!
_ -> {-print it anyway-} pretty
@@ -611,7 +618,6 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo
= if (may_gc && liveness_mask /= noLiveRegsMask)
then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n")
else
--- trace ("casm \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat localVars)) ++ (uppShow 80 (uppCat pp_non_void_args)))
uppAboves [
uppChar '{',
declare_local_vars, -- local var for *result*
@@ -795,8 +801,8 @@ process_casm results args string = process results args string
case readDec other of
[(num,css)] ->
if 0 <= num && num < length args
- then uppBesides [uppLparen, args !! num, uppRparen,
- process ress args css]
+ then uppBeside (uppParens (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")
@@ -918,8 +924,8 @@ no-cast case:
\begin{code}
pprAmode sty amode
| mixedTypeLocn amode
- = uppBesides [ uppLparen, pprPrimKind sty (getAmodeRep amode), uppStr ")(",
- ppr_amode sty amode, uppRparen]
+ = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppStr ")(",
+ ppr_amode sty amode ])
| otherwise -- No cast needed
= ppr_amode sty amode
\end{code}
@@ -930,7 +936,7 @@ Now the rest of the cases for ``workhorse'' @ppr_amode@:
ppr_amode sty (CVal reg_rel _)
= case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
(pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg
- (pp_reg, Just offset) -> uppBesides [ pp_reg, uppLbrack, offset, uppRbrack ]
+ (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ]
ppr_amode sty (CAddr reg_rel)
= case (pprRegRelative sty True{-sign wanted-} reg_rel) of
@@ -1149,19 +1155,13 @@ x `elementOfCLabelSet` labs
= case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
addToCLabelSet set x = addToFM set x ()
-type UniqueSet = UniqFM ()
-emptyUniqueSet = emptyUFM
-x `elementOfUniqueSet` us
- = case (lookupDirectlyUFM us x) of { Just _ -> True; Nothing -> False }
-addToUniqueSet set x = set `plusUFM` singletonDirectlyUFM x ()
-
-type TEenv = (UniqueSet, CLabelSet)
+type TEenv = (UniqSet Unique, CLabelSet)
type TeM result = TEenv -> (TEenv, result)
initTE :: TeM a -> a
initTE sa
- = case sa (emptyUniqueSet, emptyCLabelSet) of { (_, result) ->
+ = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
result }
{-# INLINE thenTE #-}
@@ -1188,9 +1188,9 @@ returnTE result env = (env, result)
tempSeenTE :: Unique -> TeM Bool
tempSeenTE uniq env@(seen_uniqs, seen_labels)
- = if (uniq `elementOfUniqueSet` seen_uniqs)
+ = if (uniq `elementOfUniqSet` seen_uniqs)
then (env, True)
- else ((addToUniqueSet seen_uniqs uniq,
+ else ((addOneToUniqSet seen_uniqs uniq,
seen_labels),
False)
@@ -1208,8 +1208,6 @@ pprTempDecl :: Unique -> PrimRep -> Unpretty
pprTempDecl uniq kind
= uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
-ppr_for_C = PprForC ( \ x -> False ) -- pretend no special cmd-line flags
-
pprExternDecl :: CLabel -> PrimRep -> Unpretty
pprExternDecl clabel kind
@@ -1222,7 +1220,7 @@ pprExternDecl clabel kind
_ -> ppLocalnessMacro False{-data-} clabel
) _TO_ pp_macro_str ->
- uppBesides [ pp_macro_str, uppLparen, pprCLabel ppr_for_C clabel, pp_paren_semi ]
+ uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
BEND
\end{code}
diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..d28c6c57fa2106e8e25a49ee629ab55cc0248991
--- /dev/null
+++ b/ghc/compiler/basicTypes/FieldLabel.lhs
@@ -0,0 +1,45 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[FieldLabel]{The @FieldLabel@ type}
+
+\begin{code}
+#include "HsVersions.h"
+
+module FieldLabel where
+
+import Ubiq{-uitous-}
+
+import Name ( Name{-instance Eq/Outputable-} )
+import Type ( Type(..) )
+\end{code}
+
+\begin{code}
+data FieldLabel
+ = FieldLabel Name
+ Type
+ FieldLabelTag
+
+type FieldLabelTag = Int
+
+mkFieldLabel = FieldLabel
+
+firstFieldLabelTag :: FieldLabelTag
+firstFieldLabelTag = 1
+
+allFieldLabelTags :: [FieldLabelTag]
+allFieldLabelTags = [1..]
+
+fieldLabelName (FieldLabel n _ _) = n
+fieldLabelType (FieldLabel _ ty _) = ty
+fieldLabelTag (FieldLabel _ _ tag) = tag
+
+instance Eq FieldLabel where
+ (FieldLabel n1 _ _) == (FieldLabel n2 _ _) = n1 == n2
+
+instance Outputable FieldLabel where
+ ppr sty (FieldLabel n _ _) = ppr sty n
+
+instance NamedThing FieldLabel
+ -- ToDo: fill this in
+\end{code}
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index ec6367e937cb46bf1ad2909be1dce6a23c99232b..6c1d19b87c47e6b88e0e2bcec6104446a19aadb7 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -32,12 +32,15 @@ module Id {- (
idType,
getIdInfo, replaceIdInfo,
getPragmaInfo,
- getIdPrimRep, getInstIdModule,
+ idPrimRep, getInstIdModule,
getMentionedTyConsAndClassesFromId,
- getDataConTag,
- getDataConSig, getInstantiatedDataConSig,
- getDataConTyCon,
+ dataConTag,
+ dataConSig, getInstantiatedDataConSig,
+ dataConTyCon, dataConArity,
+ dataConFieldLabels,
+
+ recordSelectorFieldLabel,
-- PREDICATES
isDataCon, isTupleCon,
@@ -62,7 +65,7 @@ module Id {- (
-- not exported: apply_to_Id, -- please don't use this, generally
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
- getIdArity, getDataConArity, addIdArity,
+ getIdArity, addIdArity,
getIdDemandInfo, addIdDemandInfo,
getIdSpecialisation, addIdSpecialisation,
getIdStrictness, addIdStrictness,
@@ -96,30 +99,38 @@ import NameLoop -- for paranoia checking
import Bag
import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
+import CStrings ( identToC, cSEP )
import IdInfo
import Maybes ( maybeToBool )
import NameTypes ( mkShortName, fromPrelude, FullName, ShortName )
+import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
import Name ( Name(..) )
import Outputable ( isAvarop, isAconop, getLocalName,
isExported, ExportFlag(..) )
import PragmaInfo ( PragmaInfo(..) )
import PrelMods ( pRELUDE_BUILTIN )
-import PprType ( GenType, GenTyVar,
- getTypeString, typeMaybeString, specMaybeTysSuffix )
+import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
+ GenType, GenTyVar
+ )
import PprStyle
import Pretty
import SrcLoc ( mkBuiltinSrcLoc )
-import TyCon ( TyCon, mkTupleTyCon, getTyConDataCons )
+import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
applyTyCon, isPrimType, instantiateTy,
- tyVarsOfType,
+ tyVarsOfType, applyTypeEnvToTy, typePrimRep,
GenType, ThetaType(..), TauType(..), Type(..)
)
-import TyVar ( GenTyVar, alphaTyVars, isEmptyTyVarSet )
+import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
import UniqFM
import UniqSet -- practically all of it
-import Unique ( Unique, mkTupleDataConUnique, pprUnique, showUnique )
-import Util ( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
+import UniqSupply ( getBuiltinUniques )
+import Unique ( mkTupleDataConUnique, pprUnique, showUnique,
+ Unique{-instance Ord3-}
+ )
+import Util ( mapAccumL, nOfThem,
+ panic, panic#, pprPanic, assertPanic
+ )
\end{code}
Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
@@ -176,6 +187,7 @@ data IdDetails
| DataConId FullName
ConTag
[StrictnessMark] -- Strict args; length = arity
+ [FieldLabel] -- Field labels for this constructor
[TyVar] [(Class,Type)] [Type] TyCon
-- the type is:
@@ -184,6 +196,8 @@ data IdDetails
| TupleConId Int -- Its arity
+ | RecordSelectorId FieldLabel
+
---------------- Things to do with overloading
| SuperDictSelId -- Selector for superclass dictionary
@@ -229,6 +243,7 @@ data IdDetails
| InstId ShortName -- An instance of a dictionary, class operation,
-- or overloaded value
+ Bool -- as for LocalId
| SpecId -- A specialisation of another Id
Id -- Id of which this is a specialisation
@@ -437,10 +452,10 @@ unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
isDataCon id = is_data (unsafeGenId2Id id)
where
- is_data (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
- is_data (Id _ _ (TupleConId _) _ _) = True
- is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
- is_data other = False
+ is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
+ is_data (Id _ _ (TupleConId _) _ _) = True
+ is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
+ is_data other = False
isTupleCon id = is_tuple (unsafeGenId2Id id)
@@ -476,29 +491,31 @@ idHasNoFreeTyVars :: Id -> Bool
toplevelishId (Id _ _ details _ _)
= chk details
where
- chk (DataConId _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (ImportedId _) = True
- chk (PreludeId _) = True
- chk (TopLevId _) = True -- NB: see notes
- chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
- chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _ _) = True
- chk (ConstMethodId _ _ _ _ _) = True
- chk (SpecId unspec _ _) = toplevelishId unspec
- -- depends what the unspecialised thing is
- chk (WorkerId unwrkr) = toplevelishId unwrkr
- chk (InstId _) = False -- these are local
- chk (LocalId _ _) = False
- chk (SysLocalId _ _) = False
- chk (SpecPragmaId _ _ _) = False
+ chk (DataConId _ _ _ _ _ _ _ _) = True
+ chk (TupleConId _) = True
+ chk (RecordSelectorId _) = True
+ chk (ImportedId _) = True
+ chk (PreludeId _) = True
+ chk (TopLevId _) = True -- NB: see notes
+ chk (SuperDictSelId _ _) = True
+ chk (MethodSelId _ _) = True
+ chk (DefaultMethodId _ _ _) = True
+ chk (DictFunId _ _ _ _) = True
+ chk (ConstMethodId _ _ _ _ _) = True
+ chk (SpecId unspec _ _) = toplevelishId unspec
+ -- depends what the unspecialised thing is
+ chk (WorkerId unwrkr) = toplevelishId unwrkr
+ chk (InstId _ _) = False -- these are local
+ chk (LocalId _ _) = False
+ chk (SysLocalId _ _) = False
+ chk (SpecPragmaId _ _ _) = False
idHasNoFreeTyVars (Id _ _ details _ info)
= chk details
where
- chk (DataConId _ _ _ _ _ _ _) = True
+ chk (DataConId _ _ _ _ _ _ _ _) = True
chk (TupleConId _) = True
+ chk (RecordSelectorId _) = True
chk (ImportedId _) = True
chk (PreludeId _) = True
chk (TopLevId _) = True
@@ -508,7 +525,7 @@ idHasNoFreeTyVars (Id _ _ details _ info)
chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
- chk (InstId _) = False -- these are local
+ chk (InstId _ no_free_tvs) = no_free_tvs
chk (SpecId _ _ no_free_tvs) = no_free_tvs
chk (LocalId _ no_free_tvs) = no_free_tvs
chk (SysLocalId _ no_free_tvs) = no_free_tvs
@@ -522,8 +539,7 @@ isTopLevId other = False
isImportedId (Id _ _ (ImportedId _) _ _) = True
isImportedId other = False
-isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
- -- LATER: bottomIsGuaranteed (getInfo info)
+isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
isSysLocalId other = False
@@ -578,7 +594,7 @@ pprIdInUnfolding in_scopes v
else if v == nilDataCon then
ppPStr SLIT("_NIL_")
else if isTupleCon v then
- ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))
+ ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
-- ones to think about:
else
@@ -592,7 +608,9 @@ pprIdInUnfolding in_scopes v
-- these ones' exportedness checked later...
TopLevId _ -> pp_full_name
- DataConId _ _ _ _ _ _ _ -> pp_full_name
+ DataConId _ _ _ _ _ _ _ _ -> pp_full_name
+
+ RecordSelectorId lbl -> ppr sty lbl
-- class-ish things: class already recorded as "mentioned"
SuperDictSelId c sc
@@ -754,14 +772,10 @@ unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _)
-- TyVar(Templates) in the i/face; only a problem
-- if -fshow-pragma-name-errs; but we can do without the pain.
-- A HACK in any case (WDP 94/05/02)
- = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun
- --)
+ = naughty_DictFunId dfun
unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
- = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun -- similar deal...
- --)
+ = naughty_DictFunId dfun -- similar deal...
unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
@@ -785,9 +799,6 @@ compiling the prelude, the compiler may not recognise that as true.
\begin{code}
externallyVisibleId :: Id -> Bool
-externallyVisibleId id = panic "Id.externallyVisibleId"
-{-LATER:
-
externallyVisibleId id@(Id _ _ details _ _)
= if isLocallyDefined id then
toplevelishId id && isExported id && not (weird_datacon details)
@@ -805,26 +816,22 @@ externallyVisibleId id@(Id _ _ details _ _)
-- of WeirdLocalType; but we need to know this when asked if
-- "Mumble" is externally visible...
- weird_datacon (DataConId _ _ _ _ _ _ tycon)
+{- LATER: if at all:
+ weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
= maybeToBool (maybePurelyLocalTyCon tycon)
+-}
weird_datacon not_a_datacon_therefore_not_weird = False
weird_tuplecon (TupleConId arity)
= arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
weird_tuplecon _ = False
--}
\end{code}
\begin{code}
idWantsToBeINLINEd :: Id -> Bool
-idWantsToBeINLINEd id
- = panic "Id.idWantsToBeINLINEd"
-{- LATER:
- = case (getIdUnfolding id) of
- IWantToBeINLINEd _ -> True
- _ -> False
--}
+idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
+idWantsToBeINLINEd _ = False
\end{code}
For @unlocaliseId@: See the brief commentary in
@@ -861,7 +868,7 @@ unlocaliseId mod (Id u ty info (WorkerId unwrkr))
Nothing -> Nothing
Just xx -> Just (Id u ty info (WorkerId xx))
-unlocaliseId mod (Id u ty info (InstId name))
+unlocaliseId mod (Id u ty info (InstId name no_ftvs))
= Just (Id u ty info (TopLevId full_name))
-- type might be wrong, but it hardly matters
-- at this stage (just before printing C) ToDo
@@ -902,41 +909,37 @@ The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
former ``should be'' the usual crunch point.
\begin{code}
-{-LATER:
+type TypeEnv = TyVarEnv Type
+
applyTypeEnvToId :: TypeEnv -> Id -> Id
-applyTypeEnvToId type_env id@(Id u ty info details)
+applyTypeEnvToId type_env id@(Id _ ty _ _ _)
| idHasNoFreeTyVars id
= id
| otherwise
= apply_to_Id ( \ ty ->
applyTypeEnvToTy type_env ty
) id
--}
\end{code}
\begin{code}
-{-LATER:
apply_to_Id :: (Type -> Type)
-> Id
-> Id
-apply_to_Id ty_fn (Id u ty info details)
- = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
+apply_to_Id ty_fn (Id u ty details prag info)
+ = let
+ new_ty = ty_fn ty
+ in
+ Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
where
- apply_to_details (InstId inst)
- = let
- new_inst = apply_to_Inst ty_fn inst
- in
- InstId new_inst
-
apply_to_details (SpecId unspec ty_maybes no_ftvs)
= let
new_unspec = apply_to_Id ty_fn unspec
new_maybes = map apply_to_maybe ty_maybes
in
- SpecId new_unspec new_maybes no_ftvs
- -- ToDo: recalc no_ftvs????
+ SpecId new_unspec new_maybes (no_free_tvs ty)
+ -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
where
apply_to_maybe Nothing = Nothing
apply_to_maybe (Just ty) = Just (ty_fn ty)
@@ -948,7 +951,6 @@ apply_to_Id ty_fn (Id u ty info details)
WorkerId new_unwrkr
apply_to_details other = other
--}
\end{code}
Sadly, I don't think the one using the magic typechecker substitution
@@ -970,9 +972,9 @@ applySubstToId subst id@(Id u ty info details)
case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
(s4, Id u new_ty new_info new_details) }}}
where
- apply_to_details subst _ (InstId inst)
+ apply_to_details subst _ (InstId inst no_ftvs)
= case (applySubstToInst subst inst) of { (s2, new_inst) ->
- (s2, InstId new_inst) }
+ (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
apply_to_details subst new_ty (SpecId unspec ty_maybes _)
= case (applySubstToId subst unspec) of { (s2, new_unspec) ->
@@ -995,18 +997,21 @@ applySubstToId subst id@(Id u ty info details)
\begin{code}
getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
+
getIdNamePieces show_uniqs id
= get (unsafeGenId2Id id)
where
get (Id u _ details _ _)
= case details of
- DataConId n _ _ _ _ _ _ ->
+ DataConId n _ _ _ _ _ _ _ ->
case (getOrigName n) of { (mod, name) ->
if fromPrelude mod then [name] else [mod, name] }
TupleConId 0 -> [SLIT("()")]
TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
+ RecordSelectorId lbl -> panic "getIdNamePieces:RecordSelectorId"
+
ImportedId n -> get_fullname_pieces n
PreludeId n -> get_fullname_pieces n
TopLevId n -> get_fullname_pieces n
@@ -1075,7 +1080,7 @@ getIdNamePieces show_uniqs id
LocalId n _ -> let local = getLocalName n in
if show_uniqs then [local, showUnique u] else [local]
- InstId n -> [getLocalName n, showUnique u]
+ InstId n _ -> [getLocalName n, showUnique u]
SysLocalId n _ -> [getLocalName n, showUnique u]
SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
@@ -1110,7 +1115,7 @@ getMentionedTyConsAndClassesFromId id
\end{code}
\begin{code}
---getIdPrimRep i = primRepFromType (idType i)
+idPrimRep i = typePrimRep (idType i)
\end{code}
\begin{code}
@@ -1140,7 +1145,7 @@ mkConstMethodId u c op ity full_ty from_here modname info
mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
-mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo
+mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
{-LATER:
getConstMethodId clas op ty
@@ -1151,14 +1156,13 @@ getConstMethodId clas op ty
in
case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
Just xx -> xx
- Nothing -> error (ppShow 80 (ppAboves [
- ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op,
- ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
+ Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
+ ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
ppr PprDebug sel_id],
ppStr "(This can arise if an interface pragma refers to an instance",
ppStr "but there is no imported interface which *defines* that instance.",
ppStr "The info above, however ugly, should indicate what else you need to import."
- ]))
+ ])
-}
\end{code}
@@ -1228,36 +1232,29 @@ mkSameSpecCon ty_maybes unspec@(Id u ty info details)
where
new_ty = specialiseTy ty ty_maybes 0
- -- pprTrace "SameSpecCon:Unique:"
- -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
-
localiseId :: Id -> Id
localiseId id@(Id u ty info details)
= Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
where
name = getOccurrenceName id
loc = getSrcLoc id
+-}
--- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId)
--- ToDo: it does??? WDP
mkIdWithNewUniq :: Id -> Unique -> Id
-mkIdWithNewUniq (Id _ ty info details) uniq
- = Id uniq ty info new_details
--}
+mkIdWithNewUniq (Id _ ty details prag info) uniq
+ = Id uniq ty details prag info
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
@Uniques@, but that's OK because the templates are supposed to be
instantiated before use.
\begin{code}
-{-LATER:
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys
- = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
+ = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
(getBuiltinUniques (length tys))
tys
--}
\end{code}
\begin{code}
@@ -1293,11 +1290,11 @@ besides the code-generator need arity info!)
getIdArity :: Id -> ArityInfo
getIdArity (Id _ _ _ _ id_info) = getInfo id_info
-getDataConArity :: DataCon -> Int
-getDataConArity id@(Id _ _ _ _ id_info)
+dataConArity :: DataCon -> Int
+dataConArity id@(Id _ _ _ _ id_info)
= ASSERT(isDataCon id)
case (arityMaybe (getInfo id_info)) of
- Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
+ Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
Just i -> i
addIdArity :: Id -> Int -> Id
@@ -1314,13 +1311,13 @@ addIdArity (Id u ty details pinfo info) arity
\begin{code}
mkDataCon :: Unique{-DataConKey-}
-> FullName
- -> [StrictnessMark]
+ -> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType -> [TauType] -> TyCon
--ToDo: -> SpecEnv
-> Id
-- can get the tag and all the pieces of the type from the Type
-mkDataCon k n stricts tvs ctxt args_tys tycon
+mkDataCon k n stricts fields tvs ctxt args_tys tycon
= ASSERT(length stricts == length args_tys)
data_con
where
@@ -1329,13 +1326,13 @@ mkDataCon k n stricts tvs ctxt args_tys tycon
data_con
= Id k
type_of_constructor
- (DataConId n data_con_tag stricts tvs ctxt args_tys tycon)
+ (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
NoPragmaInfo
datacon_info
data_con_tag = position_within fIRST_TAG data_con_family
- data_con_family = getTyConDataCons tycon
+ data_con_family = tyConDataCons tycon
position_within :: Int -> [Id] -> Int
@@ -1450,36 +1447,53 @@ fIRST_TAG = 1 -- Tags allocated from here for real constructors
\end{code}
\begin{code}
-getDataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-getDataConTag (Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag
-getDataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG
-getDataConTag (Id _ _ (SpecId unspec _ _) _ _) = getDataConTag unspec
+dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
+dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
+dataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG
+dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
-getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
-getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
-getDataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a
+dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
+dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
+dataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a
-getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
+dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
-- will panic if not a DataCon
-getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
+dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
= (tyvars, theta_ty, arg_tys, tycon)
-getDataConSig (Id _ _ (TupleConId arity) _ _)
+dataConSig (Id _ _ (TupleConId arity) _ _)
= (tyvars, [], tyvar_tys, mkTupleTyCon arity)
where
tyvars = take arity alphaTyVars
tyvar_tys = mkTyVarTys tyvars
+
+dataConFieldLabels :: DataCon -> [FieldLabel]
+dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
+\end{code}
+
+\begin{code}
+mkRecordSelectorId field_label selector_ty
+ = Id (getItsUnique name)
+ selector_ty
+ (RecordSelectorId field_label)
+ NoPragmaInfo
+ noIdInfo
+ where
+ name = fieldLabelName field_label
+
+recordSelectorFieldLabel :: Id -> FieldLabel
+recordSelectorFieldLabel (Id _ _ (RecordSelectorId lbl) _ _) = lbl
\end{code}
{- LATER
-getDataConTyCon (Id _ _ _ (SpecId unspec tys _))
- = mkSpecTyCon (getDataConTyCon unspec) tys
+dataConTyCon (Id _ _ _ (SpecId unspec tys _))
+ = mkSpecTyCon (dataConTyCon unspec) tys
-getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
+dataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
= (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
where
- (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec
+ (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec
ty_env = tyvars `zip` ty_maybes
@@ -1493,7 +1507,7 @@ getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
spec_theta_ty = if null theta_ty then []
- else panic "getDataConSig:ThetaTy:SpecDataCon"
+ else panic "dataConSig:ThetaTy:SpecDataCon"
spec_tycon = mkSpecTyCon tycon ty_maybes
-}
\end{code}
@@ -1516,7 +1530,7 @@ getInstantiatedDataConSig ::
getInstantiatedDataConSig data_con inst_tys
= ASSERT(isDataCon data_con)
let
- (tvs, theta, arg_tys, tycon) = getDataConSig data_con
+ (tvs, theta, arg_tys, tycon) = dataConSig data_con
inst_env = ASSERT(length tvs == length inst_tys)
tvs `zip` inst_tys
@@ -1698,7 +1712,6 @@ because a specialised data constructor has the same Unique as its
unspecialised counterpart.
\begin{code}
-{-LATER:
cmpId_withSpecDataCon :: Id -> Id -> TAG_
cmpId_withSpecDataCon id1 id2
@@ -1711,18 +1724,12 @@ cmpId_withSpecDataCon id1 id2
cmp_ids = cmpId id1 id2
eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
-cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _))
- = cmpUniTypeMaybeList mtys1 mtys2
-
-cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _))
- = LT_
-
-cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2
- = GT_
+cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _)
+ = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
-cmpEqDataCon unspec1 unspec2
- = EQ_
--}
+cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_
+cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_
+cmpEqDataCon _ _ = EQ_
\end{code}
%************************************************************************
@@ -1735,6 +1742,10 @@ cmpEqDataCon unspec1 unspec2
instance Outputable ty => Outputable (GenId ty) where
ppr sty id = pprId sty id
+-- and a SPECIALIZEd one:
+instance Outputable {-Id, i.e.:-}(GenId Type) where
+ ppr sty id = pprId sty id
+
showId :: PprStyle -> Id -> String
showId sty id = ppShow 80 (pprId sty id)
@@ -1778,13 +1789,12 @@ pprId other_sty id
= let
pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
- for_code = panic "pprId: for code"
- {- = let
+ for_code
+ = let
pieces_to_print -- maybe use Unique only
= if isSysLocalId id then tail pieces else pieces
in
ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
- -}
in
case other_sty of
PprForC -> for_code
@@ -1810,12 +1820,12 @@ pprId other_sty id
= ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
- pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = ppNil
+ pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
pp_uniq (Id _ _ (TupleConId _) _ _) = ppNil
pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
- pp_uniq (Id _ _ (InstId _) _ _) = ppNil
+ pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
-- print PprDebug Ids with # afterwards if they are of primitive type.
@@ -1834,8 +1844,9 @@ instance NamedThing (GenId ty) where
getExportFlag (Id _ _ details _ _)
= get details
where
- get (DataConId _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
+ get (DataConId _ _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
get (TupleConId _) = NotExported
+ get (RecordSelectorId l) = getExportFlag l
get (ImportedId n) = getExportFlag n
get (PreludeId n) = getExportFlag n
get (TopLevId n) = getExportFlag n
@@ -1846,7 +1857,7 @@ instance NamedThing (GenId ty) where
get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
get (SpecId unspec _ _) = getExportFlag unspec
get (WorkerId unwrkr) = getExportFlag unwrkr
- get (InstId _) = NotExported
+ get (InstId _ _) = NotExported
get (LocalId _ _) = NotExported
get (SysLocalId _ _) = NotExported
get (SpecPragmaId _ _ _) = NotExported
@@ -1854,10 +1865,11 @@ instance NamedThing (GenId ty) where
isLocallyDefined this_id@(Id _ _ details _ _)
= get details
where
- get (DataConId _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
+ get (DataConId _ _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
get (TupleConId _) = False
get (ImportedId _) = False
get (PreludeId _) = False
+ get (RecordSelectorId l) = isLocallyDefined l
get (TopLevId n) = isLocallyDefined n
get (SuperDictSelId c _) = isLocallyDefined c
get (MethodSelId c _) = isLocallyDefined c
@@ -1870,7 +1882,7 @@ instance NamedThing (GenId ty) where
get (ConstMethodId c tyc _ from_here _) = from_here
get (SpecId unspec _ _) = isLocallyDefined unspec
get (WorkerId unwrkr) = isLocallyDefined unwrkr
- get (InstId _) = True
+ get (InstId _ _) = True
get (LocalId _ _) = True
get (SysLocalId _ _) = True
get (SpecPragmaId _ _ _) = True
@@ -1878,9 +1890,10 @@ instance NamedThing (GenId ty) where
getOrigName this_id@(Id u _ details _ _)
= get details
where
- get (DataConId n _ _ _ _ _ _) = getOrigName n
+ get (DataConId n _ _ _ _ _ _ _) = getOrigName n
get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()"))
get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
+ get (RecordSelectorId l)= getOrigName l
get (ImportedId n) = getOrigName n
get (PreludeId n) = getOrigName n
get (TopLevId n) = getOrigName n
@@ -1911,7 +1924,7 @@ instance NamedThing (GenId ty) where
BEND
-}
- get (InstId n) = (panic "NamedThing.Id.getOrigName (LocalId)",
+ get (InstId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
getLocalName n)
get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
getLocalName n)
@@ -1933,9 +1946,10 @@ instance NamedThing (GenId ty) where
getOccurrenceName this_id@(Id _ _ details _ _)
= get details
where
- get (DataConId n _ _ _ _ _ _) = getOccurrenceName n
+ get (DataConId n _ _ _ _ _ _ _) = getOccurrenceName n
get (TupleConId 0) = SLIT("()")
get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
+ get (RecordSelectorId l)= getOccurrenceName l
get (ImportedId n) = getOccurrenceName n
get (PreludeId n) = getOccurrenceName n
get (TopLevId n) = getOccurrenceName n
@@ -1947,8 +1961,9 @@ instance NamedThing (GenId ty) where
getSrcLoc (Id _ _ details _ id_info)
= get details
where
- get (DataConId n _ _ _ _ _ _) = getSrcLoc n
+ get (DataConId n _ _ _ _ _ _ _) = getSrcLoc n
get (TupleConId _) = mkBuiltinSrcLoc
+ get (RecordSelectorId l)= getSrcLoc l
get (ImportedId n) = getSrcLoc n
get (PreludeId n) = getSrcLoc n
get (TopLevId n) = getSrcLoc n
@@ -1956,7 +1971,7 @@ instance NamedThing (GenId ty) where
get (MethodSelId c _) = getSrcLoc c
get (SpecId unspec _ _) = getSrcLoc unspec
get (WorkerId unwrkr) = getSrcLoc unwrkr
- get (InstId n) = getSrcLoc n
+ get (InstId n _) = getSrcLoc n
get (LocalId n _) = getSrcLoc n
get (SysLocalId n _) = getSrcLoc n
get (SpecPragmaId n _ _)= getSrcLoc n
@@ -1968,8 +1983,9 @@ instance NamedThing (GenId ty) where
fromPreludeCore (Id _ _ details _ _)
= get details
where
- get (DataConId _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
+ get (DataConId _ _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
get (TupleConId _) = True
+ get (RecordSelectorId l) = fromPreludeCore l
get (ImportedId n) = fromPreludeCore n
get (PreludeId n) = fromPreludeCore n
get (TopLevId n) = fromPreludeCore n
@@ -1980,7 +1996,7 @@ instance NamedThing (GenId ty) where
get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
get (SpecId unspec _ _) = fromPreludeCore unspec
get (WorkerId unwrkr) = fromPreludeCore unwrkr
- get (InstId _) = False
+ get (InstId _ _) = False
get (LocalId _ _) = False
get (SysLocalId _ _) = False
get (SpecPragmaId _ _ _) = False
@@ -2030,7 +2046,7 @@ mapIdEnv = mapUFM
mkIdEnv = listToUFM
nullIdEnv = emptyUFM
rngIdEnv = eltsUFM
-unitIdEnv = singletonUFM
+unitIdEnv = unitUFM
growIdEnvList env pairs = plusUFM env (listToUFM pairs)
isNullIdEnv env = sizeUFM env == 0
@@ -2054,14 +2070,16 @@ intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
idSetToList :: GenIdSet ty -> [GenId ty]
-singletonIdSet :: GenId ty -> GenIdSet ty
+unitIdSet :: GenId ty -> GenIdSet ty
+addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
isEmptyIdSet :: GenIdSet ty -> Bool
mkIdSet :: [GenId ty] -> GenIdSet ty
emptyIdSet = emptyUniqSet
-singletonIdSet = singletonUniqSet
+unitIdSet = unitUniqSet
+addOneToIdSet = addOneToUniqSet
intersectIdSets = intersectUniqSets
unionIdSets = unionUniqSets
unionManyIdSets = unionManyUniqSets
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index b2594b3939ef50d5b8a2bf6a53268cd3241caabf..8f35f6af71ecf4118bcfeef571e9f26e773065e6 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -76,7 +76,7 @@ import IdLoop -- IdInfo is a dependency-loop ranch, and
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
-import MatchEnv ( nullMEnv, mEnvToList )
+import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
@@ -85,7 +85,6 @@ import Type ( eqSimpleTy )
import Util ( mapAccumL, panic, assertPanic, pprPanic )
applySubstToTy = panic "IdInfo.applySubstToTy"
-isUnboxedDataType = panic "IdInfo.isUnboxedDataType"
splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs"
showTypeCategory = panic "IdInfo.showTypeCategory"
mkFormSummary = panic "IdInfo.mkFormSummary"
@@ -180,8 +179,11 @@ Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@
will in turn @apply_to_IdInfo@ of the self-same @IdInfo@. (A very
nasty loop, friends...)
\begin{code}
-apply_to_IdInfo ty_fn (IdInfo arity demand spec strictness unfold
+apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
update deforest arg_usage fb_ww srcloc)
+ | isEmptyMEnv spec
+ = idinfo
+ | otherwise
= panic "IdInfo:apply_to_IdInfo"
{- LATER:
let
diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi
index 7cc2c6368ccc04e3bc356bdf3f1680e4b5c2b4d2..bdc4f120ffdada61da22c118f6fc919c7e5a910e 100644
--- a/ghc/compiler/basicTypes/IdLoop.lhi
+++ b/ghc/compiler/basicTypes/IdLoop.lhi
@@ -17,10 +17,10 @@ import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
)
import IdInfo ( IdInfo )
import Literal ( Literal )
-import MagicUFs ( MagicUnfoldingFun )
+import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import Outputable ( Outputable(..) )
import PprStyle ( PprStyle )
-import PprType ( pprParendType )
+import PprType ( pprParendGenType )
import Pretty ( PrettyRep )
import Type ( GenType )
import TyVar ( GenTyVar )
@@ -39,9 +39,11 @@ getIdInfo :: Id -> IdInfo
nullIdEnv :: UniqFM a
lookupIdEnv :: UniqFM b -> GenId a -> Maybe b
mAX_WORKER_ARGS :: Int
-pprParendType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
+pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
+mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
+
type IdEnv a = UniqFM a
type CoreExpr = GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique))
(GenId (GenType (GenTyVar (GenUsage Unique)) Unique))
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 00fcbab71a0c91e3ab39e7fc6df482d7a8e1541a..c809a493dae4756bdd4574ab786455c53a766118 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -28,7 +28,7 @@ import Outputable ( ExportFlag(..) )
import Pretty
import PprStyle ( PprStyle(..) )
import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
-import TyCon ( TyCon, getSynTyConArity )
+import TyCon ( TyCon, synTyConArity )
import TyVar ( GenTyVar )
import Unique ( pprUnique, Unique )
import Util ( panic, panic#, pprPanic )
@@ -129,7 +129,7 @@ getTagFromClassOpName (ClassOpName _ _ _ tag) = tag
getSynNameArity :: Name -> Maybe Arity
getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity
-getSynNameArity (WiredInTyCon tycon) = getSynTyConArity tycon
+getSynNameArity (WiredInTyCon tycon) = synTyConArity tycon
getSynNameArity other_name = Nothing
getNameShortName :: Name -> ShortName
diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..1cd1071a1f4be3bf4a22fd159d7c8a97bdf4cb17
--- /dev/null
+++ b/ghc/compiler/basicTypes/PprEnv.lhs
@@ -0,0 +1,121 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[PprEnv]{The @PprEnv@ type}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PprEnv (
+ PprEnv{-abstract-},
+
+ initPprEnv,
+
+ pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle,
+ pTy, pTyVar, pUVar, pUse
+ ) where
+
+import Ubiq{-uitous-}
+
+import Id ( DataCon(..) )
+import Pretty ( Pretty(..) )
+import Util ( panic )
+\end{code}
+
+For tyvars and uvars, we {\em do} normally use these homogenized
+names; for values, we {\em don't}. In printing interfaces, though,
+we use homogenized value names, so that interfaces don't wobble
+uncontrollably from changing Unique-based names.
+
+\begin{code}
+data PprEnv tyvar uvar bndr occ
+ = PE PprStyle -- stored for safe keeping
+
+ (Literal -> Pretty) -- Doing these this way saves
+ (DataCon -> Pretty) -- carrying around a PprStyle
+ (PrimOp -> Pretty)
+ (CostCentre -> Pretty)
+
+ (tyvar -> Pretty) -- to print tyvars
+ (uvar -> Pretty) -- to print usage vars
+
+ (bndr -> Pretty) -- to print "major" val_bdrs
+ (bndr -> Pretty) -- to print "minor" val_bdrs
+ (occ -> Pretty) -- to print bindees
+
+ (GenType tyvar uvar -> Pretty)
+ (GenUsage uvar -> Pretty)
+\end{code}
+
+\begin{code}
+initPprEnv
+ :: PprStyle
+ -> Maybe (Literal -> Pretty)
+ -> Maybe (DataCon -> Pretty)
+ -> Maybe (PrimOp -> Pretty)
+ -> Maybe (CostCentre -> Pretty)
+ -> Maybe (tyvar -> Pretty)
+ -> Maybe (uvar -> Pretty)
+ -> Maybe (bndr -> Pretty)
+ -> Maybe (bndr -> Pretty)
+ -> Maybe (occ -> Pretty)
+ -> Maybe (GenType tyvar uvar -> Pretty)
+ -> Maybe (GenUsage uvar -> Pretty)
+ -> PprEnv tyvar uvar bndr occ
+
+-- you can specify all the printers individually; if
+-- you don't specify one, you get bottom
+
+initPprEnv sty l d p c tv uv maj_bndr min_bndr occ ty use
+ = PE sty
+ (demaybe l)
+ (demaybe d)
+ (demaybe p)
+ (demaybe c)
+ (demaybe tv)
+ (demaybe uv)
+ (demaybe maj_bndr)
+ (demaybe min_bndr)
+ (demaybe occ)
+ (demaybe ty)
+ (demaybe use)
+ where
+ demaybe Nothing = bottom
+ demaybe (Just x) = x
+
+ bottom = panic "PprEnv.initPprEnv: unspecified printing function"
+
+{-
+initPprEnv sty pmaj pmin pocc
+ = PE (ppr sty) -- for a Literal
+ (ppr sty) -- for a DataCon
+ (ppr sty) -- for a PrimOp
+ (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre
+
+ (ppr sty) -- for a tyvar
+ (ppr sty) -- for a usage var
+
+ pmaj pmin pocc -- for GenIds in various guises
+
+ (ppr sty) -- for a Type
+ (ppr sty) -- for a Usage
+-}
+\end{code}
+
+\begin{code}
+pStyle (PE s _ _ _ _ _ _ _ _ _ _ _) = s
+pLit (PE _ pp _ _ _ _ _ _ _ _ _ _) = pp
+pCon (PE _ _ pp _ _ _ _ _ _ _ _ _) = pp
+pPrim (PE _ _ _ pp _ _ _ _ _ _ _ _) = pp
+pSCC (PE _ _ _ _ pp _ _ _ _ _ _ _) = pp
+
+pTyVar (PE _ _ _ _ _ pp _ _ _ _ _ _) = pp
+pUVar (PE _ _ _ _ _ _ pp _ _ _ _ _) = pp
+
+pMajBndr (PE _ _ _ _ _ _ _ pp _ _ _ _) = pp
+pMinBndr (PE _ _ _ _ _ _ _ _ pp _ _ _) = pp
+pOcc (PE _ _ _ _ _ _ _ _ _ pp _ _) = pp
+
+pTy (PE _ _ _ _ _ _ _ _ _ _ pp _) = pp
+pUse (PE _ _ _ _ _ _ _ _ _ _ _ pp) = pp
+\end{code}
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
index 81fec960964dff9c8e73d46c833f83503dbf3abb..1915538caecc092b7849f8845688226cdeb604b9 100644
--- a/ghc/compiler/basicTypes/UniqSupply.lhs
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -15,6 +15,7 @@ module UniqSupply (
UniqSM(..), -- type: unique supply monad
initUs, thenUs, returnUs,
mapUs, mapAndUnzipUs, mapAndUnzip3Us,
+ thenMaybeUs, mapAccumLUs,
mkSplitUniqSupply,
splitUniqSupply,
@@ -169,6 +170,24 @@ mapAndUnzip3Us f (x:xs)
= f x `thenUs` \ (r1, r2, r3) ->
mapAndUnzip3Us f xs `thenUs` \ (rs1, rs2, rs3) ->
returnUs (r1:rs1, r2:rs2, r3:rs3)
+
+thenMaybeUs :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b)
+thenMaybeUs m k
+ = m `thenUs` \ result ->
+ case result of
+ Nothing -> returnUs Nothing
+ Just x -> k x
+
+mapAccumLUs :: (acc -> x -> UniqSM (acc, y))
+ -> acc
+ -> [x]
+ -> UniqSM (acc, [y])
+
+mapAccumLUs f b [] = returnUs (b, [])
+mapAccumLUs f b (x:xs)
+ = f b x `thenUs` \ (b__2, x__2) ->
+ mapAccumLUs f b__2 xs `thenUs` \ (b__3, xs__2) ->
+ returnUs (b__3, x__2:xs__2)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 84fd88487aa4bd2490b2dcd7924e89b7c697c769..4d17fc1a6267feba861a9133a991f50affa58dee 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -8,7 +8,7 @@
module CgBindery (
CgBindings(..), CgIdInfo(..){-dubiously concrete-},
- StableLoc, VolatileLoc, LambdaFormInfo{-re-exported-},
+ StableLoc, VolatileLoc,
maybeAStkLoc, maybeBStkLoc,
@@ -20,25 +20,35 @@ module CgBindery (
bindNewToAStack, bindNewToBStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp, bindNewPrimToAmode,
- getAtomAmode, getAtomAmodes,
+ getArgAmode, getArgAmodes,
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
rebindToAStack, rebindToBStack
-
- -- and to make a self-sufficient interface...
) where
+import Ubiq{-uitous-}
+import CgLoop1 -- here for paranoia-checking
+
import AbsCSyn
import CgMonad
import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
-import CLabel ( mkClosureLabel, CLabel )
-import ClosureInfo
-import Id ( getIdPrimRep, toplevelishId, isDataCon, Id )
-import Maybes ( catMaybes, Maybe(..) )
-import UniqSet -- ( setToList )
-import StgSyn
-import Util
+import CLabel ( mkClosureLabel )
+import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument )
+import HeapOffs ( VirtualHeapOffset(..),
+ VirtualSpAOffset(..), VirtualSpBOffset(..)
+ )
+import Id ( idPrimRep, toplevelishId, isDataCon,
+ mkIdEnv, rngIdEnv, IdEnv(..),
+ idSetToList,
+ GenId{-instance NamedThing-}
+ )
+import Maybes ( catMaybes )
+import PprAbsC ( pprAmode )
+import PprStyle ( PprStyle(..) )
+import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
+import Unpretty ( uppShow )
+import Util ( zipWithEqual, panic )
\end{code}
@@ -113,13 +123,13 @@ newTempAmodeAndIdInfo name lf_info
= (temp_amode, temp_idinfo)
where
uniq = getItsUnique name
- temp_amode = CTemp uniq (getIdPrimRep name)
+ temp_amode = CTemp uniq (idPrimRep name)
temp_idinfo = tempIdInfo name uniq lf_info
-idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode
+idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
-idInfoPiecesToAmode :: PrimKind -> VolatileLoc -> StableLoc -> FCode CAddrMode
+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)
@@ -195,7 +205,7 @@ getCAddrModeAndInfo name
returnFC (amode, lf_info)
where
global_amode = CLbl (mkClosureLabel name) kind
- kind = getIdPrimRep name
+ kind = idPrimRep name
getCAddrMode :: Id -> FCode CAddrMode
getCAddrMode name
@@ -211,7 +221,7 @@ getCAddrModeIfVolatile name
= lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
case stable_loc of
NoStableLoc -> -- Aha! So it is volatile!
- idInfoPiecesToAmode (getIdPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
+ idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
returnFC (Just amode)
a_stable_loc -> returnFC Nothing
@@ -228,7 +238,7 @@ forget the volatile one.
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
getVolatileRegs vars
- = mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff ->
+ = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff ->
returnFC (catMaybes stuff)
where
snaffle_it var
@@ -262,17 +272,17 @@ getVolatileRegs vars
\end{code}
\begin{code}
-getAtomAmodes :: [StgArg] -> FCode [CAddrMode]
-getAtomAmodes [] = returnFC []
-getAtomAmodes (atom:atoms)
- = getAtomAmode atom `thenFC` \ amode ->
- getAtomAmodes atoms `thenFC` \ amodes ->
+getArgAmodes :: [StgArg] -> FCode [CAddrMode]
+getArgAmodes [] = returnFC []
+getArgAmodes (atom:atoms)
+ = getArgAmode atom `thenFC` \ amode ->
+ getArgAmodes atoms `thenFC` \ amodes ->
returnFC ( amode : amodes )
-getAtomAmode :: StgArg -> FCode CAddrMode
+getArgAmode :: StgArg -> FCode CAddrMode
-getAtomAmode (StgVarArg var) = getCAddrMode var
-getAtomAmode (StgLitArg lit) = returnFC (CLit lit)
+getArgAmode (StgVarArg var) = getCAddrMode var
+getArgAmode (StgLitArg lit) = returnFC (CLit lit)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 45b21c1105f546c2c8bb39cb5f3417ec10b701c0..5ed617db045ba43ed6e62ab971cfedfd07261138 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%********************************************************
%* *
@@ -10,48 +10,66 @@
\begin{code}
#include "HsVersions.h"
-module CgCase (
- cgCase,
- saveVolatileVarsAndRegs
+module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
- -- and to make the interface self-sufficient...
- ) where
+import Ubiq{-uitous-}
+import CgLoop2 ( cgExpr, getPrimOpArgAmodes )
-import StgSyn
import CgMonad
+import StgSyn
import AbsCSyn
-import PrelInfo ( PrimOp(..), primOpCanTriggerGC
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
+ magicIdPrimRep, getAmodeRep
)
-import Type ( primRepFromType, getTyConDataCons,
- getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
- isEnumerationTyCon,
- Type
+import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
+ bindNewToReg, bindNewToTemp,
+ bindNewPrimToAmode,
+ rebindToAStack, rebindToBStack,
+ getCAddrModeAndInfo, getCAddrModeIfVolatile,
+ idInfoToAmode
)
-import CgBindery -- all of it
import CgCon ( buildDynCon, bindConArgs )
-import CgExpr ( cgExpr, getPrimOpArgAmodes )
import CgHeapery ( heapCheck )
-import CgRetConv -- lots of stuff
-import CgStackery -- plenty
+import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
+ ctrlReturnConvAlg,
+ DataReturnConvention(..), CtrlReturnConvention(..),
+ assignPrimOpResultRegs,
+ makePrimOpArgsRobust
+ )
+import CgStackery ( allocAStack, allocBStack )
import CgTailCall ( tailCallBusiness, performReturn )
-import CgUsages -- and even more
-import CLabel -- bunches of things...
-import ClosureInfo {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
- layOutDynCon
- )-}
-import CostCentre ( useCurrentCostCentre, CostCentre )
-import Literal ( literalPrimRep )
-import Id ( getDataConTag, getIdPrimRep, fIRST_TAG, isDataCon,
- toplevelishId, getInstantiatedDataConSig,
- ConTag(..), DataCon(..)
+import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
+import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
+ mkAltLabel, mkClosureLabel
+ )
+import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
+import CmdLineOpts ( opt_SccProfilingOn )
+import CostCentre ( useCurrentCostCentre )
+import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) )
+import Id ( idPrimRep, toplevelishId,
+ dataConTag, fIRST_TAG, ConTag(..),
+ isDataCon, DataCon(..),
+ idSetToList, GenId{-instance NamedThing,Eq-}
)
-import Maybes ( catMaybes, Maybe(..) )
-import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, PrimRep(..) )
-import UniqSet -- ( uniqSetToList, UniqSet(..) )
-import Util
+import Maybes ( catMaybes )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
+import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
+ PrimRep(..)
+ )
+import TyCon ( isEnumerationTyCon )
+import Type ( typePrimRep,
+ getDataSpecTyCon, getDataSpecTyCon_maybe,
+ isEnumerationTyCon
+ )
+import Util ( sortLt, isIn, isn'tIn, zipEqual,
+ pprError, panic, assertPanic
+ )
+
+getDataSpecTyCon = panic "CgCase.getDataSpecTyCon (ToDo)"
+getDataSpecTyCon_maybe = panic "CgCase.getDataSpecTyCon_maybe (ToDo)"
\end{code}
\begin{code}
@@ -193,18 +211,17 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
| otherwise -- *Can* trigger GC
= getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
---NO: getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- Get amodes for the arguments and results, and assign to regs
-- (Can-trigger-gc primops guarantee to have their (nonRobust)
-- args in regs)
let
- op_result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op
+ op_result_regs = assignPrimOpResultRegs op
op_result_amodes = map CReg op_result_regs
(op_arg_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
+ = makePrimOpArgsRobust op arg_amodes
liveness_arg = mkIntCLit liveness_mask
in
@@ -275,7 +292,7 @@ eliminate a heap check altogether.
\begin{code}
cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
- = getAtomAmode v `thenFC` \ amode ->
+ = getArgAmode v `thenFC` \ amode ->
cgPrimAltsGivenScrutinee NoGC amode alts deflt
\end{code}
@@ -288,7 +305,7 @@ cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
=
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getAtomAmodes args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
-- Squish the environment
nukeDeadBindings live_in_alts `thenC`
@@ -368,7 +385,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
tag_amode = CTemp uniq IntRep
- (spec_tycon, _, _) = getUniDataSpecTyCon ty
+ (spec_tycon, _, _) = getDataSpecTyCon ty
getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
-- Default is either StgNoDefault or StgBindDefault with unused binder
@@ -383,14 +400,14 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
-- Sort alternatives into canonical order; there must be a complete
-- set because there's no default case.
sorted_alts = sortLt lt alts
- (con1,_,_,_) `lt` (con2,_,_,_) = getDataConTag con1 < getDataConTag con2
+ (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
arg_amodes :: [CAddrMode]
-- Turn them into amodes
arg_amodes = concat (map mk_amodes sorted_alts)
mk_amodes (con, args, use_mask, rhs)
- = [ CTemp (getItsUnique arg) (getIdPrimRep arg) | arg <- args ]
+ = [ CTemp (getItsUnique arg) (idPrimRep arg) | arg <- args ]
\end{code}
The situation is simpler for primitive
@@ -398,9 +415,7 @@ results, because there is only one!
\begin{code}
getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
- = [CTemp uniq kind]
- where
- kind = primRepFromType ty
+ = [CTemp uniq (typePrimRep ty)]
\end{code}
@@ -425,7 +440,6 @@ cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if
cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
= -- Generate the instruction to restore cost centre, if any
restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
@@ -437,7 +451,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
-- which is worse than having the alt code in the switch statement
let
- (spec_tycon, _, _) = getUniDataSpecTyCon ty
+ (spec_tycon, _, _) = getDataSpecTyCon ty
use_labelled_alts
= case ctrlReturnConvAlg spec_tycon of
@@ -448,7 +462,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
= if not use_labelled_alts then
Nothing -- no semi-tagging info
else
- cgSemiTaggedAlts isw_chkr uniq alts deflt -- Just <something>
+ cgSemiTaggedAlts uniq alts deflt -- Just <something>
in
cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
`thenFC` \ (tagged_alt_absCs, deflt_absC) ->
@@ -560,10 +574,9 @@ It's all pretty turgid anyway.
\begin{code}
cgAlgAlts gc_flag uniq restore_cc semi_tagging
ty alts deflt@(StgBindDefault binder True{-used-} _)
- = getIntSwitchChkrC `thenFC` \ isw_chkr ->
- let
+ = let
extra_branches :: [FCode (ConTag, AbstractC)]
- extra_branches = catMaybes (map (mk_extra_branch isw_chkr) default_cons)
+ extra_branches = catMaybes (map mk_extra_branch default_cons)
must_label_default = semi_tagging || not (null extra_branches)
in
@@ -575,14 +588,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
default_join_lbl = mkDefaultLabel uniq
jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
- (spec_tycon, _, spec_cons)
- = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
- -- ppr PprDebug uniq,
- -- ppr PprDebug ty,
- -- ppr PprShowAll binder
- -- ]))) (
- getUniDataSpecTyCon ty
- -- )
+ (spec_tycon, _, spec_cons) = getDataSpecTyCon ty
alt_cons = [ con | (con,_,_,_) <- alts ]
@@ -596,18 +602,18 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
-- nothing to do. Otherwise, we have a special case for a nullary constructor,
-- but in the general case we do an allocation and heap-check.
- mk_extra_branch :: IntSwitchChecker -> DataCon -> (Maybe (FCode (ConTag, AbstractC)))
+ mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
- mk_extra_branch isw_chkr con
+ mk_extra_branch con
= ASSERT(isDataCon con)
- case dataReturnConvAlg isw_chkr con of
+ case dataReturnConvAlg con of
ReturnInHeap -> Nothing
ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
returnFC (tag, abs_c)
)
where
lf_info = mkConLFInfo con
- tag = getDataConTag con
+ tag = dataConTag con
closure_lbl = mkClosureLabel con
-- alloc_code generates code to allocate constructor con, whose args are
@@ -625,7 +631,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
absC jump_instruction
)
where
- zero_size reg = getPrimRepSize (kindFromMagicId reg) == 0
+ zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
\end{code}
Now comes the general case
@@ -698,16 +704,15 @@ cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
in
returnFC (tag, final_abs_c)
where
- tag = getDataConTag con
+ tag = dataConTag con
lbl = mkAltLabel uniq tag
cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
cgAlgAltRhs gc_flag con args use_mask rhs
- = getIntSwitchChkrC `thenFC` \ isw_chkr ->
- let
+ = let
(live_regs, node_reqd)
- = case (dataReturnConvAlg isw_chkr con) of
+ = case (dataReturnConvAlg con) of
ReturnInHeap -> ([], True)
ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
-- Pick the live registers using the use_mask
@@ -735,14 +740,13 @@ Turgid-but-non-monadic code to conjure up the required info from
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: IntSwitchChecker
- -> Unique
+cgSemiTaggedAlts :: Unique
-> [(Id, [Id], [Bool], StgExpr)]
-> GenStgCaseDefault Id Id
-> SemiTaggingStuff
-cgSemiTaggedAlts isw_chkr uniq alts deflt
- = Just (map (st_alt isw_chkr) alts, st_deflt deflt)
+cgSemiTaggedAlts uniq alts deflt
+ = Just (map st_alt alts, st_deflt deflt)
where
st_deflt StgNoDefault = Nothing
@@ -752,8 +756,8 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt
mkDefaultLabel uniq)
)
- st_alt isw_chkr (con, args, use_mask, _)
- = case (dataReturnConvAlg isw_chkr con) of
+ st_alt (con, args, use_mask, _)
+ = case (dataReturnConvAlg con) of
ReturnInHeap ->
-- Ha! Nothing to do; Node already points to the thing
@@ -767,7 +771,7 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt
-- We have to load the live registers from the constructor
-- pointed to by Node.
let
- (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs
+ (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
used_regs = selectByMask use_mask regs
@@ -784,12 +788,12 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt
CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
join_label))
where
- con_tag = getDataConTag con
+ con_tag = dataConTag con
join_label = mkAltLabel uniq con_tag
move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
move_to_reg (reg, offset)
- = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
+ = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
\end{code}
%************************************************************************
@@ -821,7 +825,7 @@ cgPrimAlts gc_flag uniq ty alts deflt
NoGC -> CTemp uniq kind
GCMayHappen -> CReg (dataReturnConvPrim kind)
- kind = primRepFromType ty
+ kind = typePrimRep ty
cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
@@ -892,7 +896,7 @@ saveVolatileVars :: StgLiveVars -- Vars which should be made safe
-> FCode AbstractC -- Assignments to to the saves
saveVolatileVars vars
- = save_em (uniqSetToList vars)
+ = save_em (idSetToList vars)
where
save_em [] = returnFC AbsCNop
@@ -978,7 +982,9 @@ saveCurrentCostCentre ::
-- AbsCNop if not lexical CCs
saveCurrentCostCentre
- = isSwitchSetC SccProfilingOn `thenFC` \ doing_profiling ->
+ = let
+ doing_profiling = opt_SccProfilingOn
+ in
if not doing_profiling then
returnFC (Nothing, AbsCNop)
else
@@ -1047,9 +1053,9 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC
-- )
where
- (spec_tycon,_,_) = case (getUniDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
+ (spec_tycon,_,_) = case (getDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
Just xx -> xx
- Nothing -> error ("ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: "++(ppShow 80 (ppr PprDebug ty)))
+ Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty)
vtbl_label = mkVecTblLabel uniq
ret_label = mkReturnPtLabel uniq
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index af318428cbcad332d6c16f940eae72b70d43b141..eeaf9dac40992df531d724f6d9955761bd54ceca 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -12,31 +12,29 @@ with {\em closures} on the RHSs of let(rec)s. See also
module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
-import StgSyn
+import Ubiq{-uitous-}
+import CgLoop2 ( cgExpr, cgSccExpr )
+
import CgMonad
import AbsCSyn
+import StgSyn
-import PrelInfo ( PrimOp(..), Name
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Type ( isPrimType, isPrimTyCon,
- getTauType, showTypeCategory, getTyConDataCons
- )
-import CgBindery ( getCAddrMode, getAtomAmodes,
- getCAddrModeAndInfo,
- bindNewToNode, bindNewToAStack, bindNewToBStack,
- bindNewToReg, bindArgsToRegs
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getCAddrMode, getArgAmodes,
+ getCAddrModeAndInfo, bindNewToNode,
+ bindNewToAStack, bindNewToBStack,
+ bindNewToReg, bindArgsToRegs,
+ stableAmodeIdInfo, heapIdInfo
)
import CgCompInfo ( spARelToInt, spBRelToInt )
-import CgExpr ( cgExpr, cgSccExpr )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
#ifdef GRAN
- , heapCheckOnly, fetchAndReschedule -- HWL
-#endif {- GRAN -}
+ , fetchAndReschedule -- HWL
+#endif
)
-import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
+import CgRetConv ( mkLiveRegsMask,
+ ctrlReturnConvAlg, dataReturnConvAlg,
CtrlReturnConvention(..), DataReturnConvention(..)
)
import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
@@ -46,20 +44,37 @@ import CgUsages ( getVirtSps, setRealAndVirtualSps,
getSpARelOffset, getSpBRelOffset,
getHpRelOffset
)
-import CLabel
+import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel,
+ mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
+ mkErrorStdEntryLabel, mkRednCountsLabel
+ )
import ClosureInfo -- lots and lots of stuff
-import CostCentre
-import Id ( idType, getIdPrimRep, isSysLocalId, myWrapperMaybe,
- showId, getIdInfo, getIdStrictness,
- getDataConTag
+import CmdLineOpts ( opt_EmitArityChecks, opt_ForConcurrent,
+ opt_AsmTarget
+ )
+import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
+ noCostCentreAttached, costsAreSubsumed,
+ isCafCC, overheadCostCentre
+ )
+import HeapOffs ( VirtualHeapOffset(..) )
+import Id ( idType, idPrimRep,
+ showId, getIdStrictness, dataConTag,
+ emptyIdSet,
+ GenId{-instance Outputable-}
)
-import IdInfo
import ListSetOps ( minusList )
-import Maybes ( Maybe(..), maybeToBool )
-import PrimRep ( isFollowableRep )
-import UniqSet
-import Unpretty
-import Util
+import Maybes ( maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
+import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr )
+import PrimRep ( isFollowableRep, PrimRep(..) )
+import TyCon ( isPrimTyCon, tyConDataCons )
+import Unpretty ( uppShow )
+import Util ( isIn, panic, pprPanic, assertPanic )
+
+myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
+showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
+getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
%********************************************************
@@ -171,7 +186,7 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
-- ToDo: check non-primitiveness (ASSERT)
= (
-- LAY OUT THE OBJECT
- getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
+ getArgAmodes std_thunk_payload `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
= layOutDynClosure binder getAmodeRep amodes lf_info
@@ -226,7 +241,7 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
- get_kind (id, amode_and_info) = getIdPrimRep id
+ get_kind (id, amode_and_info) = idPrimRep id
in
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
@@ -302,7 +317,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
-- If f is not top-level, then f is one of the free variables too,
-- hence "payload_ids" isn't the same as "arg_ids".
--
- vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyUniqSet
+ vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet
-- Empty live vars
arg_ids_w_info = [(name,mkLFArgument) | name <- args]
@@ -320,7 +335,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
-- let x = f p q -- x isn't top level!
-- in ...
- get_kind (id, info) = getIdPrimRep id
+ get_kind (id, info) = idPrimRep id
payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
(closure_info, payload_bind_details) = layOutDynClosure
@@ -390,11 +405,10 @@ closureCodeBody binder_info closure_info cc [] body
#endif
getAbsC body_code `thenFC` \ body_absC ->
moduleName `thenFC` \ mod_name ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
absC (CClosureInfoAndCode closure_info body_absC Nothing
stdUpd (cl_descr mod_name)
- (dataConLiveness isw_chkr closure_info))
+ (dataConLiveness closure_info))
where
cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
@@ -418,22 +432,19 @@ Node points to closure is available. -- HWL
\begin{code}
closureCodeBody binder_info closure_info cc all_args body
= getEntryConvention id lf_info
- (map getIdPrimRep all_args) `thenFC` \ entry_conv ->
-
- isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
-
- isStringSwitchSetC AsmTarget `thenFC` \ native_code ->
-
+ (map idPrimRep all_args) `thenFC` \ entry_conv ->
let
+ do_arity_chks = opt_EmitArityChecks
+ is_concurrent = opt_ForConcurrent
+ native_code = opt_AsmTarget
+
stg_arity = length all_args
-- Arg mapping for standard (slow) entry point; all args on stack
(spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
= mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
- getIdPrimRep
+ idPrimRep
all_args
-- Arg mapping for the fast entry point; as many args as poss in
@@ -450,7 +461,7 @@ closureCodeBody binder_info closure_info cc all_args body
(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
= mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
- getIdPrimRep
+ idPrimRep
stk_args
-- HWL; Note: empty list of live regs in slow entry code
@@ -531,7 +542,6 @@ closureCodeBody binder_info closure_info cc all_args body
`thenFC` \ slow_abs_c ->
forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
moduleName `thenFC` \ mod_name ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- Now either construct the info table, or put the fast code in alone
-- (We never have slow code without an info table)
@@ -539,7 +549,7 @@ closureCodeBody binder_info closure_info cc all_args body
if info_table_needed then
CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
stdUpd (cl_descr mod_name)
- (dataConLiveness isw_chkr closure_info)
+ (dataConLiveness closure_info)
else
CCodeBlock fast_label fast_abs_c
)
@@ -665,18 +675,22 @@ argSatisfactionCheck closure_info args
if (isFollowableRep (getAmodeRep last_amode)) then
getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
+ let
+ lit = mkIntCLit (spARelToInt spA off)
+ in
if node_points then
- absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt spA off)])
+ absC (CMacroStmt ARGS_CHK_A [lit])
else
- absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
- [mkIntCLit (spARelToInt spA off), set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [lit, set_Node_to_this])
else
- getSpBRelOffset 0 `thenFC` \ b_rel_offset ->
+ getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
+ let
+ lit = mkIntCLit (spBRelToInt spB off)
+ in
if node_points then
- absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)])
+ absC (CMacroStmt ARGS_CHK_B [lit])
else
- absC (CMacroStmt ARGS_CHK_B_LOAD_NODE
- [mkIntCLit (spBRelToInt b_rel_offset), set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [lit, set_Node_to_this])
where
-- We must tell the arg-satis macro whether Node is pointing to
-- the closure or not. If it isn't so pointing, then we give to
@@ -780,7 +794,7 @@ stackCheck closure_info regs node_reqd code
)
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
returns_prim_type = closureReturnsUnboxedType closure_info
\end{code}
@@ -817,8 +831,7 @@ setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
setupUpdate closure_info code
= if (closureUpdReqd closure_info) then
link_caf_if_needed `thenFC` \ update_closure ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- pushUpdateFrame update_closure (vector isw_chkr) code
+ pushUpdateFrame update_closure vector code
else
profCtrC SLIT("UPDF_OMITTED") [] `thenC`
code
@@ -849,7 +862,7 @@ setupUpdate closure_info code
closure_label = mkClosureLabel (closureId closure_info)
- vector isw_chkr
+ vector
= case (closureType closure_info) of
Nothing -> CReg StdUpdRetVecReg
Just (spec_tycon, _, spec_datacons) ->
@@ -857,9 +870,9 @@ setupUpdate closure_info code
UnvectoredReturn 1 ->
let
spec_data_con = head spec_datacons
- only_tag = getDataConTag spec_data_con
+ only_tag = dataConTag spec_data_con
- direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
+ direct = case (dataReturnConvAlg spec_data_con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
@@ -893,8 +906,8 @@ closureDescription :: FAST_STRING -- Module
-- 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 args body =
- uppShow 0 (prettyToUn (
+closureDescription mod_name name args body
+ = uppShow 0 (prettyToUn (
ppBesides [ppChar '<',
ppPStr mod_name,
ppChar '.',
diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs
index 4b52bf0b6a1148a17df0b9a88474b65955c80084..9b14dcdaf99da759abd203d6e27426e6b1296ed1 100644
--- a/ghc/compiler/codeGen/CgCompInfo.lhs
+++ b/ghc/compiler/codeGen/CgCompInfo.lhs
@@ -141,6 +141,9 @@ mAX_INTLIKE = MAX_INTLIKE
\begin{code}
-- THESE ARE DIRECTION SENSITIVE!
+spARelToInt :: Int{-VirtualSpAOffset-} -> Int{-VirtualSpAOffset-} -> Int
+spBRelToInt :: Int{-VirtualSpBOffset-} -> Int{-VirtualSpBOffset-} -> Int
+
spARelToInt spA off = spA - off -- equiv to: AREL(spA - off)
spBRelToInt spB off = off - spB -- equiv to: BREL(spB - off)
\end{code}
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 820133569966d52f1958fed339096b434cccfd1b..6c378a93eea94cddbcbb4d433b94bb16f39aa1c0 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
%
\section[CgCon]{Code generation for constructors}
@@ -11,55 +11,50 @@ with {\em constructors} on the RHSs of let(rec)s. See also
#include "HsVersions.h"
module CgCon (
- -- it's all exported, actually...
cgTopRhsCon, buildDynCon,
bindConArgs,
cgReturnDataCon
-
- -- and to make the interface self-sufficient...
) where
-import StgSyn
+import Ubiq{-uitous-}
+
import CgMonad
import AbsCSyn
+import StgSyn
-import Type ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
- TyCon, Class, Type
- )
-import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode,
- bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getArgAmodes, bindNewToNode,
+ bindArgsToRegs, newTempAmodeAndIdInfo,
+ idInfoToAmode, stableAmodeIdInfo,
+ heapIdInfo
)
import CgClosure ( cgTopRhsClosure )
-import CgHeapery ( allocDynClosure, heapCheck
-#ifdef GRAN
- , fetchAndReschedule -- HWL
-#endif {- GRAN -}
- )
import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE )
-
-import CgRetConv ( dataReturnConvAlg, mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
- )
+import CgHeapery ( allocDynClosure )
+import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CgUsages ( getHpRelOffset )
-import CLabel ( CLabel, mkClosureLabel, mkInfoTableLabel,
+import CLabel ( mkClosureLabel, mkInfoTableLabel,
mkPhantomInfoTableLabel,
mkConEntryLabel, mkStdEntryLabel
)
-import ClosureInfo -- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas
- {-( mkConLFInfo, mkLFArgument, closureLFInfo,
+import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
layOutDynCon, layOutDynClosure,
- layOutStaticClosure, UpdateFlag(..),
- mkClosureLFInfo, layOutStaticNoFVClosure
- )-}
-import Id ( getIdPrimRep, getDataConTag, getDataConTyCon,
- isDataCon, fIRST_TAG, DataCon(..), ConTag(..)
+ layOutStaticClosure
+ )
+import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre,
+ dontCareCostCentre
)
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimRep ( PrimRep(..), isFloatingRep, getPrimRepSize )
-import CostCentre
-import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import Util
+import Id ( idPrimRep, dataConTag, dataConTyCon,
+ isDataCon, DataCon(..),
+ emptyIdSet
+ )
+import Literal ( Literal(..) )
+import Maybes ( maybeToBool )
+import PrimRep ( isFloatingRep, PrimRep(..) )
+import Util ( isIn, zipWithEqual, panic, assertPanic )
+
+maybeCharLikeTyCon = panic "CgCon.maybeCharLikeTyCon (ToDo)"
+maybeIntLikeTyCon = panic "CgCon.maybeIntLikeTyCon (ToDo)"
\end{code}
%************************************************************************
@@ -71,7 +66,7 @@ import Util
\begin{code}
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
- -> [StgArg] -- Args
+ -> [StgArg] -- Args
-> Bool -- All zero-size args (see buildDynCon)
-> FCode (Id, CgIdInfo)
\end{code}
@@ -130,7 +125,7 @@ cgTopRhsCon name con args all_zero_size_args
|| any isLitLitArg args
= cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
where
- body = StgCon con args emptyUniqSet{-emptyLiveVarSet-}
+ body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
\end{code}
@@ -142,7 +137,7 @@ cgTopRhsCon name con args all_zero_size_args
ASSERT(isDataCon con)
-- LAY IT OUT
- getAtomAmodes args `thenFC` \ amodes ->
+ getArgAmodes args `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
@@ -163,13 +158,13 @@ cgTopRhsCon name con args all_zero_size_args
-- RETURN
returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
where
- con_tycon = getDataConTyCon con
- lf_info = mkConLFInfo con
+ con_tycon = dataConTyCon con
+ lf_info = mkConLFInfo con
- closure_label = mkClosureLabel name
+ closure_label = mkClosureLabel name
info_label = mkInfoTableLabel con
- con_entry_label = mkConEntryLabel con
- entry_label = mkStdEntryLabel name
+ con_entry_label = mkConEntryLabel con
+ entry_label = mkStdEntryLabel name
\end{code}
The general case is:
@@ -314,10 +309,10 @@ buildDynCon binder cc con [arg_amode] all_zero_size_args@False
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
(temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
- in_range_int_lit (CLit (MachInt val _)) = (val <= mAX_INTLIKE) && (val >= mIN_INTLIKE)
+ in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
in_range_int_lit other_amode = False
\end{code}
@@ -357,13 +352,11 @@ found a $con$.
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
= ASSERT(isDataCon con)
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-
- case (dataReturnConvAlg isw_chkr con) of
+ case (dataReturnConvAlg con) of
ReturnInRegs rs -> bindArgsToRegs args rs
ReturnInHeap ->
let
- (_, args_w_offsets) = layOutDynCon con getIdPrimRep args
+ (_, args_w_offsets) = layOutDynCon con idPrimRep args
in
mapCs bind_arg args_w_offsets
where
@@ -385,13 +378,12 @@ cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code
cgReturnDataCon con amodes all_zero_size_args live_vars
= ASSERT(isDataCon con)
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
case sequel of
CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
- | not (getDataConTag con `is_elem` map fst alts)
+ | 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:
@@ -423,7 +415,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
-- Ignore the sequel: we've already looked at it above
other_sequel -> -- The usual case
- case (dataReturnConvAlg isw_chkr con) of
+ case (dataReturnConvAlg con) of
ReturnInHeap ->
-- BUILD THE OBJECT IN THE HEAP
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 79dd48e6ea91f0b5148a83d9115a3bd26a45f731..4252890f08e1662e064faaaadc91edfa7e723ade 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -1,59 +1,52 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgConTbls]{Info tables and update bits for constructors}
\begin{code}
#include "HsVersions.h"
-module CgConTbls (
- genStaticConBits,
+module CgConTbls ( genStaticConBits ) where
- -- and to complete the interface...
- TCE(..), UniqFM, CompilationInfo, AbstractC
- ) where
-
-import Pretty -- ToDo: rm (debugging)
-import Outputable
+import Ubiq{-uitous-}
import AbsCSyn
import CgMonad
-import Type ( getTyConDataCons, primRepFromType,
- maybeIntLikeTyCon, mkSpecTyCon,
- TyVarTemplate, TyCon, Class,
- TauType(..), Type, ThetaType(..)
- )
+import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
+import CgCompInfo ( uF_UPDATEE )
import CgHeapery ( heapCheck, allocDynClosure )
-import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
- mkLiveRegsBitMask,
+import CgRetConv ( mkLiveRegsMask,
+ dataReturnConvAlg, ctrlReturnConvAlg,
CtrlReturnConvention(..),
DataReturnConvention(..)
)
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import CgUsages ( getHpRelOffset )
-import CLabel ( mkConEntryLabel, mkStaticConEntryLabel,
- mkClosureLabel,
- mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
- mkStdUpdVecTblLabel, CLabel
+import CLabel ( mkConEntryLabel, mkClosureLabel,
+ mkConUpdCodePtrVecLabel,
+ mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel
)
import ClosureInfo ( layOutStaticClosure, layOutDynCon,
- closureSizeWithoutFixedHdr, closurePtrsSize,
- fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure,
+ layOutPhantomClosure, closurePtrsSize,
+ fitsMinUpdSize, mkConLFInfo,
infoTableLabelFromCI, dataConLiveness
)
-import FiniteMap
-import Id ( getDataConTag, getDataConSig, getDataConTyCon,
- mkSameSpecCon,
- getDataConArity, fIRST_TAG, ConTag(..),
- DataCon(..)
+import CostCentre ( dontCareCostCentre )
+import FiniteMap ( fmToList )
+import HeapOffs ( zeroOff, VirtualHeapOffset(..) )
+import Id ( dataConTag, dataConSig,
+ dataConArity, fIRST_TAG,
+ emptyIdSet,
+ GenId{-instance NamedThing-}
)
-import CgCompInfo ( uF_UPDATEE )
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimRep ( getPrimRepSize, retPrimRepSize )
-import CostCentre
-import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import Util
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import TyCon ( tyConDataCons, mkSpecTyCon )
+import Type ( typePrimRep )
+import Util ( panic )
+
+maybeIntLikeTyCon = panic "CgConTbls.maybeIntLikeTyCon (ToDo)"
+mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)"
\end{code}
For every constructor we generate the following info tables:
@@ -139,7 +132,7 @@ genStaticConBits comp_info gen_tycons tycon_specs
`mkAbsCStmts`
maybe_tycon_vtbl
where
- data_cons = getTyConDataCons tycon
+ data_cons = tyConDataCons tycon
tycon_upd_label = mkStdUpdVecTblLabel tycon
maybe_tycon_vtbl =
@@ -157,7 +150,7 @@ genStaticConBits comp_info gen_tycons tycon_specs
`mkAbsCStmts`
maybe_spec_tycon_vtbl
where
- data_cons = getTyConDataCons tycon
+ data_cons = tyConDataCons tycon
spec_tycon = mkSpecTyCon tycon ty_maybes
spec_data_cons = map (mkSameSpecCon ty_maybes) data_cons
@@ -174,15 +167,12 @@ genStaticConBits comp_info gen_tycons tycon_specs
------------------
mk_upd_label tycon con
= CLbl
- (case (dataReturnConvAlg isw_chkr con) of
+ (case (dataReturnConvAlg con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag)
CodePtrRep
where
- tag = getDataConTag con
-
- ------------------
- (MkCompInfo sw_chkr isw_chkr _) = comp_info
+ tag = dataConTag con
\end{code}
%************************************************************************
@@ -197,7 +187,7 @@ static closure, for a constructor.
\begin{code}
genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC
-genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
+genConInfo comp_info tycon data_con
= mkAbstractCs [
CSplitMarker,
inregs_upd_maybe,
@@ -206,12 +196,12 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
closure_maybe]
-- Order of things is to reduce forward references
where
- (closure_info, body_code) = mkConCodeAndInfo isw_chkr data_con
+ (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,_) = layOutStaticClosure data_con primRepFromType arg_tys (mkConLFInfo data_con)
+ (static_ci,_) = layOutStaticClosure data_con typePrimRep arg_tys (mkConLFInfo data_con)
body = (initC comp_info (
profCtrC SLIT("ENT_CON") [CReg node] `thenC`
@@ -222,16 +212,16 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
closure_code = CClosureInfoAndCode closure_info body Nothing
stdUpd con_descr
- (dataConLiveness isw_chkr closure_info)
+ (dataConLiveness closure_info)
static_code = CClosureInfoAndCode static_ci body Nothing
stdUpd con_descr
- (dataConLiveness isw_chkr static_ci)
+ (dataConLiveness static_ci)
inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con
stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep
- tag = getDataConTag data_con
+ tag = dataConTag data_con
cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
@@ -247,42 +237,41 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
cost_centre
[{-No args! A slight lie for constrs with VoidRep args-}]
- zero_size arg_ty = getPrimRepSize (primRepFromType arg_ty) == 0
+ zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0
- (_,_,arg_tys,_) = getDataConSig data_con
- con_arity = getDataConArity data_con
+ (_,_,arg_tys,_) = dataConSig data_con
+ con_arity = dataConArity data_con
entry_label = mkConEntryLabel data_con
closure_label = mkClosureLabel data_con
\end{code}
\begin{code}
-mkConCodeAndInfo :: IntSwitchChecker
- -> Id -- Data constructor
+mkConCodeAndInfo :: Id -- Data constructor
-> (ClosureInfo, Code) -- The info table
-mkConCodeAndInfo isw_chkr con
- = case (dataReturnConvAlg isw_chkr con) of
+mkConCodeAndInfo con
+ = case (dataReturnConvAlg con) of
ReturnInRegs regs ->
let
(closure_info, regs_w_offsets)
- = layOutDynCon con kindFromMagicId regs
+ = layOutDynCon con magicIdPrimRep regs
body_code
= profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ emptyIdSet{-no live vars-}
in
(closure_info, body_code)
ReturnInHeap ->
let
- (_, _, arg_tys, _) = getDataConSig con
+ (_, _, arg_tys, _) = dataConSig con
(closure_info, arg_things)
- = layOutDynCon con primRepFromType arg_tys
+ = layOutDynCon con typePrimRep arg_tys
body_code
= -- NB: We don't set CC when entering data (WDP 94/06)
@@ -290,14 +279,14 @@ mkConCodeAndInfo isw_chkr con
performReturn AbsCNop -- Ptr to thing already in Node
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ emptyIdSet{-no live vars-}
in
(closure_info, body_code)
where
move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
move_to_reg (reg, offset)
- = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
+ = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
\end{code}
%************************************************************************
@@ -312,8 +301,8 @@ Generate the "phantom" info table and update code, iff the constructor returns i
genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
-genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
- = case (dataReturnConvAlg isw_chkr data_con) of
+genPhantomUpdInfo comp_info tycon data_con
+ = case (dataReturnConvAlg data_con) of
ReturnInHeap -> AbsCNop -- No need for a phantom update
@@ -321,19 +310,19 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
let
phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
upd_code con_descr
- (dataConLiveness isw_chkr phantom_ci)
+ (dataConLiveness phantom_ci)
phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
con_descr = _UNPK_ (getOccurrenceName data_con)
- con_arity = getDataConArity data_con
+ con_arity = dataConArity data_con
upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
upd_label = mkConUpdCodePtrVecLabel tycon tag
- tag = getDataConTag data_con
+ tag = dataConTag data_con
- updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrRep
+ updatee = CVal (SpBRel 0 (- uF_UPDATEE)) PtrRep
perform_return = mkAbstractCs
[
@@ -352,7 +341,7 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
blame_cc = use_cc -- who to blame for allocation
do_move (reg, virt_offset) =
- CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg)
+ CAssign (CVal (NodeRel virt_offset) (magicIdPrimRep reg)) (CReg reg)
-- Code for building a new constructor in place over the updatee
@@ -402,9 +391,9 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
])
- (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
+ (closure_info, regs_w_offsets) = layOutDynCon data_con magicIdPrimRep regs
info_label = infoTableLabelFromCI closure_info
- liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
+ liveness_mask = mkIntCLit (mkLiveRegsMask (node:regs))
build_closure =
if fitsMinUpdSize closure_info then
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 4713767f5a6514ad6870ec4abbd4a64854762b1a..6fed11240287dff664124fb4c21ed4d004fe6fdc 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -10,40 +10,41 @@
\begin{code}
#include "HsVersions.h"
-module CgExpr (
- cgExpr, cgSccExpr, getPrimOpArgAmodes
+module CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) where
- -- and to make the interface self-sufficient...
- ) where
+import Ubiq{-uitous-}
+import CgLoop2 -- here for paranoia-checking
import StgSyn
import CgMonad
import AbsCSyn
-import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..),
- primOpHeapReq, getPrimOpResultInfo, PrimRep,
- primOpCanTriggerGC
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Type ( isPrimType, getTyConDataCons )
-import CLabel ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
-import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo )
-import CgBindery ( getAtomAmodes )
+import AbsCUtils ( mkAbsCStmts, mkAbstractCs )
+import CgBindery ( getArgAmodes )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgHeapery ( allocHeap )
import CgLetNoEscape ( cgLetNoEscapeClosure )
-import CgRetConv -- various things...
-import CgTailCall ( cgTailCall, performReturn, mkDynamicAlgReturnCode,
- mkPrimReturnCode
+import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
+ DataReturnConvention(..), CtrlReturnConvention(..),
+ assignPrimOpResultRegs, makePrimOpArgsRobust
+ )
+import CgTailCall ( cgTailCall, performReturn,
+ mkDynamicAlgReturnCode, mkPrimReturnCode
+ )
+import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
+import ClosureInfo ( mkClosureLFInfo )
+import CostCentre ( setToAbleCostCentre, isDupdCC )
+import HeapOffs ( VirtualSpBOffset(..) )
+import Id ( mkIdSet, unionIdSets, GenId{-instance Outputable-} )
+import PprStyle ( PprStyle(..) )
+import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
+ getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
)
-import CostCentre ( setToAbleCostCentre, isDupdCC, CostCentre )
-import Maybes ( Maybe(..) )
-import PrimRep ( getPrimRepSize )
-import UniqSet
-import Util
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import TyCon ( tyConDataCons )
+import Util ( panic, pprPanic )
\end{code}
This module provides the support code for @StgToAbstractC@ to deal
@@ -77,7 +78,7 @@ cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
\begin{code}
cgExpr (StgCon con args live_vars)
- = getAtomAmodes args `thenFC` \ amodes ->
+ = getArgAmodes args `thenFC` \ amodes ->
cgReturnDataCon con amodes (all zero_size args) live_vars
where
zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
@@ -93,10 +94,9 @@ Here is where we insert real live machine instructions.
\begin{code}
cgExpr x@(StgPrim op args live_vars)
- = getIntSwitchChkrC `thenFC` \ isw_chkr ->
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+ = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
let
- result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op
+ result_regs = assignPrimOpResultRegs op
result_amodes = map CReg result_regs
may_gc = primOpCanTriggerGC op
dyn_tag = head result_amodes
@@ -108,7 +108,7 @@ cgExpr x@(StgPrim op args live_vars)
-- (Can-trigger-gc primops guarantee to have their args in regs)
let
(arg_robust_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
+ = makePrimOpArgsRobust op arg_amodes
liveness_arg = mkIntCLit liveness_mask
in
@@ -172,10 +172,10 @@ cgExpr x@(StgPrim op args live_vars)
vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
dyn_tag DataPtrRep
- data_con = head (getTyConDataCons tycon)
+ data_con = head (tyConDataCons tycon)
(dir_lbl, num_of_fields)
- = case (dataReturnConvAlg fake_isw_chkr data_con) of
+ = case (dataReturnConvAlg data_con) of
ReturnInRegs rs
-> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
mkIntCLit (length rs)) -- for ticky-ticky only
@@ -184,8 +184,6 @@ cgExpr x@(StgPrim op args live_vars)
-> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con)
-- Never used, and no point in generating
-- the code for it!
-
- fake_isw_chkr x = Nothing
where
-- for all PrimOps except ccalls, we pin the liveness info
-- on as the first "argument"
@@ -314,7 +312,7 @@ cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along so a binding can be set up
cgRhs name (StgRhsCon maybe_cc con args)
- = getAtomAmodes args `thenFC` \ amodes ->
+ = getArgAmodes args `thenFC` \ amodes ->
buildDynCon name maybe_cc con amodes (all zero_size args)
`thenFC` \ idinfo ->
returnFC (name, idinfo)
@@ -344,7 +342,7 @@ cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
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!
- full_live_in_rhss = live_in_rhss `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs])
+ full_live_in_rhss = live_in_rhss `unionIdSets` (mkIdSet [b | (b,r) <- pairs])
cgLetNoEscapeRhs
:: StgLiveVars -- Live in rhss
@@ -386,10 +384,9 @@ Main current use: allocating SynchVars.
\begin{code}
getPrimOpArgAmodes op args
- = getAtomAmodes args `thenFC` \ arg_amodes ->
+ = getArgAmodes args `thenFC` \ arg_amodes ->
case primOpHeapReq op of
-
FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
returnFC (amode : arg_amodes)
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index 98aed044e44a7aa300fd68e5f66c5279d363708f..798c6ba16ee1afe805923ff8c405111b7f93ea92 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgHeapery]{Heap management functions}
@@ -8,30 +8,31 @@
module CgHeapery (
heapCheck,
- allocHeap, allocDynClosure,
+ allocHeap, allocDynClosure
#ifdef GRAN
-- new for GrAnSim HWL
- heapCheckOnly, fetchAndReschedule,
+ , heapCheckOnly, fetchAndReschedule
#endif {- GRAN -}
-
- -- and to make the interface self-sufficient...
- AbstractC, CAddrMode, HeapOffset,
- CgState, ClosureInfo, Id
) where
+import Ubiq{-uitous-}
+
import AbsCSyn
import CgMonad
-import CgRetConv ( mkLiveRegsBitMask )
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgRetConv ( mkLiveRegsMask )
import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp,
initHeapUsage
)
-import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, slopSize,
- layOutDynClosure,
- allocProfilingMsg, closureKind
+import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize,
+ slopSize, allocProfilingMsg, closureKind
+ )
+import HeapOffs ( isZeroOff, addOff, intOff,
+ VirtualHeapOffset(..)
)
-import Util
+import PrimRep ( PrimRep(..) )
\end{code}
%************************************************************************
@@ -70,7 +71,7 @@ heapCheck regs node_reqd code
-- at once or not.
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
checking_code = CMacroStmt HEAP_CHK [
mkIntCLit liveness_mask,
@@ -149,7 +150,7 @@ heapCheck' do_context_switch regs node_reqd code
-- at once or not.
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
maybe_context_switch = if do_context_switch
then context_switch_code
@@ -177,7 +178,7 @@ fetchAndReschedule regs node_reqd =
else absC AbsCNop
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
mkIntCLit liveness_mask,
diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index 5480e934977c1f7ea6bbe8b896fc93018edf97fb..f59ef4eb7cffe65e128ab4b8d01ea181ce7a245d 100644
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -12,20 +12,24 @@
module CgLetNoEscape ( cgLetNoEscapeClosure ) where
+import Ubiq{-uitious-}
+import CgLoop2 ( cgExpr )
+
import StgSyn
import CgMonad
import AbsCSyn
-import CgBindery -- various things
-import CgExpr ( cgExpr )
+import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
+ bindNewToAStack, bindNewToBStack
+ )
import CgHeapery ( heapCheck )
import CgRetConv ( assignRegs )
import CgStackery ( mkVirtStkOffsets )
import CgUsages ( setRealAndVirtualSps, getVirtSps )
-import CLabel ( mkStdEntryLabel )
+import CLabel ( mkStdEntryLabel )
import ClosureInfo ( mkLFLetNoEscape )
-import Id ( getIdPrimRep )
-import Util
+import HeapOffs ( VirtualSpBOffset(..) )
+import Id ( idPrimRep )
\end{code}
%************************************************************************
@@ -164,10 +168,9 @@ cgLetNoEscapeBody :: [Id] -- Args
cgLetNoEscapeBody all_args rhs
= getVirtSps `thenFC` \ (vA, vB) ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
let
- arg_kinds = map getIdPrimRep all_args
- (arg_regs, _) = assignRegs isw_chkr [{-nothing live-}] arg_kinds
+ arg_kinds = map idPrimRep all_args
+ (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
stk_args = drop (length arg_regs) all_args
-- stk_args is the args which are passed on the stack at the fast-entry point
@@ -175,7 +178,7 @@ cgLetNoEscapeBody all_args rhs
(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
= mkVirtStkOffsets
vA vB -- Initial virtual SpA, SpB
- getIdPrimRep
+ idPrimRep
stk_args
in
diff --git a/ghc/compiler/codeGen/CgLoop1.lhi b/ghc/compiler/codeGen/CgLoop1.lhi
new file mode 100644
index 0000000000000000000000000000000000000000..ef8dd2d669484e557dbea97263e3846ee93d5deb
--- /dev/null
+++ b/ghc/compiler/codeGen/CgLoop1.lhi
@@ -0,0 +1,35 @@
+\begin{code}
+interface CgLoop1 where
+import PreludeStdIO ( Maybe )
+
+import CgBindery ( CgBindings(..), CgIdInfo(..),
+ VolatileLoc, StableLoc,
+ nukeVolatileBinds,
+ maybeAStkLoc, maybeBStkLoc
+ )
+import CgUsages ( getSpBRelOffset )
+
+import AbsCSyn ( RegRelative )
+import CgMonad ( FCode(..) )
+import ClosureInfo ( LambdaFormInfo )
+import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) )
+import Id ( IdEnv(..), Id(..) )
+
+type CgBindings = IdEnv CgIdInfo
+
+data CgIdInfo
+ = MkCgIdInfo Id -- Id that this is the info for
+ VolatileLoc
+ StableLoc
+ LambdaFormInfo
+
+data VolatileLoc
+data StableLoc
+data LambdaFormInfo
+
+nukeVolatileBinds :: CgBindings -> CgBindings
+maybeAStkLoc :: StableLoc -> Maybe VirtualSpAOffset
+maybeBStkLoc :: StableLoc -> Maybe VirtualSpBOffset
+
+getSpBRelOffset :: VirtualSpBOffset -> FCode RegRelative
+\end{code}
diff --git a/ghc/compiler/codeGen/CgLoop2.lhi b/ghc/compiler/codeGen/CgLoop2.lhi
new file mode 100644
index 0000000000000000000000000000000000000000..feda847f2cc9d530ee18a49b95ffcae763e2eaf2
--- /dev/null
+++ b/ghc/compiler/codeGen/CgLoop2.lhi
@@ -0,0 +1,15 @@
+Break loops caused by cgExpr and getPrimOpArgAmodes.
+\begin{code}
+interface CgLoop2 where
+
+import CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes )
+
+import AbsCSyn ( CAddrMode )
+import CgMonad ( Code(..), FCode(..) )
+import PrimOp ( PrimOp )
+import StgSyn ( StgExpr(..), StgArg(..) )
+
+cgExpr :: StgExpr -> Code
+cgSccExpr :: StgExpr -> Code
+getPrimOpArgAmodes :: PrimOp -> [StgArg] -> FCode [CAddrMode]
+\end{code}
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index 65c42179170bbaff4d115417e8b0c5321476a599..428d6f6881ab78a78b45981794c897431c25fc5f 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgMonad]{The code generation monad}
@@ -34,8 +34,6 @@ module CgMonad (
-- addFreeASlots, -- no need to export it
addFreeBSlots, -- ToDo: Belong elsewhere
- isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC,
-
noBlackHolingFlag,
profCtrC,
@@ -45,31 +43,35 @@ module CgMonad (
sequelToAmode,
-- out of general friendliness, we also export ...
- CgBindings(..),
CgInfoDownwards(..), CgState(..), -- non-abstract
- CgIdInfo, -- abstract
- CompilationInfo(..), IntSwitchChecker(..),
-
- stableAmodeIdInfo, heapIdInfo
-
- -- and to make the interface self-sufficient...
+ CompilationInfo(..)
) where
+import Ubiq{-uitous-}
+import CgLoop1 -- stuff from CgBindery and CgUsages
+
import AbsCSyn
-import Type ( primRepFromType, Type
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+import AbsCUtils ( mkAbsCStmts )
+import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
+ opt_OmitBlackHoling
+ )
+import HeapOffs ( maxOff,
+ VirtualSpAOffset(..), VirtualSpBOffset(..)
+ )
+import Id ( idType,
+ nullIdEnv, mkIdEnv, addOneToIdEnv,
+ modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv(..),
+ ConTag(..), GenId{-instance Outputable-}
)
-import CgBindery
-import CgUsages ( getSpBRelOffset )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( idType, ConTag(..), DataCon(..) )
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Pretty -- debugging only?
-import PrimRep ( getPrimRepSize, retPrimRepSize )
-import UniqSet -- ( elementOfUniqSet, UniqSet(..) )
-import CostCentre -- profiling stuff
-import StgSyn ( StgArg(..), StgLiveVars(..) )
-import Util
+import Maybes ( maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( ppAboves, ppCat, ppStr )
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import StgSyn ( StgLiveVars(..) )
+import Type ( typePrimRep )
+import UniqSet ( elementOfUniqSet )
+import Util ( sortLt, panic, pprPanic )
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
@@ -108,43 +110,42 @@ data CgState
CgStksAndHeapUsage
\end{code}
-@EndOfBlockInfo@ tells what to do at the end of this block of code
-or, if the expression is a @case@, what to do at the end of each alternative.
+@EndOfBlockInfo@ tells what to do at the end of this block of code or,
+if the expression is a @case@, what to do at the end of each
+alternative.
\begin{code}
data EndOfBlockInfo
= EndOfBlockInfo
- VirtualSpAOffset -- Args SpA: trim the A stack to this point at a return;
- -- push arguments starting just above this point on
- -- a tail call.
-
- -- This is therefore the A-stk ptr as seen
- -- by a case alternative.
-
- -- Args SpA is used when we want to stub any
- -- currently-unstubbed dead A-stack (ptr) slots;
- -- we want to know what SpA in the continuation is
- -- so that we don't stub any slots which are off the
- -- top of the continuation's stack!
-
- VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
-
- -- Two main differences:
- -- 1. If Sequel isn't OnStack, then Args SpB points
- -- just below the slot in which the return address
- -- should be put. In effect, the Sequel is
- -- a pending argument. If it is OnStack, Args SpB
- -- points to the top word of the return address.
- --
- -- 2. It ain't used for stubbing because there are
- -- no ptrs on B stk.
-
+ VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
+ -- return; push arguments starting just
+ -- above this point on a tail call.
+
+ -- This is therefore the A-stk ptr as seen
+ -- by a case alternative.
+
+ -- Args SpA is used when we want to stub any
+ -- currently-unstubbed dead A-stack (ptr)
+ -- slots; we want to know what SpA in the
+ -- continuation is so that we don't stub any
+ -- slots which are off the top of the
+ -- continuation's stack!
+
+ VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
+ -- Two main differences:
+ -- 1. If Sequel isn't OnStack, then Args SpB points
+ -- just below the slot in which the return address
+ -- should be put. In effect, the Sequel
+ -- is a pending argument. If it is
+ -- OnStack, Args SpB
+ -- points to the top word of the return
+ -- address.
+ --
+ -- 2. It ain't used for stubbing because there are
+ -- no ptrs on B stk.
Sequel
-
initEobInfo = EndOfBlockInfo 0 0 InRetReg
-
-
\end{code}
Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
@@ -153,21 +154,21 @@ block.
\begin{code}
data Sequel
- = InRetReg -- The continuation is in RetReg
-
- | OnStack VirtualSpBOffset
- -- Continuation is on the stack, at the
- -- specified location
+ = InRetReg -- The continuation is in RetReg
- | UpdateCode CAddrMode -- May be standard update code, or might be
- -- the data-type-specific one.
+ | OnStack VirtualSpBOffset
+ -- Continuation is on the stack, at the
+ -- specified location
- | CaseAlts
- CAddrMode -- Jump to this; if the continuation is for a vectored
- -- case this might be the label of a return vector
- -- Guaranteed to be a non-volatile addressing mode (I think)
+ | UpdateCode CAddrMode -- May be standard update code, or might be
+ -- the data-type-specific one.
- SemiTaggingStuff
+ | CaseAlts
+ CAddrMode -- Jump to this; if the continuation is for a vectored
+ -- case this might be the label of a return
+ -- vector Guaranteed to be a non-volatile
+ -- addressing mode (I think)
+ SemiTaggingStuff
type SemiTaggingStuff
= Maybe -- Maybe[1] we don't have any semi-tagging stuff...
@@ -182,17 +183,17 @@ type SemiTaggingStuff
type JoinDetails
= (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
-- and join point label
--- The abstract C is executed only from a successful
--- semitagging venture, when a case has looked at a variable, found
--- that it's evaluated, and wants to load up the contents and go to the
--- join point.
+-- The abstract C is executed only from a successful semitagging
+-- venture, when a case has looked at a variable, found that it's
+-- evaluated, and wants to load up the contents and go to the join
+-- point.
-- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only valid
--- just before the final control transfer, because it assumes that
--- SpB is pointing to the top word of the return address.
--- This seems unclean but there you go.
+-- The OnStack case of sequelToAmode delivers an Amode which is only
+-- valid just before the final control transfer, because it assumes
+-- that SpB is pointing to the top word of the return address. This
+-- seems unclean but there you go.
sequelToAmode :: Sequel -> FCode CAddrMode
@@ -576,17 +577,15 @@ nothing.
\begin{code}
costCentresC :: FAST_STRING -> [CAddrMode] -> Code
-costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
- state@(MkCgState absC binds usage)
- = if sw_chkr SccProfilingOn
+costCentresC macro args _ state@(MkCgState absC binds usage)
+ = if opt_SccProfilingOn
then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
else state
profCtrC :: FAST_STRING -> [CAddrMode] -> Code
-profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
- state@(MkCgState absC binds usage)
- = if not (sw_chkr DoTickyProfiling)
+profCtrC macro args _ state@(MkCgState absC binds usage)
+ = if not opt_DoTickyProfiling
then state
else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
@@ -616,17 +615,14 @@ getAbsC code info_down (MkCgState absC binds usage)
\begin{code}
noBlackHolingFlag, costCentresFlag :: FCode Bool
-noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr OmitBlackHoling, state)
-
-costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr SccProfilingOn, state)
+noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
+costCentresFlag _ state = (opt_SccProfilingOn, state)
\end{code}
\begin{code}
moduleName :: FCode FAST_STRING
-moduleName (MkCgInfoDown (MkCompInfo _ _ mod_name) _ _) state
+moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
= (mod_name, state)
\end{code}
@@ -802,7 +798,7 @@ dead_slots live_vars fbs das dbs ((v,i):bs)
_ -> dead_slots live_vars fbs das dbs bs
where
size :: Int
- size = (getPrimRepSize . primRepFromType . idType) v
+ size = (getPrimRepSize . typePrimRep . idType) v
-- addFreeSlots expects *both* args to be in increasing order
addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index 5881fb1f1ece4927f38b546c946d7695dc9cd44a..f1a35f6ab03feaaa2fdfdc7744dc5730dc214bd7 100644
--- a/ghc/compiler/codeGen/CgRetConv.lhs
+++ b/ghc/compiler/codeGen/CgRetConv.lhs
@@ -15,8 +15,6 @@ module CgRetConv (
ctrlReturnConvAlg,
dataReturnConvAlg,
- mkLiveRegsBitMask, noLiveRegsMask,
-
dataReturnConvPrim,
assignPrimOpResultRegs,
@@ -26,27 +24,35 @@ module CgRetConv (
-- and to make the interface self-sufficient...
) where
-import AbsCSyn
+import Ubiq{-uitous-}
+import AbsCLoop -- paranoia checking
-import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC,
- getPrimOpResultInfo, integerDataCon
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import AbsCSyn -- quite a few things
+import AbsCUtils ( mkAbstractCs, getAmodeRep,
+ amodeCanSurviveGC
+ )
+import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
+ mAX_Vanilla_REG, mAX_Float_REG,
+ mAX_Double_REG
+ )
+import CmdLineOpts ( opt_ReturnInRegsThreshold )
+import Id ( isDataCon, dataConSig,
+ DataCon(..), GenId{-instance Eq-}
)
-import Type ( getTyConFamilySize, primRepFromType, getTyConDataCons,
- TyVarTemplate, TyCon, Class,
- TauType(..), ThetaType(..), Type
+import Maybes ( catMaybes )
+import PprStyle ( PprStyle(..) )
+import PprType ( TyCon{-instance Outputable-} )
+import PrelInfo ( integerDataCon )
+import PrimOp ( primOpCanTriggerGC,
+ getPrimOpResultInfo, PrimOpResultInfo(..),
+ PrimOp{-instance Outputable-}
)
-import CgCompInfo -- various things
-import CgMonad ( IntSwitchChecker(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( Id, getDataConSig, fIRST_TAG, isDataCon,
- DataCon(..), ConTag(..)
+import PrimRep ( isFloatingRep, PrimRep(..) )
+import TyCon ( tyConDataCons, tyConFamilySize )
+import Type ( typePrimRep )
+import Util ( zipWithEqual, mapAccumL, isn'tIn,
+ pprError, pprTrace, panic, assertPanic
)
-import Maybes ( catMaybes, Maybe(..) )
-import PrimRep
-import Util
-import Pretty
\end{code}
%************************************************************************
@@ -88,11 +94,11 @@ The register assignment given by a @ReturnInRegs@ obeys three rules:
ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
ctrlReturnConvAlg tycon
- = case (getTyConFamilySize tycon) of
- Nothing -> -- pprPanic "ctrlReturnConvAlg:" (ppr PprDebug tycon)
- UnvectoredReturn 0 -- e.g., w/ "data Bin"
+ = case (tyConFamilySize tycon) of
+ 0 -> pprTrace "ctrlReturnConvAlg:" (ppr PprDebug tycon) $
+ UnvectoredReturn 0 -- e.g., w/ "data Bin"
- Just size -> -- we're supposed to know...
+ size -> -- we're supposed to know...
if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
VectoredReturn size
else
@@ -110,68 +116,23 @@ types. If @assign_reg@ runs out of a particular kind of register,
then it gives up, returning @ReturnInHeap@.
\begin{code}
-dataReturnConvAlg :: IntSwitchChecker -> DataCon -> DataReturnConvention
+dataReturnConvAlg :: DataCon -> DataReturnConvention
-dataReturnConvAlg isw_chkr data_con
+dataReturnConvAlg data_con
= ASSERT(isDataCon data_con)
case leftover_kinds of
[] -> ReturnInRegs reg_assignment
other -> ReturnInHeap -- Didn't fit in registers
where
- (_, _, arg_tys, _) = getDataConSig data_con
+ (_, _, arg_tys, _) = dataConSig data_con
(reg_assignment, leftover_kinds)
- = assignRegs isw_chkr_to_use
- [node, infoptr] -- taken...
- (map primRepFromType arg_tys)
-
- isw_chkr_to_use = isw_chkr
+ = assignRegs [node, infoptr] -- taken...
+ (map typePrimRep arg_tys)
is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11)
\end{code}
-\begin{code}
-noLiveRegsMask :: Int -- Mask indicating nothing live
-noLiveRegsMask = 0
-
-mkLiveRegsBitMask
- :: [MagicId] -- Candidate live regs; depends what they have in them
- -> Int
-
-mkLiveRegsBitMask regs
- = foldl do_reg noLiveRegsMask regs
- where
- do_reg acc (VanillaReg kind reg_no)
- | isFollowableRep kind
- = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1)))
-
- do_reg acc anything_else = acc
-
- reg_tbl -- ToDo: mk Array!
- = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
- lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
-
-{-
--- Completely opaque code. ADR
--- What's wrong with: (untested)
-
-mkLiveRegsBitMask regs
- = foldl (+) noLiveRegsMask (map liveness_bit regs)
- where
- liveness_bit (VanillaReg kind reg_no)
- | isFollowableRep kind
- = reg_tbl !! (reg_no - 1)
-
- liveness_bit anything_else
- = noLiveRegsBitMask
-
- reg_tbl
- = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
- lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
--}
-\end{code}
-
-
%************************************************************************
%* *
\subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
@@ -224,7 +185,7 @@ assignPrimOpResultRegs op
ReturnsAlg tycon
-> let
- cons = getTyConDataCons tycon
+ cons = tyConDataCons tycon
result_regs = concat (map get_return_regs cons)
in
-- As R1 is dead, it can hold the tag if necessary
@@ -233,12 +194,9 @@ assignPrimOpResultRegs op
other -> (VanillaReg IntRep ILIT(1)) : result_regs
where
get_return_regs con
- = case (dataReturnConvAlg fake_isw_chkr con) of
+ = case (dataReturnConvAlg con) of
ReturnInRegs regs -> regs
ReturnInHeap -> panic "getPrimOpAlgResultRegs"
-
- fake_isw_chkr :: IntSwitchChecker
- fake_isw_chkr x = Nothing
\end{code}
@assignPrimOpArgsRobust@ is used only for primitive ops which may
@@ -269,12 +227,12 @@ makePrimOpArgsRobust op arg_amodes
arg_kinds = map getAmodeRep non_robust_amodes
(arg_regs, extra_args)
- = assignRegs fake_isw_chkr [{-nothing live-}] arg_kinds
+ = assignRegs [{-nothing live-}] arg_kinds
-- Check that all the args fit before returning arg_regs
final_arg_regs = case extra_args of
[] -> arg_regs
- other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op))
+ other -> pprError "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr PprDebug op)
arg_assts
= mkAbstractCs (zipWithEqual assign_to_reg final_arg_regs non_robust_amodes)
@@ -286,12 +244,9 @@ makePrimOpArgsRobust op arg_amodes
| otherwise = (tail regs, CReg (head regs))
safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
- liveness_mask = mkLiveRegsBitMask final_arg_regs
+ liveness_mask = mkLiveRegsMask final_arg_regs
in
(safe_amodes, liveness_mask, arg_assts)
- where
- fake_isw_chkr :: IntSwitchChecker
- fake_isw_chkr x = Nothing
\end{code}
%************************************************************************
@@ -308,15 +263,14 @@ 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.
\begin{code}
-assignRegs :: IntSwitchChecker
- -> [MagicId] -- Unavailable registers
+assignRegs :: [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 isw_chkr regs_in_use kinds
- = assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use)
+assignRegs regs_in_use kinds
+ = assign_reg kinds [] (mkRegTbl regs_in_use)
where
assign_reg :: [PrimRep] -- arg kinds being scrutinized
@@ -360,9 +314,9 @@ floatRegNos, doubleRegNos :: [Int]
floatRegNos = [1 .. mAX_Float_REG]
doubleRegNos = [1 .. mAX_Double_REG]
-mkRegTbl :: IntSwitchChecker -> [MagicId] -> ([Int], [Int], [Int])
+mkRegTbl :: [MagicId] -> ([Int], [Int], [Int])
-mkRegTbl isw_chkr regs_in_use
+mkRegTbl regs_in_use
= (ok_vanilla, ok_float, ok_double)
where
ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) (taker vanillaRegNos))
@@ -371,7 +325,7 @@ mkRegTbl isw_chkr regs_in_use
taker :: [Int] -> [Int]
taker rs
- = case (isw_chkr ReturnInRegsThreshold) of
+ = case (opt_ReturnInRegsThreshold) of
Nothing -> rs -- no flag set; use all of them
Just n -> take n rs
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index 3759aa41e44ffe5fb81d7d40a637e6164699b300..0ad6fc52fb1a69de79388890664dc42a9ded7d7f 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgStackery]{Stack management functions}
@@ -13,18 +13,19 @@ module CgStackery (
allocAStack, allocBStack, allocUpdateFrame,
adjustRealSps, getFinalStackHW,
mkVirtStkOffsets, mkStkAmodes
-
- -- and to make the interface self-sufficient...
) where
-import StgSyn
+import Ubiq{-uitous-}
+
import CgMonad
import AbsCSyn
-import CgUsages ( getSpBRelOffset )
-import Maybes ( Maybe(..) )
-import PrimRep ( getPrimRepSize, retPrimRepSize, separateByPtrFollowness )
-import Util
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) )
+import PrimRep ( getPrimRepSize, separateByPtrFollowness,
+ PrimRep(..)
+ )
+import Util ( mapAccumR, panic )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index a22ca46a2afa98c0c87f9df7228a034d1aecf30d..560adde93b0ae469bfe5d02ff7ccbc0cb249b6a1 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%********************************************************
%* *
@@ -17,37 +17,36 @@ module CgTailCall (
mkPrimReturnCode,
tailCallBusiness
-
- -- and to make the interface self-sufficient...
) where
-IMPORT_Trace
-import Pretty -- Pretty/Outputable: rm (debugging only) ToDo
-import Outputable
+import Ubiq{-uitous-}
-import StgSyn
import CgMonad
import AbsCSyn
-import Type ( isPrimType, Type )
-import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
-import CgCompInfo ( oTHER_TAG, iND_TAG )
-import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
- mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
+import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg,
+ ctrlReturnConvAlg, CtrlReturnConvention(..),
+ DataReturnConvention(..)
)
import CgStackery ( adjustRealSps, mkStkAmodes )
-import CgUsages ( getSpARelOffset, getSpBRelOffset )
-import CLabel ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
-import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getDataConTyCon, getDataConTag,
- idType, getIdPrimRep, fIRST_TAG, Id,
- ConTag(..)
+import CgUsages ( getSpARelOffset )
+import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
+import ClosureInfo ( nodeMustPointToIt,
+ getEntryConvention, EntryConvention(..)
+ )
+import CmdLineOpts ( opt_EmitArityChecks, opt_DoSemiTagging )
+import HeapOffs ( zeroOff, VirtualSpAOffset(..) )
+import Id ( idType, dataConTyCon, dataConTag,
+ fIRST_TAG
)
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import PrimRep ( retPrimRepSize )
-import Util
+import Literal ( mkMachInt )
+import Maybes ( assocMaybe )
+import PrimRep ( PrimRep(..) )
+import StgSyn ( StgArg(..), GenStgArg(..), StgLiveVars(..) )
+import Type ( isPrimType )
+import Util ( zipWithEqual, panic, assertPanic )
\end{code}
%************************************************************************
@@ -191,8 +190,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel
-- Set the info pointer, and jump
set_info_ptr `thenC`
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- absC (CJump (CLbl (update_label isw_chkr) CodePtrRep))
+ absC (CJump (CLbl update_label CodePtrRep))
CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
-- we can go right to the alternative
@@ -216,14 +214,14 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel
)
where
- tag = getDataConTag con
- tycon = getDataConTyCon con
+ 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
- update_label isw_chkr
- = case (dataReturnConvAlg isw_chkr con) of
+ update_label
+ = case (dataReturnConvAlg con) of
ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
@@ -296,7 +294,7 @@ performTailCall fun args live_vars
= -- Get all the info we have about the function and args and go on to
-- the business end
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getAtomAmodes args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
tailCallBusiness
fun fun_amode lf_info arg_amodes
@@ -316,8 +314,9 @@ tailCallBusiness :: Id -> CAddrMode -- Function and its amode
-> Code
tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
- = isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-
+ = let
+ do_arity_chks = opt_EmitArityChecks
+ in
nodeMustPointToIt lf_info `thenFC` \ node_points ->
getEntryConvention fun lf_info
(map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
@@ -407,7 +406,9 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
adjustRealSps final_spa final_spb `thenC`
-- Now decide about semi-tagging
- isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on ->
+ let
+ semi_tagging_on = opt_DoSemiTagging
+ in
case (semi_tagging_on, arg_amodes, node_points, sequel) of
--
diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs
index 92ceaa474cc1d9577803da8c0c447399fc20c5cb..ff1a5546b9bdfcde43480cd5c777c78701b4c8b3 100644
--- a/ghc/compiler/codeGen/CgUpdate.lhs
+++ b/ghc/compiler/codeGen/CgUpdate.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgUpdate]{Manipulating update frames}
@@ -8,18 +8,15 @@
module CgUpdate ( pushUpdateFrame ) where
-import StgSyn
+import Ubiq{-uitous-}
+
import CgMonad
import AbsCSyn
-import CgCompInfo ( sTD_UF_SIZE, cON_UF_SIZE,
- sCC_STD_UF_SIZE, sCC_CON_UF_SIZE,
- spARelToInt, spBRelToInt
- )
+import CgCompInfo ( sTD_UF_SIZE, sCC_STD_UF_SIZE )
import CgStackery ( allocUpdateFrame )
-import CgUsages
-import CmdLineOpts ( GlobalSwitch(..) )
-import Util
+import CmdLineOpts ( opt_SccProfilingOn )
+import Util ( assertPanic )
\end{code}
@@ -41,8 +38,9 @@ to reflect the frame pushed.
pushUpdateFrame :: CAddrMode -> CAddrMode -> Code -> Code
pushUpdateFrame updatee vector code
- = isSwitchSetC SccProfilingOn `thenFC` \ profiling_on ->
- let
+ = let
+ profiling_on = opt_SccProfilingOn
+
-- frame_size *includes* the return address
frame_size = if profiling_on
then sCC_STD_UF_SIZE
diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs
index 2e3fec3c0621b2724b720851386b0984b841912f..eec6be60672ffd8f847cb11580b9553feecbea41 100644
--- a/ghc/compiler/codeGen/CgUsages.lhs
+++ b/ghc/compiler/codeGen/CgUsages.lhs
@@ -15,15 +15,20 @@ module CgUsages (
getHpRelOffset, getSpARelOffset, getSpBRelOffset,
- freeBStkSlot,
-
- -- and to make the interface self-sufficient...
- AbstractC, HeapOffset, RegRelative, CgState
+ freeBStkSlot
) where
-import AbsCSyn
+import Ubiq{-uitous-}
+import CgLoop1 -- here for paranoia-checking
+
+import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode )
import CgMonad
-import Util
+import HeapOffs ( zeroOff,
+ VirtualHeapOffset(..),
+ VirtualSpAOffset(..),
+ VirtualSpBOffset(..)
+ )
+import Id ( IdEnv(..) )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index dddeddf47158db8fc51e1bb5199b0d67fc85c754..ae3bc5cd04601ccf521bc7e07d7397479bb0a945 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,5 +1,5 @@
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[ClosureInfo]{Data structures which describe closures}
@@ -43,35 +43,61 @@ module ClosureInfo (
closureKind, closureTypeDescr, -- profiling
- isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps?
isStaticClosure, allocProfilingMsg,
blackHoleClosureInfo,
- getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr,
maybeSelectorInfo,
dataConLiveness -- concurrency
-
- -- and to make the interface self-sufficient...
) where
+import Ubiq{-uitous-}
+import AbsCLoop -- here for paranoia-checking
+
import AbsCSyn
-import CgMonad
-import SMRep
import StgSyn
+import CgMonad
-import Type
-import CgCompInfo -- some magic constants
-import CgRetConv
-import CLabel -- Lots of label-making things
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id
-import IdInfo -- SIGH
-import Maybes ( maybeToBool, assocMaybe, Maybe(..) )
-import Outputable -- needed for INCLUDE_FRC_METHOD
-import Pretty -- ( ppStr, Pretty(..) )
-import PrimRep ( PrimRep, getPrimRepSize, separateByPtrFollowness )
-import Util
+import CgCompInfo ( mAX_SPEC_SELECTEE_SIZE,
+ mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
+ mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
+ mAX_SPEC_ALL_NONPTRS,
+ oTHER_TAG
+ )
+import CgRetConv ( assignRegs, dataReturnConvAlg,
+ DataReturnConvention(..)
+ )
+import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
+ mkPhantomInfoTableLabel, mkInfoTableLabel,
+ mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
+ mkStaticInfoTableLabel, mkStaticConEntryLabel,
+ mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
+ )
+import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent )
+import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
+ intOffsetIntoGoods,
+ VirtualHeapOffset(..)
+ )
+import Id ( idType, idPrimRep, getIdArity,
+ externallyVisibleId, dataConSig,
+ dataConTag, fIRST_TAG,
+ isDataCon, dataConArity, dataConTyCon,
+ isTupleCon, DataCon(..),
+ GenId{-instance Eq-}
+ )
+import IdInfo ( arityMaybe )
+import Maybes ( assocMaybe, maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import PrimRep ( getPrimRepSize, separateByPtrFollowness )
+import SMRep -- all of it
+import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
+import Type ( isPrimType, splitForAllTy, splitFunTy, mkFunTys )
+import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
+
+maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)"
+maybeIntLikeTyCon = panic "ClosureInfo.maybeIntLikeTyCon (ToDo)"
+getDataSpecTyCon_maybe = panic "ClosureInfo.getDataSpecTyCon_maybe (ToDo)"
+getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
\end{code}
The ``wrapper'' data type for closure information:
@@ -392,13 +418,13 @@ mkClosureLFInfo False -- don't bother if at top-level
-- ASSERT(is_single_constructor) -- Should be true, by causes error for SpecTyCon
LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
where
- (_, params_w_offsets) = layOutDynCon con getIdPrimRep params
+ (_, params_w_offsets) = layOutDynCon con idPrimRep params
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
offset_into_int_maybe = intOffsetIntoGoods the_offset
Just offset_into_int = offset_into_int_maybe
- is_single_constructor = maybeToBool (maybeSingleConstructorTyCon tycon)
- (_,_,_, tycon) = getDataConSig con
+ is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
+ (_,_,_, tycon) = dataConSig con
\end{code}
Same kind of thing, looking for vector-apply thunks, of the form:
@@ -452,7 +478,7 @@ mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo con
= ASSERT(isDataCon con)
let
- arity = getDataConArity con
+ arity = dataConArity con
in
if isTupleCon con then
LFTuple con (arity == 0)
@@ -691,7 +717,7 @@ chooseDynSMRep lf_info tot_wds ptr_wds
else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep
else SpecRep
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
_ -> SpecRep
in
@@ -712,14 +738,15 @@ smaller offsets than the unboxed things, and furthermore, the offsets in
the result list
\begin{code}
-mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
+mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
-> (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
+ -- 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.
@@ -748,8 +775,9 @@ Be sure to see the stg-details notes about these...
\begin{code}
nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
nodeMustPointToIt lf_info
- = isSwitchSetC SccProfilingOn `thenFC` \ do_profiling ->
-
+ = let
+ do_profiling = opt_SccProfilingOn
+ in
case lf_info of
LFReEntrant top arity no_fvs -> returnFC (
not no_fvs || -- Certainly if it has fvs we need to point to it
@@ -843,8 +871,9 @@ getEntryConvention :: Id -- Function being applied
getEntryConvention id lf_info arg_kinds
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ let
+ is_concurrent = opt_ForConcurrent
+ in
returnFC (
if (node_points && is_concurrent) then ViaNode else
@@ -857,7 +886,7 @@ getEntryConvention id lf_info arg_kinds
else
DirectEntry (mkFastEntryLabel id arity) arity arg_regs
where
- (arg_regs, _) = assignRegs isw_chkr live_regs (take arity arg_kinds)
+ (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
live_regs = if node_points then [node] else []
LFCon con zero_arity
@@ -887,7 +916,7 @@ getEntryConvention id lf_info arg_kinds
-> ASSERT(arity == length arg_kinds)
DirectEntry (mkStdEntryLabel id) arity arg_regs
where
- (arg_regs, _) = assignRegs isw_chkr live_regs arg_kinds
+ (arg_regs, _) = assignRegs live_regs arg_kinds
live_regs = if node_points then [node] else []
)
@@ -1067,21 +1096,6 @@ noUpdVapRequired binder_info
%************************************************************************
\begin{code}
-isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool
-isConstantRep (SpecialisedRep ConstantRep _ _ _) = True
-isConstantRep other = False
-
-isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures
-isSpecRep other = False -- True indicates that the _VHS is 0 !
-
-isStaticRep (StaticRep _ _) = True
-isStaticRep _ = False
-
-isPhantomRep PhantomRep = True
-isPhantomRep _ = False
-
-isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True
-isIntLikeRep other = False
isStaticClosure :: ClosureInfo -> Bool
isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep
@@ -1121,11 +1135,9 @@ closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
-- rather than take it from the Id. The Id is probably just "f"!
closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
- = getUniDataSpecTyCon_maybe (funResultTy de_foralld_ty (length args))
- where
- (_, de_foralld_ty) = splitForalls (idType fun_id)
+ = getDataSpecTyCon_maybe (fun_result_ty (length args) fun_id)
-closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (idType id)
+closureType (MkClosureInfo id lf _) = getDataSpecTyCon_maybe (idType id)
\end{code}
@closureReturnsUnboxedType@ is used to check whether a closure, {\em
@@ -1140,13 +1152,20 @@ overflow checks.
closureReturnsUnboxedType :: ClosureInfo -> Bool
closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
- = isPrimType (funResultTy de_foralld_ty arity)
- where
- (_, de_foralld_ty) = splitForalls (idType fun_id)
+ = isPrimType (fun_result_ty arity fun_id)
closureReturnsUnboxedType other_closure = False
-- All non-function closures aren't functions,
-- and hence are boxed, since they are heap alloc'd
+
+-- ToDo: need anything like this in Type.lhs?
+fun_result_ty arity id
+ = let
+ (_, de_foralld_ty) = splitForAllTy (idType id)
+ (arg_tys, res_ty) = splitFunTy{-w/ dicts as args?-} de_foralld_ty
+ in
+ ASSERT(arity >= 0 && length arg_tys >= arity)
+ mkFunTys (drop arity arg_tys) res_ty
\end{code}
\begin{code}
@@ -1154,7 +1173,7 @@ closureSemiTag :: ClosureInfo -> Int
closureSemiTag (MkClosureInfo _ lf_info _)
= case lf_info of
- LFCon data_con _ -> getDataConTag data_con - fIRST_TAG
+ LFCon data_con _ -> dataConTag data_con - fIRST_TAG
LFTuple _ _ -> 0
_ -> fromInteger oTHER_TAG
\end{code}
@@ -1248,26 +1267,26 @@ allocProfilingMsg (MkClosureInfo _ lf_info _)
LFImported -> panic "ALLOC_IMP"
\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.
+We need a black-hole closure info to pass to @allocDynClosure@ when we
+want to allocate the black hole on entry to a CAF.
\begin{code}
-blackHoleClosureInfo (MkClosureInfo id _ _) = MkClosureInfo id LFBlackHole BlackHoleRep
+blackHoleClosureInfo (MkClosureInfo id _ _)
+ = MkClosureInfo id LFBlackHole BlackHoleRep
\end{code}
-The register liveness when returning from a constructor. For simplicity,
-we claim just [node] is live for all but PhantomRep's. In truth, this means
-that non-constructor info tables also claim node, but since their liveness
-information is never used, we don't care.
+The register liveness when returning from a constructor. For
+simplicity, we claim just [node] is live for all but PhantomRep's. In
+truth, this means that non-constructor info tables also claim node,
+but since their liveness information is never used, we don't care.
\begin{code}
-
-dataConLiveness isw_chkr (MkClosureInfo con _ PhantomRep)
- = case (dataReturnConvAlg isw_chkr con) of
- ReturnInRegs regs -> mkLiveRegsBitMask regs
+dataConLiveness (MkClosureInfo con _ PhantomRep)
+ = case (dataReturnConvAlg con) of
+ ReturnInRegs regs -> mkLiveRegsMask regs
ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
-dataConLiveness _ _ = mkLiveRegsBitMask [node]
+dataConLiveness _ = mkLiveRegsMask [node]
\end{code}
%************************************************************************
@@ -1303,8 +1322,7 @@ closureKind (MkClosureInfo _ lf _)
closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo id lf _)
= if (isDataCon id) then -- DataCon has function types
- _UNPK_ (getOccurrenceName (getDataConTyCon id)) -- We want the TyCon not the ->
+ _UNPK_ (getOccurrenceName (dataConTyCon id)) -- We want the TyCon not the ->
else
- getUniTyDescription (idType id)
+ getTyDescription (idType id)
\end{code}
-
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index d8112a8bd2a70f8f095b6c6ad22a68c56f874dfb..2b193da6e5796adf3703e36bff118965bb440f6e 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CodeGen]{@CodeGen@: main module of the code generator}
@@ -19,28 +19,32 @@ functions drive the mangling of top-level bindings.
module CodeGen ( codeGen ) where
+import Ubiq{-uitous-}
+
import StgSyn
import CgMonad
import AbsCSyn
-import CLabel ( modnameToC )
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
+import Bag ( foldBag )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon )
-import CgConTbls ( genStaticConBits, TCE(..), UniqFM )
-import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo )
-import CmdLineOpts
-import FiniteMap ( FiniteMap )
-import Maybes ( Maybe(..) )
-import Pretty -- debugging only
-import PrimRep ( getPrimRepSize )
-import Util
+import CgConTbls ( genStaticConBits )
+import ClosureInfo ( mkClosureLFInfo )
+import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude,
+ opt_EnsureSplittableC, opt_SccGroup
+ )
+import CStrings ( modnameToC )
+import Maybes ( maybeToBool )
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import Util ( panic, assertPanic )
\end{code}
\begin{code}
codeGen :: FAST_STRING -- module name
-> ([CostCentre], -- local cost-centres needing declaring/registering
[CostCentre]) -- "extern" cost-centres needing declaring
- -> [FAST_STRING] -- import names
+ -> Bag FAST_STRING -- import names
-> [TyCon] -- tycons with data constructors to convert
-> FiniteMap TyCon [(Bool, [Maybe Type])]
-- tycon specialisation info
@@ -51,11 +55,11 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg
= let
doing_profiling = opt_SccProfilingOn
compiling_prelude = opt_CompilingPrelude
- maybe_split = if (switch_is_on (EnsureSplittableC (panic "codeGen:esc")))
+ maybe_split = if maybeToBool (opt_EnsureSplittableC)
then CSplitMarker
else AbsCNop
- cinfo = MkCompInfo switch_is_on int_switch_set mod_name
+ cinfo = MkCompInfo mod_name
in
if not doing_profiling then
mkAbstractCs [
@@ -85,15 +89,16 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg
initC cinfo (cgTopBindings maybe_split stg_pgm) ]
where
-----------------
- grp_name = case (stringSwitchSet sw_lookup_fn SccGroup) of
- Just xx -> _PK_ xx
+ grp_name = case opt_SccGroup of
+ Just xx -> xx
Nothing -> mod_name -- default: module name
-----------------
mkCcRegister ccs import_names
= let
register_ccs = mkAbstractCs (map mk_register ccs)
- register_imports = mkAbstractCs (map mk_import_register import_names)
+ register_imports
+ = foldBag mkAbsCStmts mk_import_register AbsCNop import_names
in
mkAbstractCs [
CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs
index 4adcfd7f13b79e1409d55002935239ec61cb9878..99432c764314f6af065505ef3a517b3cb92e49f1 100644
--- a/ghc/compiler/codeGen/SMRep.lhs
+++ b/ghc/compiler/codeGen/SMRep.lhs
@@ -12,7 +12,9 @@ Other modules should access this info through ClosureInfo.
module SMRep (
SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr
+ ltSMRepHdr,
+ isConstantRep, isSpecRep, isStaticRep, isPhantomRep,
+ isIntLikeRep
) where
import Ubiq{-uitous-}
@@ -129,7 +131,27 @@ MuTupleRep == MUTUPLE
--jim
-}
+\end{code}
+
+\begin{code}
+isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool
+isConstantRep (SpecialisedRep ConstantRep _ _ _) = True
+isConstantRep other = False
+
+isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures
+isSpecRep other = False -- True indicates that the _VHS is 0 !
+
+isStaticRep (StaticRep _ _) = True
+isStaticRep _ = False
+isPhantomRep PhantomRep = True
+isPhantomRep _ = False
+
+isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True
+isIntLikeRep other = False
+\end{code}
+
+\begin{code}
instance Eq SMRep where
(SpecialisedRep k1 a1 b1 _) == (SpecialisedRep k2 a2 b2 _) = (tagOf_SMSpecRepKind k1) _EQ_ (tagOf_SMSpecRepKind k2)
&& a1 == a2 && b1 == b2
diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index 90f76565a519c492edce46682dd2bc5d5af811c1..ecae1733c40a356f334a0c12c794c1d140dcc776 100644
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -26,7 +26,7 @@ import Id ( idType, mkSysLocal,
GenId{-instances-}
)
import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon )
-import TyCon ( TyCon{-instance-} )
+import TyCon ( isBoxedTyCon, TyCon{-instance-} )
import Type ( maybeAppDataTyCon, eqTy )
import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util ( zipEqual, zipWithEqual, assertPanic, panic )
@@ -34,7 +34,6 @@ import Util ( zipEqual, zipWithEqual, assertPanic, panic )
infixr 9 `thenL`
updateIdType = panic "CoreLift.updateIdType"
-isBoxedTyCon = panic "CoreLift.isBoxedTyCon"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index a08c45f13e4cfa8e5342baae2a2d975f55347b33..e31af01511404a60f343ec31c7282fe35e474a74 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -21,6 +21,7 @@ import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId,
getInstantiatedDataConSig, GenId{-instances-}
)
+import Maybes ( catMaybes )
import Outputable ( Outputable(..) )
import PprCore
import PprStyle ( PprStyle(..) )
@@ -32,11 +33,13 @@ import SrcLoc ( SrcLoc )
import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
isPrimType,getTypeKind,instantiateTy,
mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
- maybeAppDataTyCon, eqTy )
-import TyCon ( isPrimTyCon,isVisibleDataTyCon )
+ maybeAppDataTyCon, eqTy
+ )
+import TyCon ( isPrimTyCon, tyConFamilySize )
import TyVar ( getTyVarKind, GenTyVar{-instances-} )
import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
- unionUniqSets, elementOfUniqSet, UniqSet(..) )
+ unionUniqSets, elementOfUniqSet, UniqSet(..)
+ )
import Unique ( Unique )
import Usage ( GenUsage )
import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
@@ -89,9 +92,7 @@ lintCoreBindings sty whoDunnit spec_done binds
ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
msg sty,
ppStr "*** Offending Program ***",
- ppAboves
- (map (pprCoreBinding sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (ppr sty))
- binds),
+ ppAboves (map (pprCoreBinding sty) binds),
ppStr "*** End of Offense ***"
])
where
@@ -297,23 +298,28 @@ lintCoreAlts :: CoreCaseAlts
-> TyCon -- TyCon pinned on the case
-> LintM (Maybe Type) -- Type of alternatives
-lintCoreAlts (AlgAlts alts deflt) ty tycon
- = panic "CoreLint.lintCoreAlts"
-{- LATER:
- WDP: can't tell what type DNT wants here
+lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
= -- Check tycon is not a primitive tycon
addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
`seqL`
- -- Check we have a non-abstract data tycon
- addErrIfL (not (isVisibleDataTyCon tycon)) (mkCaseAbstractMsg tycon)
+ -- Check we are scrutinising a proper datatype
+ -- (ToDo: robustify)
+ addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
`seqL`
lintDeflt deflt ty
`thenL` \maybe_deflt_ty ->
mapL (lintAlgAlt ty tycon) alts
`thenL` \maybe_alt_tys ->
- returnL (maybe_deflt_ty : maybe_alt_tys)
+ -- Check the result types
+ case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
+ [] -> returnL Nothing
-lintCoreAlts (PrimAlts alts deflt) ty tycon
+ (first_ty:tys) -> mapL check tys `seqL`
+ returnL (Just first_ty)
+ where
+ check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
+
+lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
= -- Check tycon is a primitive tycon
addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
`seqL`
@@ -321,21 +327,16 @@ lintCoreAlts (PrimAlts alts deflt) ty tycon
`thenL` \maybe_alt_tys ->
lintDeflt deflt ty
`thenL` \maybe_deflt_ty ->
- returnL (maybe_deflt_ty : maybe_alt_tys)
-- Check the result types
--}
-{-
- `thenL` \ maybe_result_tys ->
- case catMaybes (maybe_result_tys) of
+ case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
[] -> returnL Nothing
(first_ty:tys) -> mapL check tys `seqL`
returnL (Just first_ty)
where
- check ty = checkTys first_ty ty (mkCaseAltMsg alts)
--}
+ check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
-lintAlgAlt scrut_ty (con,args,rhs)
+lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
= (case maybeAppDataTyCon scrut_ty of
Nothing ->
addErrL (mkAlgAltMsg1 scrut_ty)
@@ -551,7 +552,7 @@ mkCasePrimMsg tycon sty
mkCaseAbstractMsg :: TyCon -> ErrMsg
mkCaseAbstractMsg tycon sty
- = ppAbove (ppStr "An algebraic case on an abstract type:")
+ = ppAbove (ppStr "An algebraic case on some weird type:")
(ppr sty tycon)
mkDefltMsg :: CoreCaseDefault -> ErrMsg
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 037afb41f9a7e88e435591c0ccb732e5c0ffaf42..2e017b8b461a8a7d398efe1d91b3888fd15d63b5 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -17,7 +17,7 @@ module CoreSyn (
mkApp, mkCon, mkPrim,
mkValLam, mkTyLam, mkUseLam,
mkLam,
- collectBinders,
+ collectBinders, isValBinder, notValBinder,
collectArgs, isValArg, notValArg, numValArgs,
@@ -57,13 +57,10 @@ module CoreSyn (
import Ubiq{-uitous-}
import CostCentre ( showCostCentre, CostCentre )
-import Id ( idType )
+import Id ( idType, GenId{-instance Eq-} )
+import Type ( isUnboxedType )
import Usage ( UVar(..) )
import Util ( panic, assertPanic )
-
-isUnboxedDataType = panic "CoreSyn.isUnboxedDataType"
---eqId :: Id -> Id -> Bool
-eqId = panic "CoreSyn.eqId"
\end{code}
%************************************************************************
@@ -197,12 +194,13 @@ being bound has unboxed type. We have different variants ...
(unboxed bindings in a letrec are still prohibited)
\begin{code}
-mkCoLetAny :: GenCoreBinding val_bdr val_occ tyvar uvar
- -> GenCoreExpr val_bdr val_occ tyvar uvar
- -> GenCoreExpr val_bdr val_occ tyvar uvar
-mkCoLetsAny :: [GenCoreBinding val_bdr val_occ tyvar uvar] ->
- GenCoreExpr val_bdr val_occ tyvar uvar ->
- GenCoreExpr val_bdr val_occ tyvar uvar
+mkCoLetAny :: GenCoreBinding Id Id tyvar uvar
+ -> GenCoreExpr Id Id tyvar uvar
+ -> GenCoreExpr Id Id tyvar uvar
+mkCoLetsAny :: [GenCoreBinding Id Id tyvar uvar] ->
+ GenCoreExpr Id Id tyvar uvar ->
+ GenCoreExpr Id Id tyvar uvar
+
mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
-> GenCoreExpr val_bdr val_occ tyvar uvar
-> GenCoreExpr val_bdr val_occ tyvar uvar
@@ -216,7 +214,7 @@ mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
mkCoLetAny bind@(NonRec binder rhs) body
= case body of
- Var binder2 | binder `eqId` binder2
+ Var binder2 | binder == binder2
-> rhs -- hey, I have the rhs
other
-> Let bind body
@@ -231,9 +229,9 @@ mkCoLetAny bind@(NonRec binder rhs) body
mkCoLetNoUnboxed bind@(Rec binds) body
= mkCoLetrecNoUnboxed binds body
mkCoLetNoUnboxed bind@(NonRec binder rhs) body
- = --ASSERT (not (isUnboxedDataType (idType binder)))
+ = --ASSERT (not (isUnboxedType (idType binder)))
case body of
- Var binder2 | binder `eqId` binder2
+ Var binder2 | binder == binder2
-> rhs -- hey, I have the rhs
other
-> Let bind body
@@ -251,7 +249,7 @@ mkCoLetrecNoUnboxed binds body
Let (Rec binds) body
where
is_boxed_bind (binder, rhs)
- = (not . isUnboxedDataType . idType) binder
+ = (not . isUnboxedType . idType) binder
\end{code}
\begin{code}
@@ -264,10 +262,10 @@ mkCoLetUnboxedToCase bind@(Rec binds) body
= mkCoLetrecNoUnboxed binds body
mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
= case body of
- Var binder2 | binder `eqId` binder2
+ Var binder2 | binder == binder2
-> rhs -- hey, I have the rhs
other
- -> if (not (isUnboxedDataType (idType binder))) then
+ -> if (not (isUnboxedType (idType binder))) then
Let bind body -- boxed...
else
Case rhs -- unboxed...
@@ -341,6 +339,11 @@ data GenCoreBinder val_bdr tyvar uvar
= ValBinder val_bdr
| TyBinder tyvar
| UsageBinder uvar
+
+isValBinder (ValBinder _) = True
+isValBinder _ = False
+
+notValBinder = not . isValBinder
\end{code}
Clump Lams together if possible.
@@ -379,42 +382,25 @@ collectBinders ::
GenCoreExpr val_bdr val_occ tyvar uvar ->
([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
-collectBinders (Lam (UsageBinder u) body)
- = let
- (uvars, tyvars, args, final_body) = collectBinders body
- in
- (u:uvars, tyvars, args, final_body)
-
-collectBinders other
- = let
- (tyvars, args, body) = dig_for_tyvars other
- in
- ([], tyvars, args, body)
+collectBinders expr
+ = usages expr []
where
- dig_for_tyvars (Lam (TyBinder tv) body)
- = let
- (tyvars, args, body2) = dig_for_tyvars body
- in
- (tv : tyvars, args, body2)
-
- dig_for_tyvars body
- = ASSERT(not (usage_lambda body))
- let
- (args, body2) = dig_for_valvars body
- in
- ([], args, body2)
-
- ---------------------------------------
- dig_for_valvars (Lam (ValBinder v) body)
- = let
- (args, body2) = dig_for_valvars body
- in
- (v : args, body2)
-
- dig_for_valvars body
- = ASSERT(not (usage_lambda body))
- ASSERT(not (tyvar_lambda body))
- ([], body)
+ usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc)
+ usages other uacc
+ = case (tyvars other []) of { (tacc, vacc, expr) ->
+ (reverse uacc, tacc, vacc, expr) }
+
+ tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
+ tyvars other tacc
+ = ASSERT(not (usage_lambda other))
+ case (valvars other []) of { (vacc, expr) ->
+ (reverse tacc, vacc, expr) }
+
+ valvars (Lam (ValBinder v) body) vacc = valvars body (v:vacc)
+ valvars other vacc
+ = ASSERT(not (usage_lambda other))
+ ASSERT(not (tyvar_lambda other))
+ (reverse vacc, other)
---------------------------------------
usage_lambda (Lam (UsageBinder _) _) = True
@@ -489,13 +475,36 @@ and the arguments to which it is applied.
\begin{code}
collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
-> (GenCoreExpr val_bdr val_occ tyvar uvar,
- [GenCoreArg val_occ tyvar uvar])
+ [GenUsage uvar],
+ [GenType tyvar uvar],
+ [GenCoreArg val_occ tyvar uvar]{-ValArgs-})
collectArgs expr
- = collect expr []
+ = usages expr []
where
- collect (App fun arg) args = collect fun (arg : args)
- collect fun args = (fun, args)
+ usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
+ usages fun uacc
+ = case (tyvars fun []) of { (expr, tacc, vacc) ->
+ (expr, uacc, tacc, vacc) }
+
+ tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc)
+ tyvars fun tacc
+ = ASSERT(not (usage_app fun))
+ case (valvars fun []) of { (expr, vacc) ->
+ (expr, tacc, vacc) }
+
+ valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
+ valvars fun vacc
+ = ASSERT(not (usage_app fun))
+ ASSERT(not (ty_app fun))
+ (fun, vacc)
+
+ ---------------------------------------
+ usage_app (App _ (UsageArg _)) = True
+ usage_app _ = False
+
+ ty_app (App _ (TyArg _)) = True
+ ty_app _ = False
\end{code}
%************************************************************************
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 7aec06e516423af4fa2ee86e3cb8cc8f5ae6d5bc..92668988fd43811840016989c5dfc962618f8407 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -28,7 +28,8 @@ module CoreUnfold (
) where
import Ubiq
-import IdLoop -- for paranoia checking
+import IdLoop -- for paranoia checking;
+ -- and also to get mkMagicUnfoldingFun
import PrelLoop -- for paranoia checking
import Bag ( emptyBag, unitBag, unionBags, Bag )
@@ -38,24 +39,21 @@ import CgCompInfo ( uNFOLDING_CHEAP_OP_COST,
uNFOLDING_NOREP_LIT_COST
)
import CoreSyn
-import CoreUtils ( coreExprType )
+import CoreUtils ( coreExprType, manifestlyWHNF )
import CostCentre ( ccMentionsId )
import Id ( IdSet(..), GenId{-instances-} )
import IdInfo ( bottomIsGuaranteed )
import Literal ( isNoRepLit, isLitLitLit )
-import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import Pretty
-import PrimOp ( PrimOp(..) )
+import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
+import TyCon ( tyConFamilySize )
import Type ( getAppDataTyCon )
-import UniqSet ( emptyUniqSet, singletonUniqSet, mkUniqSet,
- unionUniqSets
+import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
+ addOneToUniqSet, unionUniqSets
)
import Usage ( UVar(..) )
import Util ( isIn, panic )
-manifestlyWHNF = panic "manifestlyWHNF (CoreUnfold)"
-primOpCanTriggerGC = panic "primOpCanTriggerGC (CoreUnfold)"
-getTyConFamilySize = panic "getTyConFamilySize (CoreUnfold)"
whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
\end{code}
@@ -333,8 +331,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
------------
size_up_alts scrut_ty (AlgAlts alts deflt)
= foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
- `addSizeN`
- (case (getTyConFamilySize tycon) of { Just n -> n })
+ `addSizeN` (tyConFamilySize tycon)
-- NB: we charge N for an alg. "case", where N is
-- the number of constructors in the thing being eval'd.
-- (You'll eventually get a "discount" of N if you
@@ -426,7 +423,7 @@ add1 :: IdSet -> Id -> IdSet
add_some :: IdSet -> [Id] -> IdSet
no_in_scopes = emptyUniqSet
-in_scopes `add1` x = in_scopes `unionUniqSets` singletonUniqSet x
+in_scopes `add1` x = addOneToUniqSet in_scopes x
in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs
\end{code}
@@ -747,7 +744,7 @@ ppr_uf_Expr in_scopes (SCC cc body)
\begin{code}
ppr_uf_Binder :: Id -> Pretty
ppr_uf_Binder v
- = ppBesides [ppLparen, pprIdInUnfolding (singletonUniqSet v) v, ppPStr SLIT(" :: "),
+ = ppBesides [ppLparen, pprIdInUnfolding (unitUniqSet v) v, ppPStr SLIT(" :: "),
ppr ppr_Unfolding (idType v), ppRparen]
ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 363cecb61f6e4ad323debe1aa473ffbbe224b301..ddc7658249641415fab80b87976e480133104448 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -9,19 +9,19 @@
module CoreUtils (
coreExprType, coreAltsType,
- substCoreExpr
+ substCoreExpr, substCoreBindings
, mkCoreIfThenElse
, mkErrorApp, escErrorMsg
, argToExpr
, unTagBinders, unTagBindersAlts
, manifestlyWHNF, manifestlyBottom
+ , maybeErrorApp
+ , nonErrorRHSs
+ , squashableDictishCcExpr
{- exprSmallEnoughToDup,
coreExprArity,
isWrapperFor,
- maybeErrorApp,
- nonErrorRHSs,
- squashableDictishCcExpr,
-} ) where
@@ -38,10 +38,10 @@ import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
)
import IdInfo ( arityMaybe )
import Literal ( literalType, isNoRepLit, Literal(..) )
-import Maybes ( catMaybes )
+import Maybes ( catMaybes, maybeToBool )
import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
+import PprType ( GenType{-instances-} )
import Pretty ( ppAboves )
import PrelInfo ( trueDataCon, falseDataCon,
augmentId, buildId,
@@ -49,21 +49,21 @@ import PrelInfo ( trueDataCon, falseDataCon,
)
import PrimOp ( primOpType, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
-import TyVar ( isNullTyVarEnv, TyVarEnv(..), GenTyVar{-instances-} )
-import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy,
- getFunTy_maybe, applyTy, splitSigmaTy
+import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
+import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
+ getFunTy_maybe, applyTy, isPrimType,
+ splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
)
-import Unique ( Unique{-instances-} )
import UniqSupply ( initUs, returnUs, thenUs,
mapUs, mapAndUnzipUs,
UniqSM(..), UniqSupply
)
+import Usage ( UVar(..) )
import Util ( zipEqual, panic, pprPanic, assertPanic )
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
dup_binder = panic "CoreUtils.dup_binder"
-applyTypeEnvToTy = panic "CoreUtils.applyTypeEnvToTy"
\end{code}
%************************************************************************
@@ -253,11 +253,11 @@ exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of
exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
- = case (collectArgs expr) of { (fun, args) ->
+ = case (collectArgs expr) of { (fun, _, _, vargs) ->
case fun of
Var v -> v /= buildId
&& v /= augmentId
- && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
+ && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
_ -> False
}
-}
@@ -280,14 +280,13 @@ manifestlyWHNF (SCC _ e) = manifestlyWHNF e
manifestlyWHNF (Let _ e) = False
manifestlyWHNF (Case _ _) = False
-manifestlyWHNF (Lam (ValBinder _) _) = True
-manifestlyWHNF (Lam other_binder e) = manifestlyWHNF e
+manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e
manifestlyWHNF other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, args) ->
+ = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
case fun of
Var f -> let
- num_val_args = numValArgs args
+ num_val_args = length vargs
in
num_val_args == 0 -- Just a type application of
-- a variable (f t1 t2 t3);
@@ -317,8 +316,7 @@ manifestlyBottom (SCC _ e) = manifestlyBottom e
manifestlyBottom (Let _ e) = manifestlyBottom e
-- We do not assume \x.bottom == bottom:
-manifestlyBottom (Lam (ValBinder _) _) = False
-manifestlyBottom (Lam other_binder e) = manifestlyBottom e
+manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
manifestlyBottom (Case e a)
= manifestlyBottom e
@@ -335,7 +333,7 @@ manifestlyBottom (Case e a)
mbdef (BindDefault _ e') = manifestlyBottom e'
manifestlyBottom other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, args) ->
+ = case (collectArgs other_expr) of { (fun, _, _, _) ->
case fun of
Var f | isBottomingId f -> True
-- Application of a function which always gives
@@ -389,11 +387,11 @@ expr `isWrapperFor` var
--------------
unravel_casing case_ables (Case scrut alts)
- = case (collectArgs scrut) of { (fun, args) ->
+ = case (collectArgs scrut) of { (fun, _, _, vargs) ->
case fun of
Var scrut_var -> let
answer =
- scrut_var /= var && all (doesn't_mention var) args
+ scrut_var /= var && all (doesn't_mention var) vargs
&& scrut_var `is_elem` case_ables
&& unravel_alts case_ables alts
in
@@ -403,15 +401,15 @@ expr `isWrapperFor` var
}
unravel_casing case_ables other_expr
- = case (collectArgs other_expr) of { (fun, args) ->
+ = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
case fun of
Var wrkr -> let
answer =
-- DOESN'T WORK: wrkr == var's_worker
wrkr /= var
&& isWorkerId wrkr
- && all (doesn't_mention var) args
- && all (only_from case_ables) args
+ && all (doesn't_mention var) vargs
+ && all (only_from case_ables) vargs
in
answer
@@ -508,23 +506,24 @@ Example:
Notice that the \tr{<alts>} don't get duplicated.
\begin{code}
-{- LATER:
-nonErrorRHSs :: GenCoreCaseAlts binder Id -> [GenCoreExpr binder Id]
+nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
-nonErrorRHSs alts = filter not_error_app (find_rhss alts)
+nonErrorRHSs alts
+ = filter not_error_app (find_rhss alts)
where
- find_rhss (AlgAlts alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
- find_rhss (PrimAlts alts deflt) = [rhs | (_,rhs) <- alts] ++ deflt_rhs deflt
+ find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
+ find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt
deflt_rhs NoDefault = []
deflt_rhs (BindDefault _ rhs) = [rhs]
- not_error_app rhs = case maybeErrorApp rhs Nothing of
- Just _ -> False
- Nothing -> True
+ not_error_app rhs
+ = case (maybeErrorApp rhs Nothing) of
+ Just _ -> False
+ Nothing -> True
\end{code}
-maybeErrorApp checkes whether an expression is of the form
+maybeErrorApp checks whether an expression is of the form
error ty args
@@ -540,24 +539,24 @@ Here's where it is useful:
===>
error ty' "Foo"
-where ty' is the type of any of the alternatives.
-You might think this never occurs, but see the comments on
-the definition of @singleAlt@.
+where ty' is the type of any of the alternatives. You might think
+this never occurs, but see the comments on the definition of
+@singleAlt@.
-Note: we *avoid* the case where ty' might end up as a
-primitive type: this is very uncool (totally wrong).
+Note: we *avoid* the case where ty' might end up as a primitive type:
+this is very uncool (totally wrong).
-NOTICE: in the example above we threw away e1 and e2, but
-not the string "Foo". How did we know to do that?
+NOTICE: in the example above we threw away e1 and e2, but not the
+string "Foo". How did we know to do that?
-Answer: for now anyway, we only handle the case of a function
-whose type is of form
+Answer: for now anyway, we only handle the case of a function whose
+type is of form
bottomingFn :: forall a. t1 -> ... -> tn -> a
^---------------------^ NB!
-Furthermore, we only count a bottomingApp if the function is
-applied to more than n args. If so, we transform:
+Furthermore, we only count a bottomingApp if the function is applied
+to more than n args. If so, we transform:
bottomingFn ty e1 ... en en+1 ... em
to
@@ -566,47 +565,47 @@ to
That is, we discard en+1 .. em
\begin{code}
-maybeErrorApp :: GenCoreExpr bndr Id -- Expr to look at
- -> Maybe Type -- Just ty => a result type *already cloned*;
- -- Nothing => don't know result ty; we
- -- *pretend* that the result ty won't be
- -- primitive -- somebody later must
- -- ensure this.
- -> Maybe (GenCoreExpr bndr Id)
+maybeErrorApp
+ :: GenCoreExpr a Id TyVar UVar -- Expr to look at
+ -> Maybe Type -- Just ty => a result type *already cloned*;
+ -- Nothing => don't know result ty; we
+ -- *pretend* that the result ty won't be
+ -- primitive -- somebody later must
+ -- ensure this.
+ -> Maybe (GenCoreExpr a Id TyVar UVar)
maybeErrorApp expr result_ty_maybe
- = case collectArgs expr of
- (Var fun, (TypeArg ty : other_args))
+ = case (collectArgs expr) of
+ (Var fun, [{-no usage???-}], [ty], other_args)
| isBottomingId fun
&& maybeToBool result_ty_maybe -- we *know* the result type
-- (otherwise: live a fairy-tale existence...)
&& not (isPrimType result_ty) ->
- case splitSigmaTy (idType fun) of
- ([tyvar_tmpl], [], tau_ty) ->
- case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
+
+ case (splitSigmaTy (idType fun)) of
+ ([tyvar], [], tau_ty) ->
+ case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
let
n_args_to_keep = length arg_tys
args_to_keep = take n_args_to_keep other_args
in
- if res_ty == mkTyVarTemplateTy tyvar_tmpl &&
- n_args_to_keep <= length other_args
+ if (res_ty `eqTy` mkTyVarTy tyvar)
+ && n_args_to_keep <= length other_args
then
-- Phew! We're in business
- Just (mkGenApp (Var fun)
- (TypeArg result_ty : args_to_keep))
+ Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
else
Nothing
}
- other -> -- Function type wrong shape
- Nothing
+ other -> Nothing -- Function type wrong shape
other -> Nothing
where
Just result_ty = result_ty_maybe
\end{code}
\begin{code}
-squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b -> Bool
+squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
squashableDictishCcExpr cc expr
= if not (isDictCC cc) then
@@ -615,11 +614,11 @@ squashableDictishCcExpr cc expr
squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
where
squashable (Var _) = True
- squashable (CoTyApp f _) = squashable f
- squashable (Con _ _ _) = True -- I think so... WDP 94/09
- squashable (Prim _ _ _) = True -- ditto
- squashable other = False
--}
+ squashable (Con _ _) = True -- I think so... WDP 94/09
+ squashable (Prim _ _) = True -- ditto
+ squashable (App f a)
+ | notValArg a = squashable f
+ squashable other = False
\end{code}
%************************************************************************
@@ -629,13 +628,24 @@ squashableDictishCcExpr cc expr
%************************************************************************
\begin{code}
+substCoreBindings :: ValEnv
+ -> TypeEnv -- TyVar=>Type
+ -> [CoreBinding]
+ -> UniqSM [CoreBinding]
+
substCoreExpr :: ValEnv
-> TypeEnv -- TyVar=>Type
-> CoreExpr
-> UniqSM CoreExpr
-substCoreExpr venv tenv expr
+substCoreBindings venv tenv binds
-- if the envs are empty, then avoid doing anything
+ = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
+ returnUs binds
+ else
+ do_CoreBindings venv tenv binds
+
+substCoreExpr venv tenv expr
= if (isNullIdEnv venv && isNullTyVarEnv tenv) then
returnUs expr
else
diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs
index 8879ffeaf19bcee3d5d51fd68e4e595e788f26a1..8703b34dfa0c867405e0cedaa36fa2a132983710 100644
--- a/ghc/compiler/coreSyn/FreeVars.lhs
+++ b/ghc/compiler/coreSyn/FreeVars.lhs
@@ -26,14 +26,14 @@ import AnnCoreSyn -- output
import CoreSyn
import Id ( idType, getIdArity, isBottomingId,
- emptyIdSet, singletonIdSet, mkIdSet,
+ emptyIdSet, unitIdSet, mkIdSet,
elementOfIdSet, minusIdSet, unionManyIdSets,
IdSet(..)
)
import IdInfo ( arityMaybe )
import PrimOp ( PrimOp(..) )
import Type ( tyVarsOfType )
-import TyVar ( emptyTyVarSet, singletonTyVarSet, minusTyVarSet,
+import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
intersectTyVarSets,
TyVarSet(..)
)
@@ -74,8 +74,8 @@ data FVInfo
noFreeIds = emptyIdSet
noFreeTyVars = emptyTyVarSet
noFreeAnything = (noFreeIds, noFreeTyVars)
-aFreeId i = singletonIdSet i
-aFreeTyVar t = singletonTyVarSet t
+aFreeId i = unitIdSet i
+aFreeTyVar t = unitTyVarSet t
is_among = elementOfIdSet
munge_id_ty i = tyVarsOfType (idType i)
combine = unionUniqSets -- used both for {Id,TyVar}Sets
@@ -171,13 +171,13 @@ fvExpr id_cands tyvar_cands (Lam (UsageBinder uvar) body)
= panic "fvExpr:Lam UsageBinder"
fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
- = (FVInfo (freeVarsOf body2 `minusIdSet` singletonIdSet binder)
+ = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder)
(freeTyVarsOf body2 `combine` munge_id_ty binder)
leakiness,
AnnLam b body2)
where
-- We need to collect free tyvars from the binders
- body2 = fvExpr (singletonIdSet binder `combine` id_cands) tyvar_cands body
+ body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
leakiness = case leakinessOf body2 of
MightLeak -> LeakFree 1
@@ -412,7 +412,7 @@ addExprFVs fv_cand in_scope (Lam binder body)
TyBinder t -> (TyBinder t, emptyIdSet)
UsageBinder u -> (UsageBinder u, emptyIdSet)
ValBinder b -> (ValBinder (b, lam_fvs),
- singletonIdSet b)
+ unitIdSet b)
new_in_scope = in_scope `combine` binder_set
(new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 770e9bf0e15196e0ad591e6fa7d73eab87de1c6c..4a503e47aae984f6e9ef5515acfb993a44f6aab9 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -14,8 +14,7 @@ module PprCore (
pprCoreExpr,
pprCoreBinding,
pprBigCoreBinder,
- pprTypedCoreBinder,
- pprPlainCoreBinding
+ pprTypedCoreBinder
-- these are here to make the instances go in 0.26:
#if __GLASGOW_HASKELL__ <= 26
@@ -34,9 +33,8 @@ import Id ( idType, getIdInfo, getIdStrictness,
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
import Literal ( Literal{-instances-} )
import Outputable -- quite a few things
-import PprType ( pprType_Internal,
- GenType{-instances-}, GenTyVar{-instance-}
- )
+import PprEnv
+import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
import PprStyle ( PprStyle(..) )
import Pretty
import PrimOp ( PrimOp{-instances-} )
@@ -58,7 +56,7 @@ function for ``major'' val_bdrs (those next to equal signs :-),
usually be called through some intermediary.
The binder/occ printers take the default ``homogenized'' (see
-@PrintEnv@...) @Pretty@ and the binder/occ. They can either use the
+@PprEnv@...) @Pretty@ and the binder/occ. They can either use the
homogenized one, or they can ignore it completely. In other words,
the things passed in act as ``hooks'', getting the last word on how to
print something.
@@ -66,9 +64,9 @@ print something.
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
\begin{code}
-pprPlainCoreBinding :: PprStyle -> CoreBinding -> Pretty
+pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
-pprCoreBinding
+pprGenCoreBinding
:: (Eq tyvar, Outputable tyvar,
Eq uvar, Outputable uvar,
Outputable bndr,
@@ -80,14 +78,27 @@ pprCoreBinding
-> GenCoreBinding bndr occ tyvar uvar
-> Pretty
-pprCoreBinding sty pbdr1 pbdr2 pocc bind
- = ppr_bind (initial_pe sty (Left (pbdr1, pbdr2, pocc))) bind
-
-pprPlainCoreBinding sty (NonRec binder expr)
+pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
+ = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
+
+init_ppr_env sty pbdr1 pbdr2 pocc
+ = initPprEnv sty
+ (Just (ppr sty)) -- literals
+ (Just (ppr sty)) -- data cons
+ (Just (ppr sty)) -- primops
+ (Just (\ cc -> ppStr (showCostCentre sty True cc)))
+ (Just (ppr sty)) -- tyvars
+ (Just (ppr sty)) -- usage vars
+ (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
+ (Just (ppr sty)) -- types
+ (Just (ppr sty)) -- usages
+
+--------------
+pprCoreBinding sty (NonRec binder expr)
= ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
-pprPlainCoreBinding sty (Rec binds)
+pprCoreBinding sty (Rec binds)
= ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
ppAboves (map ppr_bind binds),
ifPprDebug sty (ppStr "{- end plain Rec -}")]
@@ -98,7 +109,16 @@ pprPlainCoreBinding sty (Rec binds)
\end{code}
\begin{code}
-pprCoreExpr, pprParendCoreExpr
+pprCoreExpr
+ :: PprStyle
+ -> (Id -> Pretty) -- to print "major" val_bdrs
+ -> (Id -> Pretty) -- to print "minor" val_bdrs
+ -> (Id -> Pretty) -- to print bindees
+ -> CoreExpr
+ -> Pretty
+pprCoreExpr = pprGenCoreExpr
+
+pprGenCoreExpr, pprParendCoreExpr
:: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
Outputable bndr,
Outputable occ)
@@ -109,8 +129,8 @@ pprCoreExpr, pprParendCoreExpr
-> GenCoreExpr bndr occ tyvar uvar
-> Pretty
-pprCoreExpr sty pbdr1 pbdr2 pocc expr
- = ppr_expr (initial_pe sty (Left (pbdr1, pbdr2, pocc))) expr
+pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
+ = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr
pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
= let
@@ -120,16 +140,16 @@ pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
Lit _ -> id
_ -> ppParens -- wraps in parens
in
- parenify (pprCoreExpr sty pbdr1 pbdr2 pocc expr)
+ parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
ppr_core_arg sty pocc arg
- = ppr_arg (initial_pe sty (Left (pocc, pocc, pocc))) arg
+ = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
ppr_core_alts sty pbdr1 pbdr2 pocc alts
- = ppr_alts (initial_pe sty (Left (pbdr1, pbdr2, pocc))) alts
+ = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
ppr_core_default sty pbdr1 pbdr2 pocc deflt
- = ppr_default (initial_pe sty (Left (pbdr1, pbdr2, pocc))) deflt
+ = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
\end{code}
%************************************************************************
@@ -144,14 +164,14 @@ instance
Eq uvar, Outputable uvar)
=>
Outputable (GenCoreBinding bndr occ tyvar uvar) where
- ppr sty bind = pprCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
+ ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
instance
(Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
Eq uvar, Outputable uvar)
=>
Outputable (GenCoreExpr bndr occ tyvar uvar) where
- ppr sty expr = pprCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
+ ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
instance
(Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
@@ -174,119 +194,6 @@ instance
ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
\end{code}
-%************************************************************************
-%* *
-\subsection{Core printing environment (purely local)}
-%* *
-%************************************************************************
-
-Similar to @VE@ in @PprType@. The ``values'' we print here
-are locally-defined nested-scope names; callers to @pprCoreBinding@,
-etc., can override these.
-
-For tyvars and uvars, we {\em do} normally use these homogenized
-names; for values, we {\em don't}. In printing interfaces, though,
-we use homogenized value names, so that interfaces don't wobble
-uncontrollably from changing Unique-based names.
-
-\begin{code}
-data PrintEnv tyvar uvar bndr occ
- = PE (Literal -> Pretty) -- Doing these this way saves
- (DataCon -> Pretty) -- carrying around a PprStyle
- (PrimOp -> Pretty)
- (CostCentre -> Pretty)
-
- [Pretty] -- Tyvar pretty names
- (tyvar -> Pretty) -- Tyvar lookup function
- [Pretty] -- Uvar pretty names
- (uvar -> Pretty) -- Uvar lookup function
-
- (GenType tyvar uvar -> Pretty)
- (GenUsage uvar -> Pretty)
-
- (ValPrinters bndr occ)
-
-data ValPrinters bndr occ
- = BOPE -- print binders/occs differently
- (bndr -> Pretty) -- to print "major" val_bdrs
- (bndr -> Pretty) -- to print "minor" val_bdrs
- (occ -> Pretty) -- to print bindees
-
- | VPE -- print all values the same way
- [Pretty] -- Value pretty names
- (bndr -> Pretty) -- Binder lookup function
- (occ -> Pretty) -- Occurrence lookup function
-\end{code}
-
-\begin{code}
-initial_pe :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
- Outputable bndr, Outputable occ)
- => PprStyle
- -> Either
- (bndr -> Pretty, bndr -> Pretty, occ -> Pretty)
- ()
- -> PrintEnv tyvar uvar bndr occ
-
-initial_pe sty val_printing
- = PE (ppr sty) -- for a Literal
- (ppr sty) -- for a DataCon
- (ppr sty) -- for a PrimOp
- (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre
-
- tv_pretties ppr_tv -- for a TyVar
- uv_pretties ppr_uv -- for a UsageVar
-
- (\ ty -> pprType_Internal sty tv_pretties ppr_tv uv_pretties ppr_uv ty)
- (ppr sty) -- for a Usage
-
- val_printing_stuff
- where
- ppr_tv = ppr sty -- to print a tyvar
- ppr_uv = ppr sty -- to print a uvar
-
- tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
- ++
- map (\ n -> ppBeside (ppChar 'a') (ppInt n))
- ([0 .. ] :: [Int]) -- a0 ... aN
-
- uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
- ++
- map (\ n -> ppBeside (ppChar 'u') (ppInt n))
- ([0 .. ] :: [Int]) -- u0 ... uN
-
- val_pretties = map (\ c -> ppChar c ) ['i' .. 'k']
- ++ map (\ n -> ppBeside (ppChar 'v') (ppInt n))
- ([0 .. ] :: [Int]) -- v0 ... vN
-
- ------------------------
- val_printing_stuff
- = case val_printing of
- Left (pbdr1, pbdr2, pocc) -> BOPE pbdr1 pbdr2 pocc
- Right () -> VPE val_pretties (ppr sty) (ppr sty)
-
-\end{code}
-
-\begin{code}
-plit (PE pp _ _ _ _ _ _ _ _ _ _) = pp
-pcon (PE _ pp _ _ _ _ _ _ _ _ _) = pp
-pprim (PE _ _ pp _ _ _ _ _ _ _ _) = pp
-pscc (PE _ _ _ pp _ _ _ _ _ _ _) = pp
-ptyvar (PE _ _ _ _ _ pp _ _ _ _ _) = pp
-puvar (PE _ _ _ _ _ _ _ pp _ _ _) = pp
-
-pty (PE _ _ _ _ _ _ _ _ pp _ _) = pp
-puse (PE _ _ _ _ _ _ _ _ _ pp _) = pp
-
-pmaj_bdr (PE _ _ _ _ _ _ _ _ _ _ (BOPE pp _ _)) = pp
-pmaj_bdr (PE _ _ _ _ _ _ _ _ _ _ (VPE _ pp _)) = pp
-
-pmin_bdr (PE _ _ _ _ _ _ _ _ _ _ (BOPE _ pp _)) = pp
-pmin_bdr (PE _ _ _ _ _ _ _ _ _ _ (VPE _ pp _)) = pp
-
-pocc (PE _ _ _ _ _ _ _ _ _ _ (BOPE _ _ pp)) = pp
-pocc (PE _ _ _ _ _ _ _ _ _ _ (VPE _ _ pp)) = pp
-\end{code}
-
%************************************************************************
%* *
\subsection{Workhorse routines (...????...)}
@@ -295,7 +202,7 @@ pocc (PE _ _ _ _ _ _ _ _ _ _ (VPE _ _ pp)) = pp
\begin{code}
ppr_bind pe (NonRec val_bdr expr)
- = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+ = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
4 (ppr_expr pe expr)
ppr_bind pe (Rec binds)
@@ -304,7 +211,7 @@ ppr_bind pe (Rec binds)
ppStr "{- end Rec -}" ]
where
ppr_pair (val_bdr, expr)
- = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+ = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
4 (ppr_expr pe expr)
\end{code}
@@ -321,25 +228,25 @@ ppr_parend_expr pe expr
\end{code}
\begin{code}
-ppr_expr pe (Var name) = pocc pe name
-ppr_expr pe (Lit lit) = plit pe lit
-ppr_expr pe (Con con []) = pcon pe con
+ppr_expr pe (Var name) = pOcc pe name
+ppr_expr pe (Lit lit) = pLit pe lit
+ppr_expr pe (Con con []) = pCon pe con
ppr_expr pe (Con con args)
- = ppHang (ppBesides [pcon pe con, ppChar '!'])
+ = ppHang (ppBesides [pCon pe con, ppChar '!'])
4 (ppSep (map (ppr_arg pe) args))
ppr_expr pe (Prim prim args)
- = ppHang (ppBesides [pprim pe prim, ppChar '!'])
+ = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
4 (ppSep (map (ppr_arg pe) args))
ppr_expr pe expr@(Lam _ _)
= let
(uvars, tyvars, vars, body) = collectBinders expr
in
- ppHang (ppCat [pp_vars SLIT("_/u\\_") (puvar pe) uvars,
- pp_vars SLIT("_/\\_") (ptyvar pe) tyvars,
- pp_vars SLIT("\\") (pmin_bdr pe) vars])
+ ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar pe) uvars,
+ pp_vars SLIT("_/\\_") (pTyVar pe) tyvars,
+ pp_vars SLIT("\\") (pMinBndr pe) vars])
4 (ppr_expr pe body)
where
pp_vars lam pp [] = ppNil
@@ -348,10 +255,13 @@ ppr_expr pe expr@(Lam _ _)
ppr_expr pe expr@(App _ _)
= let
- (fun, args) = collectArgs expr
+ (fun, uargs, targs, vargs) = collectArgs expr
in
ppHang (ppr_parend_expr pe fun)
- 4 (ppSep (map (ppr_arg pe) args))
+ 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs)
+ , ppInterleave ppNil (map (pTy pe) targs)
+ , ppInterleave ppNil (map (ppr_arg pe) vargs)
+ ])
ppr_expr pe (Case expr alts)
= ppSep
@@ -364,7 +274,7 @@ ppr_expr pe (Case expr alts)
ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
= ppAboves [
- ppCat [ppStr "let {", pmaj_bdr pe val_bdr, ppEquals],
+ ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
ppNest 2 (ppr_expr pe rhs),
ppStr "} in",
ppr_expr pe body ]
@@ -372,7 +282,7 @@ ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
= ppAbove
(ppHang (ppStr "let {")
- 2 (ppCat [ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+ 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
4 (ppr_expr pe rhs),
ppStr "} in"]))
(ppr_expr pe expr)
@@ -383,7 +293,7 @@ ppr_expr pe (Let bind expr)
ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
ppr_expr pe (SCC cc expr)
- = ppSep [ppCat [ppPStr SLIT("_scc_"), pscc pe cc],
+ = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
ppr_parend_expr pe expr ]
\end{code}
@@ -392,8 +302,8 @@ ppr_alts pe (AlgAlts alts deflt)
= ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
where
ppr_alt (con, params, expr)
- = ppHang (ppCat [ppr_con con (pcon pe con),
- ppInterleave ppSP (map (pmin_bdr pe) params),
+ = ppHang (ppCat [ppr_con con (pCon pe con),
+ ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"])
4 (ppr_expr pe expr)
where
@@ -404,7 +314,7 @@ ppr_alts pe (PrimAlts alts deflt)
= ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
where
ppr_alt (lit, expr)
- = ppHang (ppCat [plit pe lit, ppStr "->"])
+ = ppHang (ppCat [pLit pe lit, ppStr "->"])
4 (ppr_expr pe expr)
\end{code}
@@ -412,15 +322,15 @@ ppr_alts pe (PrimAlts alts deflt)
ppr_default pe NoDefault = ppNil
ppr_default pe (BindDefault val_bdr expr)
- = ppHang (ppCat [pmin_bdr pe val_bdr, ppStr "->"])
+ = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
4 (ppr_expr pe expr)
\end{code}
\begin{code}
-ppr_arg pe (LitArg lit) = plit pe lit
-ppr_arg pe (VarArg v) = pocc pe v
-ppr_arg pe (TyArg ty) = pty pe ty
-ppr_arg pe (UsageArg use) = puse pe use
+ppr_arg pe (LitArg lit) = pLit pe lit
+ppr_arg pe (VarArg v) = pOcc pe v
+ppr_arg pe (TyArg ty) = pTy pe ty
+ppr_arg pe (UsageArg use) = pUse pe use
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 4db1bdfc9d886ae6372c8b8aee2d2a5875db3629..1e290757065696a00fdb1779583d8da5e9dffb52 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -34,21 +34,23 @@ start.
deSugar :: UniqSupply -- name supply
-> FAST_STRING -- module name
- -> (TypecheckedHsBinds, -- input: class, instance, and value
- TypecheckedHsBinds, -- bindings; see "tcModule" (which produces
+ -> (TypecheckedHsBinds, -- input: recsel, class, instance, and value
+ TypecheckedHsBinds, -- bindings; see "tcModule" (which produces
TypecheckedHsBinds, -- them)
+ TypecheckedHsBinds,
[(Id, TypecheckedHsExpr)])
-- ToDo: handling of const_inst thingies is certainly WRONG ***************************
-> ([CoreBinding], -- output
Bag DsMatchContext) -- Shadowing complaints
-deSugar us mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
+deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs)
= let
(us0, us0a) = splitUniqSupply us
(us1, us1a) = splitUniqSupply us0a
(us2, us2a) = splitUniqSupply us1a
- (us3, us4) = splitUniqSupply us2a
+ (us3, us3a) = splitUniqSupply us2a
+ (us4, us5) = splitUniqSupply us3a
((core_const_prs, consts_pairs), shadows1)
= initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
@@ -67,21 +69,28 @@ deSugar us mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
= initDs us3 consts_env mod_name (dsBinds val_binds)
core_val_pairs = pairsFromCoreBinds core_val_binds
+ (core_recsel_binds, shadows5)
+ = initDs us4 consts_env mod_name (dsBinds recsel_binds)
+ core_recsel_prs = pairsFromCoreBinds core_recsel_binds
+
final_binds
- = if (null core_clas_prs && null core_inst_prs && null core_const_prs) then
+ = if (null core_clas_prs && null core_inst_prs
+ && null core_recsel_prs {-???dont know???-} && null core_const_prs) then
-- we don't have to make the whole thing recursive
core_clas_binds ++ core_val_binds
else -- gotta make it recursive (sigh)
- [Rec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)]
+ [Rec (core_clas_prs ++ core_inst_prs
+ ++ core_const_prs ++ core_val_pairs ++ core_recsel_prs)]
- lift_final_binds = liftCoreBindings us4 final_binds
+ lift_final_binds = liftCoreBindings us5 final_binds
really_final_binds = if opt_DoCoreLinting
then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
else lift_final_binds
- shadows = shadows1 `unionBags` shadows2 `unionBags` shadows3 `unionBags` shadows4
+ shadows = shadows1 `unionBags` shadows2 `unionBags`
+ shadows3 `unionBags` shadows4 `unionBags` shadows5
in
(really_final_binds, shadows)
\end{code}
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index bc26cf44ec03fb4c77b4ed07af6455e2c0c6e33f..ec1bdd4fff8abdae82d5999d8bf7431d5114a5ed 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -31,14 +31,13 @@ import CoreUtils ( escErrorMsg )
import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
import Id ( idType, DictVar(..), GenId )
import ListSetOps ( minusList, intersectLists )
-import PprType ( GenType, GenTyVar )
+import PprType ( GenType )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
import Type ( mkTyVarTys, splitSigmaTy,
tyVarsOfType, tyVarsOfTypes
)
-import TyVar ( tyVarSetToList, GenTyVar )
-import Unique ( Unique )
+import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
import Util ( isIn, panic )
isDictTy = panic "DsBinds.isDictTy"
@@ -290,35 +289,28 @@ dsInstBinds :: [TyVar] -- Abstract wrt these
do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
-dsInstBinds tyvars []
- = returnDs do_nothing
-
-dsInstBinds _ _ = panic "DsBinds.dsInstBinds:maybe we want something different?"
-
-{- LATER
+dsInstBinds tyvars [] = returnDs do_nothing
dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
- = dsExpr expr `thenDs` ( \ rhs ->
+ = dsExpr expr `thenDs` \ rhs ->
let -- Need to apply dsExpr to the variable in case it
-- has a substitution in the current environment
subst_item = (inst, rhs)
in
extendEnvDs [subst_item] (
dsInstBinds tyvars bs
- ) `thenDs` (\ (binds, subst_env) ->
+ ) `thenDs` \ (binds, subst_env) ->
returnDs (binds, subst_item : subst_env)
- ))
dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
- = dsExpr expr `thenDs` ( \ core_lit ->
+ = dsExpr expr `thenDs` \ core_lit ->
let
subst_item = (inst, core_lit)
in
extendEnvDs [subst_item] (
dsInstBinds tyvars bs
- ) `thenDs` (\ (binds, subst_env) ->
+ ) `thenDs` \ (binds, subst_env) ->
returnDs (binds, subst_item : subst_env)
- ))
dsInstBinds tyvars ((inst, expr) : bs)
| null abs_tyvars
@@ -351,7 +343,7 @@ dsInstBinds tyvars ((inst, expr) : bs)
subst_item : subst_env)
where
inst_ty = idType inst
- abs_tyvars = tyVarsOfType inst_ty `intersectLists` tyvars
+ abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
abs_tys = mkTyVarTys abs_tyvars
(_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
@@ -359,26 +351,23 @@ dsInstBinds tyvars ((inst, expr) : bs)
-- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
-- appropriate. Uses "inst"'s type.
+ -- if profiling, wrap the dict in "_scc_ DICT <dict>":
ds_dict_cc expr
- = -- if profiling, wrap the dict in "_scc_ DICT <dict>":
- let
- doing_profiling = opt_SccProfilingOn
- compiling_prelude = opt_CompilingPrelude
- in
- if not doing_profiling
- || not (isDictTy inst_ty) then -- that's easy: do nothing
- returnDs expr
- else if compiling_prelude then
- returnDs (SCC prel_dicts_cc expr)
- else
- getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
+ | not opt_SccProfilingOn ||
+ not (isDictTy inst_ty)
+ = returnDs expr -- that's easy: do nothing
+
+ | opt_CompilingPrelude
+ = returnDs (SCC prel_dicts_cc expr)
+
+ | otherwise
+ = getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
-- ToDo: do -dicts-all flag (mark dict things
-- with individual CCs)
- let
+ let
dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
- in
- returnDs (SCC dict_cc expr)
--}
+ in
+ returnDs (SCC dict_cc expr)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index f2eb50bc1e7717e5716df5c051417eb66bd7965c..b54e111991732992fbcb906ac546318fb1b39fdf 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -19,7 +19,7 @@ import CoreUtils ( coreExprType )
import Id ( getInstantiatedDataConSig, mkTupleCon )
import Maybes ( maybeToBool )
import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
+import PprType ( GenType{-instances-} )
import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo,
packStringForCId, realWorldStatePrimTy,
realWorldStateTy, realWorldTy, stateDataCon,
@@ -27,9 +27,7 @@ import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo,
import Pretty
import PrimOp ( PrimOp(..) )
import Type ( isPrimType, maybeAppDataTyCon, eqTy )
-import TyVar ( GenTyVar{-instance-} )
-import Unique ( Unique{-instances-} )
-import Util ( pprPanic, panic )
+import Util ( pprPanic, pprError, panic )
maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
\end{code}
@@ -198,7 +196,8 @@ we decide what's happening with enumerations. ADR
(data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
can't_see_datacons_error thing ty
- = error (ppShow 100 (ppBesides [ppStr "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ ", ppStr thing, ppStr "; type: ", ppr PprForUser ty]))
+ = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
+ (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty])
\end{code}
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 5d36347feb81a68c7bb75961733513c4e8407e3c..088809955ea59b2b27e7e7061a5b0ad1931e412f 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -32,17 +32,15 @@ import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
import Literal ( mkMachInt, Literal(..) )
import MagicUFs ( MagicUnfoldingFun )
import PprStyle ( PprStyle(..) )
-import PprType ( GenType, GenTyVar )
+import PprType ( GenType )
import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
charDataCon, charTy )
-import Pretty ( ppShow )
-import Type ( splitSigmaTy )
-import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar )
-import Unique ( Unique )
+import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
+import Type ( splitSigmaTy, typePrimRep )
+import TyVar ( nullTyVarEnv, addOneToTyVarEnv )
import Usage ( UVar(..) )
-import Util ( panic )
+import Util ( pprError, panic )
-primRepFromType = panic "DsExpr.primRepFromType"
maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
splitTyArgs = panic "DsExpr.splitTyArgs"
@@ -103,8 +101,8 @@ dsExpr (HsLitOut (HsString s) _)
-- "str" ==> build (\ c n -> foldr charTy T c n "str")
{- LATER:
-dsExpr (HsLitOut (HsString str) _) =
- newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] ->
+dsExpr (HsLitOut (HsString str) _)
+ = newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] ->
let
new_ty = mkTyVarTy new_tyvar
in
@@ -132,10 +130,11 @@ dsExpr (HsLitOut (HsLitLit s) ty)
where
(data_con, kind)
= case (maybeBoxedPrimType ty) of
- Nothing
- -> error ("ERROR: ``literal-literal'' not a single-constructor type: "++ _UNPK_ s ++"; type: "++(ppShow 80 (ppr PprDebug ty)))
Just (boxing_data_con, prim_ty)
- -> (boxing_data_con, primRepFromType prim_ty)
+ -> (boxing_data_con, typePrimRep prim_ty)
+ Nothing
+ -> pprError "ERROR: ``literal-literal'' not a single-constructor type: "
+ (ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty])
dsExpr (HsLitOut (HsInt i) _)
= returnDs (Lit (NoRepInteger i))
@@ -317,6 +316,9 @@ dsExpr (ArithSeqOut expr (FromThenTo from thn two))
mkAppDs expr2 [] [from2, thn2, two2]
\end{code}
+
+Type lambda and application
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
dsExpr (TyLam tyvars expr)
= dsExpr expr `thenDs` \ core_expr ->
@@ -325,6 +327,31 @@ dsExpr (TyLam tyvars expr)
dsExpr expr@(TyApp e tys) = dsApp expr []
\end{code}
+
+Record construction and update
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+{-
+dsExpr (RecordCon con_expr rbinds)
+ = dsExpr con_expr `thenDs` \ con_expr' ->
+ let
+ con_args = map mk_arg (arg_tys `zip` fieldLabelTags)
+ (arg_tys, data_ty) = splitFunTy (coreExprType con_expr')
+
+ mk_arg (arg_ty, tag) = case [ | (sel_id,rhs) <- rbinds,
+ fieldLabelTag (recordSelectorFieldLabel sel_id) == tag
+ ] of
+ (rhs:rhss) -> ASSERT( null rhss )
+ dsExpr rhs
+
+ [] -> returnDs ......GONE HOME!>>>>>
+
+ mkAppDs con_expr [] con_args
+-}
+\end{code}
+
+Dictionary lambda and application
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@DictLam@ and @DictApp@ turn into the regular old things.
(OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
complicated; reminiscent of fully-applied constructors.
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index 5287b22ff99a7a4a5292fc2aef6f287a9d14c9f7..d90e3303968fc2f15036aa7445aea9e7c41afc4a 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -16,20 +16,17 @@ import HsSyn ( GRHSsAndBinds(..), GRHS(..),
import TcHsSyn ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
TypecheckedPat(..), TypecheckedHsBinds(..),
TypecheckedHsExpr(..) )
-import CoreSyn ( CoreBinding(..), CoreExpr(..) )
+import CoreSyn ( CoreBinding(..), CoreExpr(..), mkCoLetsAny )
import DsMonad
import DsUtils
-import CoreUtils ( escErrorMsg, mkErrorApp )
+import CoreUtils ( escErrorMsg, mkErrorApp, mkCoreIfThenElse )
import PrelInfo ( stringTy )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
import SrcLoc ( SrcLoc{-instance-} )
import Util ( panic )
-
-mkCoLetsAny = panic "DsGRHSs.mkCoLetsAny"
-mkCoreIfThenElse = panic "DsGRHSs.mkCoreIfThenElse"
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 636ebf43eb18d85d29bad9c174aa439c8ee15d94..6d9dc558ede58f130f0a71989abc63de204da748 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -31,24 +31,21 @@ import CmdLineOpts ( opt_SccGroup )
import CoreSyn ( CoreExpr(..) )
import CoreUtils ( substCoreExpr )
import HsSyn ( OutPat )
-import Id ( mkSysLocal, lookupIdEnv, growIdEnvList, GenId, IdEnv(..) )
+import Id ( mkSysLocal, mkIdWithNewUniq,
+ lookupIdEnv, growIdEnvList, GenId, IdEnv(..)
+ )
import PprType ( GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
import Pretty
import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
import TcHsSyn ( TypecheckedPat(..) )
-import TyVar ( nullTyVarEnv, GenTyVar )
+import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instances-} )
import UniqSupply ( splitUniqSupply, getUnique, getUniques,
mapUs, thenUs, returnUs, UniqSM(..) )
-import Unique ( Unique )
import Util ( assoc, mapAccumL, zipWithEqual, panic )
infixr 9 `thenDs`
-
-cloneTyVar = panic "DsMonad.cloneTyVar"
-cloneTyVarFromTemplate = panic "DsMonad.cloneTyVarFromTemplate"
-mkIdWithNewUniq = panic "DsMonad.mkIdWithNewUniq"
\end{code}
Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
@@ -165,7 +162,7 @@ newTyVarsDs :: [TyVar] -> DsM [TyVar]
newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
= case (getUniques (length tyvar_tmpls) us) of { uniqs ->
- (zipWithEqual cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) }
+ (zipWithEqual cloneTyVar tyvar_tmpls uniqs, warns) }
\end{code}
We can also reach out and either set/grab location information from
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 07cbe0b249279e78b7049369e09e04a2da175679..700db9e238b09567459f97496412666376330866 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -42,12 +42,12 @@ import PrelInfo ( stringTy )
import Id ( idType, getInstantiatedDataConSig, mkTupleCon,
DataCon(..), DictVar(..), Id(..), GenId )
import TyCon ( mkTupleTyCon )
-import Type ( mkTyVarTys, mkRhoTy, mkFunTys,
- applyTyCon, getAppDataTyCon )
+import Type ( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType,
+ applyTyCon, getAppDataTyCon
+ )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic )
-isUnboxedDataType = panic "DsUtils.isUnboxedDataType"
quantifyTy = panic "DsUtils.quantifyTy"
splitDictType = panic "DsUtils.splitDictType"
mkCoTyApps = panic "DsUtils.mkCoTyApps"
@@ -228,7 +228,7 @@ dsExprToAtom arg_expr continue_with
newSysLocalDs ty `thenDs` \ arg_id ->
continue_with (VarArg arg_id) `thenDs` \ body ->
returnDs (
- if isUnboxedDataType ty
+ if isUnboxedType ty
then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
else Let (NonRec arg_id arg_expr) body
)
@@ -537,7 +537,7 @@ mkFailurePair :: Type -- Result type of the whole case expression
CoreExpr) -- Either the fail variable, or fail variable
-- applied to unit tuple
mkFailurePair ty
- | isUnboxedDataType ty
+ | isUnboxedType ty
= newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
returnDs (\ body ->
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index f657e967a3938b55d329ce1a36e6207e9ee604a8..c7d0b5d860b9207592ae7160b73be87ffcf92755 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -25,9 +25,13 @@ import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
import CoreUtils ( escErrorMsg, mkErrorApp )
-import Id ( idType, mkTupleCon, GenId{-instance-} )
+import FieldLabel ( allFieldLabelTags, fieldLabelTag )
+import Id ( idType, mkTupleCon, dataConSig,
+ recordSelectorFieldLabel,
+ GenId{-instance-}
+ )
import PprStyle ( PprStyle(..) )
-import PprType ( GenTyVar{-instance-}, GenType{-instance-} )
+import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
charTy, charDataCon, intTy, intDataCon,
floatTy, floatDataCon, doubleTy, doubleDataCon,
@@ -35,10 +39,12 @@ import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
floatPrimTy, doublePrimTy, stringTy,
addrTy, addrPrimTy, addrDataCon,
wordTy, wordPrimTy, wordDataCon )
-import Type ( isPrimType, eqTy )
-import TyVar ( GenTyVar )
-import Unique ( Unique )
-import Util ( panic, pprPanic )
+import Type ( isPrimType, eqTy, getAppDataTyCon,
+ instantiateTauTy
+ )
+import TyVar ( GenTyVar{-instance Eq-} )
+import Unique ( Unique{-instance Eq-} )
+import Util ( panic, pprPanic, assertPanic )
\end{code}
The function @match@ is basically the same as in the Wadler chapter,
@@ -320,6 +326,27 @@ tidy1 v (LazyPat pat) match_result
tidy1 v (ConOpPat pat1 id pat2 ty) match_result
= returnDs (ConPat id ty [pat1, pat2], match_result)
+tidy1 v (RecPat con_id pat_ty rpats) match_result
+ = returnDs (ConPat con_id pat_ty pats, match_result)
+ where
+ pats = map mk_pat tagged_arg_tys
+
+ -- Boring stuff to find the arg-tys of the constructor
+ (tyvars, _, arg_tys, _) = dataConSig con_id
+ (_, inst_tys, _) = getAppDataTyCon pat_ty
+ tenv = tyvars `zip` inst_tys
+ con_arg_tys' = map (instantiateTauTy tenv) arg_tys
+ tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
+
+ -- mk_pat picks a WildPat of the appropriate type for absent fields,
+ -- and the specified pattern for present fields
+ mk_pat (arg_ty, tag) = case [pat | (sel_id,pat,_) <- rpats,
+ fieldLabelTag (recordSelectorFieldLabel sel_id) == tag
+ ] of
+ (pat:pats) -> ASSERT( null pats )
+ pat
+ [] -> WildPat arg_ty
+
tidy1 v (ListPat ty pats) match_result
= returnDs (list_ConPat, match_result)
where
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index 52bb3a6ed5362992e7496aec72ddd53f2328aba0..1ae29da52d98df2cd3640eb21a54c9e07e4072ef 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -75,7 +75,7 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps
mk_core_lit ty (HsFloatPrim f) = MachFloat f
mk_core_lit ty (HsDoublePrim d) = MachDouble d
mk_core_lit ty (HsLitLit s) = ASSERT(isPrimType ty)
- MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; primRepFromType???")
+ MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???")
mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled"
\end{code}
diff --git a/ghc/compiler/deforest/Core2Def.lhs b/ghc/compiler/deforest/Core2Def.lhs
index 25c5d31111e6f4261e1bb6036d3553b5edf12be6..b6bfea937ad66db90498a2d1ddb171a58e19675a 100644
--- a/ghc/compiler/deforest/Core2Def.lhs
+++ b/ghc/compiler/deforest/Core2Def.lhs
@@ -95,8 +95,8 @@ ToDo:
> Let (NonRec (v,ManyOcc _) e) e'
> | isTrivial e -> c2d (addOneToIdEnv p v (c2d p e)) e'
> | otherwise ->
-> trace ("Not inlining ManyOcc " ++ ppShow 80 (ppr PprDebug v)) (
-> Let (NonRec v (c2d p e)) (c2d p e'))
+> pprTrace "Not inlining ManyOcc " (ppr PprDebug v) $
+> Let (NonRec v (c2d p e)) (c2d p e')
>
> Let (NonRec (v,DeadCode) e) e' ->
> panic "Core2Def(c2d): oops, unexpected DeadCode"
@@ -104,8 +104,8 @@ ToDo:
> Let (NonRec (v,OneOcc fun_or_arg dup_danger _ _ _) e) e'
> | isTrivial e -> inline_it
> | isDupDanger dup_danger ->
-> trace ("Not inlining DupDanger " ++ ppShow 80 (ppr PprDebug v))(
-> Let (NonRec v (c2d p e)) (c2d p e'))
+> pprTrace "Not inlining DupDanger " (ppr PprDebug v) $
+> Let (NonRec v (c2d p e)) (c2d p e')
> | isFun fun_or_arg ->
> panic "Core2Def(c2d): oops, unexpected Macro"
> | otherwise -> inline_it
diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs
index 08b65d78bfc8e184a3c893204e4e6a705db987b2..48cde68606a50000fe5143bf2e16dba6c044f04b 100644
--- a/ghc/compiler/deforest/Cyclic.lhs
+++ b/ghc/compiler/deforest/Cyclic.lhs
@@ -165,8 +165,7 @@ Comment the next section out to disable back-loops.
> if not (null back_loops){- && not (f `elem` ls')-} then
> --if length back_loops > 1 then panic "barf!" else
> d2c (head back_loops) `thenUs` \core_e ->
-> trace ("Back Loop:\n" ++
-> ppShow 80 (ppr PprDebug core_e)) $
+> pprTrace "Back Loop:\n" (ppr PprDebug core_e) $
If we find a back-loop that also occurs where we would normally make a
new function...
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index a01b198ab8892a4d427331113edf586f7a516a48..51446f29c1c74b2cca4573e6932e9ff87b0d40a6 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -25,10 +25,9 @@ import HsTypes ( PolyType )
--others:
import Id ( DictVar(..), Id(..), GenId )
import Outputable
-import PprType ( pprType )
import Pretty
import SrcLoc ( SrcLoc{-instances-} )
-import TyVar ( GenTyVar{-instances-} )
+--import TyVar ( GenTyVar{-instances-} )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index dad1f5294de72d3f152799d3eaf2bb89cbaf90a5..18f817a650e273c341510e0bcb8fdd060695a694 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -161,7 +161,7 @@ data ConDecl name
SrcLoc
| RecConDecl name
- [(name, BangType name)] -- list of "fields"
+ [([name], BangType name)] -- list of "fields"
SrcLoc
| NewConDecl name -- newtype con decl
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 2004ddf329b8dc10977881d567a0272a69d0bb3d..fc9356ade7703ca4ea1de0b8520f5f3f082eb061 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -20,13 +20,11 @@ import HsTypes ( PolyType )
-- others:
import Id ( DictVar(..), GenId, Id(..) )
import Outputable
-import PprType ( pprType, pprParendType, GenType{-instance-}, GenTyVar{-instance-} )
+import PprType ( pprGenType, pprParendGenType, GenType{-instance-} )
import Pretty
import PprStyle ( PprStyle(..) )
import SrcLoc ( SrcLoc )
-import TyVar ( GenTyVar{-instances-} )
import Usage ( GenUsage{-instance-} )
-import Unique ( Unique{-instances-} )
import Util ( panic{-ToDo:rm eventually-} )
\end{code}
@@ -99,11 +97,14 @@ data HsExpr tyvar uvar id pat
-- for tuples, we can get the types
-- direct from the components
- | RecordCon id -- record construction
- [(id, Maybe (HsExpr tyvar uvar id pat))]
+ -- Record construction
+ | RecordCon (HsExpr tyvar uvar id pat) -- Always (HsVar id) until type checker,
+ -- but the latter adds its type args too
+ (HsRecordBinds tyvar uvar id pat)
- | RecordUpd (HsExpr tyvar uvar id pat) -- record update
- [(id, Maybe (HsExpr tyvar uvar id pat))]
+ -- Record update
+ | RecordUpd (HsExpr tyvar uvar id pat)
+ (HsRecordBinds tyvar uvar id pat)
| ExprWithTySig -- signature binding
(HsExpr tyvar uvar id pat)
@@ -160,6 +161,11 @@ Everything from here on appears only in typechecker output.
| SingleDict -- a simple special case of Dictionary
id -- local dictionary name
+
+type HsRecordBinds tyvar uvar id pat
+ = [(id, HsExpr tyvar uvar id pat, Bool)]
+ -- True <=> source code used "punning",
+ -- i.e. {op1, op2} rather than {op1=e1, op2=e2}
\end{code}
A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
@@ -272,7 +278,7 @@ pprExpr sty (ExplicitList exprs)
= ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs))
pprExpr sty (ExplicitListOut ty exprs)
= ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)),
- ifnotPprForUser sty (ppBeside ppSP (ppParens (pprType sty ty))) ]
+ ifnotPprForUser sty (ppBeside ppSP (ppParens (pprGenType sty ty))) ]
pprExpr sty (ExplicitTuple exprs)
= ppParens (ppInterleave ppComma (map (pprExpr sty) exprs))
@@ -300,7 +306,7 @@ pprExpr sty (TyLam tyvars expr)
4 (pprExpr sty expr)
pprExpr sty (TyApp expr [ty])
- = ppHang (pprExpr sty expr) 4 (pprParendType sty ty)
+ = ppHang (pprExpr sty expr) 4 (pprParendGenType sty ty)
pprExpr sty (TyApp expr tys)
= ppHang (pprExpr sty expr)
@@ -360,16 +366,17 @@ pprParendExpr sty expr
%************************************************************************
\begin{code}
+pp_rbinds :: (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => PprStyle -> Pretty
+ -> HsRecordBinds tyvar uvar id pat -> Pretty
+
pp_rbinds sty thing rbinds
= ppHang thing 4
(ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}'])
-
-pp_rbind :: (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> (id, Maybe (HsExpr tyvar uvar id pat)) -> Pretty
-
-pp_rbind sty (v, Nothing) = ppr sty v
-pp_rbind sty (v, Just e) = ppCat [ppr sty v, ppStr "<-", ppr sty e]
+ where
+ pp_rbind sty (v, _, True{-pun-}) = ppr sty v
+ pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "<-", ppr sty e]
\end{code}
%************************************************************************
diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
index 4c8186f940b49633b8b7ffe88b4fafb5c133b33b..b257cd336e6d3e7eef7732d1fff8a1e070eb9cd8 100644
--- a/ghc/compiler/hsSyn/HsMatches.lhs
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -17,8 +17,6 @@ import Outputable ( ifPprShowAll )
import PprType
import Pretty
import SrcLoc ( SrcLoc{-instances-} )
-import TyVar ( GenTyVar{-instances-} )
-import Unique ( Unique{-instances-} )
import Util ( panic )
\end{code}
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 73124ac4f0f4b0cacc0458a35a2dbbe6202b4ad7..11e4d260094a601fb7baccd3c3234ca64e5a0106 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -24,16 +24,13 @@ import HsLit ( HsLit )
import HsLoop ( HsExpr )
-- others:
-import Id ( GenId, getDataConSig )
+import Id ( GenId, dataConSig )
import Maybes ( maybeToBool )
import Outputable
import PprStyle ( PprStyle(..) )
import Pretty
import TyCon ( maybeTyConSingleCon )
-import TyVar ( GenTyVar )
-import PprType ( GenType, GenTyVar )
-import Unique ( Unique )
-
+import PprType ( GenType )
\end{code}
Patterns come in distinct before- and after-typechecking flavo(u)rs.
@@ -55,7 +52,7 @@ data InPat name
| TuplePatIn [InPat name] -- tuple
| RecPatIn name -- record
- [(name, Maybe (InPat name))]
+ [(name, InPat name, Bool)] -- True <=> source used punning
data OutPat tyvar uvar id
= WildPat (GenType tyvar uvar) -- wild card
@@ -82,8 +79,9 @@ data OutPat tyvar uvar id
| TuplePat [(OutPat tyvar uvar id)] -- tuple
-- UnitPat is TuplePat []
- | RecPat id -- record
- [(id, Maybe (OutPat tyvar uvar id))]
+ | RecPat Id -- record constructor
+ (GenType tyvar uvar) -- the type of the pattern
+ [(id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning
| LitPat -- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
@@ -137,8 +135,8 @@ pprInPat sty (TuplePatIn pats)
pprInPat sty (RecPatIn con rpats)
= ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
where
- pp_rpat (v, Nothing) = ppr sty v
- pp_rpat (v, Just p) = ppCat [ppr sty v, ppStr "<-", ppr sty p]
+ pp_rpat (v, _, True{-pun-}) = ppr sty v
+ pp_rpat (v, p, _) = ppCat [ppr sty v, ppStr "<-", ppr sty p]
\end{code}
\begin{code}
@@ -172,11 +170,11 @@ pprOutPat sty (ListPat ty pats)
pprOutPat sty (TuplePat pats)
= ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
-pprOutPat sty (RecPat con rpats)
+pprOutPat sty (RecPat con ty rpats)
= ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
where
- pp_rpat (v, Nothing) = ppr sty v
- pp_rpat (v, Just p) = ppBesides [ppr sty v, ppStr "<-", ppr sty p]
+-- pp_rpat (v, _, True{-pun-}) = ppr sty v
+ pp_rpat (v, p, _) = ppBesides [ppr sty v, ppStr "<-", ppr sty p]
pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more
pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more
@@ -266,7 +264,7 @@ irrefutablePat other_pat = False -- Literals, NPat
only_con con = maybeToBool (maybeTyConSingleCon tycon)
where
- (_,_,_,tycon) = getDataConSig con
+ (_,_,_,tycon) = dataConSig con
\end{code}
This function @collectPatBinders@ works with the ``collectBinders''
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index d455ff0b41b6153d29b88208144457a3676be57d..d588f68d721e48240cdf46c445f6bbea8b24734e 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -10,10 +10,7 @@ module ErrUtils (
Error(..),
addErrLoc, addShortErrLocLine,
- dontAddErrLoc, pprBagOfErrors,
-
- TcError(..), TcWarning(..), Message(..),
- mkTcErr, arityErr
+ dontAddErrLoc, pprBagOfErrors
) where
@@ -51,33 +48,3 @@ pprBagOfErrors sty bag_of_errors
ppAboves (map (\ p -> ppAbove ppSP p) pretties)
\end{code}
-TypeChecking Errors
-~~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-type Message = PprStyle -> Pretty
-type TcError = Message
-type TcWarning = Message
-
-
-mkTcErr :: SrcLoc -- Where
- -> [Message] -- Context
- -> Message -- What went wrong
- -> TcError -- The complete error report
-
-mkTcErr locn ctxt msg sty
- = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
- 4 (ppAboves [msg sty | msg <- ctxt])
-
-
-arityErr kind name n m sty =
- ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
- n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
- where
- errmsg = kind ++ " has too " ++ quantity ++ " arguments"
- quantity | m < n = "few"
- | otherwise = "many"
- n_arguments | n == 0 = ppStr "no arguments"
- | n == 1 = ppStr "1 argument"
- | True = ppCat [ppInt n, ppStr "arguments"]
-\end{code}
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index c69184443ba001a2c94618f9dc05398daa25ccbc..7e84618856fb45e69ff4b8a3cff4b7b081f483a0 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -19,15 +19,27 @@ import ReadPrefix ( rdModule )
import Rename ( renameModule )
import Typecheck ( typecheckModule, InstInfo )
import Desugar ( deSugar, DsMatchContext, pprDsWarnings )
+import SimplCore ( core2core )
+import CoreToStg ( topCoreBindsToStg )
+import SimplStg ( stg2stg )
+import CodeGen ( codeGen )
+#if ! OMIT_NATIVE_CODEGEN
+import AsmCodeGen ( dumpRealAsm, writeRealAsm )
+#endif
+import AbsCSyn ( absCNop, AbstractC )
+import AbsCUtils ( flattenAbsC )
import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
import ErrUtils ( pprBagOfErrors )
-import Maybes ( MaybeErr(..) )
+import Maybes ( maybeToBool, MaybeErr(..) )
import PrelInfo ( builtinNameInfo )
import RdrHsSyn ( getRawExportees )
+import Specialise ( SpecialiseData(..) )
+import StgSyn ( pprPlainStgBinding, GenStgBinding )
-import PprCore ( pprPlainCoreBinding )
+import PprAbsC ( dumpRealC, writeRealC )
+import PprCore ( pprCoreBinding )
import PprStyle ( PprStyle(..) )
import Pretty
@@ -39,20 +51,8 @@ import TyVar ( GenTyVar ) -- instances
import Unique ( Unique) -- instances
{-
---import AbsCSyn
---import CodeGen ( codeGen )
---import CoreToStg ( topCoreBindsToStg )
---import MkIface ( mkInterface )
-
---import SimplCore ( core2core )
---import SimplStg ( stg2stg )
---import StgSyn ( pprPlainStgBinding, GenStgBinding, GenStgRhs, CostCentre,
- StgBinderInfo, StgBinding(..)
- )
+--import MkIface ( mkInterface )
-#if ! OMIT_NATIVE_CODEGEN
---import AsmCodeGen ( dumpRealAsm, writeRealAsm )
-#endif
-}
\end{code}
@@ -153,12 +153,13 @@ doIt (core_cmds, stg_cmds) input_pgm
else ( -- No typechecking errors ...
case tc_results
- of { (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
+ of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
interface_stuff@(_,_,_,_,_), -- @-pat just for strictness...
(local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) ->
doDump opt_D_dump_tc "Typechecked:"
(pp_show (ppAboves [
+ ppr pprStyle recsel_binds,
ppr pprStyle class_binds,
ppr pprStyle inst_binds,
ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds),
@@ -167,12 +168,11 @@ doIt (core_cmds, stg_cmds) input_pgm
doDump opt_D_dump_deriv "Derived instances:"
(pp_show (ddump_deriv pprStyle)) `thenMn_`
-
-- ******* DESUGARER
show_pass "DeSugar" `thenMn_`
let
(desugared,ds_warnings)
- = deSugar ds_uniqs ds_mod_name typechecked_quad
+ = deSugar ds_uniqs ds_mod_name typechecked_quint
in
(if isEmptyBag ds_warnings then
returnMn ()
@@ -182,13 +182,11 @@ doIt (core_cmds, stg_cmds) input_pgm
) `thenMn_`
doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) desugared)))
+ (map (pprCoreBinding pprStyle) desugared)))
`thenMn_`
-{- LATER ...
-
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
- core2core core_cmds switch_lookup_fn co_mod_name pprStyle
+ core2core core_cmds co_mod_name pprStyle
sm_uniqs local_tycons pragma_tycon_specs desugared
`thenMn`
@@ -196,7 +194,7 @@ doIt (core_cmds, stg_cmds) input_pgm
SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) simplified)))
+ (map (pprCoreBinding pprStyle) simplified)))
`thenMn_`
-- ******* STG-TO-STG SIMPLIFICATION
@@ -206,7 +204,7 @@ doIt (core_cmds, stg_cmds) input_pgm
in
show_pass "Stg2Stg" `thenMn_`
- stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
+ stg2stg stg_cmds st_mod_name pprStyle st_uniqs stg_binds
`thenMn`
\ (stg_binds2, cost_centre_info) ->
@@ -215,6 +213,7 @@ doIt (core_cmds, stg_cmds) input_pgm
(pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
`thenMn_`
+{- LATER ...
-- ******* INTERFACE GENERATION (needs STG output)
{- let
mod_name = "_TestName_"
@@ -227,17 +226,19 @@ doIt (core_cmds, stg_cmds) input_pgm
if_inst_info = emptyBag
in
-}
+
show_pass "Interface" `thenMn_`
let
mod_interface
- = mkInterface switch_is_on if_mod_name export_list_fns
+ = mkInterface if_mod_name export_list_fns
inlinings_env all_tycon_specs
interface_stuff
stg_binds2
in
- doOutput ProduceHi ( \ file ->
+ doOutput opt_ProduceHi ( \ file ->
ppAppendFile file 1000{-pprCols-} mod_interface )
`thenMn_`
+-}
-- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
show_pass "CodeGen" `thenMn_`
@@ -245,7 +246,6 @@ doIt (core_cmds, stg_cmds) input_pgm
abstractC = codeGen cc_mod_name -- module name for CC labelling
cost_centre_info
cc_import_names -- import names for CC registering
- switch_lookup_fn
gen_tycons -- type constructors generated locally
all_tycon_specs -- tycon specialisations
stg_binds2
@@ -253,42 +253,40 @@ doIt (core_cmds, stg_cmds) input_pgm
flat_abstractC = flattenAbsC fl_uniqs abstractC
in
doDump opt_D_dump_absC "Abstract C:"
- (dumpRealC switch_is_on abstractC) `thenMn_`
+ (dumpRealC abstractC) `thenMn_`
doDump opt_D_dump_flatC "Flat Abstract C:"
- (dumpRealC switch_is_on flat_abstractC) `thenMn_`
+ (dumpRealC flat_abstractC) `thenMn_`
-- You can have C (c_output) or assembly-language (ncg_output),
-- but not both. [Allowing for both gives a space leak on
-- flat_abstractC. WDP 94/10]
let
(flat_absC_c, flat_absC_ncg) =
- case (string_switch_is_on ProduceC || switch_is_on D_dump_realC,
- string_switch_is_on ProduceS || switch_is_on D_dump_asm) of
- (True, False) -> (flat_abstractC, AbsCNop)
- (False, True) -> (AbsCNop, flat_abstractC)
- (False, False) -> (AbsCNop, AbsCNop)
+ case (maybeToBool opt_ProduceC || opt_D_dump_realC,
+ maybeToBool opt_ProduceS || opt_D_dump_asm) of
+ (True, False) -> (flat_abstractC, absCNop)
+ (False, True) -> (absCNop, flat_abstractC)
+ (False, False) -> (absCNop, absCNop)
(True, True) -> error "ERROR: Can't do both .hc and .s at the same time"
- c_output_d = dumpRealC switch_is_on flat_absC_c
- c_output_w = (\ f -> writeRealC switch_is_on f flat_absC_c)
+ c_output_d = dumpRealC flat_absC_c
+ c_output_w = (\ f -> writeRealC f flat_absC_c)
#if OMIT_NATIVE_CODEGEN
ncg_output_d = error "*** GHC not built with a native-code generator ***"
ncg_output_w = ncg_output_d
#else
- ncg_output_d = dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
- ncg_output_w = (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
+ ncg_output_d = dumpRealAsm flat_absC_ncg ncg_uniqs
+ ncg_output_w = (\ f -> writeRealAsm f flat_absC_ncg ncg_uniqs)
#endif
in
doDump opt_D_dump_asm "" ncg_output_d `thenMn_`
- doOutput ProduceS ncg_output_w `thenMn_`
+ doOutput opt_ProduceS ncg_output_w `thenMn_`
doDump opt_D_dump_realC "" c_output_d `thenMn_`
- doOutput ProduceC c_output_w `thenMn_`
-
-LATER -}
+ doOutput opt_ProduceC c_output_w `thenMn_`
exitMn 0
} ) } } }
where
@@ -319,8 +317,8 @@ LATER -}
doOutput switch io_action
= case switch of
- Nothing -> returnMn ()
- Just fname ->
+ Nothing -> returnMn ()
+ Just fn -> let fname = _UNPK_ fn in
fopen fname "a+" `thenPrimIO` \ file ->
if (file == ``NULL'') then
error ("doOutput: failed to open:"++fname)
@@ -333,8 +331,8 @@ LATER -}
doDump switch hdr string
= if switch
- then writeMn stderr hdr `thenMn_`
- writeMn stderr ('\n': string) `thenMn_`
+ then writeMn stderr hdr `thenMn_`
+ writeMn stderr ('\n': string) `thenMn_`
writeMn stderr "\n"
else returnMn ()
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 0b8de5f9db842f3cc531e09083fe6d66982ec44c..46bb220b58f14c3d2484d458a7ef92e16f521c1a 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -163,7 +163,6 @@ mkInterface modname export_list_fns inline_env tycon_specs
-- mkInterface to do I/O (WDP 94/10)
error "Can't produce interface file because of errors!\n"
else
--- trace ("mkIface:Ids:"++(ppShow 80 (ppr PprDebug global_ids))) (
ppAboves
[ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
@@ -181,7 +180,6 @@ mkInterface modname export_list_fns inline_env tycon_specs
ppChar '\n'
]
--- )
where
any_purely_local tycons classes vals
= any bad_tc tycons || any bad_cl classes || any bad_id vals
@@ -322,7 +320,7 @@ get_tycon_pair tycon
ExportAbs -> orig_nm
NotExported -> orig_nm
- cons = getTyConDataCons tycon
+ cons = tyConDataCons tycon
in
(orig_mod, nm_to_print) }
@@ -411,7 +409,7 @@ do_value better_id_fn inline_env val
ppPStr SLIT("#-}")]
in
ppAbove (ppCat [ppr_non_op name_str,
- ppPStr SLIT("::"), pprType sty val_ty])
+ ppPStr SLIT("::"), pprGenType sty val_ty])
pp_id_info
-- sadly duplicates Outputable.pprNonOp (ToDo)
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 3997048dff61d8ea08c60c1ff7d02de55348a05d..90863433d388361818aa0ac5ebe4b6d7665f1f74 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -1,62 +1,59 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\begin{code}
#include "HsVersions.h"
-module AbsCStixGen (
- genCodeAbstractC,
+module AbsCStixGen ( genCodeAbstractC ) where
- -- and, of course, that's not enough...
- AbstractC, Target, StixTree, UniqSupply, UniqSM(..)
- ) where
+import Ubiq{-uitous-}
import AbsCSyn
-import PrelInfo ( PrimOp(..), primOpNeedsWrapper, isCompareOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import Stix
+
+import MachMisc
+import MachRegs
+
+import AbsCUtils ( getAmodeRep, mixedTypeLocn,
+ nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
)
import CgCompInfo ( mIN_UPD_SIZE )
-import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI,
- closureUpdReqd
+import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
+ fastLabelFromCI, closureUpdReqd
)
-import MachDesc
-import Maybes ( Maybe(..), maybeToBool )
-import Outputable
-import PrimRep ( isFloatingRep )
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Stix
+import HeapOffs ( hpRelToInt )
+import Literal ( Literal(..) )
+import Maybes ( maybeToBool )
+import OrdList ( OrdList )
+import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
+import PrimRep ( isFloatingRep, PrimRep(..) )
import StixInfo ( genCodeInfoTable )
-import UniqSupply
-import Util
+import StixMacro ( macroCode )
+import StixPrim ( primCode, amodeToStix, amodeToStix' )
+import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) )
+import Util ( naturalMergeSortLe, panic )
\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.
+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}
--- hacking with Uncle Will:
-#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
+genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
-genCodeAbstractC
- :: Target
- -> AbstractC
- -> UniqSM [[StixTree]]
-
-genCodeAbstractC target_STRICT absC =
- mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
+genCodeAbstractC absC
+ = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
returnUs ([StComment SLIT("Native Code")] : trees)
where
- -- "target" munging things... ---
- a2stix = amodeToStix target
- a2stix' = amodeToStix' target
- volsaves = volatileSaves target
- volrestores = volatileRestores target
- p2stix = primToStix target
- macro_code = macroCode target
- hp_rel = hpRel target
+ a2stix = amodeToStix
+ a2stix' = amodeToStix'
+ volsaves = volatileSaves
+ volrestores = volatileRestores
+ p2stix = primCode
+ macro_code = macroCode
+ hp_rel = hpRelToInt
-- real code follows... ---------
\end{code}
@@ -66,34 +63,33 @@ Here we handle top-level things, like @CCodeBlock@s and
\begin{code}
{-
genCodeTopAbsC
- :: Target
- -> AbstractC
+ :: AbstractC
-> UniqSM [StixTree]
-}
- gentopcode (CCodeBlock label absC) =
- gencode absC `thenUs` \ code ->
+ gentopcode (CCodeBlock label absC)
+ = gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
- gentopcode stmt@(CStaticClosure label _ _ _) =
- genCodeStaticClosure stmt `thenUs` \ code ->
+ gentopcode stmt@(CStaticClosure label _ _ _)
+ = genCodeStaticClosure stmt `thenUs` \ code ->
returnUs (StSegment DataSegment : StLabel label : code [])
gentopcode stmt@(CRetUnVector _ _) = returnUs []
- gentopcode stmt@(CFlatRetVector label _) =
- genCodeVecTbl stmt `thenUs` \ code ->
+ gentopcode stmt@(CFlatRetVector label _)
+ = genCodeVecTbl stmt `thenUs` \ code ->
returnUs (StSegment TextSegment : code [StLabel label])
gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
| slow_is_empty
- = genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
+ = genCodeInfoTable stmt `thenUs` \ itbl ->
returnUs (StSegment TextSegment : itbl [])
| otherwise
- = genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
- gencode slow `thenUs` \ slow_code ->
+ = genCodeInfoTable stmt `thenUs` \ itbl ->
+ gencode slow `thenUs` \ slow_code ->
returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
slow_code [StFunEnd slow_lbl]))
where
@@ -102,9 +98,9 @@ Here we handle top-level things, like @CCodeBlock@s and
gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
-- ToDo: what if this is empty? ------------------------^^^^
- genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
- gencode slow `thenUs` \ slow_code ->
- gencode fast `thenUs` \ fast_code ->
+ genCodeInfoTable stmt `thenUs` \ itbl ->
+ gencode slow `thenUs` \ slow_code ->
+ gencode fast `thenUs` \ fast_code ->
returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
fast_code [StFunEnd fast_lbl])))
@@ -112,8 +108,8 @@ Here we handle top-level things, like @CCodeBlock@s and
slow_lbl = entryLabelFromCI cl_info
fast_lbl = fastLabelFromCI cl_info
- gentopcode absC =
- gencode absC `thenUs` \ code ->
+ gentopcode absC
+ = gencode absC `thenUs` \ code ->
returnUs (StSegment TextSegment : code [])
\end{code}
@@ -123,12 +119,11 @@ Vector tables are trivial!
\begin{code}
{-
genCodeVecTbl
- :: Target
- -> AbstractC
+ :: AbstractC
-> UniqSM StixTreeList
-}
- genCodeVecTbl (CFlatRetVector label amodes) =
- returnUs (\xs -> vectbl : xs)
+ genCodeVecTbl (CFlatRetVector label amodes)
+ = returnUs (\xs -> vectbl : xs)
where
vectbl = StData PtrRep (reverse (map a2stix amodes))
@@ -139,12 +134,11 @@ Static closures are not so hard either.
\begin{code}
{-
genCodeStaticClosure
- :: Target
- -> AbstractC
+ :: AbstractC
-> UniqSM StixTreeList
-}
- genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) =
- returnUs (\xs -> table : xs)
+ genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
+ = returnUs (\xs -> table : xs)
where
table = StData PtrRep (StCLbl info_lbl : body)
info_lbl = infoTableLabelFromCI cl_info
@@ -170,8 +164,7 @@ Now the individual AbstractC statements.
\begin{code}
{-
gencode
- :: Target
- -> AbstractC
+ :: AbstractC
-> UniqSM StixTreeList
-}
\end{code}
@@ -197,8 +190,8 @@ resulting StixTreeLists are joined together.
\begin{code}
- gencode (AbsCStmts c1 c2) =
- gencode c1 `thenUs` \ b1 ->
+ gencode (AbsCStmts c1 c2)
+ = gencode c1 `thenUs` \ b1 ->
gencode c2 `thenUs` \ b2 ->
returnUs (b1 . b2)
@@ -212,8 +205,8 @@ addresses, etc.)
\begin{code}
- gencode (CInitHdr cl_info reg_rel _ _) =
- let
+ gencode (CInitHdr cl_info reg_rel _ _)
+ = let
lhs = a2stix (CVal reg_rel PtrRep)
lbl = infoTableLabelFromCI cl_info
in
@@ -232,8 +225,8 @@ of the source? Be careful about floats/doubles.
gencode (CAssign lhs rhs)
| getAmodeRep lhs == VoidRep = returnUs id
- | otherwise =
- let pk = getAmodeRep lhs
+ | otherwise
+ = let pk = getAmodeRep lhs
pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
lhs' = a2stix lhs
rhs' = a2stix' rhs
@@ -248,23 +241,23 @@ with the address of the info table before jumping to the entry code for Node.
\begin{code}
- gencode (CJump dest) =
- returnUs (\xs -> StJump (a2stix dest) : xs)
+ gencode (CJump dest)
+ = returnUs (\xs -> StJump (a2stix dest) : xs)
- gencode (CFallThrough (CLbl lbl _)) =
- returnUs (\xs -> StFallThrough lbl : xs)
+ gencode (CFallThrough (CLbl lbl _))
+ = returnUs (\xs -> StFallThrough lbl : xs)
- gencode (CReturn dest DirectReturn) =
- returnUs (\xs -> StJump (a2stix dest) : xs)
+ gencode (CReturn dest DirectReturn)
+ = returnUs (\xs -> StJump (a2stix dest) : xs)
- gencode (CReturn table (StaticVectoredReturn n)) =
- returnUs (\xs -> StJump dest : xs)
+ gencode (CReturn table (StaticVectoredReturn n))
+ = returnUs (\xs -> StJump dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table)
(StInt (toInteger (-n-1))))
- gencode (CReturn table (DynamicVectoredReturn am)) =
- returnUs (\xs -> StJump dest : xs)
+ gencode (CReturn table (DynamicVectoredReturn am))
+ = returnUs (\xs -> StJump dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
@@ -277,8 +270,8 @@ Now the PrimOps, some of which may need caller-saves register wrappers.
gencode (COpStmt results op args liveness_mask vols)
-- ToDo (ADR?): use that liveness mask
- | primOpNeedsWrapper op =
- let
+ | primOpNeedsWrapper op
+ = let
saves = volsaves vols
restores = volrestores vols
in
@@ -356,11 +349,11 @@ Finally, all of the disgusting AbstractC macros.
gencode (CMacroStmt macro args) = macro_code macro args
- gencode (CCallProfCtrMacro macro _) =
- returnUs (\xs -> StComment macro : xs)
+ gencode (CCallProfCtrMacro macro _)
+ = returnUs (\xs -> StComment macro : xs)
- gencode (CCallProfCCMacro macro _) =
- returnUs (\xs -> StComment macro : xs)
+ gencode (CCallProfCCMacro macro _)
+ = returnUs (\xs -> StComment macro : xs)
\end{code}
@@ -383,12 +376,11 @@ comparison tree. (Perhaps this could be tuned.)
{-
mkSimpleSwitches
- :: Target
- -> CAddrMode -> [(Literal,AbstractC)] -> AbstractC
+ :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
-> UniqSM StixTreeList
-}
- mkSimpleSwitches am alts absC =
- getUniqLabelNCG `thenUs` \ udlbl ->
+ mkSimpleSwitches am alts absC
+ = getUniqLabelNCG `thenUs` \ udlbl ->
getUniqLabelNCG `thenUs` \ ujlbl ->
let am' = a2stix am
joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
@@ -401,14 +393,6 @@ comparison tree. (Perhaps this could be tuned.)
-- lowest and highest possible values the discriminant could take
lowest = if floating then targetMinDouble else targetMinInt
highest = if floating then targetMaxDouble else targetMaxInt
-
- -- These should come from somewhere else, depending on the target arch
- -- (Note that the floating point values aren't terribly important.)
- -- ToDo: Fix!(JSM)
- targetMinDouble = MachDouble (-1.7976931348623157e+308)
- targetMaxDouble = MachDouble (1.7976931348623157e+308)
- targetMinInt = mkMachInt (-2147483647)
- targetMaxInt = mkMachInt 2147483647
in
(
if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
@@ -431,20 +415,20 @@ comparison tree. (Perhaps this could be tuned.)
\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.
+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.
+If a join is necessary after the switch, the alternatives should
+already finish with a jump to the join point.
\begin{code}
{-
mkJumpTable
- :: Target
- -> StixTree -- discriminant
+ :: StixTree -- discriminant
-> [(Literal, AbstractC)] -- alternatives
-> Integer -- low tag
-> Integer -- high tag
@@ -452,8 +436,8 @@ with a jump to the join point.
-> UniqSM StixTreeList
-}
- mkJumpTable am alts lowTag highTag dflt =
- getUniqLabelNCG `thenUs` \ utlbl ->
+ mkJumpTable am alts lowTag highTag dflt
+ = getUniqLabelNCG `thenUs` \ utlbl ->
mapUs genLabel alts `thenUs` \ branches ->
let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
@@ -500,8 +484,7 @@ alternatives should already finish with a jump to the join point.
\begin{code}
{-
mkBinaryTree
- :: Target
- -> StixTree -- discriminant
+ :: StixTree -- discriminant
-> Bool -- floating point?
-> [(Literal, AbstractC)] -- alternatives
-> Int -- number of choices
@@ -513,8 +496,8 @@ alternatives should already finish with a jump to the join point.
mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
| rangeOfOne = gencode alt
- | otherwise =
- let tag' = a2stix (CLit tag)
+ | otherwise
+ = let tag' = a2stix (CLit tag)
cmpOp = if floating then DoubleNeOp else IntNeOp
test = StPrim cmpOp [am, tag']
cjmp = StCondJump udlbl test
@@ -526,8 +509,8 @@ alternatives should already finish with a jump to the join point.
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 ->
+ mkBinaryTree am floating alts choices lowTag highTag udlbl
+ = getUniqLabelNCG `thenUs` \ uhlbl ->
let tag' = a2stix (CLit splitTag)
cmpOp = if floating then DoubleGeOp else IntGeOp
test = StPrim cmpOp [am, tag']
@@ -550,16 +533,15 @@ alternatives should already finish with a jump to the join point.
\begin{code}
{-
mkIfThenElse
- :: Target
- -> CAddrMode -- discriminant
+ :: CAddrMode -- discriminant
-> Literal -- tag
-> AbstractC -- if-part
-> AbstractC -- else-part
-> UniqSM StixTreeList
-}
- mkIfThenElse discrim tag alt deflt =
- getUniqLabelNCG `thenUs` \ ujlbl ->
+ mkIfThenElse discrim tag alt deflt
+ = getUniqLabelNCG `thenUs` \ ujlbl ->
getUniqLabelNCG `thenUs` \ utlbl ->
let discrim' = a2stix discrim
tag' = a2stix (CLit tag)
@@ -604,8 +586,8 @@ mightFallThrough absC = ft absC True
ft _ if_empty = if_empty
{- Old algorithm, which called nonemptyAbsC for every subexpression! =========
-fallThroughAbsC (AbsCStmts c1 c2) =
- case nonemptyAbsC c2 of
+fallThroughAbsC (AbsCStmts c1 c2)
+ = case nonemptyAbsC c2 of
Nothing -> fallThroughAbsC c1
Just x -> fallThroughAbsC x
fallThroughAbsC (CJump _) = False
diff --git a/ghc/compiler/nativeGen/AlphaCode.lhs b/ghc/compiler/nativeGen/AlphaCode.lhs
deleted file mode 100644
index 5b5069a39f81e480d556877b0257476d6eb0d522..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/AlphaCode.lhs
+++ /dev/null
@@ -1,1402 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-
-\section[AlphaCode]{The Native (Alpha) Machine Code}
-
-\begin{code}
-#include "HsVersions.h"
-
-module AlphaCode (
- Addr(..),Cond(..),Imm(..),RI(..),Size(..),
- AlphaCode(..),AlphaInstr(..),AlphaRegs,
- strImmLab,
-
- printLabeledCodes,
-
- baseRegOffset, stgRegMap, callerSaves,
-
- kindToSize,
-
- v0, f0, sp, ra, pv, gp, zero, argRegs,
-
- freeRegs, reservedRegs
-
- -- and, for self-sufficiency ...
- ) where
-
-IMPORT_Trace
-
-import AbsCSyn ( MagicId(..) )
-import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..),
- Reg(..), RegUsage(..), RegLiveness(..)
- )
-import BitSet
-import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
-import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
-import FiniteMap
-import Maybes ( Maybe(..), maybeToBool )
-import OrdList ( OrdList, mkUnitList, flattenOrdList )
-import Outputable
-import PrimRep ( PrimRep(..) )
-import UniqSet
-import Stix
-import Unpretty
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AlphaReg]{The Native (Alpha) Machine Register Table}
-%* *
-%************************************************************************
-
-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}
-
-fReg :: Int -> Int
-fReg x = (32 + x)
-
-v0, f0, ra, pv, gp, sp, zero :: Reg
-v0 = realReg 0
-f0 = realReg (fReg 0)
-ra = FixedReg ILIT(26)
-pv = t12
-gp = FixedReg ILIT(29)
-sp = FixedReg ILIT(30)
-zero = FixedReg ILIT(31)
-
-t9, t10, t11, t12 :: Reg
-t9 = realReg 23
-t10 = realReg 24
-t11 = realReg 25
-t12 = realReg 27
-
-argRegs :: [(Reg, Reg)]
-argRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]]
-
-realReg :: Int -> Reg
-realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TheAlphaCode]{The datatype for alpha assembly language}
-%* *
-%************************************************************************
-
-Here is a definition of the Alpha assembly language.
-
-\begin{code}
-
-data Imm = ImmInt Int
- | ImmInteger Integer -- Sigh.
- | ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLab Unpretty -- Simple string label
- deriving ()
-
-strImmLab s = ImmLab (uppStr s)
-
-data Addr = AddrImm Imm
- | AddrReg Reg
- | AddrRegImm Reg Imm
- deriving ()
-
-data Cond = EQ -- For CMP and BI
- | LT -- For CMP and BI
- | LE -- For CMP and BI
- | ULT -- For CMP only
- | ULE -- For CMP only
- | NE -- For BI only
- | GT -- For BI only
- | GE -- For BI only
- | ALWAYS -- For BI (same as BR)
- | NEVER -- For BI (null instruction)
- deriving ()
-
-data RI = RIReg Reg
- | RIImm Imm
- deriving ()
-
-data Size = B
- | BU
- | W
- | WU
- | L
- | Q
- | FF
- | DF
- | GF
- | SF
- | TF
- deriving ()
-
-data AlphaInstr =
-
--- Loads and stores.
-
- LD Size Reg Addr -- size, dst, src
- | LDA Reg Addr -- dst, src
- | LDAH Reg Addr -- dst, src
- | LDGP Reg Addr -- dst, src
- | LDI Size Reg Imm -- size, dst, src
- | ST Size Reg Addr -- 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 Addr Int
- | BSR Imm Int
- | JSR Reg Addr Int
-
--- Pseudo-ops.
-
- | LABEL CLabel
- | FUNBEGIN CLabel
- | FUNEND CLabel
- | COMMENT FAST_STRING
- | SEGMENT CodeSegment
- | ASCII Bool String -- needs backslash conversion?
- | DATA Size [Imm]
-
-type AlphaCode = OrdList AlphaInstr
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TheAlphaPretty]{Pretty-printing the Alpha Assembly Language}
-%* *
-%************************************************************************
-
-\begin{code}
-
-printLabeledCodes :: PprStyle -> [AlphaInstr] -> Unpretty
-printLabeledCodes sty codes = uppAboves (map (pprAlphaInstr sty) codes)
-
-\end{code}
-
-Printing the pieces...
-
-\begin{code}
-
-pprReg :: Reg -> Unpretty
-
-pprReg (FixedReg i) = pprAlphaReg i
-pprReg (MappedReg i) = pprAlphaReg i
-pprReg other = uppStr (show other) -- should only happen when debugging
-
-pprAlphaReg :: FAST_INT -> Unpretty
-pprAlphaReg i = uppPStr
- (case i of {
- ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1");
- ILIT( 2) -> SLIT("$2"); ILIT( 3) -> SLIT("$3");
- ILIT( 4) -> SLIT("$4"); ILIT( 5) -> SLIT("$5");
- ILIT( 6) -> SLIT("$6"); ILIT( 7) -> SLIT("$7");
- ILIT( 8) -> SLIT("$8"); ILIT( 9) -> SLIT("$9");
- ILIT(10) -> SLIT("$10"); ILIT(11) -> SLIT("$11");
- ILIT(12) -> SLIT("$12"); ILIT(13) -> SLIT("$13");
- ILIT(14) -> SLIT("$14"); ILIT(15) -> SLIT("$15");
- ILIT(16) -> SLIT("$16"); ILIT(17) -> SLIT("$17");
- ILIT(18) -> SLIT("$18"); ILIT(19) -> SLIT("$19");
- ILIT(20) -> SLIT("$20"); ILIT(21) -> SLIT("$21");
- ILIT(22) -> SLIT("$22"); ILIT(23) -> SLIT("$23");
- ILIT(24) -> SLIT("$24"); ILIT(25) -> SLIT("$25");
- ILIT(26) -> SLIT("$26"); ILIT(27) -> SLIT("$27");
- ILIT(28) -> SLIT("$28"); ILIT(29) -> SLIT("$29");
- ILIT(30) -> SLIT("$30"); ILIT(31) -> SLIT("$31");
- ILIT(32) -> SLIT("$f0"); ILIT(33) -> SLIT("$f1");
- ILIT(34) -> SLIT("$f2"); ILIT(35) -> SLIT("$f3");
- ILIT(36) -> SLIT("$f4"); ILIT(37) -> SLIT("$f5");
- ILIT(38) -> SLIT("$f6"); ILIT(39) -> SLIT("$f7");
- ILIT(40) -> SLIT("$f8"); ILIT(41) -> SLIT("$f9");
- ILIT(42) -> SLIT("$f10"); ILIT(43) -> SLIT("$f11");
- ILIT(44) -> SLIT("$f12"); ILIT(45) -> SLIT("$f13");
- ILIT(46) -> SLIT("$f14"); ILIT(47) -> SLIT("$f15");
- ILIT(48) -> SLIT("$f16"); ILIT(49) -> SLIT("$f17");
- ILIT(50) -> SLIT("$f18"); ILIT(51) -> SLIT("$f19");
- ILIT(52) -> SLIT("$f20"); ILIT(53) -> SLIT("$f21");
- ILIT(54) -> SLIT("$f22"); ILIT(55) -> SLIT("$f23");
- ILIT(56) -> SLIT("$f24"); ILIT(57) -> SLIT("$f25");
- ILIT(58) -> SLIT("$f26"); ILIT(59) -> SLIT("$f27");
- ILIT(60) -> SLIT("$f28"); ILIT(61) -> SLIT("$f29");
- ILIT(62) -> SLIT("$f30"); ILIT(63) -> SLIT("$f31");
- _ -> SLIT("very naughty alpha register")
- })
-
-pprCond :: Cond -> Unpretty
-pprCond EQ = uppPStr SLIT("eq")
-pprCond LT = uppPStr SLIT("lt")
-pprCond LE = uppPStr SLIT("le")
-pprCond ULT = uppPStr SLIT("ult")
-pprCond ULE = uppPStr SLIT("ule")
-pprCond NE = uppPStr SLIT("ne")
-pprCond GT = uppPStr SLIT("gt")
-pprCond GE = uppPStr SLIT("ge")
-
-pprImm :: PprStyle -> Imm -> Unpretty
-
-pprImm sty (ImmInt i) = uppInt i
-pprImm sty (ImmInteger i) = uppInteger i
-
-pprImm sty (ImmCLbl l) = pprCLabel sty l
-
-pprImm sty (ImmLab s) = s
-
-pprAddr :: PprStyle -> Addr -> Unpretty
-pprAddr sty (AddrReg reg) = uppBesides [uppLparen, pprReg reg, uppRparen]
-
-pprAddr sty (AddrImm imm) = pprImm sty imm
-
-pprAddr sty (AddrRegImm r1 imm) =
- uppBesides [
- pprImm sty imm,
- uppLparen,
- pprReg r1,
- uppRparen
- ]
-
-pprRI :: PprStyle -> RI -> Unpretty
-pprRI sty (RIReg r) = pprReg r
-pprRI sty (RIImm r) = pprImm sty r
-
-pprRegRIReg :: PprStyle -> FAST_STRING -> Reg -> RI -> Reg -> Unpretty
-pprRegRIReg sty name reg1 ri reg2 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
-pprSizeRegRegReg name size reg1 reg2 reg3 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- pprSize size,
- uppChar '\t',
- pprReg reg1,
- uppComma,
- pprReg reg2,
- uppComma,
- pprReg reg3
- ]
-
-pprSize :: Size -> Unpretty
-pprSize x = uppPStr
- (case x of
- B -> SLIT("b")
- BU -> SLIT("bu")
- W -> SLIT("w")
- WU -> SLIT("wu")
- L -> SLIT("l")
- Q -> SLIT("q")
- FF -> SLIT("f")
- DF -> SLIT("d")
- GF -> SLIT("g")
- SF -> SLIT("s")
- TF -> SLIT("t")
- )
-
-pprAlphaInstr :: PprStyle -> AlphaInstr -> Unpretty
-
-pprAlphaInstr sty (LD size reg addr) =
- uppBesides [
- uppPStr SLIT("\tld"),
- pprSize size,
- uppChar '\t',
- pprReg reg,
- uppComma,
- pprAddr sty addr
- ]
-
-pprAlphaInstr sty (LDA reg addr) =
- uppBesides [
- uppPStr SLIT("\tlda\t"),
- pprReg reg,
- uppComma,
- pprAddr sty addr
- ]
-
-pprAlphaInstr sty (LDAH reg addr) =
- uppBesides [
- uppPStr SLIT("\tldah\t"),
- pprReg reg,
- uppComma,
- pprAddr sty addr
- ]
-
-pprAlphaInstr sty (LDGP reg addr) =
- uppBesides [
- uppPStr SLIT("\tldgp\t"),
- pprReg reg,
- uppComma,
- pprAddr sty addr
- ]
-
-pprAlphaInstr sty (LDI size reg imm) =
- uppBesides [
- uppPStr SLIT("\tldi"),
- pprSize size,
- uppChar '\t',
- pprReg reg,
- uppComma,
- pprImm sty imm
- ]
-
-pprAlphaInstr sty (ST size reg addr) =
- uppBesides [
- uppPStr SLIT("\tst"),
- pprSize size,
- uppChar '\t',
- pprReg reg,
- uppComma,
- pprAddr sty addr
- ]
-
-pprAlphaInstr sty (CLR reg) =
- uppBesides [
- uppPStr SLIT("\tclr\t"),
- pprReg reg
- ]
-
-pprAlphaInstr sty (ABS size ri reg) =
- uppBesides [
- uppPStr SLIT("\tabs"),
- pprSize size,
- uppChar '\t',
- pprRI sty ri,
- uppComma,
- pprReg reg
- ]
-
-pprAlphaInstr sty (NEG size ov ri reg) =
- uppBesides [
- uppPStr SLIT("\tneg"),
- pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
- pprRI sty ri,
- uppComma,
- pprReg reg
- ]
-
-pprAlphaInstr sty (ADD size ov reg1 ri reg2) =
- uppBesides [
- uppPStr SLIT("\tadd"),
- pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (SADD size scale reg1 ri reg2) =
- uppBesides [
- uppPStr (case scale of {L -> SLIT("\ts4"); Q -> SLIT("\ts8")}),
- uppPStr SLIT("add"),
- pprSize size,
- uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (SUB size ov reg1 ri reg2) =
- uppBesides [
- uppPStr SLIT("\tsub"),
- pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (SSUB size scale reg1 ri reg2) =
- uppBesides [
- uppPStr (case scale of {L -> SLIT("\ts4"); Q -> SLIT("\ts8")}),
- uppPStr SLIT("sub"),
- pprSize size,
- uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (MUL size ov reg1 ri reg2) =
- uppBesides [
- uppPStr SLIT("\tmul"),
- pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (DIV size uns reg1 ri reg2) =
- uppBesides [
- uppPStr SLIT("\tdiv"),
- pprSize size,
- if uns then uppPStr SLIT("u\t") else uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (REM size uns reg1 ri reg2) =
- uppBesides [
- uppPStr SLIT("\trem"),
- pprSize size,
- if uns then uppPStr SLIT("u\t") else uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (NOT ri reg) =
- uppBesides [
- uppPStr SLIT("\tnot"),
- uppChar '\t',
- pprRI sty ri,
- uppComma,
- pprReg reg
- ]
-
-pprAlphaInstr sty (AND reg1 ri reg2) = pprRegRIReg sty SLIT("and") reg1 ri reg2
-pprAlphaInstr sty (ANDNOT reg1 ri reg2) = pprRegRIReg sty SLIT("andnot") reg1 ri reg2
-pprAlphaInstr sty (OR reg1 ri reg2) = pprRegRIReg sty SLIT("or") reg1 ri reg2
-pprAlphaInstr sty (ORNOT reg1 ri reg2) = pprRegRIReg sty SLIT("ornot") reg1 ri reg2
-pprAlphaInstr sty (XOR reg1 ri reg2) = pprRegRIReg sty SLIT("xor") reg1 ri reg2
-pprAlphaInstr sty (XORNOT reg1 ri reg2) = pprRegRIReg sty SLIT("xornot") reg1 ri reg2
-
-pprAlphaInstr sty (SLL reg1 ri reg2) = pprRegRIReg sty SLIT("sll") reg1 ri reg2
-pprAlphaInstr sty (SRL reg1 ri reg2) = pprRegRIReg sty SLIT("srl") reg1 ri reg2
-pprAlphaInstr sty (SRA reg1 ri reg2) = pprRegRIReg sty SLIT("sra") reg1 ri reg2
-
-pprAlphaInstr sty (ZAP reg1 ri reg2) = pprRegRIReg sty SLIT("zap") reg1 ri reg2
-pprAlphaInstr sty (ZAPNOT reg1 ri reg2) = pprRegRIReg sty SLIT("zapnot") reg1 ri reg2
-
-pprAlphaInstr sty (NOP) = uppPStr SLIT("\tnop")
-
-pprAlphaInstr sty (CMP cond reg1 ri reg2) =
- uppBesides [
- uppPStr SLIT("\tcmp"),
- pprCond cond,
- uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (FCLR reg) =
- uppBesides [
- uppPStr SLIT("\tfclr\t"),
- pprReg reg
- ]
-
-pprAlphaInstr sty (FABS reg1 reg2) =
- uppBesides [
- uppPStr SLIT("\tfabs\t"),
- pprReg reg1,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (FNEG size reg1 reg2) =
- uppBesides [
- uppPStr SLIT("\tneg"),
- pprSize size,
- uppChar '\t',
- pprReg reg1,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
-pprAlphaInstr sty (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
-pprAlphaInstr sty (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
-pprAlphaInstr sty (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
-
-pprAlphaInstr sty (CVTxy size1 size2 reg1 reg2) =
- uppBesides [
- uppPStr SLIT("\tcvt"),
- pprSize size1,
- case size2 of {Q -> uppPStr SLIT("qc"); _ -> pprSize size2},
- uppChar '\t',
- pprReg reg1,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (FCMP size cond reg1 reg2 reg3) =
- uppBesides [
- uppPStr SLIT("\tcmp"),
- pprSize size,
- pprCond cond,
- uppChar '\t',
- pprReg reg1,
- uppComma,
- pprReg reg2,
- uppComma,
- pprReg reg3
- ]
-
-pprAlphaInstr sty (FMOV reg1 reg2) =
- uppBesides [
- uppPStr SLIT("\tfmov\t"),
- pprReg reg1,
- uppComma,
- pprReg reg2
- ]
-
-pprAlphaInstr sty (BI ALWAYS reg lab) = pprAlphaInstr sty (BR lab)
-
-pprAlphaInstr sty (BI NEVER reg lab) = uppNil
-
-pprAlphaInstr sty (BI cond reg lab) =
- uppBesides [
- uppPStr SLIT("\tb"),
- pprCond cond,
- uppChar '\t',
- pprReg reg,
- uppComma,
- pprImm sty lab
- ]
-
-pprAlphaInstr sty (BF cond reg lab) =
- uppBesides [
- uppPStr SLIT("\tfb"),
- pprCond cond,
- uppChar '\t',
- pprReg reg,
- uppComma,
- pprImm sty lab
- ]
-
-pprAlphaInstr sty (BR lab) =
- uppBeside (uppPStr SLIT("\tbr\t")) (pprImm sty lab)
-
-pprAlphaInstr sty (JMP reg addr hint) =
- uppBesides [
- uppPStr SLIT("\tjmp\t"),
- pprReg reg,
- uppComma,
- pprAddr sty addr,
- uppComma,
- uppInt hint
- ]
-
-pprAlphaInstr sty (BSR imm n) =
- uppBeside (uppPStr SLIT("\tbsr\t")) (pprImm sty imm)
-
-pprAlphaInstr sty (JSR reg addr n) =
- uppBesides [
- uppPStr SLIT("\tjsr\t"),
- pprReg reg,
- uppComma,
- pprAddr sty addr
- ]
-
-pprAlphaInstr sty (LABEL clab) =
- uppBesides [
- if (externallyVisibleCLabel clab) then
- uppBesides [uppPStr SLIT("\t.globl\t"), pprLab, uppChar '\n']
- else
- uppNil,
- pprLab,
- uppChar ':'
- ]
- where pprLab = pprCLabel sty clab
-
-pprAlphaInstr sty (FUNBEGIN clab) =
- uppBesides [
- if (externallyVisibleCLabel clab) then
- uppBesides [uppPStr SLIT("\t.globl\t"), pprLab, uppChar '\n']
- else
- uppNil,
- uppPStr SLIT("\t.ent "),
- pprLab,
- uppChar '\n',
- pprLab,
- pp_ldgp,
- pprLab,
- pp_frame
- ]
- where
- pprLab = pprCLabel sty clab
-#ifdef USE_FAST_STRINGS
- pp_ldgp = uppPStr (_packCString (A# ":\n\tldgp $29,0($27)\n"#))
- pp_frame = uppPStr (_packCString (A# "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
-#else
- pp_ldgp = uppStr ":\n\tldgp $29,0($27)\n"
- pp_frame = uppStr "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"
-#endif
-
-pprAlphaInstr sty (FUNEND clab) =
- uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel sty clab)
-
-pprAlphaInstr sty (COMMENT s) = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s)
-
-pprAlphaInstr sty (SEGMENT TextSegment)
- = uppPStr SLIT("\t.text\n\t.align 3")
-
-pprAlphaInstr sty (SEGMENT DataSegment)
- = uppPStr SLIT("\t.data\n\t.align 3")
-
-pprAlphaInstr sty (ASCII False str) =
- uppBesides [
- uppStr "\t.asciz \"",
- uppStr str,
- uppChar '"'
- ]
-
-pprAlphaInstr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
- where
- asciify :: String -> Int -> Unpretty
- asciify [] _ = uppStr ("\\0\"")
- asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
- asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
- asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
- asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
- asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
- asciify (c:(cs@(d:_))) n | isDigit d =
- uppBeside (uppStr (charToC c)) (asciify cs 0)
- | otherwise =
- uppBeside (uppStr (charToC c)) (asciify cs (n-1))
-
-pprAlphaInstr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs)
- where pp_item x = case s of
- B -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
- BU -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
- W -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x)
- WU -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x)
- L -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x)
- Q -> uppBeside (uppPStr SLIT("\t.quad\t")) (pprImm sty x)
- FF -> uppBeside (uppPStr SLIT("\t.f_floating\t")) (pprImm sty x)
- DF -> uppBeside (uppPStr SLIT("\t.d_floating\t")) (pprImm sty x)
- GF -> uppBeside (uppPStr SLIT("\t.g_floating\t")) (pprImm sty x)
- SF -> uppBeside (uppPStr SLIT("\t.s_floating\t")) (pprImm sty x)
- TF -> uppBeside (uppPStr SLIT("\t.t_floating\t")) (pprImm sty x)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Schedule]{Register allocation information}
-%* *
-%************************************************************************
-
-\begin{code}
-
-data AlphaRegs = SRegs BitSet BitSet
-
-instance MachineRegisters AlphaRegs where
- mkMRegs xs = SRegs (mkBS ints) (mkBS floats')
- where
- (ints, floats) = partition (< 32) xs
- floats' = map (subtract 32) floats
-
- possibleMRegs FloatRep (SRegs _ floats) = [ x + 32 | x <- listBS floats]
- possibleMRegs DoubleRep (SRegs _ floats) = [ x + 32 | x <- listBS floats]
- possibleMRegs _ (SRegs ints _) = listBS ints
-
- useMReg (SRegs ints floats) n =
- if n _LT_ ILIT(32) then SRegs (ints `minusBS` singletonBS IBOX(n)) floats
- else SRegs ints (floats `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32))))
-
- useMRegs (SRegs ints floats) xs =
- SRegs (ints `minusBS` ints')
- (floats `minusBS` floats')
- where
- SRegs ints' floats' = mkMRegs xs
-
- freeMReg (SRegs ints floats) n =
- if n _LT_ ILIT(32) then SRegs (ints `unionBS` singletonBS IBOX(n)) floats
- else SRegs ints (floats `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32))))
-
- freeMRegs (SRegs ints floats) xs =
- SRegs (ints `unionBS` ints')
- (floats `unionBS` floats')
- where
- SRegs ints' floats' = mkMRegs xs
-
-instance MachineCode AlphaInstr where
- regUsage = alphaRegUsage
- regLiveness = alphaRegLiveness
- patchRegs = alphaPatchRegs
-
- -- We spill just below the frame pointer, leaving two words per spill location.
- spillReg dyn (MemoryReg i pk) = mkUnitList (ST (kindToSize pk) dyn (spRel i))
- loadReg (MemoryReg i pk) dyn = mkUnitList (LD (kindToSize pk) dyn (spRel i))
-
-spRel :: Int -> Addr
-spRel n = AddrRegImm sp (ImmInt (n * 8))
-
-kindToSize :: PrimRep -> Size
-kindToSize PtrRep = Q
-kindToSize CodePtrRep = Q
-kindToSize DataPtrRep = Q
-kindToSize RetRep = Q
-kindToSize CostCentreRep = Q
-kindToSize CharRep = BU
-kindToSize IntRep = Q
-kindToSize WordRep = Q
-kindToSize AddrRep = Q
-kindToSize FloatRep = TF
-kindToSize DoubleRep = TF
-kindToSize ArrayRep = Q
-kindToSize ByteArrayRep = Q
-kindToSize StablePtrRep = Q
-kindToSize MallocPtrRep = Q
-
-\end{code}
-
-@alphaRegUsage@ 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!)
-
-\begin{code}
-
-alphaRegUsage :: AlphaInstr -> RegUsage
-alphaRegUsage instr = case instr of
- LD B reg addr -> usage (regAddr addr, [reg, t9])
- LD BU reg addr -> usage (regAddr addr, [reg, t9])
- LD W reg addr -> usage (regAddr addr, [reg, t9])
- LD WU reg addr -> usage (regAddr addr, [reg, t9])
- LD sz reg addr -> usage (regAddr addr, [reg])
- LDA reg addr -> usage (regAddr addr, [reg])
- LDAH reg addr -> usage (regAddr addr, [reg])
- LDGP reg addr -> usage (regAddr addr, [reg])
- LDI sz reg imm -> usage ([], [reg])
- ST B reg addr -> usage (reg : regAddr addr, [t9, t10])
- ST W reg addr -> usage (reg : regAddr addr, [t9, t10])
- ST sz reg addr -> usage (reg : regAddr addr, [])
- CLR reg -> usage ([], [reg])
- ABS sz ri reg -> usage (regRI ri, [reg])
- NEG sz ov ri reg -> usage (regRI ri, [reg])
- ADD sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SUB sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
- MUL sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- DIV sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
- REM sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
- NOT ri reg -> usage (regRI ri, [reg])
- AND r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ANDNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- OR r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XOR r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SLL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRA r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ZAP r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ZAPNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- CMP co r1 ar r2 -> usage (r1 : regRI ar, [r2])
- FCLR reg -> usage ([], [reg])
- FABS r1 r2 -> usage ([r1], [r2])
- FNEG sz r1 r2 -> usage ([r1], [r2])
- FADD sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FDIV sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FMUL sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FSUB sz r1 r2 r3 -> usage ([r1, r2], [r3])
- CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2])
- FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3])
- FMOV r1 r2 -> usage ([r1], [r2])
-
-
- -- We assume that all local jumps will be BI/BF/BR. JMP must be out-of-line.
- BI cond reg lbl -> usage ([reg], [])
- BF cond reg lbl -> usage ([reg], [])
- JMP reg addr hint -> RU (mkUniqSet (filter interesting (regAddr addr))) freeSet
-
- BSR _ n -> RU (argSet n) callClobberedSet
- JSR reg addr n -> RU (argSet n) callClobberedSet
-
- _ -> noUsage
-
- where
- usage (src, dst) = RU (mkUniqSet (filter interesting src))
- (mkUniqSet (filter interesting dst))
-
- interesting (FixedReg _) = False
- interesting _ = True
-
- regAddr (AddrReg r1) = [r1]
- regAddr (AddrRegImm r1 _) = [r1]
- regAddr (AddrImm _) = []
-
- regRI (RIReg r) = [r]
- regRI _ = []
-
-freeRegs :: [Reg]
-freeRegs = freeMappedRegs [0..63]
-
-freeMappedRegs :: [Int] -> [Reg]
-
-freeMappedRegs nums
- = foldr free [] nums
- where
- free IBOX(i) acc
- = if _IS_TRUE_(freeReg i) then (MappedReg i) : acc else acc
-
-freeSet :: UniqSet Reg
-freeSet = mkUniqSet freeRegs
-
-noUsage :: RegUsage
-noUsage = RU emptyUniqSet emptyUniqSet
-
--- Color me CAF-like
-argSet :: Int -> UniqSet Reg
-argSet 0 = emptyUniqSet
-argSet 1 = mkUniqSet (freeMappedRegs [16, fReg 16])
-argSet 2 = mkUniqSet (freeMappedRegs [16, 17, fReg 16, fReg 17])
-argSet 3 = mkUniqSet (freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18])
-argSet 4 = mkUniqSet (freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19])
-argSet 5 = mkUniqSet (freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20])
-argSet 6 = mkUniqSet (freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21])
-
-callClobberedSet :: UniqSet Reg
-callClobberedSet = mkUniqSet callClobberedRegs
- where
- callClobberedRegs
- = freeMappedRegs
- [0, 1, 2, 3, 4, 5, 6, 7, 8,
- 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
- fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15,
- fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23,
- fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30]
-
-\end{code}
-
-@alphaRegLiveness@ takes future liveness information and modifies it according to
-the semantics of branches and labels. (An out-of-line branch clobbers the liveness
-passed back by the following instruction; a forward local branch passes back the
-liveness from the target label; a conditional branch merges the liveness from the
-target and the liveness from its successor; a label stashes away the current liveness
-in the future liveness environment).
-
-\begin{code}
-alphaRegLiveness :: AlphaInstr -> RegLiveness -> RegLiveness
-alphaRegLiveness instr info@(RL live future@(FL all env)) = case instr of
-
- -- 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 `unionUniqSets` live) future
- BF _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionUniqSets` live) future
- JMP _ _ _ -> RL emptyUniqSet future
- BSR _ _ -> RL live future
- JSR _ _ _ -> RL live future
- LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
- _ -> info
-
- where
- lookup lbl = case lookupFM env lbl of
- Just regs -> regs
- Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
- " in future?") emptyUniqSet
-
-\end{code}
-
-@alphaPatchRegs@ takes an instruction (possibly with
-MemoryReg/UnmappedReg registers) and changes all register references
-according to the supplied environment.
-
-\begin{code}
-
-alphaPatchRegs :: AlphaInstr -> (Reg -> Reg) -> AlphaInstr
-alphaPatchRegs instr env = case instr of
- LD sz reg addr -> LD sz (env reg) (fixAddr addr)
- LDA reg addr -> LDA (env reg) (fixAddr addr)
- LDAH reg addr -> LDAH (env reg) (fixAddr addr)
- LDGP reg addr -> LDGP (env reg) (fixAddr addr)
- LDI sz reg imm -> LDI sz (env reg) imm
- ST sz reg addr -> ST sz (env reg) (fixAddr addr)
- CLR reg -> CLR (env reg)
- ABS sz ar reg -> ABS sz (fixRI ar) (env reg)
- NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg)
- ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2)
- SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2)
- SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2)
- SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2)
- MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2)
- DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2)
- REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2)
- NOT ar reg -> NOT (fixRI ar) (env reg)
- AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2)
- ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2)
- OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2)
- ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2)
- XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2)
- XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2)
- SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
- SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
- SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
- ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2)
- ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2)
- CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2)
- FCLR reg -> FCLR (env reg)
- FABS r1 r2 -> FABS (env r1) (env r2)
- FNEG s r1 r2 -> FNEG s (env r1) (env r2)
- FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
- FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
- FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
- FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
- CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2)
- FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3)
- FMOV r1 r2 -> FMOV (env r1) (env r2)
- BI cond reg lbl -> BI cond (env reg) lbl
- BF cond reg lbl -> BF cond (env reg) lbl
- JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint
- JSR reg addr i -> JSR (env reg) (fixAddr addr) i
- _ -> instr
-
- where
- fixAddr (AddrReg r1) = AddrReg (env r1)
- fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
- fixAddr other = other
-
- fixRI (RIReg r) = RIReg (env r)
- fixRI other = other
-
-\end{code}
-
-If you value your sanity, do not venture below this line.
-
-\begin{code}
-
--- platform.h is generate and tells us what the target architecture is
-#include "../../includes/platform.h"
-#include "../../includes/MachRegs.h"
-#include "../../includes/alpha-dec-osf1.h"
-
--- Redefine the literals used for Alpha floating point register names
--- in the header files. Gag me with a spoon, eh?
-
-#define f0 32
-#define f1 33
-#define f2 34
-#define f3 35
-#define f4 36
-#define f5 37
-#define f6 38
-#define f7 39
-#define f8 40
-#define f9 41
-#define f10 42
-#define f11 43
-#define f12 44
-#define f13 45
-#define f14 46
-#define f15 47
-#define f16 48
-#define f17 49
-#define f18 50
-#define f19 51
-#define f20 52
-#define f21 53
-#define f22 54
-#define f23 55
-#define f24 56
-#define f25 57
-#define f26 58
-#define f27 59
-#define f28 60
-#define f29 61
-#define f30 62
-#define f31 63
-
-baseRegOffset :: MagicId -> Int
-baseRegOffset StkOReg = OFFSET_StkO
-baseRegOffset (VanillaReg _ ILIT(1)) = OFFSET_R1
-baseRegOffset (VanillaReg _ ILIT(2)) = OFFSET_R2
-baseRegOffset (VanillaReg _ ILIT(3)) = OFFSET_R3
-baseRegOffset (VanillaReg _ ILIT(4)) = OFFSET_R4
-baseRegOffset (VanillaReg _ ILIT(5)) = OFFSET_R5
-baseRegOffset (VanillaReg _ ILIT(6)) = OFFSET_R6
-baseRegOffset (VanillaReg _ ILIT(7)) = OFFSET_R7
-baseRegOffset (VanillaReg _ ILIT(8)) = OFFSET_R8
-baseRegOffset (FloatReg ILIT(1)) = OFFSET_Flt1
-baseRegOffset (FloatReg ILIT(2)) = OFFSET_Flt2
-baseRegOffset (FloatReg ILIT(3)) = OFFSET_Flt3
-baseRegOffset (FloatReg ILIT(4)) = OFFSET_Flt4
-baseRegOffset (DoubleReg ILIT(1)) = OFFSET_Dbl1
-baseRegOffset (DoubleReg ILIT(2)) = OFFSET_Dbl2
-baseRegOffset TagReg = OFFSET_Tag
-baseRegOffset RetReg = OFFSET_Ret
-baseRegOffset SpA = OFFSET_SpA
-baseRegOffset SuA = OFFSET_SuA
-baseRegOffset SpB = OFFSET_SpB
-baseRegOffset SuB = OFFSET_SuB
-baseRegOffset Hp = OFFSET_Hp
-baseRegOffset HpLim = OFFSET_HpLim
-baseRegOffset LivenessReg = OFFSET_Liveness
---baseRegOffset ActivityReg = OFFSET_Activity
-#ifdef DEBUG
-baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
-baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg"
-baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg"
-baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre"
-baseRegOffset VoidReg = panic "baseRegOffset:VoidReg"
-#endif
-
-callerSaves :: MagicId -> Bool
-#ifdef CALLER_SAVES_Base
-callerSaves BaseReg = True
-#endif
-#ifdef CALLER_SAVES_StkO
-callerSaves StkOReg = 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_FltReg1
-callerSaves (FloatReg ILIT(1)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg2
-callerSaves (FloatReg ILIT(2)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg3
-callerSaves (FloatReg ILIT(3)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg4
-callerSaves (FloatReg ILIT(4)) = True
-#endif
-#ifdef CALLER_SAVES_DblReg1
-callerSaves (DoubleReg ILIT(1)) = True
-#endif
-#ifdef CALLER_SAVES_DblReg2
-callerSaves (DoubleReg ILIT(2)) = True
-#endif
-#ifdef CALLER_SAVES_Tag
-callerSaves TagReg = True
-#endif
-#ifdef CALLER_SAVES_Ret
-callerSaves RetReg = True
-#endif
-#ifdef CALLER_SAVES_SpA
-callerSaves SpA = True
-#endif
-#ifdef CALLER_SAVES_SuA
-callerSaves SuA = True
-#endif
-#ifdef CALLER_SAVES_SpB
-callerSaves SpB = True
-#endif
-#ifdef CALLER_SAVES_SuB
-callerSaves SuB = True
-#endif
-#ifdef CALLER_SAVES_Hp
-callerSaves Hp = True
-#endif
-#ifdef CALLER_SAVES_HpLim
-callerSaves HpLim = True
-#endif
-#ifdef CALLER_SAVES_Liveness
-callerSaves LivenessReg = True
-#endif
-#ifdef CALLER_SAVES_Activity
---callerSaves ActivityReg = True
-#endif
-#ifdef CALLER_SAVES_StdUpdRetVec
-callerSaves StdUpdRetVecReg = True
-#endif
-#ifdef CALLER_SAVES_StkStub
-callerSaves StkStubReg = True
-#endif
-callerSaves _ = False
-
-stgRegMap :: MagicId -> Maybe Reg
-#ifdef REG_Base
-stgRegMap BaseReg = Just (FixedReg ILIT(REG_Base))
-#endif
-#ifdef REG_StkO
-stgRegMap StkOReg = Just (FixedReg ILIT(REG_StkOReg))
-#endif
-#ifdef REG_R1
-stgRegMap (VanillaReg _ ILIT(1)) = Just (FixedReg ILIT(REG_R1))
-#endif
-#ifdef REG_R2
-stgRegMap (VanillaReg _ ILIT(2)) = Just (FixedReg ILIT(REG_R2))
-#endif
-#ifdef REG_R3
-stgRegMap (VanillaReg _ ILIT(3)) = Just (FixedReg ILIT(REG_R3))
-#endif
-#ifdef REG_R4
-stgRegMap (VanillaReg _ ILIT(4)) = Just (FixedReg ILIT(REG_R4))
-#endif
-#ifdef REG_R5
-stgRegMap (VanillaReg _ ILIT(5)) = Just (FixedReg ILIT(REG_R5))
-#endif
-#ifdef REG_R6
-stgRegMap (VanillaReg _ ILIT(6)) = Just (FixedReg ILIT(REG_R6))
-#endif
-#ifdef REG_R7
-stgRegMap (VanillaReg _ ILIT(7)) = Just (FixedReg ILIT(REG_R7))
-#endif
-#ifdef REG_R8
-stgRegMap (VanillaReg _ ILIT(8)) = Just (FixedReg ILIT(REG_R8))
-#endif
-#ifdef REG_Flt1
-stgRegMap (FloatReg ILIT(1)) = Just (FixedReg ILIT(REG_Flt1))
-#endif
-#ifdef REG_Flt2
-stgRegMap (FloatReg ILIT(2)) = Just (FixedReg ILIT(REG_Flt2))
-#endif
-#ifdef REG_Flt3
-stgRegMap (FloatReg ILIT(3)) = Just (FixedReg ILIT(REG_Flt3))
-#endif
-#ifdef REG_Flt4
-stgRegMap (FloatReg ILIT(4)) = Just (FixedReg ILIT(REG_Flt4))
-#endif
-#ifdef REG_Dbl1
-stgRegMap (DoubleReg ILIT(1)) = Just (FixedReg ILIT(REG_Dbl1))
-#endif
-#ifdef REG_Dbl2
-stgRegMap (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_Dbl2))
-#endif
-#ifdef REG_Tag
-stgRegMap TagReg = Just (FixedReg ILIT(REG_TagReg))
-#endif
-#ifdef REG_Ret
-stgRegMap RetReg = Just (FixedReg ILIT(REG_Ret))
-#endif
-#ifdef REG_SpA
-stgRegMap SpA = Just (FixedReg ILIT(REG_SpA))
-#endif
-#ifdef REG_SuA
-stgRegMap SuA = Just (FixedReg ILIT(REG_SuA))
-#endif
-#ifdef REG_SpB
-stgRegMap SpB = Just (FixedReg ILIT(REG_SpB))
-#endif
-#ifdef REG_SuB
-stgRegMap SuB = Just (FixedReg ILIT(REG_SuB))
-#endif
-#ifdef REG_Hp
-stgRegMap Hp = Just (FixedReg ILIT(REG_Hp))
-#endif
-#ifdef REG_HpLim
-stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim))
-#endif
-#ifdef REG_Liveness
-stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness))
-#endif
-#ifdef REG_Activity
---stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity))
-#endif
-#ifdef REG_StdUpdRetVec
-stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec))
-#endif
-#ifdef REG_StkStub
-stgRegMap StkStubReg = Just (FixedReg ILIT(REG_StkStub))
-#endif
-stgRegMap _ = Nothing
-
-\end{code}
-
-Here is the list of registers we can use in register allocation.
-
-With a per-instruction clobber list, we might be able to get some of
-these back, but it's probably not worth the hassle.
-
-\begin{code}
-
-freeReg :: FAST_INT -> FAST_BOOL
-
-freeReg ILIT(26) = _FALSE_ -- return address (ra)
-freeReg ILIT(28) = _FALSE_ -- reserved for the assembler (at)
-freeReg ILIT(29) = _FALSE_ -- global pointer (gp)
-freeReg ILIT(30) = _FALSE_ -- stack pointer (sp)
-freeReg ILIT(31) = _FALSE_ -- always zero (zero)
-freeReg ILIT(63) = _FALSE_ -- always zero (f31)
-
-#ifdef REG_Base
-freeReg ILIT(REG_Base) = _FALSE_
-#endif
-#ifdef REG_StkO
-freeReg ILIT(REG_StkO) = _FALSE_
-#endif
-#ifdef REG_R1
-freeReg ILIT(REG_R1) = _FALSE_
-#endif
-#ifdef REG_R2
-freeReg ILIT(REG_R2) = _FALSE_
-#endif
-#ifdef REG_R3
-freeReg ILIT(REG_R3) = _FALSE_
-#endif
-#ifdef REG_R4
-freeReg ILIT(REG_R4) = _FALSE_
-#endif
-#ifdef REG_R5
-freeReg ILIT(REG_R5) = _FALSE_
-#endif
-#ifdef REG_R6
-freeReg ILIT(REG_R6) = _FALSE_
-#endif
-#ifdef REG_R7
-freeReg ILIT(REG_R7) = _FALSE_
-#endif
-#ifdef REG_R8
-freeReg ILIT(REG_R8) = _FALSE_
-#endif
-#ifdef REG_Flt1
-freeReg ILIT(REG_Flt1) = _FALSE_
-#endif
-#ifdef REG_Flt2
-freeReg ILIT(REG_Flt2) = _FALSE_
-#endif
-#ifdef REG_Flt3
-freeReg ILIT(REG_Flt3) = _FALSE_
-#endif
-#ifdef REG_Flt4
-freeReg ILIT(REG_Flt4) = _FALSE_
-#endif
-#ifdef REG_Dbl1
-freeReg ILIT(REG_Dbl1) = _FALSE_
-#endif
-#ifdef REG_Dbl2
-freeReg ILIT(REG_Dbl2) = _FALSE_
-#endif
-#ifdef REG_Tag
-freeReg ILIT(REG_Tag) = _FALSE_
-#endif
-#ifdef REG_Ret
-freeReg ILIT(REG_Ret) = _FALSE_
-#endif
-#ifdef REG_SpA
-freeReg ILIT(REG_SpA) = _FALSE_
-#endif
-#ifdef REG_SuA
-freeReg ILIT(REG_SuA) = _FALSE_
-#endif
-#ifdef REG_SpB
-freeReg ILIT(REG_SpB) = _FALSE_
-#endif
-#ifdef REG_SuB
-freeReg ILIT(REG_SuB) = _FALSE_
-#endif
-#ifdef REG_Hp
-freeReg ILIT(REG_Hp) = _FALSE_
-#endif
-#ifdef REG_HpLim
-freeReg ILIT(REG_HpLim) = _FALSE_
-#endif
-#ifdef REG_Liveness
-freeReg ILIT(REG_Liveness) = _FALSE_
-#endif
-#ifdef REG_Activity
---freeReg ILIT(REG_Activity) = _FALSE_
-#endif
-#ifdef REG_StdUpdRetVec
-freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
-#endif
-#ifdef REG_StkStub
-freeReg ILIT(REG_StkStub) = _FALSE_
-#endif
-freeReg _ = _TRUE_
-
-reservedRegs :: [Int]
-reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2, NCG_Reserved_F1, NCG_Reserved_F2]
-
-\end{code}
diff --git a/ghc/compiler/nativeGen/AlphaDesc.lhs b/ghc/compiler/nativeGen/AlphaDesc.lhs
deleted file mode 100644
index 43852f2082fe06fed350d6c319d7426f65c22fa0..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/AlphaDesc.lhs
+++ /dev/null
@@ -1,208 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[AlphaDesc]{The Alpha Machine Description}
-
-\begin{code}
-#include "HsVersions.h"
-
-module AlphaDesc (
- mkAlpha
-
- -- and assorted nonsense referenced by the class methods
- ) where
-
-import AbsCSyn
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..),
- RegUsage(..), RegLiveness(..), FutureLive(..)
- )
-import CLabel ( CLabel )
-import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet,
- switchIsOn, SwitchResult(..)
- )
-import HeapOffs ( hpRelToInt )
-import MachDesc
-import Maybes ( Maybe(..) )
-import OrdList
-import Outputable
-import PrimRep ( PrimRep(..) )
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import AlphaCode
-import AlphaGen ( alphaCodeGen )
-import Stix
-import StixMacro
-import StixPrim
-import UniqSupply
-import Util
-
-\end{code}
-
-Header sizes depend only on command-line options, not on the target
-architecture. (I think.)
-
-\begin{code}
-
-fhs :: (GlobalSwitch -> SwitchResult) -> Int
-
-fhs switches = 1 + profFHS + ageFHS
- where
- profFHS = if switchIsOn switches SccProfilingOn then 1 else 0
- ageFHS = if switchIsOn switches SccProfilingOn then 1 else 0
-
-vhs :: (GlobalSwitch -> SwitchResult) -> SMRep -> Int
-
-vhs switches sm = case sm of
- StaticRep _ _ -> 0
- SpecialisedRep _ _ _ _ -> 0
- GenericRep _ _ _ -> 0
- BigTupleRep _ -> 1
- MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -}
- DataRep _ -> 1
- DynamicRep -> 2
- BlackHoleRep -> 0
- PhantomRep -> panic "vhs:phantom"
-
-\end{code}
-
-Here we map STG registers onto appropriate Stix Trees. First, we
-handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@.
-The rest are either in real machine registers or stored as offsets
-from BaseReg.
-
-\begin{code}
-
-alphaReg :: (GlobalSwitch -> SwitchResult) -> MagicId -> RegLoc
-
-alphaReg switches x =
- case stgRegMap x of
- Just reg -> Save nonReg
- Nothing -> Always nonReg
- where nonReg = case x of
- StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
- StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
- BaseReg -> sStLitLbl SLIT("MainRegTable")
- Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
- HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+8"))
- TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*8)])
- where
- r2 = VanillaReg PtrRep ILIT(2)
- infoptr = case alphaReg switches r2 of
- Always tree -> tree
- Save _ -> StReg (StixMagicId r2)
- _ -> StInd (kindFromMagicId x)
- (StPrim IntAddOp [baseLoc, StInt (toInteger (offset*8))])
- baseLoc = case stgRegMap BaseReg of
- Just _ -> StReg (StixMagicId BaseReg)
- Nothing -> sStLitLbl SLIT("MainRegTable")
- offset = baseRegOffset x
-
-\end{code}
-
-Sizes in bytes.
-
-\begin{code}
-
-size pk = case kindToSize pk of
- {B -> 1; BU -> 1; W -> 2; WU -> 2; L -> 4; FF -> 4; SF -> 4; _ -> 8}
-
-\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.
-
-\begin{code}
-
-vsaves switches vols =
- map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
- where
- save x = StAssign (kindFromMagicId x) loc reg
- where reg = StReg (StixMagicId x)
- loc = case alphaReg switches x of
- Save loc -> loc
- Always loc -> panic "vsaves"
-
-vrests switches vols =
- map restore ((filter callerSaves)
- ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,{-ActivityReg,-}StkStubReg,StdUpdRetVecReg] ++ vols))
- where
- restore x = StAssign (kindFromMagicId x) reg loc
- where reg = StReg (StixMagicId x)
- loc = case alphaReg switches x of
- Save loc -> loc
- Always loc -> panic "vrests"
-
-\end{code}
-
-Static closure sizes.
-
-\begin{code}
-
-charLikeSize, intLikeSize :: Target -> Int
-
-charLikeSize target =
- size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
- where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
-
-intLikeSize target =
- size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
- where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
-
-mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
-
-mhs switches = StInt (toInteger words)
- where
- words = fhs switches + vhs switches (MuTupleRep 0)
-
-dhs switches = StInt (toInteger words)
- where
- words = fhs switches + vhs switches (DataRep 0)
-
-\end{code}
-
-Setting up a alpha target.
-
-\begin{code}
-
-mkAlpha :: (GlobalSwitch -> SwitchResult)
- -> (Target,
- (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
- Bool, -- underscore
- (String -> String)) -- fmtAsmLbl
-
-mkAlpha switches =
- let
- fhs' = fhs switches
- vhs' = vhs switches
- alphaReg' = alphaReg switches
- vsaves' = vsaves switches
- vrests' = vrests switches
- hprel = hpRelToInt target
- as = amodeCode target
- as' = amodeCode' target
- csz = charLikeSize target
- isz = intLikeSize target
- mhs' = mhs switches
- dhs' = dhs switches
- ps = genPrimCode target
- mc = genMacroCode target
- hc = doHeapCheck
- target = mkTarget {-switches-} fhs' vhs' alphaReg' {-id-} size
- hprel as as'
- (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
- {-alphaCodeGen False mungeLabel-}
- in
- (target, alphaCodeGen, False, mungeLabel)
-\end{code}
-
-The alpha assembler likes temporary labels to look like \tr{$L123}
-instead of \tr{L123}. (Don't toss the \tr{L}, because then \tr{Lf28}
-turns into \tr{$f28}.)
-\begin{code}
-mungeLabel :: String -> String
-mungeLabel xs = '$' : xs
-\end{code}
diff --git a/ghc/compiler/nativeGen/AlphaGen.lhs b/ghc/compiler/nativeGen/AlphaGen.lhs
deleted file mode 100644
index 2d5071acf06b4db9efce8b9fbc37465647e25945..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/AlphaGen.lhs
+++ /dev/null
@@ -1,1107 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-
-\begin{code}
-#include "HsVersions.h"
-
-module AlphaGen (
- alphaCodeGen,
-
- -- and, for self-sufficiency
- PprStyle, StixTree, CSeq
- ) where
-
-IMPORT_Trace
-
-import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AsmRegAlloc ( runRegAllocate, extractMappedRegNos, mkReg,
- Reg(..), RegLiveness(..), RegUsage(..), FutureLive(..),
- MachineRegisters(..), MachineCode(..)
- )
-import CLabel ( CLabel, isAsmTemp )
-import AlphaCode {- everything -}
-import MachDesc
-import Maybes ( maybeToBool, Maybe(..) )
-import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
-import Outputable
-import AlphaDesc
-import Stix
-import UniqSupply
-import Pretty
-import Unpretty
-import Util
-
-type CodeBlock a = (OrdList a -> OrdList a)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AlphaCodeGen]{Generating Alpha Code}
-%* *
-%************************************************************************
-
-This is the top-level code-generation function for the Alpha.
-
-\begin{code}
-
-alphaCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
-alphaCodeGen sty trees =
- mapUs genAlphaCode trees `thenUs` \ dynamicCodes ->
- let
- staticCodes = scheduleAlphaCode dynamicCodes
- pretty = printLabeledCodes sty staticCodes
- in
- returnUs pretty
-
-\end{code}
-
-This bit does the code scheduling. The scheduler must also deal with
-register allocation of temporaries. Much parallelism can be exposed via
-the OrdList, but more might occur, so further analysis might be needed.
-
-\begin{code}
-
-scheduleAlphaCode :: [AlphaCode] -> [AlphaInstr]
-scheduleAlphaCode = concat . map (runRegAllocate freeAlphaRegs reservedRegs)
- where
- freeAlphaRegs :: AlphaRegs
- freeAlphaRegs = mkMRegs (extractMappedRegNos freeRegs)
-
-\end{code}
-
-Registers 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 Reg PrimRep (CodeBlock AlphaInstr)
- | Any PrimRep (Reg -> (CodeBlock AlphaInstr))
-
-registerCode :: Register -> Reg -> CodeBlock AlphaInstr
-registerCode (Fixed _ _ code) reg = code
-registerCode (Any _ code) reg = code reg
-
-registerName :: Register -> Reg -> Reg
-registerName (Fixed reg _ _) _ = reg
-registerName (Any _ _) reg = reg
-
-registerKind :: Register -> PrimRep
-registerKind (Fixed _ pk _) = pk
-registerKind (Any pk _) = pk
-
-isFixed :: Register -> Bool
-isFixed (Fixed _ _ _) = True
-isFixed (Any _ _) = False
-
-\end{code}
-
-Memory addressing modes passed up the tree.
-
-\begin{code}
-
-data Amode = Amode Addr (CodeBlock AlphaInstr)
-
-amodeAddr (Amode addr _) = addr
-amodeCode (Amode _ code) = code
-
-\end{code}
-
-General things for putting together code sequences.
-
-\begin{code}
-
-asmVoid :: OrdList AlphaInstr
-asmVoid = mkEmptyList
-
-asmInstr :: AlphaInstr -> AlphaCode
-asmInstr i = mkUnitList i
-
-asmSeq :: [AlphaInstr] -> AlphaCode
-asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
-
-asmParThen :: [AlphaCode] -> CodeBlock AlphaInstr
-asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-
-returnInstr :: AlphaInstr -> UniqSM (CodeBlock AlphaInstr)
-returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-
-returnInstrs :: [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr)
-returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-
-returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr)
-returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
-
-mkSeqInstr :: AlphaInstr -> (CodeBlock AlphaInstr)
-mkSeqInstr instr code = mkSeqList (asmInstr instr) code
-
-mkSeqInstrs :: [AlphaInstr] -> (CodeBlock AlphaInstr)
-mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
-
-\end{code}
-
-Top level alpha code generator for a chunk of stix code.
-
-\begin{code}
-
-genAlphaCode :: [StixTree] -> UniqSM (AlphaCode)
-
-genAlphaCode trees =
- mapUs getCode trees `thenUs` \ blocks ->
- returnUs (foldr (.) id blocks asmVoid)
-
-\end{code}
-
-Code extractor for an entire stix tree---stix statement level.
-
-\begin{code}
-
-getCode
- :: StixTree -- a stix statement
- -> UniqSM (CodeBlock AlphaInstr)
-
-getCode (StSegment seg) = returnInstr (SEGMENT seg)
-
-getCode (StAssign pk dst src)
- | isFloatingRep pk = assignFltCode pk dst src
- | otherwise = assignIntCode pk dst src
-
-getCode (StLabel lab) = returnInstr (LABEL lab)
-
-getCode (StFunBegin lab) = returnInstr (FUNBEGIN lab)
-
-getCode (StFunEnd lab) = returnInstr (FUNEND lab)
-
-getCode (StJump arg) = genJump arg
-
--- 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
-getCode (StFallThrough lbl) = returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
-
-getCode (StCondJump lbl arg) = genCondJump lbl arg
-
-getCode (StData kind args) =
- mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
- returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
- (foldr1 (.) codes xs))
- where
- getData :: StixTree -> UniqSM (CodeBlock AlphaInstr, Imm)
- getData (StInt i) = returnUs (id, ImmInteger i)
- getData (StDouble d) = returnUs (id, ImmLab (prettyToUn (ppRational d)))
- getData (StLitLbl s) = returnUs (id, ImmLab s)
- getData (StLitLit s) = returnUs (id, strImmLab (cvtLitLit (_UNPK_ s)))
- getData (StString s) =
- getUniqLabelNCG `thenUs` \ lbl ->
- returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
- getData (StCLbl l) = returnUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
-
-getCode (StComment s) = returnInstr (COMMENT s)
-
-\end{code}
-
-Generate code to get a subtree into a register.
-
-\begin{code}
-
-getReg :: StixTree -> UniqSM Register
-
-getReg (StReg (StixMagicId stgreg)) =
- case stgRegMap stgreg of
- Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
- -- cannae be Nothing
-
-getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
-
-getReg (StDouble d) =
- getUniqLabelNCG `thenUs` \ lbl ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA TF [ImmLab (prettyToUn (ppRational d))],
- SEGMENT TextSegment,
- LDA tmp (AddrImm (ImmCLbl lbl)),
- LD TF dst (AddrReg tmp)]
- in
- returnUs (Any DoubleRep code)
-
-getReg (StString s) =
- getUniqLabelNCG `thenUs` \ lbl ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII True (_UNPK_ s),
- SEGMENT TextSegment,
- LDA dst (AddrImm (ImmCLbl lbl))]
- in
- returnUs (Any PtrRep code)
-
-getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
- getUniqLabelNCG `thenUs` \ lbl ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII False (init xs),
- SEGMENT TextSegment,
- LDA dst (AddrImm (ImmCLbl lbl))]
- in
- returnUs (Any PtrRep code)
- where
- xs = _UNPK_ (_TAIL_ s)
-
-getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
-
-getReg (StCall fn kind args) =
- genCCall fn kind args `thenUs` \ call ->
- returnUs (Fixed reg kind call)
- where
- reg = if isFloatingRep kind then f0 else v0
-
-getReg (StPrim primop args) =
- case primop of
-
- CharGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
- CharGeOp -> case args of [x,y] -> trivialCode (CMP LE) [y,x]
- CharEqOp -> trivialCode (CMP EQ) args
- CharNeOp -> intNECode args
- CharLtOp -> trivialCode (CMP LT) args
- CharLeOp -> trivialCode (CMP LE) args
-
- IntAddOp -> trivialCode (ADD Q False) args
-
- IntSubOp -> trivialCode (SUB Q False) args
- IntMulOp -> trivialCode (MUL Q False) args
- IntQuotOp -> trivialCode (DIV Q False) args
- IntRemOp -> trivialCode (REM Q False) args
- IntNegOp -> trivialUCode (NEG Q False) args
- IntAbsOp -> trivialUCode (ABS Q) args
-
- AndOp -> trivialCode AND args
- OrOp -> trivialCode OR args
- NotOp -> trivialUCode NOT args
- SllOp -> trivialCode SLL args
- SraOp -> trivialCode SRA args
- SrlOp -> trivialCode SRL args
- ISllOp -> panic "AlphaGen:isll"
- ISraOp -> panic "AlphaGen:isra"
- ISrlOp -> panic "AlphaGen:isrl"
-
- IntGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
- IntGeOp -> case args of [x,y] -> trivialCode (CMP LE) [y,x]
- IntEqOp -> trivialCode (CMP EQ) args
- IntNeOp -> intNECode args
- IntLtOp -> trivialCode (CMP LT) args
- IntLeOp -> trivialCode (CMP LE) args
-
- WordGtOp -> case args of [x,y] -> trivialCode (CMP ULT) [y,x]
- WordGeOp -> case args of [x,y] -> trivialCode (CMP ULE) [y,x]
- WordEqOp -> trivialCode (CMP EQ) args
- WordNeOp -> intNECode args
- WordLtOp -> trivialCode (CMP ULT) args
- WordLeOp -> trivialCode (CMP ULE) args
-
- AddrGtOp -> case args of [x,y] -> trivialCode (CMP ULT) [y,x]
- AddrGeOp -> case args of [x,y] -> trivialCode (CMP ULE) [y,x]
- AddrEqOp -> trivialCode (CMP EQ) args
- AddrNeOp -> intNECode args
- AddrLtOp -> trivialCode (CMP ULT) args
- AddrLeOp -> trivialCode (CMP ULE) args
-
- FloatAddOp -> trivialFCode (FADD TF) args
- FloatSubOp -> trivialFCode (FSUB TF) args
- FloatMulOp -> trivialFCode (FMUL TF) args
- FloatDivOp -> trivialFCode (FDIV TF) args
- FloatNegOp -> trivialUFCode (FNEG TF) args
-
- FloatGtOp -> cmpFCode (FCMP TF LE) EQ args
- FloatGeOp -> cmpFCode (FCMP TF LT) EQ args
- FloatEqOp -> cmpFCode (FCMP TF EQ) NE args
- FloatNeOp -> cmpFCode (FCMP TF EQ) EQ args
- FloatLtOp -> cmpFCode (FCMP TF LT) NE args
- FloatLeOp -> cmpFCode (FCMP TF LE) NE args
-
- FloatExpOp -> call SLIT("exp") DoubleRep
- FloatLogOp -> call SLIT("log") DoubleRep
- FloatSqrtOp -> call SLIT("sqrt") DoubleRep
-
- FloatSinOp -> call SLIT("sin") DoubleRep
- FloatCosOp -> call SLIT("cos") DoubleRep
- FloatTanOp -> call SLIT("tan") DoubleRep
-
- FloatAsinOp -> call SLIT("asin") DoubleRep
- FloatAcosOp -> call SLIT("acos") DoubleRep
- FloatAtanOp -> call SLIT("atan") DoubleRep
-
- FloatSinhOp -> call SLIT("sinh") DoubleRep
- FloatCoshOp -> call SLIT("cosh") DoubleRep
- FloatTanhOp -> call SLIT("tanh") DoubleRep
-
- FloatPowerOp -> call SLIT("pow") DoubleRep
-
- DoubleAddOp -> trivialFCode (FADD TF) args
- DoubleSubOp -> trivialFCode (FSUB TF) args
- DoubleMulOp -> trivialFCode (FMUL TF) args
- DoubleDivOp -> trivialFCode (FDIV TF) args
- DoubleNegOp -> trivialUFCode (FNEG TF) args
-
- DoubleGtOp -> cmpFCode (FCMP TF LE) EQ args
- DoubleGeOp -> cmpFCode (FCMP TF LT) EQ args
- DoubleEqOp -> cmpFCode (FCMP TF EQ) NE args
- DoubleNeOp -> cmpFCode (FCMP TF EQ) EQ args
- DoubleLtOp -> cmpFCode (FCMP TF LT) NE args
- DoubleLeOp -> cmpFCode (FCMP TF LE) NE args
-
- DoubleExpOp -> call SLIT("exp") DoubleRep
- DoubleLogOp -> call SLIT("log") DoubleRep
- DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
-
- DoubleSinOp -> call SLIT("sin") DoubleRep
- DoubleCosOp -> call SLIT("cos") DoubleRep
- DoubleTanOp -> call SLIT("tan") DoubleRep
-
- DoubleAsinOp -> call SLIT("asin") DoubleRep
- DoubleAcosOp -> call SLIT("acos") DoubleRep
- DoubleAtanOp -> call SLIT("atan") DoubleRep
-
- DoubleSinhOp -> call SLIT("sinh") DoubleRep
- DoubleCoshOp -> call SLIT("cosh") DoubleRep
- DoubleTanhOp -> call SLIT("tanh") DoubleRep
-
- DoublePowerOp -> call SLIT("pow") DoubleRep
-
- OrdOp -> coerceIntCode IntRep args
- ChrOp -> chrCode args
-
- Float2IntOp -> coerceFP2Int args
- Int2FloatOp -> coerceInt2FP args
- Double2IntOp -> coerceFP2Int args
- Int2DoubleOp -> coerceInt2FP args
-
- Double2FloatOp -> coerceFltCode args
- Float2DoubleOp -> coerceFltCode args
-
- where
- call fn pk = getReg (StCall fn pk args)
-
-getReg (StInd pk mem) =
- getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = kindToSize pk
- code__2 dst = code . mkSeqInstr (LD size dst src)
- in
- returnUs (Any pk code__2)
-
-getReg (StInt i)
- | is8Bits i =
- let
- code dst = mkSeqInstr (OR zero (RIImm src) dst)
- in
- returnUs (Any IntRep code)
- | otherwise =
- let
- code dst = mkSeqInstr (LDI Q dst src)
- in
- returnUs (Any IntRep code)
- where
- src = ImmInt (fromInteger i)
-
-getReg leaf
- | maybeToBool imm =
- let
- code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
- in
- returnUs (Any PtrRep code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-\end{code}
-
-Now, given a tree (the argument to an StInd) that references memory,
-produce a suitable addressing mode.
-
-\begin{code}
-
-getAmode :: StixTree -> UniqSM Amode
-
-getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
-
-getAmode (StPrim IntSubOp [x, StInt i]) =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg x `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnUs (Amode (AddrRegImm reg off) code)
-
-
-getAmode (StPrim IntAddOp [x, StInt i]) =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg x `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnUs (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
- | maybeToBool imm =
- returnUs (Amode (AddrImm imm__2) id)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg other `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- in
- returnUs (Amode (AddrReg reg) code)
-
-\end{code}
-
-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, @getCallArg@
-can be applied to all of a call's arguments using @mapAccumL@.
-
-\begin{code}
-
-getCallArg
- :: ([(Reg,Reg)],Int) -- Argument registers and stack offset (accumulator)
- -> StixTree -- Current argument
- -> UniqSM (([(Reg,Reg)],Int), CodeBlock AlphaInstr) -- Updated accumulator and code
-
--- We have to use up all of our argument registers first.
-
-getCallArg ((iDst,fDst):dsts, offset) arg =
- getReg arg `thenUs` \ register ->
- let
- reg = if isFloatingRep pk then fDst else iDst
- code = registerCode register reg
- src = registerName register reg
- pk = registerKind register
- in
- returnUs (
- 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
-
-getCallArg ([], offset) arg =
- getReg arg `thenUs` \ register ->
- getNewRegNCG (registerKind register)
- `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerKind register
- sz = kindToSize pk
- in
- returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
-
-\end{code}
-
-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}
-
-assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr)
-
-assignIntCode pk (StInd _ dst) src =
- getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getReg src `thenUs` \ register ->
- let
- code1 = amodeCode amode asmVoid
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp asmVoid
- src__2 = registerName register tmp
- sz = kindToSize pk
- code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- returnUs code__2
-
-assignIntCode pk dst src =
- getReg dst `thenUs` \ register1 ->
- getReg src `thenUs` \ register2 ->
- let
- dst__2 = registerName register1 zero
- 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
- returnUs code__2
-
-assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr)
-
-assignFltCode pk (StInd _ dst) src =
- getNewRegNCG pk `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getReg src `thenUs` \ register ->
- let
- code1 = amodeCode amode asmVoid
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp asmVoid
- src__2 = registerName register tmp
- sz = kindToSize pk
- code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- returnUs code__2
-
-assignFltCode pk dst src =
- getReg dst `thenUs` \ register1 ->
- getReg src `thenUs` \ register2 ->
- let
- dst__2 = registerName register1 zero
- 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
- returnUs code__2
-
-\end{code}
-
-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, so we use jmp.
-
-\begin{code}
-
-genJump
- :: StixTree -- the branch target
- -> UniqSM (CodeBlock AlphaInstr)
-
-genJump (StCLbl lbl)
- | isAsmTemp lbl = returnInstr (BR target)
- | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
- where
- target = ImmCLbl lbl
-
-genJump tree =
- getReg tree `thenUs` \ register ->
- getNewRegNCG PtrRep `thenUs` \ 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 zero (AddrReg pv) 0]
- else
- returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
-
-\end{code}
-
-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. For comparisons with 0, we're laughing, because
-we can just do the desired conditional branch.
-
-\begin{code}
-
-genCondJump
- :: CLabel -- the branch target
- -> StixTree -- the condition on which to branch
- -> UniqSM (CodeBlock AlphaInstr)
-
-genCondJump lbl (StPrim op [x, StInt 0]) =
- getReg x `thenUs` \ register ->
- getNewRegNCG (registerKind register)
- `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerKind register
- target = ImmCLbl lbl
- in
- returnSeq code [BI (cmpOp op) value target]
- where
- cmpOp CharGtOp = GT
- cmpOp CharGeOp = GE
- cmpOp CharEqOp = EQ
- cmpOp CharNeOp = NE
- cmpOp CharLtOp = LT
- cmpOp CharLeOp = LE
- cmpOp IntGtOp = GT
- cmpOp IntGeOp = GE
- cmpOp IntEqOp = EQ
- cmpOp IntNeOp = NE
- cmpOp IntLtOp = LT
- cmpOp IntLeOp = LE
- cmpOp WordGtOp = NE
- cmpOp WordGeOp = ALWAYS
- cmpOp WordEqOp = EQ
- cmpOp WordNeOp = NE
- cmpOp WordLtOp = NEVER
- cmpOp WordLeOp = EQ
- cmpOp AddrGtOp = NE
- cmpOp AddrGeOp = ALWAYS
- cmpOp AddrEqOp = EQ
- cmpOp AddrNeOp = NE
- cmpOp AddrLtOp = NEVER
- cmpOp AddrLeOp = EQ
-
-genCondJump lbl (StPrim op [x, StDouble 0.0]) =
- getReg x `thenUs` \ register ->
- getNewRegNCG (registerKind register)
- `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerKind register
- target = ImmCLbl lbl
- in
- returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
- where
- cmpOp FloatGtOp = GT
- cmpOp FloatGeOp = GE
- cmpOp FloatEqOp = EQ
- cmpOp FloatNeOp = NE
- cmpOp FloatLtOp = LT
- cmpOp FloatLeOp = LE
- cmpOp DoubleGtOp = GT
- cmpOp DoubleGeOp = GE
- cmpOp DoubleEqOp = EQ
- cmpOp DoubleNeOp = NE
- cmpOp DoubleLtOp = LT
- cmpOp DoubleLeOp = LE
-
-genCondJump lbl (StPrim op args)
- | fltCmpOp op =
- trivialFCode instr args `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- returnUs (code . mkSeqInstr (BF cond result target))
- where
- 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, EQ)
- FloatGeOp -> (FCMP TF LT, EQ)
- FloatEqOp -> (FCMP TF EQ, NE)
- FloatNeOp -> (FCMP TF EQ, EQ)
- FloatLtOp -> (FCMP TF LT, NE)
- FloatLeOp -> (FCMP TF LE, NE)
- DoubleGtOp -> (FCMP TF LE, EQ)
- DoubleGeOp -> (FCMP TF LT, EQ)
- DoubleEqOp -> (FCMP TF EQ, NE)
- DoubleNeOp -> (FCMP TF EQ, EQ)
- DoubleLtOp -> (FCMP TF LT, NE)
- DoubleLeOp -> (FCMP TF LE, NE)
-
-genCondJump lbl (StPrim op args) =
- trivialCode instr args `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- returnUs (code . mkSeqInstr (BI cond result target))
- where
- (instr, cond) = case op of
- CharGtOp -> (CMP LE, EQ)
- CharGeOp -> (CMP LT, EQ)
- CharEqOp -> (CMP EQ, NE)
- CharNeOp -> (CMP EQ, EQ)
- CharLtOp -> (CMP LT, NE)
- CharLeOp -> (CMP LE, NE)
- IntGtOp -> (CMP LE, EQ)
- IntGeOp -> (CMP LT, EQ)
- IntEqOp -> (CMP EQ, NE)
- IntNeOp -> (CMP EQ, EQ)
- IntLtOp -> (CMP LT, NE)
- IntLeOp -> (CMP LE, NE)
- WordGtOp -> (CMP ULE, EQ)
- WordGeOp -> (CMP ULT, EQ)
- WordEqOp -> (CMP EQ, NE)
- WordNeOp -> (CMP EQ, EQ)
- WordLtOp -> (CMP ULT, NE)
- WordLeOp -> (CMP ULE, NE)
- AddrGtOp -> (CMP ULE, EQ)
- AddrGeOp -> (CMP ULT, EQ)
- AddrEqOp -> (CMP EQ, NE)
- AddrNeOp -> (CMP EQ, EQ)
- AddrLtOp -> (CMP ULT, NE)
- AddrLeOp -> (CMP ULE, NE)
-
-\end{code}
-
-Now the biggest nightmare---calls. Most of the nastiness is buried in
-getCallArg, which moves the arguments to the correct registers/stack
-locations. Apart from that, the code is easy.
-
-\begin{code}
-
-genCCall
- :: FAST_STRING -- function to call
- -> PrimRep -- type of the result
- -> [StixTree] -- arguments (of mixed type)
- -> UniqSM (CodeBlock AlphaInstr)
-
-genCCall fn kind args =
- mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
- `thenUs` \ ((unused,_), argCode) ->
- let
- nRegs = length argRegs - length unused
- code = asmParThen (map ($ asmVoid) argCode)
- in
- returnSeq code [
- LDA pv (AddrImm (ImmLab (uppPStr fn))),
- JSR ra (AddrReg pv) nRegs,
- LDGP gp (AddrReg ra)]
- where
- mapAccumLNCG f b [] = returnUs (b, [])
- mapAccumLNCG f b (x:xs) =
- f b x `thenUs` \ (b__2, x__2) ->
- mapAccumLNCG f b__2 xs `thenUs` \ (b__3, xs__2) ->
- returnUs (b__3, x__2:xs__2)
-
-\end{code}
-
-Trivial (dyadic) instructions. Only look for constants on the right hand
-side, because that's where the generic optimizer will have put them.
-
-\begin{code}
-
-trivialCode
- :: (Reg -> RI -> Reg -> AlphaInstr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialCode instr [x, StInt y]
- | is8Bits y =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ 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
- returnUs (Any IntRep code__2)
-
-trivialCode instr [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] .
- mkSeqInstr (instr src1 (RIReg src2) dst)
- in
- returnUs (Any IntRep code__2)
-
-trivialFCode
- :: (Reg -> Reg -> Reg -> AlphaInstr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialFCode instr [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr (instr src1 src2 dst)
- in
- returnUs (Any DoubleRep code__2)
-
-\end{code}
-
-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.
-
-\begin{code}
-intNECode
- :: [StixTree]
- -> UniqSM Register
-
-intNECode args =
- trivialCode (CMP EQ) args `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
- in
- returnUs (Any IntRep code__2)
-
-cmpFCode
- :: (Reg -> Reg -> Reg -> AlphaInstr)
- -> Cond
- -> [StixTree]
- -> UniqSM Register
-
-cmpFCode instr cond args =
- trivialFCode instr args `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code = registerCode register tmp
- result = registerName register tmp
-
- code__2 dst = code . mkSeqInstrs [
- OR zero (RIImm (ImmInt 1)) dst,
- BF cond result (ImmCLbl lbl),
- OR zero (RIReg zero) dst,
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-Trivial unary instructions. Note that we don't have to worry about
-matching an StInt as the argument, because genericOpt will already
-have handled the constant-folding.
-
-\begin{code}
-
-trivialUCode
- :: (RI -> Reg -> AlphaInstr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialUCode instr [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
- in
- returnUs (Any IntRep code__2)
-
-trivialUFCode
- :: (Reg -> Reg -> AlphaInstr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialUFCode instr [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr src dst)
- in
- returnUs (Any DoubleRep code__2)
-
-\end{code}
-
-Simple coercions that don't require any code to be generated.
-Here we just change the type on the register passed on up
-
-\begin{code}
-
-coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
-coerceIntCode pk [x] =
- getReg x `thenUs` \ register ->
- case register of
- Fixed reg _ code -> returnUs (Fixed reg pk code)
- Any _ code -> returnUs (Any pk code)
-
-coerceFltCode :: [StixTree] -> UniqSM Register
-coerceFltCode [x] =
- getReg x `thenUs` \ register ->
- case register of
- Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
- Any _ code -> returnUs (Any DoubleRep code)
-
-\end{code}
-
-Integer to character conversion.
-
-\begin{code}
-
-chrCode [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
- in
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-More complicated integer/float conversions. Here we have to store
-temporaries in memory to move between the integer and the floating
-point register sets.
-
-\begin{code}
-
-coerceInt2FP :: [StixTree] -> UniqSM Register
-coerceInt2FP [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ 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
- returnUs (Any DoubleRep code__2)
-
-coerceFP2Int :: [StixTree] -> UniqSM Register
-coerceFP2Int [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ 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
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-Some random little helpers.
-
-\begin{code}
-
-is8Bits :: Integer -> Bool
-is8Bits i = i >= -256 && i < 256
-
-maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i)
- | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
- | otherwise = Just (ImmInteger i)
-maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StLitLit s) = Just (strImmLab (cvtLitLit (_UNPK_ s)))
-maybeImm (StCLbl l) = Just (ImmCLbl l)
-maybeImm _ = Nothing
-
-mangleIndexTree :: StixTree -> StixTree
-
-mangleIndexTree (StIndex pk base (StInt i)) =
- StPrim IntAddOp [base, off]
- where
- off = StInt (i * size pk)
- size :: PrimRep -> Integer
- size pk = case kindToSize pk of
- {B -> 1; BU -> 1; W -> 2; WU -> 2; L -> 4; FF -> 4; SF -> 4; _ -> 8}
-
-mangleIndexTree (StIndex pk base off) =
- case pk of
- CharRep -> StPrim IntAddOp [base, off]
- _ -> StPrim IntAddOp [base, off__2]
- where
- off__2 = StPrim SllOp [off, StInt 3]
-
-cvtLitLit :: String -> String
-cvtLitLit "stdin" = "_iob+0" -- This one is probably okay...
-cvtLitLit "stdout" = "_iob+56" -- but these next two are dodgy at best
-cvtLitLit "stderr" = "_iob+112"
-cvtLitLit s
- | isHex s = s
- | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
- where
- isHex ('0':'x':xs) = all isHexDigit xs
- isHex _ = False
- -- Now, where have I seen this before?
- isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
-
-
-\end{code}
-
-spRel gives us a stack relative addressing mode for volatile temporaries
-and for excess call arguments.
-
-\begin{code}
-
-spRel
- :: Int -- desired stack offset in words, positive or negative
- -> Addr
-spRel n = AddrRegImm sp (ImmInt (n * 8))
-
-stackArgLoc = 0 :: Int -- where to stack extra call arguments (beyond 6)
-
-\end{code}
-
-\begin{code}
-
-getNewRegNCG :: PrimRep -> UniqSM Reg
-getNewRegNCG pk =
- getUnique `thenUs` \ u ->
- returnUs (mkReg u pk)
-
-\end{code}
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index da0d83bb7a75ec4599abca08559e4e8c7187ff59..ac259c4feaf56371987ad4e2f93b3e015d4f1f92 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -1,158 +1,128 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\begin{code}
#include "HsVersions.h"
-#include "../../includes/platform.h"
-#include "../../includes/GhcConstants.h"
-
-module AsmCodeGen (
- writeRealAsm,
- dumpRealAsm,
-
- -- And, I guess we need these...
- AbstractC, GlobalSwitch, SwitchResult,
- UniqSupply, UniqSM(..)
- ) where
-
-import AbsCSyn ( AbstractC )
-import AbsCStixGen ( genCodeAbstractC )
-import PrelInfo ( PrimRep, PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
-import MachDesc
-import Maybes ( Maybe(..) )
-import Outputable
-#if alpha_TARGET_ARCH
-import AlphaDesc ( mkAlpha )
-#endif
-#if i386_TARGET_ARCH
-import I386Desc ( mkI386 )
-#endif
-#if sparc_TARGET_ARCH
-import SparcDesc ( mkSparc )
-#endif
-import Stix
-import UniqSupply
-import Unpretty
-import Util
+
+module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where
+
+import Ubiq{-uitous-}
+
+import MachMisc
+import MachRegs
+import MachCode
+import PprMach
+
+import AbsCStixGen ( genCodeAbstractC )
+import AbsCSyn ( AbstractC, MagicId )
+import AsmRegAlloc ( runRegAllocate )
+import OrdList ( OrdList )
+import PrimOp ( commutableOp, PrimOp(..) )
+import PrimRep ( PrimRep{-instance Eq-} )
+import RegAllocInfo ( mkMRegsState, MRegsState )
+import Stix ( StixTree(..), StixReg(..), CodeSegment )
+import UniqSupply ( returnUs, thenUs, mapUs, UniqSM(..) )
+import Unpretty ( uppAppendFile, uppShow, uppAboves, Unpretty(..) )
\end{code}
-This is a generic assembly language generator for the Glasgow Haskell
-Compiler. It has been a long time in germinating, basically due to
-time constraints and the large spectrum of design possibilities.
-Presently it generates code for:
-\begin{itemize}
-\item Sparc
-\end{itemize}
-In the pipeline (sic) are plans and/or code for 680x0, 386/486.
-
-The code generator presumes the presence of a working C port. This is
-because any code that cannot be compiled (e.g. @casm@s) is re-directed
-via this route. It also help incremental development. Because this
-code generator is specially written for the Abstract C produced by the
-Glasgow Haskell Compiler, several optimisation opportunities are open
-to us that are not open to @gcc@. In particular, we know that the A
-and B stacks and the Heap are all mutually exclusive wrt. aliasing,
-and that expressions have no side effects (all state transformations
-are top level objects).
-
-There are two main components to the code generator.
-\begin{itemize}
-\item Abstract C is considered in statements,
- with a Twig-like system handling each statement in turn.
-\item A scheduler turns the tree of assembly language orderings
- into a sequence suitable for input to an assembler.
-\end{itemize}
-The @codeGenerate@ function returns the final assembly language output
-(as a String). We can return a string, because there is only one way
-of printing the output suitable for assembler consumption. It also
-allows limited abstraction of different machines from the Main module.
-
-The first part is the actual assembly language generation. First we
-split up the Abstract C into individual functions, then consider
-chunks in isolation, giving back an @OrdList@ of assembly language
-instructions. The generic algorithm is heavily inspired by Twig
-(ref), but also draws concepts from (ref). The basic idea is to
-(dynamically) walk the Abstract C syntax tree, annotating it with
-possible code matches. For example, on the Sparc, a possible match
-(with its translation) could be
-@
- :=
- / \
- i r2 => ST r2,[r1]
- |
- r1
-@
-where @r1,r2@ are registers, and @i@ is an indirection. The Twig
-bit twiddling algorithm for tree matching has been abandoned. It is
-replaced with a more direct scheme. This is because, after careful
-consideration it is felt that the overhead of handling many bit
-patterns would be heavier that simply looking at the syntax of the
-tree at the node being considered, and dynamically choosing and
-pruning rules.
-
-The ultimate result of the first part is a Set of ordering lists of
-ordering lists of assembly language instructions (yes, really!), where
-each element in the set is basic chunk. Now several (generic)
-simplifications and transformations can be performed. This includes
-ones that turn the the ordering of orderings into just a single
-ordering list. (The equivalent of applying @concat@ to a list of
-lists.) A lot of the re-ordering and optimisation is actually done
-(generically) here! The final part, the scheduler, can now be used on
-this structure. The code sequence is optimised (obviously) to avoid
-stalling the pipeline. This part {\em has} to be heavily machine
-dependent.
-
-[The above seems to describe mostly dreamware. -- JSM]
-
-The flag that needs to be added is -fasm-<platform> where platform is one of
-the choices below.
+The 96/03 native-code generator has machine-independent and
+machine-dependent modules (those \tr{#include}'ing \tr{NCG.h}).
+
+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 @StixInfo@ (info
+tables), @StixPrim@ (primitive operations), @StixMacro@ (Abstract C
+macros), and @StixInteger@ (GMP arbitrary-precision operations).
+
+Before entering machine-dependent land, we do some machine-independent
+@genericOpt@imisations (defined below) on the @StixTree@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).
+
+The machine-dependent bits break down as follows:
+\begin{description}
+\item[@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
+ have a module of its own), plus a miscellany of other things
+ (e.g., @targetDoubleSize@, @smStablePtrTable@, ...)
+
+\item[@MachCode@:] @stmt2Instrs@ is where @Stix@ stuff turns into
+ machine instructions.
+\item[@PprMach@:] @pprInstr@ turns an @Instr@ into text (well, really
+ an @Unpretty@).
+
+\item[@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
+ reasons.
+
+ The @RegAllocInfo@ module collects together the machine-specific
+ info needed to do register allocation.
+\end{description}
+
+So, here we go:
\begin{code}
-writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> UniqSupply -> PrimIO ()
+writeRealAsm :: _FILE -> AbstractC -> UniqSupply -> IO ()
-writeRealAsm flags file absC uniq_supply
- = uppAppendFile file 80 (runNCG (code flags absC) uniq_supply)
+writeRealAsm file absC us
+ = uppAppendFile file 80 (runNCG absC us)
-dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> UniqSupply -> String
+dumpRealAsm :: AbstractC -> UniqSupply -> String
-dumpRealAsm flags absC uniq_supply = uppShow 80 (runNCG (code flags absC) uniq_supply)
+dumpRealAsm absC us = uppShow 80 (runNCG absC us)
-runNCG m uniq_supply = m uniq_supply
+runNCG absC
+ = genCodeAbstractC absC `thenUs` \ treelists ->
+ let
+ stix = map (map genericOpt) treelists
+ in
+ codeGen stix
+\end{code}
-code flags absC =
- genCodeAbstractC target absC `thenUs` \ treelists ->
+@codeGen@ is the top-level code-generation function:
+\begin{code}
+codeGen :: [[StixTree]] -> UniqSM Unpretty
+
+codeGen trees
+ = mapUs genMachCode trees `thenUs` \ dynamic_codes ->
let
- stix = map (map (genericOpt target)) treelists
+ static_instrs = scheduleMachCode dynamic_codes
in
- codeGen {-target-} sty stix
- where
- sty = PprForAsm (switchIsOn flags) (underscore {-target-}) (fmtAsmLbl {-target-})
-
- (target, codeGen, underscore, fmtAsmLbl)
- = case stringSwitchSet flags AsmTarget of
-#if ! OMIT_NATIVE_CODEGEN
-# if alpha_TARGET_ARCH
- Just _ {-???"alpha-dec-osf1"-} -> mkAlpha flags
-# endif
-# if i386_TARGET_ARCH
- Just _ {-???"i386_unknown_linuxaout"-} -> mkI386 True flags
-# endif
-# if sparc_sun_sunos4_TARGET
- Just _ {-???"sparc-sun-sunos4"-} -> mkSparc True flags
-# endif
-# if sparc_sun_solaris2_TARGET
- Just _ {-???"sparc-sun-solaris2"-} -> mkSparc False flags
-# endif
-#endif
- _ -> error
- ("ERROR:Trying to generate assembly language for an unsupported architecture\n"++
- "(or one for which this build is not configured).")
+ returnUs (uppAboves (map pprInstr static_instrs))
+\end{code}
+Top level code generator for a chunk of stix code:
+\begin{code}
+genMachCode :: [StixTree] -> UniqSM InstrList
+
+genMachCode stmts
+ = mapUs stmt2Instrs stmts `thenUs` \ blocks ->
+ returnUs (foldr (.) id blocks asmVoid)
+\end{code}
+
+The next bit does the code scheduling. The scheduler must also deal
+with register allocation of temporaries. Much parallelism can be
+exposed via the OrdList, but more might occur, so further analysis
+might be needed.
+
+\begin{code}
+scheduleMachCode :: [InstrList] -> [Instr]
+
+scheduleMachCode
+ = concat . map (runRegAllocate freeRegsState reservedRegs)
+ where
+ freeRegsState = mkMRegsState (extractMappedRegNos freeRegs)
\end{code}
%************************************************************************
@@ -161,128 +131,108 @@ code flags absC =
%* *
%************************************************************************
-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.
+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.
+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
- :: Target
- -> StixTree
- -> StixTree
-
+genericOpt :: StixTree -> StixTree
\end{code}
For most nodes, just optimize the children.
\begin{code}
--- hacking with Uncle Will:
-#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
-
-genericOpt target_STRICT (StInd pk addr) =
- StInd pk (genericOpt target addr)
-
-genericOpt target (StAssign pk dst src) =
- StAssign pk (genericOpt target dst) (genericOpt target src)
+genericOpt (StInd pk addr) = StInd pk (genericOpt addr)
-genericOpt target (StJump addr) =
- StJump (genericOpt target addr)
+genericOpt (StAssign pk dst src)
+ = StAssign pk (genericOpt dst) (genericOpt src)
-genericOpt target (StCondJump addr test) =
- StCondJump addr (genericOpt target test)
+genericOpt (StJump addr) = StJump (genericOpt addr)
-genericOpt target (StCall fn pk args) =
- StCall fn pk (map (genericOpt target) args)
+genericOpt (StCondJump addr test)
+ = StCondJump addr (genericOpt test)
+genericOpt (StCall fn pk args)
+ = StCall fn pk (map genericOpt args)
\end{code}
-Fold indices together when the types match.
-
+Fold indices together when the types match:
\begin{code}
+genericOpt (StIndex pk (StIndex pk' base off) off')
+ | pk == pk'
+ = StIndex pk (genericOpt base)
+ (genericOpt (StPrim IntAddOp [off, off']))
-genericOpt target (StIndex pk (StIndex pk' base off) off')
- | pk == pk' =
- StIndex pk (genericOpt target base)
- (genericOpt target (StPrim IntAddOp [off, off']))
-
-genericOpt target (StIndex pk base off) =
- StIndex pk (genericOpt target base)
- (genericOpt target off)
-
+genericOpt (StIndex pk base off)
+ = StIndex pk (genericOpt base) (genericOpt off)
\end{code}
-For primOps, we first optimize the children, and then we try our hand
+For PrimOps, we first optimize the children, and then we try our hand
at some constant-folding.
\begin{code}
-
-genericOpt target (StPrim op args) =
- primOpt op (map (genericOpt target) args)
-
+genericOpt (StPrim op args) = primOpt op (map genericOpt args)
\end{code}
-Replace register leaves with appropriate StixTrees for the given target.
-(Oh, so this is why we've been hauling the target around!)
+Replace register leaves with appropriate StixTrees for the given
+target.
\begin{code}
+genericOpt leaf@(StReg (StixMagicId id))
+ = case (stgReg id) of
+ Always tree -> genericOpt tree
+ Save _ -> leaf
-genericOpt target leaf@(StReg (StixMagicId id)) =
- case stgReg target id of
- Always tree -> genericOpt target tree
- Save _ -> leaf
-
-genericOpt target other = other
-
+genericOpt other = other
\end{code}
-Now, try to constant-fold the primOps. The arguments have
-already been optimized and folded.
+Now, try to constant-fold the PrimOps. The arguments have already
+been optimized and folded.
\begin{code}
-
primOpt
:: PrimOp -- The operation from an StPrim
-> [StixTree] -- The optimized arguments
-> StixTree
-primOpt op arg@[StInt x] =
- case op of
+primOpt op arg@[StInt x]
+ = case op of
IntNegOp -> StInt (-x)
IntAbsOp -> StInt (abs x)
_ -> StPrim op arg
-primOpt op args@[StInt x, StInt y] =
- case op of
- CharGtOp -> StInt (if x > y then 1 else 0)
+primOpt op args@[StInt x, StInt y]
+ = case op of
+ CharGtOp -> StInt (if x > y then 1 else 0)
CharGeOp -> StInt (if x >= y then 1 else 0)
CharEqOp -> StInt (if x == y then 1 else 0)
CharNeOp -> StInt (if x /= y then 1 else 0)
- CharLtOp -> StInt (if x < y then 1 else 0)
+ CharLtOp -> StInt (if x < y then 1 else 0)
CharLeOp -> StInt (if x <= y then 1 else 0)
IntAddOp -> StInt (x + y)
IntSubOp -> StInt (x - y)
IntMulOp -> StInt (x * y)
IntQuotOp -> StInt (x `quot` y)
IntRemOp -> StInt (x `rem` y)
- IntGtOp -> StInt (if x > y then 1 else 0)
+ IntGtOp -> StInt (if x > y then 1 else 0)
IntGeOp -> StInt (if x >= y then 1 else 0)
IntEqOp -> StInt (if x == y then 1 else 0)
IntNeOp -> StInt (if x /= y then 1 else 0)
- IntLtOp -> StInt (if x < y then 1 else 0)
+ IntLtOp -> StInt (if x < y then 1 else 0)
IntLeOp -> StInt (if x <= y then 1 else 0)
_ -> StPrim op args
-
\end{code}
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.
+also assume that constants have been shifted to the right when
+possible.
\begin{code}
primOpt op [x@(StInt _), y] | commutableOp op = primOpt op [y, x]
@@ -291,40 +241,40 @@ primOpt op [x@(StInt _), y] | commutableOp op = primOpt op [y, x]
We can often do something with constants of 0 and 1 ...
\begin{code}
-primOpt op args@[x, y@(StInt 0)] =
- case op of
+primOpt op args@[x, y@(StInt 0)]
+ = case op of
IntAddOp -> x
IntSubOp -> x
IntMulOp -> y
- AndOp -> y
- OrOp -> x
- SllOp -> x
- SraOp -> x
- SrlOp -> x
- ISllOp -> x
- ISraOp -> x
- ISrlOp -> x
- _ -> StPrim op args
-
-primOpt op args@[x, y@(StInt 1)] =
- case op of
- IntMulOp -> x
+ AndOp -> y
+ OrOp -> x
+ SllOp -> x
+ SraOp -> x
+ SrlOp -> x
+ ISllOp -> x
+ ISraOp -> x
+ ISrlOp -> x
+ _ -> StPrim op args
+
+primOpt op args@[x, y@(StInt 1)]
+ = case op of
+ IntMulOp -> x
IntQuotOp -> x
- IntRemOp -> StInt 0
- _ -> StPrim op args
+ IntRemOp -> StInt 0
+ _ -> StPrim op args
\end{code}
Now look for multiplication/division by powers of 2 (integers).
\begin{code}
-primOpt op args@[x, y@(StInt n)] =
- case op of
- IntMulOp -> case exact_log2 n of
+primOpt op args@[x, y@(StInt n)]
+ = case op of
+ IntMulOp -> case exactLog2 n of
Nothing -> StPrim op args
- Just p -> StPrim SllOp [x, StInt p]
- IntQuotOp -> case exact_log2 n of
+ Just p -> StPrim SllOp [x, StInt p]
+ IntQuotOp -> case exactLog2 n of
Nothing -> StPrim op args
- Just p -> StPrim SraOp [x, StInt p]
+ Just p -> StPrim SraOp [x, StInt p]
_ -> StPrim op args
\end{code}
@@ -333,52 +283,3 @@ Anything else is just too hard.
\begin{code}
primOpt op args = StPrim op args
\end{code}
-
-The commutable ops are those for which we will try to move constants
-to the right hand side for strength reduction.
-
-\begin{code}
-commutableOp :: PrimOp -> Bool
-
-commutableOp CharEqOp = True
-commutableOp CharNeOp = True
-commutableOp IntAddOp = True
-commutableOp IntMulOp = True
-commutableOp AndOp = True
-commutableOp OrOp = True
-commutableOp IntEqOp = True
-commutableOp IntNeOp = True
-commutableOp IntegerAddOp = True
-commutableOp IntegerMulOp = True
-commutableOp FloatAddOp = True
-commutableOp FloatMulOp = True
-commutableOp FloatEqOp = True
-commutableOp FloatNeOp = True
-commutableOp DoubleAddOp = True
-commutableOp DoubleMulOp = True
-commutableOp DoubleEqOp = True
-commutableOp DoubleNeOp = True
-commutableOp _ = False
-\end{code}
-
-This algorithm for determining the $\log_2$ of exact powers of 2 comes
-from gcc. It requires bit manipulation primitives, so we have a ghc
-version and an hbc version. Other Haskell compilers are on their own.
-
-\begin{code}
-w2i x = word2Int# x
-i2w x = int2Word# x
-i2w_s x = (x::Int#)
-
-exact_log2 :: Integer -> Maybe Integer
-exact_log2 x
- | x <= 0 || x >= 2147483648 = Nothing
- | otherwise = case fromInteger x of
- I# x# -> if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then Nothing
- else Just (toInteger (I# (pow2 x#)))
-
- where pow2 x# | x# ==# 1# = 0#
- | otherwise = 1# +# pow2 (w2i (i2w x# `shiftr` i2w_s 1#))
-
- shiftr x y = shiftRA# x y
-\end{code}
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 29061de5bfd2d39920f4ecdc64d8166ff9ca0089..8e574e6ccde4e27b8b41ed5b302a826b68fb390c 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -1,238 +1,57 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
+\section[AsmRegAlloc]{Register allocator}
\begin{code}
#include "HsVersions.h"
-#include "../../includes/platform.h"
-#include "../../includes/GhcConstants.h"
-module AsmRegAlloc (
- FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..),
- MachineRegisters(..), MachineCode(..),
+module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
- mkReg, runRegAllocate, runHairyRegAllocate,
- extractMappedRegNos
+import Ubiq{-uitous-}
- -- And, for self-sufficiency
- ) where
+import MachCode ( InstrList(..) )
+import MachMisc ( Instr )
+import MachRegs
+import RegAllocInfo
-import CLabel ( CLabel )
-import FiniteMap
-import MachDesc
-import Maybes ( maybeToBool, Maybe(..) )
-import OrdList -- ( mkUnitList, mkSeqList, mkParList, OrdList )
-import Outputable
-import Pretty
-import UniqSet
-import Unique ( Unique )
-import Util
-
-#if ! OMIT_NATIVE_CODEGEN
-
-# if alpha_TARGET_ARCH
-import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing
-
-{-# SPECIALIZE
- runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr]
- #-}
-# endif
-
-# if i386_TARGET_ARCH
-import I386Code -- ( I386Instr, I386Regs ) -- for specializing
-
-{-# SPECIALIZE
- runRegAllocate :: I386Regs -> [Int] -> (OrdList I386Instr) -> [I386Instr]
- #-}
-# endif
-
-# if sparc_TARGET_ARCH
-import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing
-
-{-# SPECIALIZE
- runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr]
- #-}
-# endif
-
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Reg]{Real registers}
-%* *
-%************************************************************************
-
-Static Registers correspond to actual machine registers. These should
-be avoided until the last possible moment.
-
-Dynamic registers are allocated on the fly, usually to represent a single
-value in the abstract assembly code (i.e. dynamic registers are usually
-single assignment). Ultimately, they are mapped to available machine
-registers before spitting out the code.
-
-\begin{code}
-
-data Reg = FixedReg FAST_INT -- A pre-allocated machine register
-
- | MappedReg FAST_INT -- A dynamically allocated machine register
-
- | MemoryReg Int PrimRep -- A machine "register" actually held in a memory
- -- allocated table of registers which didn't fit
- -- in real registers.
-
- | UnmappedReg Unique PrimRep -- One of an infinite supply of registers,
- -- always mapped to one of the earlier two
- -- before we're done.
- -- No thanks: deriving (Eq)
-
-mkReg :: Unique -> PrimRep -> Reg
-mkReg = UnmappedReg
-
-instance Text Reg where
- showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i)
- showsPrec _ (MappedReg i) = showString "%" . shows IBOX(i)
- showsPrec _ (MemoryReg i _) = showString "%M" . shows i
- showsPrec _ (UnmappedReg i _) = showString "%U" . shows i
-
-#ifdef DEBUG
-instance Outputable Reg where
- ppr sty r = ppStr (show r)
-#endif
-
-cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
-cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i'
-cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i'
-cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmp u u'
-cmpReg r1 r2 =
- let tag1 = tagReg r1
- tag2 = tagReg r2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
- where
- tagReg (FixedReg _) = (ILIT(1) :: FAST_INT)
- tagReg (MappedReg _) = ILIT(2)
- tagReg (MemoryReg _ _) = ILIT(3)
- tagReg (UnmappedReg _ _) = ILIT(4)
-
-cmp_i :: Int -> Int -> TAG_
-cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_
-
-cmp_ihash :: FAST_INT -> FAST_INT -> TAG_
-cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_
-
-instance Eq Reg where
- a == b = case cmpReg a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpReg a b of { EQ_ -> False; _ -> True }
-
-instance Ord Reg where
- a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-
-instance NamedThing Reg where
- -- the *only* method that should be defined is "getItsUnique"!
- -- (so we can use UniqFMs/UniqSets on Regs
- getItsUnique (UnmappedReg u _) = u
- getItsUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
- getItsUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
- getItsUnique (MemoryReg i _) = mkPseudoUnique3 i
+import BitSet ( BitSet )
+import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
+import Maybes ( maybeToBool )
+import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
+ flattenOrdList, OrdList
+ )
+import Stix ( StixTree )
+import UniqSupply ( mkBuiltinUnique )
+import Util ( mapAccumB, panic )
\end{code}
This is the generic register allocator.
-%************************************************************************
-%* *
-\subsection[RegPlace]{Map Stix registers to {\em real} registers}
-%* *
-%************************************************************************
-
-An important point: The @regUsage@ function for a particular assembly language
-must not refer to fixed registers, such as Hp, SpA, etc. The source and destination
-lists should only refer to dynamically allocated registers or static registers
-from the free list. As far as we are concerned, the fixed registers simply don't
-exist (for allocation purposes, anyway).
-
-\begin{code}
-
-class MachineRegisters a where
- mkMRegs :: [Int] -> a
- possibleMRegs :: PrimRep -> a -> [Int]
- useMReg :: a -> FAST_INT -> a
- useMRegs :: a -> [Int] -> a
- freeMReg :: a -> FAST_INT -> a
- freeMRegs :: a -> [Int] -> a
-
-type RegAssignment = FiniteMap Reg Reg
-type RegConflicts = FiniteMap Int (UniqSet Reg)
-
-data FutureLive
- = FL (UniqSet Reg)
- (FiniteMap CLabel (UniqSet Reg))
-fstFL (FL a b) = a
-
-data RegHistory a
- = RH a
- Int
- RegAssignment
-
-data RegFuture
- = RF (UniqSet Reg) -- in use
- FutureLive -- future
- RegConflicts
-
-data RegInfo a
- = RI (UniqSet Reg) -- in use
- (UniqSet Reg) -- sources
- (UniqSet Reg) -- destinations
- [Reg] -- last used
- RegConflicts
-
-data RegUsage
- = RU (UniqSet Reg)
- (UniqSet Reg)
-
-data RegLiveness
- = RL (UniqSet Reg)
- FutureLive
-
-class MachineCode a where
- regUsage :: a -> RegUsage
- regLiveness :: a -> RegLiveness -> RegLiveness
- patchRegs :: a -> (Reg -> Reg) -> a
- spillReg :: Reg -> Reg -> OrdList a
- loadReg :: Reg -> Reg -> OrdList a
-\end{code}
-
-First we try something extremely simple.
-If that fails, we have to do things the hard way.
+First we try something extremely simple. If that fails, we have to do
+things the hard way.
\begin{code}
runRegAllocate
- :: (MachineRegisters a, MachineCode b)
- => a
- -> [Int]
- -> (OrdList b)
- -> [b]
-
-runRegAllocate regs reserve_regs instrs =
- case simpleAlloc of
+ :: MRegsState
+ -> [RegNo]
+ -> InstrList
+ -> [Instr]
+
+runRegAllocate regs reserve_regs instrs
+ = case simpleAlloc of
Just x -> x
Nothing -> hairyAlloc
where
flatInstrs = flattenOrdList instrs
- simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
- hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs
+ simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
+ hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs
runHairyRegAllocate -- use only hairy for i386!
- :: (MachineRegisters a, MachineCode b)
- => a
- -> [Int]
- -> (OrdList b)
- -> [b]
+ :: MRegsState
+ -> [RegNo]
+ -> InstrList
+ -> [Instr]
runHairyRegAllocate regs reserve_regs instrs
= hairyRegAlloc regs reserve_regs flatInstrs
@@ -248,25 +67,24 @@ this approach will suffice for about 96 percent of the code blocks that
we generate.
\begin{code}
-
simpleRegAlloc
- :: (MachineRegisters a, MachineCode b)
- => a -- registers to select from
+ :: MRegsState -- registers to select from
-> [Reg] -- live static registers
-> RegAssignment -- mapping of dynamics to statics
- -> [b] -- code
- -> Maybe [b]
+ -> [Instr] -- code
+ -> Maybe [Instr]
simpleRegAlloc _ _ _ [] = Just []
-simpleRegAlloc free live env (instr:instrs) =
- if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
+
+simpleRegAlloc free live env (instr:instrs)
+ = if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
Just (instr3 : instrs3)
else
Nothing
where
instr3 = patchRegs instr (lookup env2)
- (srcs, dsts) = case regUsage instr of { RU s d -> (uniqSetToList s, uniqSetToList d) }
+ (srcs, dsts) = case regUsage instr of { RU s d -> (regSetToList s, regSetToList d) }
lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x}
@@ -284,10 +102,9 @@ simpleRegAlloc free live env (instr:instrs) =
instrs3 = case instrs2 of Just x -> x
allocateNewReg
- :: MachineRegisters a
- => Reg
- -> Maybe (a, [(Reg, Reg)])
- -> Maybe (a, [(Reg, Reg)])
+ :: Reg
+ -> Maybe (MRegsState, [(Reg, Reg)])
+ -> Maybe (MRegsState, [(Reg, Reg)])
allocateNewReg _ Nothing = Nothing
@@ -299,7 +116,6 @@ simpleRegAlloc free live env (instr:instrs) =
reg = head choices
free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
-
\end{code}
Here is the ``clever'' bit. First go backward (i.e. left), looking for
@@ -307,16 +123,14 @@ the last use of dynamic registers. Then go forward (i.e. right), filling
registers with static placements.
\begin{code}
-
hairyRegAlloc
- :: (MachineRegisters a, MachineCode b)
- => a
- -> [Int]
- -> [b]
- -> [b]
-
-hairyRegAlloc regs reserve_regs instrs =
- case mapAccumB (doRegAlloc reserve_regs)
+ :: MRegsState
+ -> [RegNo]
+ -> [Instr]
+ -> [Instr]
+
+hairyRegAlloc regs reserve_regs instrs
+ = case mapAccumB (doRegAlloc reserve_regs)
(RH regs' 1 emptyFM) noFuture instrs
of (RH _ loc' _, _, instrs') ->
if loc' == 1 then instrs' else
@@ -325,19 +139,18 @@ hairyRegAlloc regs reserve_regs instrs =
of ((RH _ loc'' _),_,instrs'') ->
if loc'' == loc' then instrs'' else panic "runRegAllocate"
where
- regs' = regs `useMRegs` reserve_regs
- regs'' = mkMRegs reserve_regs `asTypeOf` regs
+ regs' = regs `useMRegs` reserve_regs
+ regs'' = mkMRegsState reserve_regs
do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
do_RegAlloc_Nil
- :: (MachineRegisters a, MachineCode b)
- => RegHistory a
+ :: RegHistory MRegsState
-> RegFuture
- -> b
- -> (RegHistory a, RegFuture, b)
+ -> Instr
+ -> (RegHistory MRegsState, RegFuture, Instr)
noFuture :: RegFuture
-noFuture = RF emptyUniqSet (FL emptyUniqSet emptyFM) emptyFM
+noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
\end{code}
Here we patch instructions that reference ``registers'' which are really in
@@ -349,21 +162,14 @@ instructions are rewritten with new dynamic registers, so we have to run registe
allocation again after all of this is said and done.
\begin{code}
-
-patchMem
- :: MachineCode a
- => [a]
- -> OrdList a
+patchMem :: [Instr] -> InstrList
patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
-patchMem'
- :: MachineCode a
- => a
- -> OrdList a
+patchMem' :: Instr -> InstrList
-patchMem' instr =
- if null memSrcs && null memDsts then mkUnitList instr
+patchMem' instr
+ = if null memSrcs && null memDsts then mkUnitList instr
else mkSeqList
(foldr mkParList mkEmptyList loadSrcs)
(mkSeqList instr'
@@ -375,8 +181,8 @@ patchMem' instr =
memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
memToDyn other = other
- memSrcs = [ r | r@(MemoryReg _ _) <- uniqSetToList srcs]
- memDsts = [ r | r@(MemoryReg _ _) <- uniqSetToList dsts]
+ memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
+ memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
loadSrcs = map load memSrcs
spillDsts = map spill memDsts
@@ -385,62 +191,55 @@ patchMem' instr =
spill mem = spillReg (memToDyn mem) mem
instr' = mkUnitList (patchRegs instr memToDyn)
-
\end{code}
\begin{code}
-
doRegAlloc
- :: (MachineRegisters a, MachineCode b)
- => [Int]
- -> RegHistory a
+ :: [RegNo]
+ -> RegHistory MRegsState
-> RegFuture
- -> b
- -> (RegHistory a, RegFuture, b)
+ -> Instr
+ -> (RegHistory MRegsState, RegFuture, Instr)
doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
where
(free_env', instr') = doRegAlloc' reserved_regs free_env info instr
(in_use', info) = getUsage in_use instr
-
\end{code}
\begin{code}
-
getUsage
- :: MachineCode a
- => RegFuture
- -> a
- -> (RegFuture, RegInfo a)
+ :: RegFuture
+ -> Instr
+ -> (RegFuture, RegInfo Instr)
-getUsage (RF next_in_use future reg_conflicts) instr =
- (RF in_use' future' reg_conflicts',
+getUsage (RF next_in_use future reg_conflicts) instr
+ = (RF in_use' future' reg_conflicts',
RI in_use' srcs dsts last_used reg_conflicts')
where (RU srcs dsts) = regUsage instr
(RL in_use future') = regLiveness instr (RL next_in_use future)
- live_through = in_use `minusUniqSet` dsts
- last_used = [ r | r <- uniqSetToList srcs,
- not (r `elementOfUniqSet` (fstFL future) || r `elementOfUniqSet` in_use)]
- in_use' = srcs `unionUniqSets` live_through
+ live_through = in_use `minusRegSet` dsts
+ last_used = [ r | r <- regSetToList srcs,
+ not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)]
+ in_use' = srcs `unionRegSets` live_through
reg_conflicts' = case new_conflicts of
[] -> reg_conflicts
_ -> addListToFM reg_conflicts new_conflicts
- new_conflicts = if isEmptyUniqSet live_dynamics then []
+ new_conflicts = if isEmptyRegSet live_dynamics then []
else [ (r, merge_conflicts r)
- | r <- extractMappedRegNos (uniqSetToList dsts) ]
+ | r <- extractMappedRegNos (regSetToList dsts) ]
merge_conflicts reg = case lookupFM reg_conflicts reg of
Nothing -> live_dynamics
- Just conflicts -> conflicts `unionUniqSets` live_dynamics
- live_dynamics = mkUniqSet
- [ r | r@(UnmappedReg _ _) <- uniqSetToList live_through ]
+ Just conflicts -> conflicts `unionRegSets` live_dynamics
+ live_dynamics = mkRegSet
+ [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
doRegAlloc'
- :: (MachineRegisters a, MachineCode b)
- => [Int]
- -> RegHistory a
- -> RegInfo b
- -> b
- -> (RegHistory a, b)
+ :: [RegNo]
+ -> RegHistory MRegsState
+ -> RegInfo Instr
+ -> Instr
+ -> (RegHistory MRegsState, Instr)
doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
@@ -449,17 +248,17 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst
where
-- free up new registers
- free :: [Int]
+ free :: [RegNo]
free = extractMappedRegNos (map dynToStatic lastu)
-- (1) free registers that are used last as source operands in this instruction
- frs_not_in_use = frs `useMRegs` (extractMappedRegNos (uniqSetToList in_use))
+ frs_not_in_use = frs `useMRegs` (extractMappedRegNos (regSetToList in_use))
frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
-- (2) allocate new registers for the destination operands
-- allocate registers for new dynamics
- new_dynamix = [ r | r@(UnmappedReg _ _) <- uniqSetToList dsts, r `not_elem` keysFM env ]
+ new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ]
(frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
@@ -475,8 +274,7 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst
dynToStatic other = other
allocateNewRegs
- :: MachineRegisters a
- => Reg -> (a, Int, [(Reg, Reg)]) -> (a, Int, [(Reg, Reg)])
+ :: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)])
allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
where (fs', f, mem') = case acceptable fs of
@@ -486,17 +284,7 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst
acceptable regs = filter no_conflict (possibleMRegs pk regs)
no_conflict reg = case lookupFM conflicts reg of
Nothing -> True
- Just conflicts -> not (d `elementOfUniqSet` conflicts)
-\end{code}
-
-\begin{code}
-extractMappedRegNos :: [Reg] -> [Int]
-
-extractMappedRegNos regs
- = foldr ex [] regs
- where
- ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it
- ex _ acc = acc -- leave it out
+ Just conflicts -> not (d `elementOfRegSet` conflicts)
\end{code}
We keep a local copy of the Prelude function \tr{notElem},
diff --git a/ghc/compiler/nativeGen/I386Code.lhs b/ghc/compiler/nativeGen/I386Code.lhs
deleted file mode 100644
index 2205224d9227bb7ceb34789d3d7cc42b4d8d47c5..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/I386Code.lhs
+++ /dev/null
@@ -1,1365 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-
-\section[I386Code]{The Native (I386) Machine Code}
-
-\begin{code}
-#define ILIT2(x) ILIT(x)
-#include "HsVersions.h"
-
-module I386Code (
- Addr(..),
- Cond(..), Imm(..), Operand(..), Size(..),
- Base(..), Index(..), Displacement(..),
- I386Code(..),I386Instr(..),I386Regs,
- strImmLit,
- spRel,
-
- printLabeledCodes,
-
- baseRegOffset, stgRegMap, callerSaves,
-
- is13Bits, offset,
-
- kindToSize,
-
- st0, st1, eax, ebx, ecx, edx, esi, edi, ebp, esp,
-
- freeRegs, reservedRegs
-
- -- and, for self-sufficiency ...
- ) where
-
-import AbsCSyn ( MagicId(..) )
-import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..),
- Reg(..), RegUsage(..), RegLiveness(..)
- )
-import BitSet
-import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
-import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
-import FiniteMap
-import Maybes ( Maybe(..), maybeToBool )
-import OrdList ( OrdList, mkUnitList, flattenOrdList )
-import Outputable
-import UniqSet
-import Stix
-import Unpretty
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[I386Reg]{The Native (I386) Machine Register Table}
-%* *
-%************************************************************************
-
-- 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).
-- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
-- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
-- Registers 8-15 hold extended floating point values.
-
-ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM)
-
-\begin{code}
-
-gReg,fReg :: Int -> Int
-gReg x = x
-fReg x = (8 + x)
-
-st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg
-eax = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
-ebx = case (gReg 1) of { IBOX(g1) -> FixedReg g1 }
-ecx = case (gReg 2) of { IBOX(g2) -> FixedReg g2 }
-edx = case (gReg 3) of { IBOX(g3) -> FixedReg g3 }
-esi = case (gReg 4) of { IBOX(g4) -> FixedReg g4 }
-edi = case (gReg 5) of { IBOX(g5) -> FixedReg g5 }
-ebp = case (gReg 6) of { IBOX(g6) -> FixedReg g6 }
-esp = case (gReg 7) of { IBOX(g7) -> FixedReg g7 }
-st0 = realReg (fReg 0)
-st1 = realReg (fReg 1)
-st2 = realReg (fReg 2)
-st3 = realReg (fReg 3)
-st4 = realReg (fReg 4)
-st5 = realReg (fReg 5)
-st6 = realReg (fReg 6)
-st7 = realReg (fReg 7)
-
-realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TheI386Code]{The datatype for i386 assembly language}
-%* *
-%************************************************************************
-
-Here is a definition of the I386 assembly language.
-
-\begin{code}
-
-data Imm = ImmInt Int
- | ImmInteger Integer -- Sigh.
- | ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLab Unpretty -- Simple string label (underscored)
- | ImmLit Unpretty -- Simple string
- deriving ()
-
-strImmLit s = ImmLit (uppStr s)
-
-data Cond = ALWAYS
- | GEU
- | LU
- | EQ
- | GT
- | GE
- | GU
- | LT
- | LE
- | LEU
- | NE
- | NEG
- | POS
- deriving ()
-
-
-data Size = B
- | HB
- | S -- unused ?
- | L
- | F
- | D
- deriving ()
-
-data Operand = OpReg Reg -- register
- | OpImm Imm -- immediate value
- | OpAddr Addr -- memory reference
- deriving ()
-
-data Addr = Addr Base Index Displacement
- | ImmAddr Imm Int
- -- deriving Eq
-
-type Base = Maybe Reg
-type Index = Maybe (Reg, Int) -- Int is 2, 4 or 8
-type Displacement = Imm
-
-data I386Instr =
-
--- Moves.
-
- MOV Size Operand Operand
- | MOVZX Size Operand Operand -- size is the size of operand 2
- | MOVSX Size Operand Operand -- size is the size of operand 2
-
--- 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
-
--- Multiplication (signed and unsigned), Division (signed and unsigned),
--- result in %eax, %edx.
-
- | IMUL Size Operand Operand
- | IDIV Size Operand
-
--- 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 Operand Operand -- 1st operand must be an Imm
- | SAR Size Operand Operand -- 1st operand must be an Imm
- | SHR Size Operand Operand -- 1st operand must be an Imm
- | NOP
-
--- Float Arithmetic. -- ToDo for 386
-
--- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
--- right up until we spit them out.
-
- | SAHF -- stores ah into flags
- | FABS
- | FADD Size Operand -- src
- | FADDP
- | FIADD Size Addr -- src
- | FCHS
- | FCOM Size Operand -- src
- | FCOS
- | FDIV Size Operand -- src
- | FDIVP
- | FIDIV Size Addr -- src
- | FDIVR Size Operand -- src
- | FDIVRP
- | FIDIVR Size Addr -- src
- | FICOM Size Addr -- src
- | FILD Size Addr Reg -- src, dst
- | FIST Size Addr -- dst
- | FLD Size Operand -- src
- | FLD1
- | FLDZ
- | FMUL Size Operand -- src
- | FMULP
- | FIMUL Size Addr -- src
- | FRNDINT
- | FSIN
- | FSQRT
- | FST Size Operand -- dst
- | FSTP Size Operand -- dst
- | FSUB Size Operand -- src
- | FSUBP
- | FISUB Size Addr -- src
- | FSUBR Size Operand -- src
- | FSUBRP
- | FISUBR Size Addr -- src
- | FTST
- | FCOMP Size Operand -- src
- | FUCOMPP
- | FXCH
- | FNSTSW
- | FNOP
-
--- Comparison
-
- | TEST Size Operand Operand
- | CMP Size Operand Operand
- | SETCC Cond Operand
-
--- Stack Operations.
-
- | PUSH Size Operand
- | POP Size Operand
-
--- Jumping around.
-
- | JMP Operand -- target
- | JXX Cond CLabel -- target
- | CALL Imm
-
--- Other things.
-
- | CLTD -- sign extend %eax into %edx:%eax
-
--- Pseudo-ops.
-
- | LABEL CLabel
- | COMMENT FAST_STRING
- | SEGMENT CodeSegment
- | ASCII Bool String -- needs backslash conversion?
- | DATA Size [Imm]
-
-type I386Code = OrdList I386Instr
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TheI386Pretty]{Pretty-printing the I386 Assembly Language}
-%* *
-%************************************************************************
-
-\begin{code}
-
-printLabeledCodes :: PprStyle -> [I386Instr] -> Unpretty
-printLabeledCodes sty codes = uppAboves (map (pprI386Instr sty) codes)
-
-\end{code}
-
-Printing the pieces...
-
-\begin{code}
-
-pprReg :: Size -> Reg -> Unpretty
-
-pprReg s (FixedReg i) = pprI386Reg s i
-pprReg s (MappedReg i) = pprI386Reg s i
-pprReg s other = uppStr (show other) -- should only happen when debugging
-
-pprI386Reg :: Size -> FAST_INT -> Unpretty
-pprI386Reg B i = uppPStr
- (case i of {
- ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl");
- ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl");
- _ -> SLIT("very naughty I386 byte register")
- })
-
-pprI386Reg HB i = uppPStr
- (case i of {
- ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
- ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh");
- _ -> SLIT("very naughty I386 high byte register")
- })
-
-pprI386Reg S i = uppPStr
- (case i of {
- ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx");
- ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx");
- ILIT( 4) -> SLIT("%si"); ILIT( 5) -> SLIT("%di");
- ILIT( 6) -> SLIT("%bp"); ILIT( 7) -> SLIT("%sp");
- _ -> SLIT("very naughty I386 word register")
- })
-
-pprI386Reg L i = uppPStr
- (case i of {
- ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx");
- ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx");
- ILIT( 4) -> SLIT("%esi"); ILIT( 5) -> SLIT("%edi");
- ILIT( 6) -> SLIT("%ebp"); ILIT( 7) -> SLIT("%esp");
- _ -> SLIT("very naughty I386 double word register")
- })
-
-pprI386Reg F i = uppPStr
- (case i of {
---ToDo: rm these
- ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
- ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
- ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
- ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
- _ -> SLIT("very naughty I386 float register")
- })
-
-pprI386Reg D i = uppPStr
- (case i of {
---ToDo: rm these
- ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
- ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
- ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
- ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
- _ -> SLIT("very naughty I386 float register")
- })
-
-pprCond :: Cond -> Unpretty -- ToDo
-pprCond x = uppPStr
- (case x of {
- GEU -> SLIT("ae"); LU -> SLIT("b");
- EQ -> SLIT("e"); GT -> SLIT("g");
- GE -> SLIT("ge"); GU -> SLIT("a");
- LT -> SLIT("l"); LE -> SLIT("le");
- LEU -> SLIT("be"); NE -> SLIT("ne");
- NEG -> SLIT("s"); POS -> SLIT("ns");
- ALWAYS -> SLIT("mp"); -- hack
- _ -> error "Spix: iI386Code: unknown conditional!"
- })
-
-pprDollImm :: PprStyle -> Imm -> Unpretty
-
-pprDollImm sty i = uppBesides [ uppPStr SLIT("$"), pprImm sty i]
-
-pprImm :: PprStyle -> Imm -> Unpretty
-
-pprImm sty (ImmInt i) = uppInt i
-pprImm sty (ImmInteger i) = uppInteger i
-pprImm sty (ImmCLbl l) = pprCLabel sty l
-pprImm sty (ImmLab l) = l
-
---pprImm (PprForAsm _ False _) (ImmLab s) = s
---pprImm _ (ImmLab s) = uppBeside (uppChar '_') s
-
-pprImm sty (ImmLit s) = s
-
-pprAddr :: PprStyle -> Addr -> Unpretty
-pprAddr sty (ImmAddr imm off)
- = uppBesides [pprImm sty imm,
- if off > 0 then uppChar '+' else uppPStr SLIT(""),
- if off == 0 then uppPStr SLIT("") else uppInt off
- ]
-pprAddr sty (Addr Nothing Nothing displacement)
- = uppBesides [pprDisp sty displacement]
-pprAddr sty (Addr base index displacement)
- = uppBesides [pprDisp sty displacement,
- uppChar '(',
- pprBase base,
- pprIndex index,
- uppChar ')'
- ]
- where
- pprBase (Just r) = uppBesides [pprReg L r,
- case index of
- Nothing -> uppPStr SLIT("")
- _ -> uppChar ','
- ]
- pprBase _ = uppPStr SLIT("")
- pprIndex (Just (r,i)) = uppBesides [pprReg L r, uppChar ',', uppInt i]
- pprIndex _ = uppPStr SLIT("")
-
-pprDisp sty (ImmInt 0) = uppPStr SLIT("")
---pprDisp sty (ImmInteger 0) = uppPStr SLIT("")
-pprDisp sty d = pprImm sty d
-
-pprOperand :: PprStyle -> Size -> Operand -> Unpretty
-pprOperand sty s (OpReg r) = pprReg s r
-pprOperand sty s (OpImm i) = pprDollImm sty i
-pprOperand sty s (OpAddr ea) = pprAddr sty ea
-
-pprSize :: Size -> Unpretty
-pprSize x = uppPStr
- (case x of
- B -> SLIT("b")
- HB -> SLIT("b")
- S -> SLIT("w")
- L -> SLIT("l")
- F -> SLIT("s")
- D -> SLIT("l")
- )
-
-pprSizeOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Unpretty
-pprSizeOp sty name size op1 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- pprSize size,
- uppChar ' ',
- pprOperand sty size op1
- ]
-
-pprSizeOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty
-pprSizeOpOp sty name size op1 op2 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- pprSize size,
- uppChar ' ',
- pprOperand sty size op1,
- uppComma,
- pprOperand sty size op2
- ]
-
-pprSizeOpReg :: PprStyle -> FAST_STRING -> Size -> Operand -> Reg -> Unpretty
-pprSizeOpReg sty name size op1 reg =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- pprSize size,
- uppChar ' ',
- pprOperand sty size op1,
- uppComma,
- pprReg size reg
- ]
-
-pprSizeAddr :: PprStyle -> FAST_STRING -> Size -> Addr -> Unpretty
-pprSizeAddr sty name size op =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- pprSize size,
- uppChar ' ',
- pprAddr sty op
- ]
-
-pprSizeAddrReg :: PprStyle -> FAST_STRING -> Size -> Addr -> Reg -> Unpretty
-pprSizeAddrReg sty name size op dst =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- pprSize size,
- uppChar ' ',
- pprAddr sty op,
- uppComma,
- pprReg size dst
- ]
-
-pprOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty
-pprOpOp sty name size op1 op2 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- uppChar ' ',
- pprOperand sty size op1,
- uppComma,
- pprOperand sty size op2
- ]
-
-pprSizeOpOpCoerce :: PprStyle -> FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty
-pprSizeOpOpCoerce sty name size1 size2 op1 op2 =
- uppBesides [ uppChar '\t', uppPStr name, uppChar ' ',
- pprOperand sty size1 op1,
- uppComma,
- pprOperand sty size2 op2
- ]
-
-pprCondInstr :: PprStyle -> FAST_STRING -> Cond -> Unpretty -> Unpretty
-pprCondInstr sty name cond arg =
- uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppChar ' ', arg]
-
-pprI386Instr :: PprStyle -> I386Instr -> Unpretty
-pprI386Instr sty (MOV size (OpReg src) (OpReg dst)) -- hack
- | src == dst
- = uppPStr SLIT("")
-pprI386Instr sty (MOV size src dst)
- = pprSizeOpOp sty SLIT("mov") size src dst
-pprI386Instr sty (MOVZX size src dst) = pprSizeOpOpCoerce sty SLIT("movzx") L size src dst
-pprI386Instr sty (MOVSX size src dst) = pprSizeOpOpCoerce sty SLIT("movxs") L size src dst
-
--- here we do some patching, since the physical registers are only set late
--- in the code generation.
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
- | reg1 == reg3
- = pprSizeOpOp sty SLIT("add") size (OpReg reg2) dst
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
- | reg2 == reg3
- = pprSizeOpOp sty SLIT("add") size (OpReg reg1) dst
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
- | reg1 == reg3
- = pprI386Instr sty (ADD size (OpImm displ) dst)
-pprI386Instr sty (LEA size src dst) = pprSizeOpOp sty SLIT("lea") size src dst
-
-pprI386Instr sty (ADD size (OpImm (ImmInt (-1))) dst)
- = pprSizeOp sty SLIT("dec") size dst
-pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst)
- = pprSizeOp sty SLIT("inc") size dst
-pprI386Instr sty (ADD size src dst)
- = pprSizeOpOp sty SLIT("add") size src dst
-pprI386Instr sty (SUB size src dst) = pprSizeOpOp sty SLIT("sub") size src dst
-pprI386Instr sty (IMUL size op1 op2) = pprSizeOpOp sty SLIT("imul") size op1 op2
-pprI386Instr sty (IDIV size op) = pprSizeOp sty SLIT("idiv") size op
-
-pprI386Instr sty (AND size src dst) = pprSizeOpOp sty SLIT("and") size src dst
-pprI386Instr sty (OR size src dst) = pprSizeOpOp sty SLIT("or") size src dst
-pprI386Instr sty (XOR size src dst) = pprSizeOpOp sty SLIT("xor") size src dst
-pprI386Instr sty (NOT size op) = pprSizeOp sty SLIT("not") size op
-pprI386Instr sty (NEGI size op) = pprSizeOp sty SLIT("neg") size op
-pprI386Instr sty (SHL size imm dst) = pprSizeOpOp sty SLIT("shl") size imm dst
-pprI386Instr sty (SAR size imm dst) = pprSizeOpOp sty SLIT("sar") size imm dst
-pprI386Instr sty (SHR size imm dst) = pprSizeOpOp sty SLIT("shr") size imm dst
-
-pprI386Instr sty (CMP size src dst) = pprSizeOpOp sty SLIT("cmp") size src dst
-pprI386Instr sty (TEST size src dst) = pprSizeOpOp sty SLIT("test") size src dst
-pprI386Instr sty (PUSH size op) = pprSizeOp sty SLIT("push") size op
-pprI386Instr sty (POP size op) = pprSizeOp sty SLIT("pop") size op
-
-pprI386Instr sty (NOP) = uppPStr SLIT("\tnop")
-pprI386Instr sty (CLTD) = uppPStr SLIT("\tcltd")
-
-pprI386Instr sty (SETCC cond op) = pprCondInstr sty SLIT("set") cond (pprOperand sty B op)
-
-pprI386Instr sty (JXX cond lab) = pprCondInstr sty SLIT("j") cond (pprCLabel sty lab)
-
-pprI386Instr sty (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm sty imm)
-pprI386Instr sty (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand sty L op)
-
-pprI386Instr sty (CALL imm) =
- uppBesides [ uppPStr SLIT("\tcall "), pprImm sty imm ]
-
-pprI386Instr sty SAHF = uppPStr SLIT("\tsahf")
-pprI386Instr sty FABS = uppPStr SLIT("\tfabs")
-
-pprI386Instr sty (FADD sz src@(OpAddr _))
- = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty (FADD sz src)
- = uppPStr SLIT("\tfadd")
-pprI386Instr sty FADDP
- = uppPStr SLIT("\tfaddp")
-pprI386Instr sty (FMUL sz src)
- = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty FMULP
- = uppPStr SLIT("\tfmulp")
-pprI386Instr sty (FIADD size op) = pprSizeAddr sty SLIT("fiadd") size op
-pprI386Instr sty FCHS = uppPStr SLIT("\tfchs")
-pprI386Instr sty (FCOM size op) = pprSizeOp sty SLIT("fcom") size op
-pprI386Instr sty FCOS = uppPStr SLIT("\tfcos")
-pprI386Instr sty (FIDIV size op) = pprSizeAddr sty SLIT("fidiv") size op
-pprI386Instr sty (FDIV sz src)
- = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty FDIVP
- = uppPStr SLIT("\tfdivp")
-pprI386Instr sty (FDIVR sz src)
- = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty FDIVRP
- = uppPStr SLIT("\tfdivpr")
-pprI386Instr sty (FIDIVR size op) = pprSizeAddr sty SLIT("fidivr") size op
-pprI386Instr sty (FICOM size op) = pprSizeAddr sty SLIT("ficom") size op
-pprI386Instr sty (FILD sz op reg) = pprSizeAddrReg sty SLIT("fild") sz op reg
-pprI386Instr sty (FIST size op) = pprSizeAddr sty SLIT("fist") size op
-pprI386Instr sty (FLD sz (OpImm (ImmCLbl src)))
- = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprCLabel sty src]
-pprI386Instr sty (FLD sz src)
- = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprOperand sty sz src]
-pprI386Instr sty FLD1 = uppPStr SLIT("\tfld1")
-pprI386Instr sty FLDZ = uppPStr SLIT("\tfldz")
-pprI386Instr sty (FIMUL size op) = pprSizeAddr sty SLIT("fimul") size op
-pprI386Instr sty FRNDINT = uppPStr SLIT("\tfrndint")
-pprI386Instr sty FSIN = uppPStr SLIT("\tfsin")
-pprI386Instr sty FSQRT = uppPStr SLIT("\tfsqrt")
-pprI386Instr sty (FST sz dst)
- = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
-pprI386Instr sty (FSTP sz dst)
- = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
-pprI386Instr sty (FISUB size op) = pprSizeAddr sty SLIT("fisub") size op
-pprI386Instr sty (FSUB sz src)
- = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty FSUBP
- = uppPStr SLIT("\tfsubp")
-pprI386Instr sty (FSUBR size src)
- = pprSizeOp sty SLIT("fsubr") size src
-pprI386Instr sty FSUBRP
- = uppPStr SLIT("\tfsubpr")
-pprI386Instr sty (FISUBR size op)
- = pprSizeAddr sty SLIT("fisubr") size op
-pprI386Instr sty FTST = uppPStr SLIT("\tftst")
-pprI386Instr sty (FCOMP sz op)
- = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppChar ' ', pprOperand sty sz op]
-pprI386Instr sty FUCOMPP = uppPStr SLIT("\tfucompp")
-pprI386Instr sty FXCH = uppPStr SLIT("\tfxch")
-pprI386Instr sty FNSTSW = uppPStr SLIT("\tfnstsw %ax")
-pprI386Instr sty FNOP = uppPStr SLIT("")
-
-pprI386Instr sty (LABEL clab) =
- uppBesides [
- if (externallyVisibleCLabel clab) then
- uppBesides [uppPStr SLIT(".globl "), pprLab, uppChar '\n']
- else
- uppNil,
- pprLab,
- uppChar ':'
- ]
- where pprLab = pprCLabel sty clab
-
-pprI386Instr sty (COMMENT s) = uppBeside (uppPStr SLIT("# ")) (uppPStr s)
-
-pprI386Instr sty (SEGMENT TextSegment)
- = uppPStr SLIT(".text\n\t.align 4")
-
-pprI386Instr sty (SEGMENT DataSegment)
- = uppPStr SLIT(".data\n\t.align 2")
-
-pprI386Instr sty (ASCII False str) =
- uppBesides [
- uppStr "\t.asciz \"",
- uppStr str,
- uppChar '"'
- ]
-
-pprI386Instr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
- where
- asciify :: String -> Int -> Unpretty
- asciify [] _ = uppStr ("\\0\"")
- asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
- asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
- asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
- asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
- asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
- asciify (c:(cs@(d:_))) n | isDigit d =
- uppBeside (uppStr (charToC c)) (asciify cs 0)
- | otherwise =
- uppBeside (uppStr (charToC c)) (asciify cs (n-1))
-
-pprI386Instr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs)
- where pp_item x = case s of
- B -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
- HB-> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
- S -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x)
- L -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x)
- F -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x)
- D -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Schedule]{Register allocation information}
-%* *
-%************************************************************************
-
-\begin{code}
-
-data I386Regs = SRegs BitSet BitSet
-
-instance MachineRegisters I386Regs where
- mkMRegs xs = SRegs (mkBS ints) (mkBS floats')
- where
- (ints, floats) = partition (< 8) xs
- floats' = map (subtract 8) floats
-
- possibleMRegs FloatRep (SRegs _ floats) = [ x + 8 | x <- listBS floats]
- possibleMRegs DoubleRep (SRegs _ floats) = [ x + 8 | x <- listBS floats]
- possibleMRegs _ (SRegs ints _) = listBS ints
-
- useMReg (SRegs ints floats) n =
- if n _LT_ ILIT(8) then SRegs (ints `minusBS` singletonBS IBOX(n)) floats
- else SRegs ints (floats `minusBS` singletonBS (IBOX(n _SUB_ ILIT(8))))
-
- useMRegs (SRegs ints floats) xs =
- SRegs (ints `minusBS` ints')
- (floats `minusBS` floats')
- where
- SRegs ints' floats' = mkMRegs xs
-
- freeMReg (SRegs ints floats) n =
- if n _LT_ ILIT(8) then SRegs (ints `unionBS` singletonBS IBOX(n)) floats
- else SRegs ints (floats `unionBS` singletonBS (IBOX(n _SUB_ ILIT(8))))
-
- freeMRegs (SRegs ints floats) xs =
- SRegs (ints `unionBS` ints')
- (floats `unionBS` floats')
- where
- SRegs ints' floats' = mkMRegs xs
-
-instance MachineCode I386Instr where
- regUsage = i386RegUsage
- regLiveness = i386RegLiveness
- patchRegs = i386PatchRegs
-
- -- We spill just below the stack pointer, leaving two words per spill location.
- spillReg dyn (MemoryReg i pk)
- = trace "spillsave"
- (mkUnitList (MOV (kindToSize pk) (OpReg dyn) (OpAddr (spRel (-2 * i)))))
- loadReg (MemoryReg i pk) dyn
- = trace "spillload"
- (mkUnitList (MOV (kindToSize pk) (OpAddr (spRel (-2 * i))) (OpReg dyn)))
-
---spRel gives us a stack relative addressing mode for volatile temporaries
---and for excess call arguments.
-
-spRel
- :: Int -- desired stack offset in words, positive or negative
- -> Addr
-spRel n = Addr (Just esp) Nothing (ImmInt (n * 4))
-
-kindToSize :: PrimRep -> Size
-kindToSize PtrRep = L
-kindToSize CodePtrRep = L
-kindToSize DataPtrRep = L
-kindToSize RetRep = L
-kindToSize CostCentreRep = L
-kindToSize CharRep = L
-kindToSize IntRep = L
-kindToSize WordRep = L
-kindToSize AddrRep = L
-kindToSize FloatRep = F
-kindToSize DoubleRep = D
-kindToSize ArrayRep = L
-kindToSize ByteArrayRep = L
-kindToSize StablePtrRep = L
-kindToSize MallocPtrRep = L
-
-\end{code}
-
-@i386RegUsage@ 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!)
-
-\begin{code}
-
-i386RegUsage :: I386Instr -> RegUsage
-i386RegUsage instr = case instr of
- MOV sz src dst -> usage2 src dst
- MOVZX sz src dst -> usage2 src dst
- MOVSX sz src dst -> usage2 src dst
- LEA sz src dst -> usage2 src dst
- ADD sz src dst -> usage2 src dst
- SUB sz src dst -> usage2 src dst
- IMUL sz src dst -> usage2 src dst
- IDIV sz src -> usage (eax:edx:opToReg src) [eax,edx]
- AND sz src dst -> usage2 src dst
- OR sz src dst -> usage2 src dst
- XOR sz src dst -> usage2 src dst
- NOT sz op -> usage1 op
- NEGI sz op -> usage1 op
- SHL sz imm dst -> usage1 dst -- imm has to be an Imm
- SAR sz imm dst -> usage1 dst -- imm has to be an Imm
- SHR sz imm dst -> usage1 dst -- imm has to be an Imm
- PUSH sz op -> usage (opToReg op) []
- POP sz op -> usage [] (opToReg op)
- TEST sz src dst -> usage (opToReg src ++ opToReg dst) []
- CMP sz src dst -> usage (opToReg src ++ opToReg dst) []
- SETCC cond op -> usage [] (opToReg op)
- JXX cond label -> usage [] []
- JMP op -> usage (opToReg op) freeRegs
- CALL imm -> usage [] callClobberedRegs
- CLTD -> usage [eax] [edx]
- NOP -> usage [] []
- SAHF -> usage [eax] []
- FABS -> usage [st0] [st0]
- FADD sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
- FADDP -> usage [st0,st1] [st0] -- allFPRegs
- FIADD sz asrc -> usage (addrToRegs asrc) [st0]
- FCHS -> usage [st0] [st0]
- FCOM sz src -> usage (st0:opToReg src) []
- FCOS -> usage [st0] [st0]
- FDIV sz src -> usage (st0:opToReg src) [st0]
- FDIVP -> usage [st0,st1] [st0]
- FDIVRP -> usage [st0,st1] [st0]
- FIDIV sz asrc -> usage (addrToRegs asrc) [st0]
- FDIVR sz src -> usage (st0:opToReg src) [st0]
- FIDIVR sz asrc -> usage (addrToRegs asrc) [st0]
- FICOM sz asrc -> usage (addrToRegs asrc) []
- FILD sz asrc dst -> usage (addrToRegs asrc) [dst] -- allFPRegs
- FIST sz adst -> usage (st0:addrToRegs adst) []
- FLD sz src -> usage (opToReg src) [st0] -- allFPRegs
- FLD1 -> usage [] [st0] -- allFPRegs
- FLDZ -> usage [] [st0] -- allFPRegs
- FMUL sz src -> usage (st0:opToReg src) [st0]
- FMULP -> usage [st0,st1] [st0]
- FIMUL sz asrc -> usage (addrToRegs asrc) [st0]
- FRNDINT -> usage [st0] [st0]
- FSIN -> usage [st0] [st0]
- FSQRT -> usage [st0] [st0]
- FST sz (OpReg r) -> usage [st0] [r]
- FST sz dst -> usage (st0:opToReg dst) []
- FSTP sz (OpReg r) -> usage [st0] [r] -- allFPRegs
- FSTP sz dst -> usage (st0:opToReg dst) [] -- allFPRegs
- FSUB sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
- FSUBR sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
- FISUB sz asrc -> usage (addrToRegs asrc) [st0]
- FSUBP -> usage [st0,st1] [st0] -- allFPRegs
- FSUBRP -> usage [st0,st1] [st0] -- allFPRegs
- FISUBR sz asrc -> usage (addrToRegs asrc) [st0]
- FTST -> usage [st0] []
- FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs
- FUCOMPP -> usage [st0, st1] [] -- allFPRegs
- FXCH -> usage [st0, st1] [st0, st1]
- FNSTSW -> usage [] [eax]
- _ -> noUsage
-
- where
-
- usage2 :: Operand -> Operand -> RegUsage
- usage2 op (OpReg reg) = usage (opToReg op) [reg]
- usage2 op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) []
- usage2 op (OpImm imm) = usage (opToReg op) []
- usage1 :: Operand -> RegUsage
- usage1 (OpReg reg) = usage [reg] [reg]
- usage1 (OpAddr ea) = usage (addrToRegs ea) []
- allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7]
- --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
- callClobberedRegs = [eax]
-
--- General purpose register collecting functions.
-
- opToReg (OpReg reg) = [reg]
- opToReg (OpImm imm) = []
- opToReg (OpAddr ea) = addrToRegs ea
-
- addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index
- where baseToReg Nothing = []
- baseToReg (Just r) = [r]
- indexToReg Nothing = []
- indexToReg (Just (r,_)) = [r]
- addrToRegs (ImmAddr _ _) = []
-
- usage src dst = RU (mkUniqSet (filter interesting src))
- (mkUniqSet (filter interesting dst))
-
- interesting (FixedReg _) = False
- interesting _ = True
-
-freeRegs :: [Reg]
-freeRegs = freeMappedRegs (\ x -> x) [0..15]
-
-freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg]
-
-freeMappedRegs modify nums
- = foldr free [] nums
- where
- free n acc
- = let
- modified_i = case (modify n) of { IBOX(x) -> x }
- in
- if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc
-
-freeSet :: UniqSet Reg
-freeSet = mkUniqSet freeRegs
-
-noUsage :: RegUsage
-noUsage = RU emptyUniqSet emptyUniqSet
-
-endUsage :: RegUsage
-endUsage = RU emptyUniqSet freeSet
-
-\end{code}
-
-@i386RegLiveness@ takes future liveness information and modifies it according to
-the semantics of branches and labels. (An out-of-line branch clobbers the liveness
-passed back by the following instruction; a forward local branch passes back the
-liveness from the target label; a conditional branch merges the liveness from the
-target and the liveness from its successor; a label stashes away the current liveness
-in the future liveness environment).
-
-\begin{code}
-i386RegLiveness :: I386Instr -> RegLiveness -> RegLiveness
-i386RegLiveness instr info@(RL live future@(FL all env)) = case instr of
-
- JXX _ lbl -> RL (lookup lbl `unionUniqSets` live) future
- JMP _ -> RL emptyUniqSet future
- CALL _ -> RL live future
- LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
- _ -> info
-
- where
- lookup lbl = case lookupFM env lbl of
- Just regs -> regs
- Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
- " in future?") emptyUniqSet
-
-\end{code}
-
-@i386PatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and
-changes all register references according to the supplied environment.
-
-\begin{code}
-
-i386PatchRegs :: I386Instr -> (Reg -> Reg) -> I386Instr
-i386PatchRegs instr env = case instr of
- MOV sz src dst -> patch2 (MOV sz) src dst
- MOVZX sz src dst -> patch2 (MOVZX sz) src dst
- MOVSX sz src dst -> patch2 (MOVSX sz) src dst
- LEA sz src dst -> patch2 (LEA sz) src dst
- ADD sz src dst -> patch2 (ADD sz) src dst
- SUB sz src dst -> patch2 (SUB sz) src dst
- IMUL sz src dst -> patch2 (IMUL sz) src dst
- IDIV sz src -> patch1 (IDIV sz) src
- 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
- NOT sz op -> patch1 (NOT sz) op
- NEGI sz op -> patch1 (NEGI sz) op
- SHL sz imm dst -> patch1 (SHL sz imm) dst
- SAR sz imm dst -> patch1 (SAR sz imm) dst
- SHR sz imm dst -> patch1 (SHR sz imm) dst
- TEST sz src dst -> patch2 (TEST sz) src dst
- CMP sz src dst -> patch2 (CMP 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 op -> patch1 JMP op
- FADD sz src -> FADD sz (patchOp src)
- FIADD sz asrc -> FIADD sz (lookupAddr asrc)
- FCOM sz src -> patch1 (FCOM sz) src
- FDIV sz src -> FDIV sz (patchOp src)
- --FDIVP sz src -> FDIVP sz (patchOp src)
- FIDIV sz asrc -> FIDIV sz (lookupAddr asrc)
- FDIVR sz src -> FDIVR sz (patchOp src)
- --FDIVRP sz src -> FDIVRP sz (patchOp src)
- FIDIVR sz asrc -> FIDIVR sz (lookupAddr asrc)
- FICOM sz asrc -> FICOM sz (lookupAddr asrc)
- FILD sz asrc dst -> FILD sz (lookupAddr asrc) (env dst)
- FIST sz adst -> FIST sz (lookupAddr adst)
- FLD sz src -> patch1 (FLD sz) (patchOp src)
- FMUL sz src -> FMUL sz (patchOp src)
- --FMULP sz src -> FMULP sz (patchOp src)
- FIMUL sz asrc -> FIMUL sz (lookupAddr asrc)
- FST sz dst -> FST sz (patchOp dst)
- FSTP sz dst -> FSTP sz (patchOp dst)
- FSUB sz src -> FSUB sz (patchOp src)
- --FSUBP sz src -> FSUBP sz (patchOp src)
- FISUB sz asrc -> FISUB sz (lookupAddr asrc)
- FSUBR sz src -> FSUBR sz (patchOp src)
- --FSUBRP sz src -> FSUBRP sz (patchOp src)
- FISUBR sz asrc -> FISUBR sz (lookupAddr asrc)
- FCOMP sz src -> FCOMP sz (patchOp src)
- _ -> instr
-
- where
- 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
- patchOp (OpAddr ea) = OpAddr (lookupAddr ea)
-
- lookupAddr (Addr base index disp)
- = Addr (lookupBase base) (lookupIndex index) disp
- where lookupBase Nothing = Nothing
- lookupBase (Just r) = Just (env r)
- lookupIndex Nothing = Nothing
- lookupIndex (Just (r,i)) = Just (env r, i)
- lookupAddr (ImmAddr imm off)
- = ImmAddr imm off
-
-\end{code}
-
-Sometimes, we want to be able to modify addresses at compile time.
-(Okay, just for chrCode of a fetch.)
-
-\begin{code}
-{-# SPECIALIZE
- is13Bits :: Int -> Bool
- #-}
-{-# SPECIALIZE
- is13Bits :: Integer -> Bool
- #-}
-
-is13Bits :: Integral a => a -> Bool
-is13Bits x = x >= -4096 && x < 4096
-
-offset :: Addr -> Int -> Maybe Addr
-offset (Addr reg index (ImmInt n)) off
- = Just (Addr reg index (ImmInt n2))
- where n2 = n + off
-
-offset (Addr reg index (ImmInteger n)) off
- = Just (Addr reg index (ImmInt (fromInteger n2)))
- where n2 = n + toInteger off
-
-offset (ImmAddr imm off1) off2
- = Just (ImmAddr imm off3)
- where off3 = off1 + off2
-
-offset _ _ = Nothing
-\end{code}
-
-If you value your sanity, do not venture below this line.
-
-\begin{code}
-
--- platform.h is generate and tells us what the target architecture is
-#include "../../includes/platform.h"
-#define STOLEN_X86_REGS 5
-#include "../../includes/MachRegs.h"
-#include "../../includes/i386-unknown-linuxaout.h"
-
--- Redefine the literals used for I386 register names in the header
--- files. Gag me with a spoon, eh?
-
-#define eax 0
-#define ebx 1
-#define ecx 2
-#define edx 3
-#define esi 4
-#define edi 5
-#define ebp 6
-#define esp 7
-#define st0 8
-#define st1 9
-#define st2 10
-#define st3 11
-#define st4 12
-#define st5 13
-#define st6 14
-#define st7 15
-#define CALLER_SAVES_Hp
--- ToDo: rm when we give esp back
-#define REG_Hp esp
-#define REG_R2 ecx
-
-baseRegOffset :: MagicId -> Int
-baseRegOffset StkOReg = OFFSET_StkO
-baseRegOffset (VanillaReg _ ILIT2(1)) = OFFSET_R1
-baseRegOffset (VanillaReg _ ILIT2(2)) = OFFSET_R2
-baseRegOffset (VanillaReg _ ILIT2(3)) = OFFSET_R3
-baseRegOffset (VanillaReg _ ILIT2(4)) = OFFSET_R4
-baseRegOffset (VanillaReg _ ILIT2(5)) = OFFSET_R5
-baseRegOffset (VanillaReg _ ILIT2(6)) = OFFSET_R6
-baseRegOffset (VanillaReg _ ILIT2(7)) = OFFSET_R7
-baseRegOffset (VanillaReg _ ILIT2(8)) = OFFSET_R8
-baseRegOffset (FloatReg ILIT2(1)) = OFFSET_Flt1
-baseRegOffset (FloatReg ILIT2(2)) = OFFSET_Flt2
-baseRegOffset (FloatReg ILIT2(3)) = OFFSET_Flt3
-baseRegOffset (FloatReg ILIT2(4)) = OFFSET_Flt4
-baseRegOffset (DoubleReg ILIT2(1)) = OFFSET_Dbl1
-baseRegOffset (DoubleReg ILIT2(2)) = OFFSET_Dbl2
-baseRegOffset TagReg = OFFSET_Tag
-baseRegOffset RetReg = OFFSET_Ret
-baseRegOffset SpA = OFFSET_SpA
-baseRegOffset SuA = OFFSET_SuA
-baseRegOffset SpB = OFFSET_SpB
-baseRegOffset SuB = OFFSET_SuB
-baseRegOffset Hp = OFFSET_Hp
-baseRegOffset HpLim = OFFSET_HpLim
-baseRegOffset LivenessReg = OFFSET_Liveness
---baseRegOffset ActivityReg = OFFSET_Activity
-#ifdef DEBUG
-baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
-baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg"
-baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg"
-baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre"
-baseRegOffset VoidReg = panic "baseRegOffset:VoidReg"
-#endif
-
-callerSaves :: MagicId -> Bool
-#ifdef CALLER_SAVES_Base
-callerSaves BaseReg = True
-#endif
-#ifdef CALLER_SAVES_StkO
-callerSaves StkOReg = True
-#endif
-#ifdef CALLER_SAVES_R1
-callerSaves (VanillaReg _ ILIT2(1)) = True
-#endif
-#ifdef CALLER_SAVES_R2
-callerSaves (VanillaReg _ ILIT2(2)) = True
-#endif
-#ifdef CALLER_SAVES_R3
-callerSaves (VanillaReg _ ILIT2(3)) = True
-#endif
-#ifdef CALLER_SAVES_R4
-callerSaves (VanillaReg _ ILIT2(4)) = True
-#endif
-#ifdef CALLER_SAVES_R5
-callerSaves (VanillaReg _ ILIT2(5)) = True
-#endif
-#ifdef CALLER_SAVES_R6
-callerSaves (VanillaReg _ ILIT2(6)) = True
-#endif
-#ifdef CALLER_SAVES_R7
-callerSaves (VanillaReg _ ILIT2(7)) = True
-#endif
-#ifdef CALLER_SAVES_R8
-callerSaves (VanillaReg _ ILIT2(8)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg1
-callerSaves (FloatReg ILIT2(1)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg2
-callerSaves (FloatReg ILIT2(2)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg3
-callerSaves (FloatReg ILIT2(3)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg4
-callerSaves (FloatReg ILIT2(4)) = True
-#endif
-#ifdef CALLER_SAVES_DblReg1
-callerSaves (DoubleReg ILIT2(1)) = True
-#endif
-#ifdef CALLER_SAVES_DblReg2
-callerSaves (DoubleReg ILIT2(2)) = True
-#endif
-#ifdef CALLER_SAVES_Tag
-callerSaves TagReg = True
-#endif
-#ifdef CALLER_SAVES_Ret
-callerSaves RetReg = True
-#endif
-#ifdef CALLER_SAVES_SpA
-callerSaves SpA = True
-#endif
-#ifdef CALLER_SAVES_SuA
-callerSaves SuA = True
-#endif
-#ifdef CALLER_SAVES_SpB
-callerSaves SpB = True
-#endif
-#ifdef CALLER_SAVES_SuB
-callerSaves SuB = True
-#endif
-#ifdef CALLER_SAVES_Hp
-callerSaves Hp = True
-#endif
-#ifdef CALLER_SAVES_HpLim
-callerSaves HpLim = True
-#endif
-#ifdef CALLER_SAVES_Liveness
-callerSaves LivenessReg = True
-#endif
-#ifdef CALLER_SAVES_Activity
---callerSaves ActivityReg = True
-#endif
-#ifdef CALLER_SAVES_StdUpdRetVec
-callerSaves StdUpdRetVecReg = True
-#endif
-#ifdef CALLER_SAVES_StkStub
-callerSaves StkStubReg = True
-#endif
-callerSaves _ = False
-
-stgRegMap :: MagicId -> Maybe Reg
-
-#ifdef REG_Base
-stgRegMap BaseReg = Just (FixedReg ILIT(REG_Base))
-#endif
-#ifdef REG_StkO
-stgRegMap StkOReg = Just (FixedReg ILIT(REG_StkOReg))
-#endif
-#ifdef REG_R1
-stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1))
-#endif
-#ifdef REG_R2
-stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2))
-#endif
-#ifdef REG_R3
-stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3))
-#endif
-#ifdef REG_R4
-stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4))
-#endif
-#ifdef REG_R5
-stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5))
-#endif
-#ifdef REG_R6
-stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6))
-#endif
-#ifdef REG_R7
-stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7))
-#endif
-#ifdef REG_R8
-stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8))
-#endif
-#ifdef REG_Flt1
-stgRegMap (FloatReg ILIT2(1)) = Just (FixedReg ILIT(REG_Flt1))
-#endif
-#ifdef REG_Flt2
-stgRegMap (FloatReg ILIT2(2)) = Just (FixedReg ILIT(REG_Flt2))
-#endif
-#ifdef REG_Flt3
-stgRegMap (FloatReg ILIT2(3)) = Just (FixedReg ILIT(REG_Flt3))
-#endif
-#ifdef REG_Flt4
-stgRegMap (FloatReg ILIT2(4)) = Just (FixedReg ILIT(REG_Flt4))
-#endif
-#ifdef REG_Dbl1
-stgRegMap (DoubleReg ILIT2(1)) = Just (FixedReg ILIT(REG_Dbl1))
-#endif
-#ifdef REG_Dbl2
-stgRegMap (DoubleReg ILIT2(2)) = Just (FixedReg ILIT(REG_Dbl2))
-#endif
-#ifdef REG_Tag
-stgRegMap TagReg = Just (FixedReg ILIT(REG_TagReg))
-#endif
-#ifdef REG_Ret
-stgRegMap RetReg = Just (FixedReg ILIT(REG_Ret))
-#endif
-#ifdef REG_SpA
-stgRegMap SpA = Just (FixedReg ILIT(REG_SpA))
-#endif
-#ifdef REG_SuA
-stgRegMap SuA = Just (FixedReg ILIT(REG_SuA))
-#endif
-#ifdef REG_SpB
-stgRegMap SpB = Just (FixedReg ILIT(REG_SpB))
-#endif
-#ifdef REG_SuB
-stgRegMap SuB = Just (FixedReg ILIT(REG_SuB))
-#endif
-#ifdef REG_Hp
-stgRegMap Hp = Just (FixedReg ILIT(REG_Hp))
-#endif
-#ifdef REG_HpLim
-stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim))
-#endif
-#ifdef REG_Liveness
-stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness))
-#endif
-#ifdef REG_Activity
---stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity))
-#endif
-#ifdef REG_StdUpdRetVec
-stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec))
-#endif
-#ifdef REG_StkStub
-stgRegMap StkStubReg = Just (FixedReg ILIT(REG_StkStub))
-#endif
-
-stgRegMap _ = Nothing
-
-\end{code}
-
-Here is the list of registers we can use in register allocation.
-
-\begin{code}
-freeReg :: FAST_INT -> FAST_BOOL
-
---freeReg ILIT(esp) = _FALSE_ -- %esp is our stack pointer.
-
-#ifdef REG_Base
-freeReg ILIT(REG_Base) = _FALSE_
-#endif
-#ifdef REG_StkO
-freeReg ILIT(REG_StkO) = _FALSE_
-#endif
-#ifdef REG_R1
-freeReg ILIT(REG_R1) = _FALSE_
-#endif
-#ifdef REG_R2
-freeReg ILIT(REG_R2) = _FALSE_
-#endif
-#ifdef REG_R3
-freeReg ILIT(REG_R3) = _FALSE_
-#endif
-#ifdef REG_R4
-freeReg ILIT(REG_R4) = _FALSE_
-#endif
-#ifdef REG_R5
-freeReg ILIT(REG_R5) = _FALSE_
-#endif
-#ifdef REG_R6
-freeReg ILIT(REG_R6) = _FALSE_
-#endif
-#ifdef REG_R7
-freeReg ILIT(REG_R7) = _FALSE_
-#endif
-#ifdef REG_R8
-freeReg ILIT(REG_R8) = _FALSE_
-#endif
-#ifdef REG_Flt1
-freeReg ILIT(REG_Flt1) = _FALSE_
-#endif
-#ifdef REG_Flt2
-freeReg ILIT(REG_Flt2) = _FALSE_
-#endif
-#ifdef REG_Flt3
-freeReg ILIT(REG_Flt3) = _FALSE_
-#endif
-#ifdef REG_Flt4
-freeReg ILIT(REG_Flt4) = _FALSE_
-#endif
-#ifdef REG_Dbl1
-freeReg ILIT(REG_Dbl1) = _FALSE_
-#endif
-#ifdef REG_Dbl2
-freeReg ILIT(REG_Dbl2) = _FALSE_
-#endif
-#ifdef REG_Tag
-freeReg ILIT(REG_Tag) = _FALSE_
-#endif
-#ifdef REG_Ret
-freeReg ILIT(REG_Ret) = _FALSE_
-#endif
-#ifdef REG_SpA
-freeReg ILIT(REG_SpA) = _FALSE_
-#endif
-#ifdef REG_SuA
-freeReg ILIT(REG_SuA) = _FALSE_
-#endif
-#ifdef REG_SpB
-freeReg ILIT(REG_SpB) = _FALSE_
-#endif
-#ifdef REG_SuB
-freeReg ILIT(REG_SuB) = _FALSE_
-#endif
-#ifdef REG_Hp
-freeReg ILIT(REG_Hp) = _FALSE_
-#endif
-#ifdef REG_HpLim
-freeReg ILIT(REG_HpLim) = _FALSE_
-#endif
-#ifdef REG_Liveness
-freeReg ILIT(REG_Liveness) = _FALSE_
-#endif
-#ifdef REG_Activity
---freeReg ILIT(REG_Activity) = _FALSE_
-#endif
-#ifdef REG_StdUpdRetVec
-freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
-#endif
-#ifdef REG_StkStub
-freeReg ILIT(REG_StkStub) = _FALSE_
-#endif
-freeReg n
-#ifdef REG_Dbl1
- | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_
-#endif
-#ifdef REG_Dbl2
- | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_
-#endif
-
- | otherwise = _TRUE_
-
-reservedRegs :: [Int]
-reservedRegs = []
---reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2,
--- NCG_Reserved_F1, NCG_Reserved_F2,
--- NCG_Reserved_D1, NCG_Reserved_D2]
-
-\end{code}
-
diff --git a/ghc/compiler/nativeGen/I386Desc.lhs b/ghc/compiler/nativeGen/I386Desc.lhs
deleted file mode 100644
index b7b32332b32ab78c2e6c1e55c850f26689ee0551..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/I386Desc.lhs
+++ /dev/null
@@ -1,198 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[I386Desc]{The I386 Machine Description}
-
-\begin{code}
-#include "HsVersions.h"
-
-module I386Desc (
- mkI386
-
- -- and assorted nonsense referenced by the class methods
- ) where
-
-import AbsCSyn
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..),
- RegLiveness(..), RegUsage(..), FutureLive(..)
- )
-import CLabel ( CLabel )
-import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
-import HeapOffs ( hpRelToInt )
-import MachDesc
-import Maybes ( Maybe(..) )
-import OrdList
-import Outputable
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import I386Code
-import I386Gen ( i386CodeGen )
-import Stix
-import StixMacro
-import StixPrim
-import UniqSupply
-import Util
-\end{code}
-
-Header sizes depend only on command-line options, not on the target
-architecture. (I think.)
-
-\begin{code}
-
-fhs :: (GlobalSwitch -> SwitchResult) -> Int
-
-fhs switches = 1 + profFHS + ageFHS
- where
- profFHS = if switchIsOn switches SccProfilingOn then 1 else 0
- ageFHS = if switchIsOn switches SccProfilingOn then 1 else 0
-
-vhs :: (GlobalSwitch -> SwitchResult) -> SMRep -> Int
-
-vhs switches sm = case sm of
- StaticRep _ _ -> 0
- SpecialisedRep _ _ _ _ -> 0
- GenericRep _ _ _ -> 0
- BigTupleRep _ -> 1
- MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -}
- DataRep _ -> 1
- DynamicRep -> 2
- BlackHoleRep -> 0
- PhantomRep -> panic "vhs:phantom"
-
-\end{code}
-
-Here we map STG registers onto appropriate Stix Trees. First, we
-handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@.
-The rest are either in real machine registers or stored as offsets
-from BaseReg.
-
-\begin{code}
-
-i386Reg :: (GlobalSwitch -> SwitchResult) -> MagicId -> RegLoc
-
-i386Reg switches x =
- case stgRegMap x of
- Just reg -> Save nonReg
- Nothing -> Always nonReg
- where nonReg = case x of
- StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
- StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
- BaseReg -> sStLitLbl SLIT("MainRegTable")
- --Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
- --HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+4"))
- TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*4)])
- where
- r2 = VanillaReg PtrRep ILIT(2)
- infoptr = case i386Reg switches r2 of
- Always tree -> tree
- Save _ -> StReg (StixMagicId r2)
- _ -> StInd (kindFromMagicId x)
- (StPrim IntAddOp [baseLoc, StInt (toInteger (offset*4))])
- baseLoc = case stgRegMap BaseReg of
- Just _ -> StReg (StixMagicId BaseReg)
- Nothing -> sStLitLbl SLIT("MainRegTable")
- offset = baseRegOffset x
-
-\end{code}
-
-Sizes in bytes.
-
-\begin{code}
-
-size pk = case kindToSize pk of
- {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
-
-\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.
-
-\begin{code}
-
-vsaves switches vols =
- map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
- where
- save x = StAssign (kindFromMagicId x) loc reg
- where reg = StReg (StixMagicId x)
- loc = case i386Reg switches x of
- Save loc -> loc
- Always loc -> panic "vsaves"
-
-vrests switches vols =
- map restore ((filter callerSaves)
- ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols))
- where
- restore x = StAssign (kindFromMagicId x) reg loc
- where reg = StReg (StixMagicId x)
- loc = case i386Reg switches x of
- Save loc -> loc
- Always loc -> panic "vrests"
-
-\end{code}
-
-Static closure sizes.
-
-\begin{code}
-
-charLikeSize, intLikeSize :: Target -> Int
-
-charLikeSize target =
- size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
- where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
-
-intLikeSize target =
- size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
- where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
-
-mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
-
-mhs switches = StInt (toInteger words)
- where
- words = fhs switches + vhs switches (MuTupleRep 0)
-
-dhs switches = StInt (toInteger words)
- where
- words = fhs switches + vhs switches (DataRep 0)
-
-\end{code}
-
-Setting up a i386 target.
-
-\begin{code}
-mkI386 :: Bool
- -> (GlobalSwitch -> SwitchResult)
- -> (Target,
- (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
- Bool, -- underscore
- (String -> String)) -- fmtAsmLbl
-
-mkI386 decentOS switches =
- let fhs' = fhs switches
- vhs' = vhs switches
- i386Reg' = i386Reg switches
- vsaves' = vsaves switches
- vrests' = vrests switches
- hprel = hpRelToInt target
- as = amodeCode target
- as' = amodeCode' target
- csz = charLikeSize target
- isz = intLikeSize target
- mhs' = mhs switches
- dhs' = dhs switches
- ps = genPrimCode target
- mc = genMacroCode target
- hc = doHeapCheck
- target = mkTarget {-switches-} fhs' vhs' i386Reg' {-id-} size
- hprel as as'
- (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
- {-i386CodeGen decentOS id-}
- in
- (target, i386CodeGen, decentOS, id)
-\end{code}
-
-
-
diff --git a/ghc/compiler/nativeGen/I386Gen.lhs b/ghc/compiler/nativeGen/I386Gen.lhs
deleted file mode 100644
index 0edbba123ecb2b34de4681335031c081f8978a6f..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/I386Gen.lhs
+++ /dev/null
@@ -1,1639 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-
-\begin{code}
-#include "HsVersions.h"
-#include "../includes/i386-unknown-linuxaout.h"
-
-module I386Gen (
- i386CodeGen,
-
- -- and, for self-sufficiency
- PprStyle, StixTree, CSeq
- ) where
-
-IMPORT_Trace
-
-import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos,
- Reg(..), RegLiveness(..), RegUsage(..),
- FutureLive(..), MachineRegisters(..), MachineCode(..)
- )
-import CLabel ( CLabel, isAsmTemp )
-import I386Code {- everything -}
-import MachDesc
-import Maybes ( maybeToBool, Maybe(..) )
-import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
-import Outputable
-import I386Desc
-import Stix
-import UniqSupply
-import Pretty
-import Unpretty
-import Util
-
-type CodeBlock a = (OrdList a -> OrdList a)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[I386CodeGen]{Generating I386 Code}
-%* *
-%************************************************************************
-
-This is the top-level code-generation function for the I386.
-
-\begin{code}
-
-i386CodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
-i386CodeGen sty trees =
- mapUs genI386Code trees `thenUs` \ dynamicCodes ->
- let
- staticCodes = scheduleI386Code dynamicCodes
- pretty = printLabeledCodes sty staticCodes
- in
- returnUs pretty
-
-\end{code}
-
-This bit does the code scheduling. The scheduler must also deal with
-register allocation of temporaries. Much parallelism can be exposed via
-the OrdList, but more might occur, so further analysis might be needed.
-
-\begin{code}
-
-scheduleI386Code :: [I386Code] -> [I386Instr]
-scheduleI386Code = concat . map (runRegAllocate freeI386Regs reservedRegs)
- where
- freeI386Regs :: I386Regs
- freeI386Regs = mkMRegs (extractMappedRegNos freeRegs)
-
-
-\end{code}
-
-Registers 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 Reg PrimRep (CodeBlock I386Instr)
- | Any PrimRep (Reg -> (CodeBlock I386Instr))
-
-registerCode :: Register -> Reg -> CodeBlock I386Instr
-registerCode (Fixed _ _ code) reg = code
-registerCode (Any _ code) reg = code reg
-
-registerName :: Register -> Reg -> Reg
-registerName (Fixed reg _ _) _ = reg
-registerName (Any _ _) reg = reg
-
-registerKind :: Register -> PrimRep
-registerKind (Fixed _ pk _) = pk
-registerKind (Any pk _) = pk
-
-isFixed :: Register -> Bool
-isFixed (Fixed _ _ _) = True
-isFixed (Any _ _) = False
-
-\end{code}
-
-Memory addressing modes passed up the tree.
-
-\begin{code}
-
-data Amode = Amode Addr (CodeBlock I386Instr)
-
-amodeAddr (Amode addr _) = addr
-amodeCode (Amode _ code) = code
-
-\end{code}
-
-Condition codes passed up the tree.
-
-\begin{code}
-
-data Condition = Condition Bool Cond (CodeBlock I386Instr)
-
-condName (Condition _ cond _) = cond
-condFloat (Condition float _ _) = float
-condCode (Condition _ _ code) = code
-
-\end{code}
-
-General things for putting together code sequences.
-
-\begin{code}
-
-asmVoid :: OrdList I386Instr
-asmVoid = mkEmptyList
-
-asmInstr :: I386Instr -> I386Code
-asmInstr i = mkUnitList i
-
-asmSeq :: [I386Instr] -> I386Code
-asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
-
-asmParThen :: [I386Code] -> (CodeBlock I386Instr)
-asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-
-returnInstr :: I386Instr -> UniqSM (CodeBlock I386Instr)
-returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-
-returnInstrs :: [I386Instr] -> UniqSM (CodeBlock I386Instr)
-returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-
-returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> UniqSM (CodeBlock I386Instr)
-returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
-
-mkSeqInstr :: I386Instr -> (CodeBlock I386Instr)
-mkSeqInstr instr code = mkSeqList (asmInstr instr) code
-
-mkSeqInstrs :: [I386Instr] -> (CodeBlock I386Instr)
-mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
-
-\end{code}
-
-Top level i386 code generator for a chunk of stix code.
-
-\begin{code}
-
-genI386Code :: [StixTree] -> UniqSM (I386Code)
-
-genI386Code trees =
- mapUs getCode trees `thenUs` \ blocks ->
- returnUs (foldr (.) id blocks asmVoid)
-
-\end{code}
-
-Code extractor for an entire stix tree---stix statement level.
-
-\begin{code}
-
-getCode
- :: StixTree -- a stix statement
- -> UniqSM (CodeBlock I386Instr)
-
-getCode (StSegment seg) = returnInstr (SEGMENT seg)
-
-getCode (StAssign pk dst src)
- | isFloatingRep pk = assignFltCode pk dst src
- | otherwise = assignIntCode pk dst src
-
-getCode (StLabel lab) = returnInstr (LABEL lab)
-
-getCode (StFunBegin lab) = returnInstr (LABEL lab)
-
-getCode (StFunEnd lab) = returnUs id
-
-getCode (StJump arg) = genJump arg
-
-getCode (StFallThrough lbl) = returnUs id
-
-getCode (StCondJump lbl arg) = genCondJump lbl arg
-
-getCode (StData kind args) =
- mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
- returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
- (foldr1 (.) codes xs))
- where
- getData :: StixTree -> UniqSM (CodeBlock I386Instr, Imm)
- getData (StInt i) = returnUs (id, ImmInteger i)
- getData (StDouble d) = returnUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
- getData (StLitLbl s) = returnUs (id, ImmLit (uppBeside (uppChar '_') s))
- getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
- getData (StString s) =
- getUniqLabelNCG `thenUs` \ lbl ->
- returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
- getData (StCLbl l) = returnUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
-
-getCode (StComment s) = returnInstr (COMMENT s)
-
-\end{code}
-
-Generate code to get a subtree into a register.
-
-\begin{code}
-
-getReg :: StixTree -> UniqSM Register
-
-getReg (StReg (StixMagicId stgreg)) =
- case stgRegMap stgreg of
- Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
- -- cannot be Nothing
-
-getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
-
-getReg (StDouble 0.0)
- = let
- code dst = mkSeqInstrs [FLDZ]
- in
- returnUs (Any DoubleRep code)
-
-getReg (StDouble 1.0)
- = let
- code dst = mkSeqInstrs [FLD1]
- in
- returnUs (Any DoubleRep code)
-
-getReg (StDouble d) =
- getUniqLabelNCG `thenUs` \ lbl ->
- --getNewRegNCG PtrRep `thenUs` \ tmp ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))],
- SEGMENT TextSegment,
- FLD D (OpImm (ImmCLbl lbl))
- ]
- in
- returnUs (Any DoubleRep code)
-
-getReg (StString s) =
- getUniqLabelNCG `thenUs` \ lbl ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII True (_UNPK_ s),
- SEGMENT TextSegment,
- MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
- in
- returnUs (Any PtrRep code)
-
-getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
- getUniqLabelNCG `thenUs` \ lbl ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII False (init xs),
- SEGMENT TextSegment,
- MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
- in
- returnUs (Any PtrRep code)
- where
- xs = _UNPK_ (_TAIL_ s)
-
-
-getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
-
-getReg (StCall fn kind args) =
- genCCall fn kind args `thenUs` \ call ->
- returnUs (Fixed reg kind call)
- where
- reg = if isFloatingRep kind then st0 else eax
-
-getReg (StPrim primop args) =
- case primop of
-
- CharGtOp -> condIntReg GT args
- CharGeOp -> condIntReg GE args
- CharEqOp -> condIntReg EQ args
- CharNeOp -> condIntReg NE args
- CharLtOp -> condIntReg LT args
- CharLeOp -> condIntReg LE args
-
- IntAddOp -> -- this should be optimised by the generic Opts,
- -- I don't know why it is not (sometimes)!
- case args of
- [x, StInt 0] -> getReg x
- _ -> addCode L args
-
- IntSubOp -> subCode L args
- IntMulOp -> trivialCode (IMUL L) args True
- IntQuotOp -> divCode L args True -- division
- IntRemOp -> divCode L args False -- remainder
- IntNegOp -> trivialUCode (NEGI L) args
- IntAbsOp -> absIntCode args
-
- AndOp -> trivialCode (AND L) args True
- OrOp -> trivialCode (OR L) args True
- NotOp -> trivialUCode (NOT L) args
- SllOp -> trivialCode (SHL L) args False
- SraOp -> trivialCode (SAR L) args False
- SrlOp -> trivialCode (SHR L) args False
- ISllOp -> panic "I386Gen:isll"
- ISraOp -> panic "I386Gen:isra"
- ISrlOp -> panic "I386Gen:isrl"
-
- IntGtOp -> condIntReg GT args
- IntGeOp -> condIntReg GE args
- IntEqOp -> condIntReg EQ args
- IntNeOp -> condIntReg NE args
- IntLtOp -> condIntReg LT args
- IntLeOp -> condIntReg LE args
-
- WordGtOp -> condIntReg GU args
- WordGeOp -> condIntReg GEU args
- WordEqOp -> condIntReg EQ args
- WordNeOp -> condIntReg NE args
- WordLtOp -> condIntReg LU args
- WordLeOp -> condIntReg LEU args
-
- AddrGtOp -> condIntReg GU args
- AddrGeOp -> condIntReg GEU args
- AddrEqOp -> condIntReg EQ args
- AddrNeOp -> condIntReg NE args
- AddrLtOp -> condIntReg LU args
- AddrLeOp -> condIntReg LEU args
-
- FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP args
- FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP args
- FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP args
- FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP args
- FloatNegOp -> trivialUFCode FloatRep FCHS args
-
- FloatGtOp -> condFltReg GT args
- FloatGeOp -> condFltReg GE args
- FloatEqOp -> condFltReg EQ args
- FloatNeOp -> condFltReg NE args
- FloatLtOp -> condFltReg LT args
- FloatLeOp -> condFltReg LE args
-
- FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
- FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
- FloatSqrtOp -> trivialUFCode FloatRep FSQRT args
-
- FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
- --trivialUFCode FloatRep FSIN args
- FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
- --trivialUFCode FloatRep FCOS args
- FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
-
- FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
- FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
- FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
-
- FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
- FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
- FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
-
- FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
-
- DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP args
- DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP args
- DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP args
- DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP args
- DoubleNegOp -> trivialUFCode DoubleRep FCHS args
-
- DoubleGtOp -> condFltReg GT args
- DoubleGeOp -> condFltReg GE args
- DoubleEqOp -> condFltReg EQ args
- DoubleNeOp -> condFltReg NE args
- DoubleLtOp -> condFltReg LT args
- DoubleLeOp -> condFltReg LE args
-
- DoubleExpOp -> call SLIT("exp") DoubleRep
- DoubleLogOp -> call SLIT("log") DoubleRep
- DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT args
-
- DoubleSinOp -> call SLIT("sin") DoubleRep
- --trivialUFCode DoubleRep FSIN args
- DoubleCosOp -> call SLIT("cos") DoubleRep
- --trivialUFCode DoubleRep FCOS args
- DoubleTanOp -> call SLIT("tan") DoubleRep
-
- DoubleAsinOp -> call SLIT("asin") DoubleRep
- DoubleAcosOp -> call SLIT("acos") DoubleRep
- DoubleAtanOp -> call SLIT("atan") DoubleRep
-
- DoubleSinhOp -> call SLIT("sinh") DoubleRep
- DoubleCoshOp -> call SLIT("cosh") DoubleRep
- DoubleTanhOp -> call SLIT("tanh") DoubleRep
-
- DoublePowerOp -> call SLIT("pow") DoubleRep
-
- OrdOp -> coerceIntCode IntRep args
- ChrOp -> chrCode args
-
- Float2IntOp -> coerceFP2Int args
- Int2FloatOp -> coerceInt2FP FloatRep args
- Double2IntOp -> coerceFP2Int args
- Int2DoubleOp -> coerceInt2FP DoubleRep args
-
- Double2FloatOp -> coerceFltCode args
- Float2DoubleOp -> coerceFltCode args
-
- where
- call fn pk = getReg (StCall fn pk args)
- promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
- where
- promote x = StPrim Float2DoubleOp [x]
-
-getReg (StInd pk mem) =
- getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = kindToSize pk
- code__2 dst = code .
- if pk == DoubleRep || pk == FloatRep
- then mkSeqInstr (FLD {-D-} size (OpAddr src))
- else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
- in
- returnUs (Any pk code__2)
-
-
-getReg (StInt i)
- = let
- src = ImmInt (fromInteger i)
- code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
- in
- returnUs (Any IntRep code)
-
-getReg leaf
- | maybeToBool imm =
- let
- code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
- in
- returnUs (Any PtrRep code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-\end{code}
-
-Now, given a tree (the argument to an StInd) that references memory,
-produce a suitable addressing mode.
-
-\begin{code}
-
-getAmode :: StixTree -> UniqSM Amode
-
-getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
-
-getAmode (StPrim IntSubOp [x, StInt i])
- =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg x `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
-
-getAmode (StPrim IntAddOp [x, StInt i])
- | maybeToBool imm
- = let
- code = mkSeqInstrs []
- in
- returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
- where
- imm = maybeImm x
- imm__2 = case imm of Just x -> x
-
-getAmode (StPrim IntAddOp [x, StInt i])
- =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg x `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
-
-getAmode (StPrim IntAddOp [x, y]) =
- getNewRegNCG PtrRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- reg2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2]
- in
- returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
-
-getAmode leaf
- | maybeToBool imm =
- let code = mkSeqInstrs []
- in
- returnUs (Amode (ImmAddr imm__2 0) code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg other `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = Nothing
- in
- returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
-
-\end{code}
-
-\begin{code}
-getOp
- :: StixTree
- -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
-getOp (StInt i)
- = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
-
-getOp (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode --asmVoid
- addr = amodeAddr amode
- sz = kindToSize pk
- in returnUs (code, OpAddr addr, sz)
-
-getOp op
- = getReg op `thenUs` \ register ->
- getNewRegNCG (registerKind register)
- `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- pk = registerKind register
- sz = kindToSize pk
- in
- returnUs (code, OpReg reg, sz)
-
-getOpRI
- :: StixTree
- -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
-getOpRI op
- | maybeToBool imm
- = returnUs (asmParThen [], OpImm imm_op, L)
- where
- imm = maybeImm op
- imm_op = case imm of Just x -> x
-
-getOpRI op
- = getReg op `thenUs` \ register ->
- getNewRegNCG (registerKind register)
- `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- pk = registerKind register
- sz = kindToSize pk
- in
- returnUs (code, OpReg reg, sz)
-
-\end{code}
-
-Set up a condition code for a conditional branch.
-
-\begin{code}
-
-getCondition :: StixTree -> UniqSM Condition
-
-getCondition (StPrim primop args) =
- case primop of
-
- CharGtOp -> condIntCode GT args
- CharGeOp -> condIntCode GE args
- CharEqOp -> condIntCode EQ args
- CharNeOp -> condIntCode NE args
- CharLtOp -> condIntCode LT args
- CharLeOp -> condIntCode LE args
-
- IntGtOp -> condIntCode GT args
- IntGeOp -> condIntCode GE args
- IntEqOp -> condIntCode EQ args
- IntNeOp -> condIntCode NE args
- IntLtOp -> condIntCode LT args
- IntLeOp -> condIntCode LE args
-
- WordGtOp -> condIntCode GU args
- WordGeOp -> condIntCode GEU args
- WordEqOp -> condIntCode EQ args
- WordNeOp -> condIntCode NE args
- WordLtOp -> condIntCode LU args
- WordLeOp -> condIntCode LEU args
-
- AddrGtOp -> condIntCode GU args
- AddrGeOp -> condIntCode GEU args
- AddrEqOp -> condIntCode EQ args
- AddrNeOp -> condIntCode NE args
- AddrLtOp -> condIntCode LU args
- AddrLeOp -> condIntCode LEU args
-
- FloatGtOp -> condFltCode GT args
- FloatGeOp -> condFltCode GE args
- FloatEqOp -> condFltCode EQ args
- FloatNeOp -> condFltCode NE args
- FloatLtOp -> condFltCode LT args
- FloatLeOp -> condFltCode LE args
-
- DoubleGtOp -> condFltCode GT args
- DoubleGeOp -> condFltCode GE args
- DoubleEqOp -> condFltCode EQ args
- DoubleNeOp -> condFltCode NE args
- DoubleLtOp -> condFltCode LT args
- DoubleLeOp -> condFltCode LE args
-
-\end{code}
-
-Turn a boolean expression into a condition, to be passed
-back up the tree.
-
-\begin{code}
-
-condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
-condIntCode cond [StInd _ x, y]
- | maybeToBool imm
- = getAmode x `thenUs` \ amode ->
- let
- code1 = amodeCode amode asmVoid
- y__2 = amodeAddr amode
- code__2 = asmParThen [code1] .
- mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
- in
- returnUs (Condition False cond code__2)
- where
- imm = maybeImm y
- imm__2 = case imm of Just x -> x
-
-condIntCode cond [x, StInt 0]
- = getReg x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code__2 = asmParThen [code1] .
- mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
- in
- returnUs (Condition False cond code__2)
-
-condIntCode cond [x, y]
- | maybeToBool imm
- = getReg x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code__2 = asmParThen [code1] .
- mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
- in
- returnUs (Condition False cond code__2)
- where
- imm = maybeImm y
- imm__2 = case imm of Just x -> x
-
-condIntCode cond [StInd _ x, y]
- = getAmode x `thenUs` \ amode ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = amodeCode amode asmVoid
- src1 = amodeAddr amode
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
- in
- returnUs (Condition False cond code__2)
-
-condIntCode cond [y, StInd _ x]
- = getAmode x `thenUs` \ amode ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = amodeCode amode asmVoid
- src1 = amodeAddr amode
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
- in
- returnUs (Condition False cond code__2)
-
-condIntCode cond [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
- in
- returnUs (Condition False cond code__2)
-
-condFltCode cond [x, StDouble 0.0] =
- getReg x `thenUs` \ register1 ->
- getNewRegNCG (registerKind register1)
- `thenUs` \ tmp1 ->
- let
- pk1 = registerKind register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code__2 = asmParThen [code1 asmVoid] .
- mkSeqInstrs [FTST, FSTP D (OpReg st0), -- or FLDZ, FUCOMPP ?
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
- in
- returnUs (Condition True (fixFPCond cond) code__2)
-
-condFltCode cond [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG (registerKind register1)
- `thenUs` \ tmp1 ->
- getNewRegNCG (registerKind register2)
- `thenUs` \ tmp2 ->
- let
- pk1 = registerKind register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
- mkSeqInstrs [FUCOMPP,
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
- in
- returnUs (Condition True (fixFPCond cond) code__2)
-
-\end{code}
-
-Turn those condition codes into integers now (when they appear on
-the right hand side of an assignment).
-
-\begin{code}
-
-condIntReg :: Cond -> [StixTree] -> UniqSM Register
-condIntReg cond args =
- condIntCode cond args `thenUs` \ condition ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- --getReg dst `thenUs` \ register ->
- let
- --code2 = registerCode register tmp asmVoid
- --dst__2 = registerName register tmp
- code = condCode condition
- cond = condName condition
--- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
- code__2 dst = code . mkSeqInstrs [
- SETCC cond (OpReg tmp),
- AND L (OpImm (ImmInt 1)) (OpReg tmp),
- MOV L (OpReg tmp) (OpReg dst)]
- in
- returnUs (Any IntRep code__2)
-
-condFltReg :: Cond -> [StixTree] -> UniqSM Register
-
-condFltReg cond args =
- getUniqLabelNCG `thenUs` \ lbl1 ->
- getUniqLabelNCG `thenUs` \ lbl2 ->
- condFltCode cond args `thenUs` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code . mkSeqInstrs [
- 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
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-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}
-
-assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
-assignIntCode pk (StInd _ dst) src
- = getAmode dst `thenUs` \ amode ->
- getOpRI src `thenUs` \ (codesrc, opsrc, sz) ->
- let
- code1 = amodeCode amode asmVoid
- dst__2 = amodeAddr amode
- code__2 = asmParThen [code1, codesrc asmVoid] .
- mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
- in
- returnUs code__2
-
-assignIntCode pk dst (StInd _ src) =
- getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode src `thenUs` \ amode ->
- getReg dst `thenUs` \ register ->
- let
- code1 = amodeCode amode asmVoid
- src__2 = amodeAddr amode
- code2 = registerCode register tmp asmVoid
- dst__2 = registerName register tmp
- sz = kindToSize pk
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
- in
- returnUs code__2
-
-assignIntCode pk dst src =
- getReg dst `thenUs` \ register1 ->
- getReg src `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- dst__2 = registerName register1 tmp
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2 && dst__2 /= src__2
- then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
- else
- code
- in
- returnUs code__2
-
-assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
-assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
- = getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode src `thenUs` \ amodesrc ->
- getAmode dst `thenUs` \ amodedst ->
- --getReg src `thenUs` \ register ->
- let
- codesrc1 = amodeCode amodesrc asmVoid
- addrsrc1 = amodeAddr amodesrc
- codedst1 = amodeCode amodedst asmVoid
- addrdst1 = amodeAddr amodedst
- addrsrc2 = case (offset addrsrc1 4) of Just x -> x
- addrdst2 = case (offset addrdst1 4) of Just x -> x
-
- code__2 = asmParThen [codesrc1, codedst1] .
- mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
- MOV L (OpReg tmp) (OpAddr addrdst1)]
- ++
- if pk == DoubleRep
- then [MOV L (OpAddr addrsrc2) (OpReg tmp),
- MOV L (OpReg tmp) (OpAddr addrdst2)]
- else [])
- in
- returnUs code__2
-
-assignFltCode pk (StInd _ dst) src =
- --getNewRegNCG pk `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getReg src `thenUs` \ register ->
- let
- sz = kindToSize pk
- dst__2 = amodeAddr amode
-
- code1 = amodeCode amode asmVoid
- code2 = registerCode register {-tmp-}st0 asmVoid
-
- --src__2 = registerName register tmp
- pk__2 = registerKind register
- sz__2 = kindToSize pk__2
-
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (FSTP sz (OpAddr dst__2))
- in
- returnUs code__2
-
-assignFltCode pk dst src =
- getReg dst `thenUs` \ register1 ->
- getReg src `thenUs` \ register2 ->
- --getNewRegNCG (registerKind register2)
- -- `thenUs` \ tmp ->
- let
- sz = kindToSize pk
- dst__2 = registerName register1 st0 --tmp
-
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
-
- code__2 = code
- in
- returnUs code__2
-
-\end{code}
-
-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, so we use call.
-
-Do not fill the delay slots here; you will confuse the register allocator.
-
-\begin{code}
-
-genJump
- :: StixTree -- the branch target
- -> UniqSM (CodeBlock I386Instr)
-
-{-
-genJump (StCLbl lbl)
- | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
- | otherwise = returnInstrs [JMP (OpImm target)]
- where
- target = ImmCLbl lbl
--}
-
-genJump (StInd pk mem) =
- getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- target = amodeAddr amode
- in
- returnSeq code [JMP (OpAddr target)]
-
-genJump tree
- | maybeToBool imm
- = returnInstr (JMP (OpImm target))
- where
- imm = maybeImm tree
- target = case imm of Just x -> x
-
-
-genJump tree =
- getReg tree `thenUs` \ register ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- target = registerName register tmp
- in
- returnSeq code [JMP (OpReg target)]
-
-\end{code}
-
-Conditional jumps are always to local labels, so we can use
-branch instructions. First, we have to ensure that the condition
-codes are set according to the supplied comparison operation.
-
-\begin{code}
-
-genCondJump
- :: CLabel -- the branch target
- -> StixTree -- the condition on which to branch
- -> UniqSM (CodeBlock I386Instr)
-
-genCondJump lbl bool =
- getCondition bool `thenUs` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- target = ImmCLbl lbl
- in
- returnSeq code [JXX cond lbl]
-
-\end{code}
-
-\begin{code}
-
-genCCall
- :: FAST_STRING -- function to call
- -> PrimRep -- type of the result
- -> [StixTree] -- arguments (of mixed type)
- -> UniqSM (CodeBlock I386Instr)
-
-genCCall fn kind [StInt i]
- | fn == SLIT ("PerformGC_wrapper")
- = getUniqLabelNCG `thenUs` \ lbl ->
- let
- call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- MOV L (OpImm (ImmCLbl lbl))
- -- this is hardwired
- (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
- LABEL lbl]
- in
- returnInstrs call
-
-genCCall fn kind args =
- mapUs getCallArg args `thenUs` \ argCode ->
- let
- nargs = length args
- code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
- ]
- ]
- code2 = asmParThen (map ($ asmVoid) (reverse argCode))
- call = [CALL (ImmLit fn__2) -- ,
- -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
- -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
- ]
- in
- returnSeq (code1 . code2) call
- where
- -- function names that begin with '.' are assumed to be special internally
- -- generated names like '.mul,' which don't get an underscore prefix
- fn__2 = case (_HEAD_ fn) of
- '.' -> uppPStr fn
- _ -> uppBeside (uppChar '_') (uppPStr fn)
-
- getCallArg
- :: StixTree -- Current argument
- -> UniqSM (CodeBlock I386Instr) -- code
- getCallArg arg =
- getOp arg `thenUs` \ (code, op, sz) ->
- returnUs (code . mkSeqInstr (PUSH sz op))
-\end{code}
-
-Trivial (dyadic) instructions. Only look for constants on the right hand
-side, because that's where the generic optimizer will have put them.
-
-\begin{code}
-
-trivialCode
- :: (Operand -> Operand -> I386Instr)
- -> [StixTree]
- -> Bool -- is the instr commutative?
- -> UniqSM Register
-
-trivialCode instr [x, y] _
- | maybeToBool imm
- = getReg x `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
- fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
- in
- returnUs (Any IntRep code__2)
- where
- imm = maybeImm y
- imm__2 = case imm of Just x -> x
-
-trivialCode instr [x, y] _
- | maybeToBool imm
- = getReg y `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
- fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
- in
- returnUs (Any IntRep code__2)
- where
- imm = maybeImm x
- imm__2 = case imm of Just x -> x
-
-trivialCode instr [x, StInd pk mem] _
- = getReg x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode mem `thenUs` \ amode ->
- let
- fixedname = registerName register eax
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 dst = let code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
- in
- returnUs (Any pk code__2)
-
-trivialCode instr [StInd pk mem, y] _
- = getReg y `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode mem `thenUs` \ amode ->
- let
- fixedname = registerName register eax
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 dst = let
- code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
- in
- returnUs (Any pk code__2)
-
-trivialCode instr [x, y] is_comm_op
- = getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- fixedname = registerName register1 eax
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 dst = let
- code1 = registerCode register1 dst asmVoid
- src1 = registerName register1 dst
- in asmParThen [code1, code2] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpReg src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpReg src2) (OpReg src1))
- in
- returnUs (Any IntRep code__2)
-
-addCode
- :: Size
- -> [StixTree]
- -> UniqSM Register
-addCode sz [x, StInt y]
- =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
- in
- returnUs (Any IntRep code__2)
-
-addCode sz [x, StInd _ mem]
- = getReg x `thenUs` \ register1 ->
- --getNewRegNCG (registerKind register1)
- -- `thenUs` \ tmp1 ->
- getAmode mem `thenUs` \ amode ->
- let
- code2 = amodeCode amode
- src2 = amodeAddr amode
-
- fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in asmParThen [code2 asmVoid,code1 asmVoid] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- ADD sz (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
- in
- returnUs (Any IntRep code__2)
-
-addCode sz [StInd _ mem, y]
- = getReg y `thenUs` \ register2 ->
- --getNewRegNCG (registerKind register2)
- -- `thenUs` \ tmp2 ->
- getAmode mem `thenUs` \ amode ->
- let
- code1 = amodeCode amode
- src1 = amodeAddr amode
-
- fixedname = registerName register2 eax
- code__2 dst = let code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- if isFixed register2 && src2 /= dst
- then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
- ADD sz (OpAddr src1) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
- in
- returnUs (Any IntRep code__2)
-
-addCode sz [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
- in
- returnUs (Any IntRep code__2)
-
-subCode
- :: Size
- -> [StixTree]
- -> UniqSM Register
-subCode sz [x, StInt y]
- = getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (-(fromInteger y))
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
- in
- returnUs (Any IntRep code__2)
-
-subCode sz args = trivialCode (SUB sz) args False
-
-divCode
- :: Size
- -> [StixTree]
- -> Bool -- True => division, False => remainder operation
- -> UniqSM Register
-
--- x must go into eax, edx must be a sign-extension of eax,
--- and y should go in some other register (or memory),
--- so that we get edx:eax / reg -> eax (remainder in edx)
--- Currently we chose to put y in memory (if it is not there already)
-divCode sz [x, StInd pk mem] is_division
- = getReg x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getAmode mem `thenUs` \ amode ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 = asmParThen [code1, code2] .
- mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr src2)]
- in
- returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
-
-divCode sz [x, StInt i] is_division
- = getReg x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- src2 = ImmInt (fromInteger i)
- code__2 = asmParThen [code1] .
- mkSeqInstrs [-- we put src2 in (ebx)
- MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
- in
- returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
-
-divCode sz [x, y] is_division
- = getReg x `thenUs` \ register1 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
- if src2 == ecx || src2 == esi
- then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpReg src2)]
- else mkSeqInstrs [ -- we put src2 in (ebx)
- MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
- in
- returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
-
-trivialFCode
- :: PrimRep
- -> (Size -> Operand -> I386Instr)
- -> (Size -> Operand -> I386Instr) -- reversed instr
- -> I386Instr -- pop
- -> I386Instr -- reversed instr, pop
- -> [StixTree]
- -> UniqSM Register
-trivialFCode pk _ instrr _ _ [StInd pk' mem, y]
- = getReg y `thenUs` \ register2 ->
- --getNewRegNCG (registerKind register2)
- -- `thenUs` \ tmp2 ->
- getAmode mem `thenUs` \ amode ->
- let
- code1 = amodeCode amode
- src1 = amodeAddr amode
-
- code__2 dst = let
- code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)]
- in
- returnUs (Any pk code__2)
-
-trivialFCode pk instr _ _ _ [x, StInd pk' mem]
- = getReg x `thenUs` \ register1 ->
- --getNewRegNCG (registerKind register1)
- -- `thenUs` \ tmp1 ->
- getAmode mem `thenUs` \ amode ->
- let
- code2 = amodeCode amode
- src2 = amodeAddr amode
-
- code__2 dst = let
- code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in asmParThen [code2 asmVoid,code1 asmVoid] .
- mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)]
- in
- returnUs (Any pk code__2)
-
-trivialFCode pk _ _ _ instrpr [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- --getNewRegNCG (registerKind register1)
- -- `thenUs` \ tmp1 ->
- --getNewRegNCG (registerKind register2)
- -- `thenUs` \ tmp2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
- let
- pk1 = registerKind register1
- code1 = registerCode register1 st0 --tmp1
- src1 = registerName register1 st0 --tmp1
-
- pk2 = registerKind register2
-
- code__2 dst = let
- code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr instrpr
- in
- returnUs (Any pk1 code__2)
-
-\end{code}
-
-Trivial unary instructions. Note that we don't have to worry about
-matching an StInt as the argument, because genericOpt will already
-have handled the constant-folding.
-
-\begin{code}
-
-trivialUCode
- :: (Operand -> I386Instr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialUCode instr [x] =
- getReg x `thenUs` \ register ->
--- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
--- fixedname = registerName register eax
- code__2 dst = let
- code = registerCode register dst
- src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- instr (OpReg dst)]
- else mkSeqInstr (instr (OpReg src))
- in
- returnUs (Any IntRep code__2)
-
-trivialUFCode
- :: PrimRep
- -> I386Instr
- -> [StixTree]
- -> UniqSM Register
-
-trivialUFCode pk instr [StInd pk' mem] =
- getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src),
- instr]
- in
- returnUs (Any pk code__2)
-
-trivialUFCode pk instr [x] =
- getReg x `thenUs` \ register ->
- --getNewRegNCG pk `thenUs` \ tmp ->
- let
- code__2 dst = let
- code = registerCode register dst
- src = registerName register dst
- in code . mkSeqInstrs [instr]
- in
- returnUs (Any pk code__2)
-\end{code}
-
-Absolute value on integers, mostly for gmp size check macros. Again,
-the argument cannot be an StInt, because genericOpt already folded
-constants.
-
-\begin{code}
-
-absIntCode :: [StixTree] -> UniqSM Register
-absIntCode [x] =
- getReg x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ reg ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code__2 dst = let code = registerCode register dst
- src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- TEST L (OpReg dst) (OpReg dst),
- JXX GE lbl,
- NEGI L (OpReg dst),
- LABEL lbl]
- else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
- JXX GE lbl,
- NEGI L (OpReg src),
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-Simple integer coercions that don't require any code to be generated.
-Here we just change the type on the register passed on up
-
-\begin{code}
-
-coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
-coerceIntCode pk [x] =
- getReg x `thenUs` \ register ->
- case register of
- Fixed reg _ code -> returnUs (Fixed reg pk code)
- Any _ code -> returnUs (Any pk code)
-
-coerceFltCode :: [StixTree] -> UniqSM Register
-coerceFltCode [x] =
- getReg x `thenUs` \ register ->
- case register of
- Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
- Any _ code -> returnUs (Any DoubleRep code)
-
-\end{code}
-
-Integer to character conversion. We try to do this in one step if
-the original object is in memory.
-
-\begin{code}
-chrCode :: [StixTree] -> UniqSM Register
-{-
-chrCode [StInd pk mem] =
- getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst))
- in
- returnUs (Any pk code__2)
--}
-chrCode [x] =
- getReg x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ reg ->
- let
- fixedname = registerName register eax
- code__2 dst = let
- code = registerCode register dst
- src = registerName register dst
- in code .
- if isFixed register && src /= dst
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- AND L (OpImm (ImmInt 255)) (OpReg dst)]
- else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
- in
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-More complicated integer/float conversions. Here we have to store
-temporaries in memory to move between the integer and the floating
-point register sets.
-
-\begin{code}
-coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
-coerceInt2FP pk [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
-
- code__2 dst = code . mkSeqInstrs [
- -- to fix: should spill instead of using R1
- MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
- in
- returnUs (Any pk code__2)
-
-coerceFP2Int :: [StixTree] -> UniqSM Register
-coerceFP2Int [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerKind register
-
- code__2 dst = let
- in code . mkSeqInstrs [
- FRNDINT,
- FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
- in
- returnUs (Any IntRep code__2)
-\end{code}
-
-Some random little helpers.
-
-\begin{code}
-
-maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i)
- | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
- | otherwise = Just (ImmInteger i)
-maybeImm (StLitLbl s) = Just (ImmLit (uppBeside (uppChar '_') s))
-maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
-maybeImm (StCLbl l) = Just (ImmCLbl l)
-maybeImm _ = Nothing
-
-mangleIndexTree :: StixTree -> StixTree
-
-mangleIndexTree (StIndex pk base (StInt i)) =
- StPrim IntAddOp [base, off]
- where
- off = StInt (i * size pk)
- size :: PrimRep -> Integer
- size pk = case kindToSize pk of
- {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
-
-mangleIndexTree (StIndex pk base off) =
- case pk of
- CharRep -> StPrim IntAddOp [base, off]
- _ -> StPrim IntAddOp [base, off__2]
- where
- off__2 = StPrim SllOp [off, StInt (shift pk)]
- shift :: PrimRep -> Integer
- shift DoubleRep = 3
- shift _ = 2
-
-cvtLitLit :: String -> String
-cvtLitLit "stdin" = "_IO_stdin_"
-cvtLitLit "stdout" = "_IO_stdout_"
-cvtLitLit "stderr" = "_IO_stderr_"
-cvtLitLit s
- | isHex s = s
- | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
- where
- isHex ('0':'x':xs) = all isHexDigit xs
- isHex _ = False
- -- Now, where have I seen this before?
- isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
-
-
-\end{code}
-
-\begin{code}
-
-stackArgLoc = 23 :: Int -- where to stack call arguments
-
-\end{code}
-
-\begin{code}
-
-getNewRegNCG :: PrimRep -> UniqSM Reg
-getNewRegNCG pk =
- getUnique `thenUs` \ u ->
- returnUs (mkReg u pk)
-
-fixFPCond :: Cond -> Cond
--- on the 486 the flags set by FP compare are the unsigned ones!
-fixFPCond GE = GEU
-fixFPCond GT = GU
-fixFPCond LT = LU
-fixFPCond LE = LEU
-fixFPCond any = any
-\end{code}
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..25d9be3f15ad9d9279aac8669b58edf6240325f0
--- /dev/null
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -0,0 +1,3248 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\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}
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
+
+import Ubiq{-uitious-}
+
+import MachMisc -- may differ per-platform
+import MachRegs
+
+import AbsCSyn ( MagicId )
+import AbsCUtils ( magicIdPrimRep )
+import CLabel ( isAsmTemp )
+import Maybes ( maybeToBool, expectJust )
+import OrdList -- quite a bit of it
+import Pretty ( prettyToUn, ppRational )
+import PrimRep ( isFloatingRep, PrimRep(..) )
+import PrimOp ( PrimOp(..) )
+import Stix ( getUniqLabelNCG, StixTree(..),
+ StixReg(..), CodeSegment(..)
+ )
+import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
+ mapAccumLUs, UniqSM(..)
+ )
+import Unpretty ( uppPStr )
+import Util ( panic, assertPanic )
+\end{code}
+
+Code extractor for an entire stix tree---stix statement level.
+
+\begin{code}
+stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
+
+stmt2Instrs stmt = case stmt of
+ StComment s -> returnInstr (COMMENT s)
+ StSegment seg -> returnInstr (SEGMENT seg)
+ StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
+ StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
+ StLabel lab -> returnInstr (LABEL lab)
+
+ StJump arg -> genJump arg
+ StCondJump lab arg -> genCondJump lab arg
+ StCall fn VoidRep args -> genCCall fn VoidRep args
+
+ StAssign pk dst src
+ | isFloatingRep pk -> assignFltCode pk dst src
+ | otherwise -> assignIntCode pk dst 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)))
+ ,returnUs id)
+
+ StData kind args
+ -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
+ returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
+ (foldr1 (.) codes xs))
+ where
+ getData :: StixTree -> UniqSM (InstrBlock, Imm)
+
+ getData (StInt i) = returnUs (id, ImmInteger i)
+ getData (StDouble d) = returnUs (id, dblImmLit d)
+ getData (StLitLbl s) = returnUs (id, ImmLab s)
+ getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
+ getData (StCLbl l) = returnUs (id, ImmCLbl l)
+ getData (StString s) =
+ getUniqLabelNCG `thenUs` \ lbl ->
+ returnUs (mkSeqInstrs [LABEL lbl,
+ ASCII True (_UNPK_ s)],
+ ImmCLbl lbl)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{General things for putting together code sequences}
+%* *
+%************************************************************************
+
+\begin{code}
+type InstrList = OrdList Instr
+type InstrBlock = InstrList -> InstrList
+
+asmVoid :: InstrList
+asmVoid = mkEmptyList
+
+asmInstr :: Instr -> InstrList
+asmInstr i = mkUnitList i
+
+asmSeq :: [Instr] -> InstrList
+asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
+
+asmParThen :: [InstrList] -> InstrBlock
+asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
+
+returnInstr :: Instr -> UniqSM InstrBlock
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
+
+returnInstrs :: [Instr] -> UniqSM InstrBlock
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
+
+returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+
+mkSeqInstr :: Instr -> InstrBlock
+mkSeqInstr instr code = mkSeqList (asmInstr instr) code
+
+mkSeqInstrs :: [Instr] -> InstrBlock
+mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
+\end{code}
+
+\begin{code}
+mangleIndexTree :: StixTree -> StixTree
+
+mangleIndexTree (StIndex pk base (StInt i))
+ = StPrim IntAddOp [base, off]
+ where
+ off = StInt (i * sizeOf pk)
+
+mangleIndexTree (StIndex pk base off)
+ = StPrim IntAddOp [base,
+ case pk of
+ CharRep -> off
+ _ -> let
+ s = shift pk
+ in
+ ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
+ StPrim SllOp [off, StInt s]
+ ]
+ where
+ shift DoubleRep = 3
+ shift _ = IF_ARCH_alpha(3,2)
+\end{code}
+
+\begin{code}
+maybeImm :: StixTree -> Maybe Imm
+
+maybeImm (StLitLbl s) = Just (ImmLab s)
+maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
+maybeImm (StCLbl l) = Just (ImmCLbl l)
+
+maybeImm (StInt i)
+ | i >= toInteger minInt && i <= toInteger maxInt
+ = Just (ImmInt (fromInteger i))
+ | otherwise
+ = Just (ImmInteger i)
+
+maybeImm _ = Nothing
+\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
+
+registerName :: Register -> Reg -> Reg
+registerName (Fixed _ reg _) _ = reg
+registerName (Any _ _) reg = reg
+
+registerRep :: Register -> PrimRep
+registerRep (Fixed pk _ _) = pk
+registerRep (Any pk _) = pk
+
+isFixed :: Register -> Bool
+isFixed (Fixed _ _ _) = True
+isFixed (Any _ _) = False
+\end{code}
+
+Generate code to get a subtree into a @Register@:
+\begin{code}
+getRegister :: StixTree -> UniqSM Register
+
+getRegister (StReg (StixMagicId stgreg))
+ = case (magicIdRegMaybe stgreg) of
+ Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
+ -- cannae be Nothing
+
+getRegister (StReg (StixTemp u pk))
+ = returnUs (Fixed pk (UnmappedReg u pk) id)
+
+getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
+
+getRegister (StCall fn kind args)
+ = genCCall fn kind args `thenUs` \ call ->
+ returnUs (Fixed kind reg call)
+ where
+ reg = if isFloatingRep kind
+ then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
+ else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
+
+getRegister (StString s)
+ = getUniqLabelNCG `thenUs` \ lbl ->
+ let
+ imm_lbl = ImmCLbl lbl
+
+ code dst = mkSeqInstrs [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ ASCII True (_UNPK_ 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
+ ]
+ in
+ returnUs (Any PtrRep code)
+
+getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
+ = getUniqLabelNCG `thenUs` \ lbl ->
+ let
+ imm_lbl = ImmCLbl lbl
+
+ code dst = mkSeqInstrs [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ ASCII False (init xs),
+ 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
+ ]
+ in
+ returnUs (Any PtrRep code)
+ where
+ xs = _UNPK_ (_TAIL_ s)
+
+-- end of machine-"independent" bit; here we go on the rest...
+
+#if alpha_TARGET_ARCH
+
+getRegister (StDouble d)
+ = getUniqLabelNCG `thenUs` \ lbl ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ let code dst = mkSeqInstrs [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ DATA TF [ImmLab (prettyToUn (ppRational d))],
+ SEGMENT TextSegment,
+ LDA tmp (AddrImm (ImmCLbl lbl)),
+ LD TF dst (AddrReg tmp)]
+ in
+ returnUs (Any DoubleRep code)
+
+getRegister (StPrim primop [x]) -- unary PrimOps
+ = case primop of
+ IntNegOp -> trivialUCode (NEG Q False) x
+ IntAbsOp -> trivialUCode (ABS Q) 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 DoubleRep [x])
+ where
+ fn = case other_op of
+ FloatExpOp -> SLIT("exp")
+ FloatLogOp -> SLIT("log")
+ FloatSqrtOp -> SLIT("sqrt")
+ FloatSinOp -> SLIT("sin")
+ FloatCosOp -> SLIT("cos")
+ FloatTanOp -> SLIT("tan")
+ FloatAsinOp -> SLIT("asin")
+ FloatAcosOp -> SLIT("acos")
+ FloatAtanOp -> SLIT("atan")
+ FloatSinhOp -> SLIT("sinh")
+ FloatCoshOp -> SLIT("cosh")
+ FloatTanhOp -> SLIT("tanh")
+ DoubleExpOp -> SLIT("exp")
+ DoubleLogOp -> SLIT("log")
+ DoubleSqrtOp -> SLIT("sqrt")
+ DoubleSinOp -> SLIT("sin")
+ DoubleCosOp -> SLIT("cos")
+ DoubleTanOp -> SLIT("tan")
+ DoubleAsinOp -> SLIT("asin")
+ DoubleAcosOp -> SLIT("acos")
+ DoubleAtanOp -> SLIT("atan")
+ DoubleSinhOp -> SLIT("sinh")
+ DoubleCoshOp -> SLIT("cosh")
+ DoubleTanhOp -> SLIT("tanh")
+ where
+ pr = panic "MachCode.getRegister: no primrep needed for Alpha"
+
+getRegister (StPrim primop [x, y]) -- dyadic PrimOps
+ = case primop of
+ CharGtOp -> trivialCode (CMP LT) y x
+ CharGeOp -> trivialCode (CMP LE) y x
+ CharEqOp -> trivialCode (CMP EQ) x y
+ CharNeOp -> int_NE_code x y
+ CharLtOp -> trivialCode (CMP LT) x y
+ CharLeOp -> trivialCode (CMP LE) x y
+
+ IntGtOp -> trivialCode (CMP LT) y x
+ IntGeOp -> trivialCode (CMP LE) y x
+ IntEqOp -> trivialCode (CMP EQ) x y
+ IntNeOp -> int_NE_code x y
+ IntLtOp -> trivialCode (CMP LT) x y
+ IntLeOp -> trivialCode (CMP LE) x y
+
+ WordGtOp -> trivialCode (CMP ULT) y x
+ WordGeOp -> trivialCode (CMP ULE) x y
+ WordEqOp -> trivialCode (CMP EQ) 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 EQ) 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) EQ x y
+ FloatGeOp -> cmpF_code (FCMP TF LT) EQ x y
+ FloatEqOp -> cmpF_code (FCMP TF EQ) NE x y
+ FloatNeOp -> cmpF_code (FCMP TF EQ) EQ x y
+ FloatLtOp -> cmpF_code (FCMP TF LT) NE x y
+ FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
+
+ DoubleGtOp -> cmpF_code (FCMP TF LE) EQ x y
+ DoubleGeOp -> cmpF_code (FCMP TF LT) EQ x y
+ DoubleEqOp -> cmpF_code (FCMP TF EQ) NE x y
+ DoubleNeOp -> cmpF_code (FCMP TF EQ) EQ x y
+ DoubleLtOp -> cmpF_code (FCMP TF LT) 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
+
+ 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
+
+ AndOp -> trivialCode AND x y
+ OrOp -> trivialCode OR x y
+ SllOp -> trivialCode SLL x y
+ SraOp -> trivialCode SRA x y
+ SrlOp -> trivialCode SRL x y
+
+ ISllOp -> panic "AlphaGen:isll"
+ ISraOp -> panic "AlphaGen:isra"
+ ISrlOp -> panic "AlphaGen:isrl"
+
+ FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") 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 -> UniqSM Register
+
+ int_NE_code x y
+ = trivialCode (CMP EQ) x y `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
+ in
+ returnUs (Any IntRep code__2)
+
+ {- ------------------------------------------------------------
+ Comments for int_NE_code also apply to cmpF_code
+ -}
+ cmpF_code
+ :: (Reg -> Reg -> Reg -> Instr)
+ -> Cond
+ -> StixTree -> StixTree
+ -> UniqSM Register
+
+ cmpF_code instr cond x y
+ = trivialFCode pr instr x y `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ getUniqLabelNCG `thenUs` \ lbl ->
+ let
+ code = registerCode register tmp
+ result = registerName register tmp
+
+ code__2 dst = code . mkSeqInstrs [
+ OR zero (RIImm (ImmInt 1)) dst,
+ BF cond result (ImmCLbl lbl),
+ OR zero (RIReg zero) dst,
+ LABEL lbl]
+ in
+ returnUs (Any IntRep code__2)
+ where
+ pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
+ ------------------------------------------------------------
+
+getRegister (StInd pk mem)
+ = getAmode mem `thenUs` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ size = primRepToSize pk
+ code__2 dst = code . mkSeqInstr (LD size dst src)
+ in
+ returnUs (Any pk code__2)
+
+getRegister (StInt i)
+ | fits8Bits i
+ = let
+ code dst = mkSeqInstr (OR zero (RIImm src) dst)
+ in
+ returnUs (Any IntRep code)
+ | otherwise
+ = let
+ code dst = mkSeqInstr (LDI Q dst src)
+ in
+ returnUs (Any IntRep code)
+ where
+ src = ImmInt (fromInteger i)
+
+getRegister leaf
+ | maybeToBool imm
+ = let
+ code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
+ in
+ returnUs (Any PtrRep code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
+
+getRegister (StDouble 0.0)
+ = let
+ code dst = mkSeqInstrs [FLDZ]
+ in
+ returnUs (Any DoubleRep code)
+
+getRegister (StDouble 1.0)
+ = let
+ code dst = mkSeqInstrs [FLD1]
+ in
+ returnUs (Any DoubleRep code)
+
+getRegister (StDouble d)
+ = getUniqLabelNCG `thenUs` \ lbl ->
+ --getNewRegNCG PtrRep `thenUs` \ tmp ->
+ let code dst = mkSeqInstrs [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ DATA DF [dblImmLit d],
+ SEGMENT TextSegment,
+ FLD DF (OpImm (ImmCLbl lbl))
+ ]
+ in
+ returnUs (Any DoubleRep code)
+
+getRegister (StPrim primop [x]) -- unary PrimOps
+ = case primop of
+ IntNegOp -> trivialUCode (NEGI L) x
+ IntAbsOp -> absIntCode x
+
+ NotOp -> trivialUCode (NOT L) x
+
+ FloatNegOp -> trivialUFCode FloatRep FCHS x
+ FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
+ DoubleNegOp -> trivialUFCode DoubleRep FCHS x
+
+ DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
+
+ OrdOp -> coerceIntCode IntRep x
+ ChrOp -> chrCode x
+
+ Float2IntOp -> coerceFP2Int x
+ Int2FloatOp -> coerceInt2FP FloatRep x
+ Double2IntOp -> coerceFP2Int x
+ Int2DoubleOp -> coerceInt2FP DoubleRep x
+
+ Double2FloatOp -> coerceFltCode x
+ Float2DoubleOp -> coerceFltCode x
+
+ other_op ->
+ let
+ fixed_x = if is_float_op -- promote to double
+ then StPrim Float2DoubleOp [x]
+ else x
+ in
+ getRegister (StCall fn DoubleRep [x])
+ where
+ (is_float_op, fn)
+ = case primop of
+ FloatExpOp -> (True, SLIT("exp"))
+ FloatLogOp -> (True, SLIT("log"))
+
+ FloatSinOp -> (True, SLIT("sin"))
+ FloatCosOp -> (True, SLIT("cos"))
+ FloatTanOp -> (True, SLIT("tan"))
+
+ FloatAsinOp -> (True, SLIT("asin"))
+ FloatAcosOp -> (True, SLIT("acos"))
+ FloatAtanOp -> (True, SLIT("atan"))
+
+ FloatSinhOp -> (True, SLIT("sinh"))
+ FloatCoshOp -> (True, SLIT("cosh"))
+ FloatTanhOp -> (True, SLIT("tanh"))
+
+ DoubleExpOp -> (False, SLIT("exp"))
+ DoubleLogOp -> (False, SLIT("log"))
+
+ DoubleSinOp -> (False, SLIT("sin"))
+ DoubleCosOp -> (False, SLIT("cos"))
+ DoubleTanOp -> (False, SLIT("tan"))
+
+ DoubleAsinOp -> (False, SLIT("asin"))
+ DoubleAcosOp -> (False, SLIT("acos"))
+ DoubleAtanOp -> (False, SLIT("atan"))
+
+ DoubleSinhOp -> (False, SLIT("sinh"))
+ DoubleCoshOp -> (False, SLIT("cosh"))
+ DoubleTanhOp -> (False, SLIT("tanh"))
+
+getRegister (StPrim primop [x, y]) -- dyadic PrimOps
+ = case primop of
+ CharGtOp -> condIntReg GT x y
+ CharGeOp -> condIntReg GE x y
+ CharEqOp -> condIntReg EQ x y
+ CharNeOp -> condIntReg NE x y
+ CharLtOp -> condIntReg LT x y
+ CharLeOp -> condIntReg LE x y
+
+ IntGtOp -> condIntReg GT x y
+ IntGeOp -> condIntReg GE x y
+ IntEqOp -> condIntReg EQ x y
+ IntNeOp -> condIntReg NE x y
+ IntLtOp -> condIntReg LT x y
+ IntLeOp -> condIntReg LE x y
+
+ WordGtOp -> condIntReg GU x y
+ WordGeOp -> condIntReg GEU x y
+ WordEqOp -> condIntReg EQ x y
+ WordNeOp -> condIntReg NE x y
+ WordLtOp -> condIntReg LU x y
+ WordLeOp -> condIntReg LEU x y
+
+ AddrGtOp -> condIntReg GU x y
+ AddrGeOp -> condIntReg GEU x y
+ AddrEqOp -> condIntReg EQ x y
+ AddrNeOp -> condIntReg NE x y
+ AddrLtOp -> condIntReg LU x y
+ AddrLeOp -> condIntReg LEU x y
+
+ FloatGtOp -> condFltReg GT x y
+ FloatGeOp -> condFltReg GE x y
+ FloatEqOp -> condFltReg EQ x y
+ FloatNeOp -> condFltReg NE x y
+ FloatLtOp -> condFltReg LT x y
+ FloatLeOp -> condFltReg LE x y
+
+ DoubleGtOp -> condFltReg GT x y
+ DoubleGeOp -> condFltReg GE x y
+ DoubleEqOp -> condFltReg EQ x y
+ DoubleNeOp -> condFltReg NE x y
+ DoubleLtOp -> condFltReg LT x y
+ DoubleLeOp -> condFltReg LE x y
+
+ IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
+ -- this should be optimised by the generic Opts,
+ -- I don't know why it is not (sometimes)!
+ case args of
+ [x, StInt 0] -> getRegister x
+ _ -> add_code L x y
+ -}
+ add_code L x y
+
+ IntSubOp -> sub_code L x y
+ IntQuotOp -> quot_code L x y True{-division-}
+ IntRemOp -> quot_code L x y False{-remainder-}
+ IntMulOp -> trivialCode (IMUL L) x y {-True-}
+
+ FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
+ FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
+ FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
+ FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
+
+ DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
+ DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
+ DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
+ DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
+
+ AndOp -> trivialCode (AND L) x y {-True-}
+ OrOp -> trivialCode (OR L) x y {-True-}
+ SllOp -> trivialCode (SHL L) x y {-False-}
+ SraOp -> trivialCode (SAR L) x y {-False-}
+ SrlOp -> trivialCode (SHR L) x y {-False-}
+
+ ISllOp -> panic "I386Gen:isll"
+ ISraOp -> panic "I386Gen:isra"
+ ISrlOp -> panic "I386Gen:isrl"
+
+ FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
+ where promote x = StPrim Float2DoubleOp [x]
+ DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
+ where
+ add_code :: Size -> StixTree -> StixTree -> UniqSM Register
+
+ add_code sz x (StInt y)
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (fromInteger y)
+ code__2 dst = code .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ in
+ returnUs (Any IntRep code__2)
+
+ add_code sz x (StInd _ mem)
+ = getRegister x `thenUs` \ register1 ->
+ --getNewRegNCG (registerRep register1)
+ -- `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
+ code2 = amodeCode amode
+ src2 = amodeAddr amode
+
+ fixedname = registerName register1 eax
+ code__2 dst = let code1 = registerCode register1 dst
+ src1 = registerName register1 dst
+ in asmParThen [code2 asmVoid,code1 asmVoid] .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ ADD sz (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
+ in
+ returnUs (Any IntRep code__2)
+
+ add_code sz (StInd _ mem) y
+ = getRegister y `thenUs` \ register2 ->
+ --getNewRegNCG (registerRep register2)
+ -- `thenUs` \ tmp2 ->
+ getAmode mem `thenUs` \ amode ->
+ let
+ code1 = amodeCode amode
+ src1 = amodeAddr amode
+
+ fixedname = registerName register2 eax
+ code__2 dst = let code2 = registerCode register2 dst
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid,code2 asmVoid] .
+ if isFixed register2 && src2 /= dst
+ then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
+ ADD sz (OpAddr src1) (OpReg dst)]
+ else
+ mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
+ in
+ returnUs (Any IntRep code__2)
+
+ add_code sz x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = asmParThen [code1, code2] .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+ in
+ returnUs (Any IntRep code__2)
+
+ --------------------
+ sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
+
+ sub_code sz x (StInt y)
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (-(fromInteger y))
+ code__2 dst = code .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ in
+ returnUs (Any IntRep code__2)
+
+ sub_code sz x y = trivialCode (SUB sz) x y {-False-}
+
+ --------------------
+ quot_code
+ :: Size
+ -> StixTree -> StixTree
+ -> Bool -- True => division, False => remainder operation
+ -> UniqSM Register
+
+ -- x must go into eax, edx must be a sign-extension of eax, and y
+ -- should go in some other register (or memory), so that we get
+ -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
+ -- put y in memory (if it is not there already)
+
+ quot_code sz x (StInd pk mem) is_division
+ = getRegister x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = amodeCode amode asmVoid
+ src2 = amodeAddr amode
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr src2)]
+ in
+ returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
+
+ quot_code sz x (StInt i) is_division
+ = getRegister x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ src2 = ImmInt (fromInteger i)
+ code__2 = asmParThen [code1] .
+ mkSeqInstrs [-- we put src2 in (ebx)
+ MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ in
+ returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
+
+ quot_code sz x y is_division
+ = getRegister x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ if src2 == ecx || src2 == esi
+ then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpReg src2)]
+ else mkSeqInstrs [ -- we put src2 in (ebx)
+ MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ in
+ returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
+ -----------------------
+
+getRegister (StInd pk mem)
+ = getAmode mem `thenUs` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ size = primRepToSize pk
+ code__2 dst = code .
+ if pk == DoubleRep || pk == FloatRep
+ then mkSeqInstr (FLD {-DF-} size (OpAddr src))
+ else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
+ in
+ returnUs (Any pk code__2)
+
+
+getRegister (StInt i)
+ = let
+ src = ImmInt (fromInteger i)
+ code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
+ in
+ returnUs (Any IntRep code)
+
+getRegister leaf
+ | maybeToBool imm
+ = let
+ code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
+ in
+ returnUs (Any PtrRep code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+getRegister (StDouble d)
+ = getUniqLabelNCG `thenUs` \ lbl ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ let code dst = mkSeqInstrs [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ DATA DF [dblImmLit d],
+ SEGMENT TextSegment,
+ SETHI (HI (ImmCLbl lbl)) tmp,
+ LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+ in
+ returnUs (Any DoubleRep code)
+
+getRegister (StPrim primop [x]) -- unary PrimOps
+ = case primop of
+ IntNegOp -> trivialUCode (SUB False False g0) x
+ IntAbsOp -> absIntCode x
+
+ NotOp -> trivialUCode (XNOR False g0) x
+
+ FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
+ DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
+
+ Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
+ Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
+
+ OrdOp -> coerceIntCode IntRep x
+ ChrOp -> chrCode x
+
+ Float2IntOp -> coerceFP2Int x
+ Int2FloatOp -> coerceInt2FP FloatRep x
+ Double2IntOp -> coerceFP2Int x
+ Int2DoubleOp -> coerceInt2FP DoubleRep x
+
+ other_op ->
+ let
+ fixed_x = if is_float_op -- promote to double
+ then StPrim Float2DoubleOp [x]
+ else x
+ in
+ getRegister (StCall fn DoubleRep [x])
+ where
+ (is_float_op, fn)
+ = case primop of
+ FloatExpOp -> (True, SLIT("exp"))
+ FloatLogOp -> (True, SLIT("log"))
+
+ FloatSinOp -> (True, SLIT("sin"))
+ FloatCosOp -> (True, SLIT("cos"))
+ FloatTanOp -> (True, SLIT("tan"))
+
+ FloatAsinOp -> (True, SLIT("asin"))
+ FloatAcosOp -> (True, SLIT("acos"))
+ FloatAtanOp -> (True, SLIT("atan"))
+
+ FloatSinhOp -> (True, SLIT("sinh"))
+ FloatCoshOp -> (True, SLIT("cosh"))
+ FloatTanhOp -> (True, SLIT("tanh"))
+
+ DoubleExpOp -> (False, SLIT("exp"))
+ DoubleLogOp -> (False, SLIT("log"))
+
+ DoubleSinOp -> (False, SLIT("sin"))
+ DoubleCosOp -> (False, SLIT("cos"))
+ DoubleTanOp -> (False, SLIT("tan"))
+
+ DoubleAsinOp -> (False, SLIT("asin"))
+ DoubleAcosOp -> (False, SLIT("acos"))
+ DoubleAtanOp -> (False, SLIT("atan"))
+
+ DoubleSinhOp -> (False, SLIT("sinh"))
+ DoubleCoshOp -> (False, SLIT("cosh"))
+ DoubleTanhOp -> (False, SLIT("tanh"))
+
+getRegister (StPrim primop [x, y]) -- dyadic PrimOps
+ = case primop of
+ CharGtOp -> condIntReg GT x y
+ CharGeOp -> condIntReg GE x y
+ CharEqOp -> condIntReg EQ x y
+ CharNeOp -> condIntReg NE x y
+ CharLtOp -> condIntReg LT x y
+ CharLeOp -> condIntReg LE x y
+
+ IntGtOp -> condIntReg GT x y
+ IntGeOp -> condIntReg GE x y
+ IntEqOp -> condIntReg EQ x y
+ IntNeOp -> condIntReg NE x y
+ IntLtOp -> condIntReg LT x y
+ IntLeOp -> condIntReg LE x y
+
+ WordGtOp -> condIntReg GU x y
+ WordGeOp -> condIntReg GEU x y
+ WordEqOp -> condIntReg EQ x y
+ WordNeOp -> condIntReg NE x y
+ WordLtOp -> condIntReg LU x y
+ WordLeOp -> condIntReg LEU x y
+
+ AddrGtOp -> condIntReg GU x y
+ AddrGeOp -> condIntReg GEU x y
+ AddrEqOp -> condIntReg EQ x y
+ AddrNeOp -> condIntReg NE x y
+ AddrLtOp -> condIntReg LU x y
+ AddrLeOp -> condIntReg LEU x y
+
+ FloatGtOp -> condFltReg GT x y
+ FloatGeOp -> condFltReg GE x y
+ FloatEqOp -> condFltReg EQ x y
+ FloatNeOp -> condFltReg NE x y
+ FloatLtOp -> condFltReg LT x y
+ FloatLeOp -> condFltReg LE x y
+
+ DoubleGtOp -> condFltReg GT x y
+ DoubleGeOp -> condFltReg GE x y
+ DoubleEqOp -> condFltReg EQ x y
+ DoubleNeOp -> condFltReg NE x y
+ DoubleLtOp -> condFltReg LT x y
+ DoubleLeOp -> condFltReg LE x y
+
+ IntAddOp -> trivialCode (ADD False False) x y
+ IntSubOp -> trivialCode (SUB False False) x y
+
+ -- ToDo: teach about V8+ SPARC mul/div instructions
+ IntMulOp -> imul_div SLIT(".umul") x y
+ IntQuotOp -> imul_div SLIT(".div") x y
+ IntRemOp -> imul_div SLIT(".rem") x y
+
+ FloatAddOp -> trivialFCode FloatRep FADD x y
+ FloatSubOp -> trivialFCode FloatRep FSUB x y
+ FloatMulOp -> trivialFCode FloatRep FMUL x y
+ FloatDivOp -> trivialFCode FloatRep FDIV x y
+
+ DoubleAddOp -> trivialFCode DoubleRep FADD x y
+ DoubleSubOp -> trivialFCode DoubleRep FSUB x y
+ DoubleMulOp -> trivialFCode DoubleRep FMUL x y
+ DoubleDivOp -> trivialFCode DoubleRep FDIV x y
+
+ AndOp -> trivialCode (AND False) x y
+ OrOp -> trivialCode (OR False) x y
+ SllOp -> trivialCode SLL x y
+ SraOp -> trivialCode SRA x y
+ SrlOp -> trivialCode SRL x y
+
+ ISllOp -> panic "SparcGen:isll"
+ ISraOp -> panic "SparcGen:isra"
+ ISrlOp -> panic "SparcGen:isrl"
+
+ FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
+ where promote x = StPrim Float2DoubleOp [x]
+ DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
+ where
+ imul_div fn x y = getRegister (StCall fn IntRep [x, y])
+
+getRegister (StInd pk mem)
+ = getAmode mem `thenUs` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ size = primRepToSize pk
+ code__2 dst = code . mkSeqInstr (LD size src dst)
+ in
+ returnUs (Any pk code__2)
+
+getRegister (StInt i)
+ | fits13Bits i
+ = let
+ src = ImmInt (fromInteger i)
+ code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
+ in
+ returnUs (Any IntRep code)
+
+getRegister leaf
+ | maybeToBool imm
+ = let
+ code dst = mkSeqInstrs [
+ SETHI (HI imm__2) dst,
+ OR False dst (RIImm (LO imm__2)) dst]
+ in
+ returnUs (Any PtrRep code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The @Amode@ type}
+%* *
+%************************************************************************
+
+@Amode@s: Memory addressing modes passed up the tree.
+\begin{code}
+data Amode = Amode Addr 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.
+
+\begin{code}
+getAmode :: StixTree -> UniqSM Amode
+
+getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
+
+#if alpha_TARGET_ARCH
+
+getAmode (StPrim IntSubOp [x, StInt i])
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister x `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (-(fromInteger i))
+ in
+ returnUs (Amode (AddrRegImm reg off) code)
+
+getAmode (StPrim IntAddOp [x, StInt i])
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister x `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (fromInteger i)
+ in
+ returnUs (Amode (AddrRegImm reg off) code)
+
+getAmode leaf
+ | maybeToBool imm
+ = returnUs (Amode (AddrImm imm__2) id)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+getAmode other
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister other `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ in
+ returnUs (Amode (AddrReg reg) code)
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+getAmode (StPrim IntSubOp [x, StInt i])
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister x `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (-(fromInteger i))
+ in
+ returnUs (Amode (Addr (Just reg) Nothing off) code)
+
+getAmode (StPrim IntAddOp [x, StInt i])
+ | maybeToBool imm
+ = let
+ code = mkSeqInstrs []
+ in
+ returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
+ where
+ imm = maybeImm x
+ imm__2 = case imm of Just x -> x
+
+getAmode (StPrim IntAddOp [x, StInt i])
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister x `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (fromInteger i)
+ in
+ returnUs (Amode (Addr (Just reg) Nothing off) code)
+
+getAmode (StPrim IntAddOp [x, y])
+ = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ reg1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ reg2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2]
+ in
+ returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+
+getAmode leaf
+ | maybeToBool imm
+ = let
+ code = mkSeqInstrs []
+ in
+ returnUs (Amode (ImmAddr imm__2 0) code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+getAmode other
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister other `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = Nothing
+ in
+ returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+getAmode (StPrim IntSubOp [x, StInt i])
+ | fits13Bits (-i)
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister x `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (-(fromInteger i))
+ in
+ returnUs (Amode (AddrRegImm reg off) code)
+
+
+getAmode (StPrim IntAddOp [x, StInt i])
+ | fits13Bits i
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister x `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (fromInteger i)
+ in
+ returnUs (Amode (AddrRegImm reg off) code)
+
+getAmode (StPrim IntAddOp [x, y])
+ = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ reg1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ reg2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2]
+ in
+ returnUs (Amode (AddrRegReg reg1 reg2) code__2)
+
+getAmode leaf
+ | maybeToBool imm
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ let
+ code = mkSeqInstr (SETHI (HI imm__2) tmp)
+ in
+ returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+getAmode other
+ = getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getRegister other `thenUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt 0
+ in
+ returnUs (Amode (AddrRegImm reg off) code)
+
+#endif {- sparc_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 :: StixTree -> UniqSM 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 (StPrim primop [x, y])
+ = case primop of
+ CharGtOp -> condIntCode GT x y
+ CharGeOp -> condIntCode GE x y
+ CharEqOp -> condIntCode EQ x y
+ CharNeOp -> condIntCode NE x y
+ CharLtOp -> condIntCode LT x y
+ CharLeOp -> condIntCode LE x y
+
+ IntGtOp -> condIntCode GT x y
+ IntGeOp -> condIntCode GE x y
+ IntEqOp -> condIntCode EQ x y
+ IntNeOp -> condIntCode NE x y
+ IntLtOp -> condIntCode LT x y
+ IntLeOp -> condIntCode LE x y
+
+ WordGtOp -> condIntCode GU x y
+ WordGeOp -> condIntCode GEU x y
+ WordEqOp -> condIntCode EQ x y
+ WordNeOp -> condIntCode NE x y
+ WordLtOp -> condIntCode LU x y
+ WordLeOp -> condIntCode LEU x y
+
+ AddrGtOp -> condIntCode GU x y
+ AddrGeOp -> condIntCode GEU x y
+ AddrEqOp -> condIntCode EQ x y
+ AddrNeOp -> condIntCode NE x y
+ AddrLtOp -> condIntCode LU x y
+ AddrLeOp -> condIntCode LEU x y
+
+ FloatGtOp -> condFltCode GT x y
+ FloatGeOp -> condFltCode GE x y
+ FloatEqOp -> condFltCode EQ x y
+ FloatNeOp -> condFltCode NE x y
+ FloatLtOp -> condFltCode LT x y
+ FloatLeOp -> condFltCode LE x y
+
+ DoubleGtOp -> condFltCode GT x y
+ DoubleGeOp -> condFltCode GE x y
+ DoubleEqOp -> condFltCode EQ x y
+ DoubleNeOp -> condFltCode NE x y
+ DoubleLtOp -> condFltCode LT x y
+ DoubleLeOp -> condFltCode LE x y
+
+#endif {- i386_TARGET_ARCH || sparc_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 -> StixTree -> StixTree -> UniqSM 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
+
+condIntCode cond (StInd _ x) y
+ | maybeToBool imm
+ = getAmode x `thenUs` \ amode ->
+ let
+ code1 = amodeCode amode asmVoid
+ y__2 = amodeAddr amode
+ code__2 = asmParThen [code1] .
+ mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
+ in
+ returnUs (CondCode False cond code__2)
+ where
+ imm = maybeImm y
+ imm__2 = case imm of Just x -> x
+
+condIntCode cond x (StInt 0)
+ = getRegister x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code__2 = asmParThen [code1] .
+ mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
+ in
+ returnUs (CondCode False cond code__2)
+
+condIntCode cond x y
+ | maybeToBool imm
+ = getRegister x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code__2 = asmParThen [code1] .
+ mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
+ in
+ returnUs (CondCode False cond code__2)
+ where
+ imm = maybeImm y
+ imm__2 = case imm of Just x -> x
+
+condIntCode cond (StInd _ x) y
+ = getAmode x `thenUs` \ amode ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = amodeCode amode asmVoid
+ src1 = amodeAddr amode
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
+ in
+ returnUs (CondCode False cond code__2)
+
+condIntCode cond y (StInd _ x)
+ = getAmode x `thenUs` \ amode ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = amodeCode amode asmVoid
+ src1 = amodeAddr amode
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
+ in
+ returnUs (CondCode False cond code__2)
+
+condIntCode cond x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
+ in
+ returnUs (CondCode False cond code__2)
+
+-----------
+
+condFltCode cond x (StDouble 0.0)
+ = getRegister x `thenUs` \ register1 ->
+ getNewRegNCG (registerRep register1)
+ `thenUs` \ tmp1 ->
+ let
+ pk1 = registerRep register1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ code__2 = asmParThen [code1 asmVoid] .
+ mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
+ FNSTSW,
+ --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+ --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+ SAHF
+ ]
+ in
+ returnUs (CondCode True (fix_FP_cond cond) code__2)
+
+condFltCode cond x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG (registerRep register1)
+ `thenUs` \ tmp1 ->
+ getNewRegNCG (registerRep register2)
+ `thenUs` \ tmp2 ->
+ let
+ pk1 = registerRep register1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
+ mkSeqInstrs [FUCOMPP,
+ FNSTSW,
+ --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+ --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+ SAHF
+ ]
+ in
+ returnUs (CondCode True (fix_FP_cond cond) code__2)
+
+{- On the 486, the flags set by FP compare are the unsigned ones!
+ (This looks like a HACK to me. WDP 96/03)
+-}
+
+fix_FP_cond :: Cond -> Cond
+
+fix_FP_cond GE = GEU
+fix_FP_cond GT = GU
+fix_FP_cond LT = LU
+fix_FP_cond LE = LEU
+fix_FP_cond any = any
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+condIntCode cond x (StInt y)
+ | fits13Bits y
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (fromInteger y)
+ code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
+ in
+ returnUs (CondCode False cond code__2)
+
+condIntCode cond x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (SUB False True src1 (RIReg src2) g0)
+ in
+ returnUs (CondCode False cond code__2)
+
+-----------
+condFltCode cond x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG (registerRep register1)
+ `thenUs` \ tmp1 ->
+ getNewRegNCG (registerRep register2)
+ `thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ let
+ promote x = asmInstr (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
+ asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
+ else if pk1 == FloatRep then
+ asmParThen [code1 (promote src1), code2 asmVoid] .
+ mkSeqInstr (FCMP True DF tmp src2)
+ else
+ asmParThen [code1 asmVoid, code2 (promote src2)] .
+ mkSeqInstr (FCMP True DF src1 tmp)
+ in
+ returnUs (CondCode True cond code__2)
+
+#endif {- sparc_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}
+assignIntCode, assignFltCode
+ :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
+
+#if alpha_TARGET_ARCH
+
+assignIntCode pk (StInd _ dst) src
+ = getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getRegister src `thenUs` \ register ->
+ let
+ code1 = amodeCode amode asmVoid
+ dst__2 = amodeAddr amode
+ code2 = registerCode register tmp asmVoid
+ src__2 = registerName register tmp
+ sz = primRepToSize pk
+ code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ in
+ returnUs code__2
+
+assignIntCode pk dst src
+ = getRegister dst `thenUs` \ register1 ->
+ getRegister src `thenUs` \ register2 ->
+ let
+ dst__2 = registerName register1 zero
+ 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
+ returnUs code__2
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+assignIntCode pk (StInd _ dst) src
+ = getAmode dst `thenUs` \ amode ->
+ get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
+ let
+ code1 = amodeCode amode asmVoid
+ dst__2 = amodeAddr amode
+ code__2 = asmParThen [code1, codesrc asmVoid] .
+ mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
+ in
+ returnUs code__2
+ where
+ get_op_RI
+ :: StixTree
+ -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
+
+ get_op_RI op
+ | maybeToBool imm
+ = returnUs (asmParThen [], OpImm imm_op, L)
+ where
+ imm = maybeImm op
+ imm_op = case imm of Just x -> x
+
+ get_op_RI op
+ = getRegister op `thenUs` \ register ->
+ getNewRegNCG (registerRep register)
+ `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ pk = registerRep register
+ sz = primRepToSize pk
+ in
+ returnUs (code, OpReg reg, sz)
+
+assignIntCode pk dst (StInd _ src)
+ = getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode src `thenUs` \ amode ->
+ getRegister dst `thenUs` \ register ->
+ let
+ code1 = amodeCode amode asmVoid
+ src__2 = amodeAddr amode
+ code2 = registerCode register tmp asmVoid
+ dst__2 = registerName register tmp
+ sz = primRepToSize pk
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
+ in
+ returnUs code__2
+
+assignIntCode pk dst src
+ = getRegister dst `thenUs` \ register1 ->
+ getRegister src `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ dst__2 = registerName register1 tmp
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+ code__2 = if isFixed register2 && dst__2 /= src__2
+ then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
+ else code
+ in
+ returnUs code__2
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+assignIntCode pk (StInd _ dst) src
+ = getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getRegister src `thenUs` \ register ->
+ let
+ code1 = amodeCode amode asmVoid
+ dst__2 = amodeAddr amode
+ code2 = registerCode register tmp asmVoid
+ src__2 = registerName register tmp
+ sz = primRepToSize pk
+ code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ in
+ returnUs code__2
+
+assignIntCode pk dst src
+ = getRegister dst `thenUs` \ register1 ->
+ getRegister src `thenUs` \ register2 ->
+ let
+ dst__2 = registerName register1 g0
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+ code__2 = if isFixed register2
+ then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
+ else code
+ in
+ returnUs code__2
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
+
+% --------------------------------
+Floating-point assignments:
+% --------------------------------
+\begin{code}
+#if alpha_TARGET_ARCH
+
+assignFltCode pk (StInd _ dst) src
+ = getNewRegNCG pk `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getRegister src `thenUs` \ register ->
+ let
+ code1 = amodeCode amode asmVoid
+ dst__2 = amodeAddr amode
+ code2 = registerCode register tmp asmVoid
+ src__2 = registerName register tmp
+ sz = primRepToSize pk
+ code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+ in
+ returnUs code__2
+
+assignFltCode pk dst src
+ = getRegister dst `thenUs` \ register1 ->
+ getRegister src `thenUs` \ register2 ->
+ let
+ dst__2 = registerName register1 zero
+ 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
+ returnUs code__2
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
+ = getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode src `thenUs` \ amodesrc ->
+ getAmode dst `thenUs` \ amodedst ->
+ --getRegister src `thenUs` \ register ->
+ let
+ codesrc1 = amodeCode amodesrc asmVoid
+ addrsrc1 = amodeAddr amodesrc
+ codedst1 = amodeCode amodedst asmVoid
+ addrdst1 = amodeAddr amodedst
+ addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
+ addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
+
+ code__2 = asmParThen [codesrc1, codedst1] .
+ mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
+ MOV L (OpReg tmp) (OpAddr addrdst1)]
+ ++
+ if pk == DoubleRep
+ then [MOV L (OpAddr addrsrc2) (OpReg tmp),
+ MOV L (OpReg tmp) (OpAddr addrdst2)]
+ else [])
+ in
+ returnUs code__2
+
+assignFltCode pk (StInd _ dst) src
+ = --getNewRegNCG pk `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getRegister src `thenUs` \ register ->
+ let
+ sz = primRepToSize pk
+ dst__2 = amodeAddr amode
+
+ code1 = amodeCode amode asmVoid
+ code2 = registerCode register {-tmp-}st0 asmVoid
+
+ --src__2= registerName register tmp
+ pk__2 = registerRep register
+ sz__2 = primRepToSize pk__2
+
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (FSTP sz (OpAddr dst__2))
+ in
+ returnUs code__2
+
+assignFltCode pk dst src
+ = getRegister dst `thenUs` \ register1 ->
+ getRegister src `thenUs` \ register2 ->
+ --getNewRegNCG (registerRep register2)
+ -- `thenUs` \ tmp ->
+ let
+ sz = primRepToSize pk
+ dst__2 = registerName register1 st0 --tmp
+
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+
+ code__2 = code
+ in
+ returnUs code__2
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+assignFltCode pk (StInd _ dst) src
+ = getNewRegNCG pk `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getRegister src `thenUs` \ register ->
+ let
+ sz = primRepToSize pk
+ dst__2 = amodeAddr amode
+
+ code1 = amodeCode amode asmVoid
+ code2 = registerCode register tmp asmVoid
+
+ src__2 = registerName register tmp
+ pk__2 = registerRep register
+ sz__2 = primRepToSize pk__2
+
+ code__2 = asmParThen [code1, code2] .
+ if pk == pk__2 then
+ mkSeqInstr (ST sz src__2 dst__2)
+ else
+ mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
+ in
+ returnUs code__2
+
+assignFltCode pk dst src
+ = getRegister dst `thenUs` \ register1 ->
+ getRegister src `thenUs` \ register2 ->
+ getNewRegNCG (registerRep register2)
+ `thenUs` \ 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
+ pk__2 = registerRep register2
+ sz__2 = primRepToSize pk__2
+
+ code__2 = if pk /= pk__2 then
+ code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
+ else if isFixed register2 then
+ code . mkSeqInstr (FMOV sz src__2 dst__2)
+ else
+ code
+ in
+ returnUs code__2
+
+#endif {- sparc_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 :: StixTree{-the branch target-} -> UniqSM InstrBlock
+
+#if alpha_TARGET_ARCH
+
+genJump (StCLbl lbl)
+ | isAsmTemp lbl = returnInstr (BR target)
+ | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
+ where
+ target = ImmCLbl lbl
+
+genJump tree
+ = getRegister tree `thenUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ 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 zero (AddrReg pv) 0]
+ else
+ returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+{-
+genJump (StCLbl lbl)
+ | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
+ | otherwise = returnInstrs [JMP (OpImm target)]
+ where
+ target = ImmCLbl lbl
+-}
+
+genJump (StInd pk mem)
+ = getAmode mem `thenUs` \ amode ->
+ let
+ code = amodeCode amode
+ target = amodeAddr amode
+ in
+ returnSeq code [JMP (OpAddr target)]
+
+genJump tree
+ | maybeToBool imm
+ = returnInstr (JMP (OpImm target))
+
+ | otherwise
+ = getRegister tree `thenUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ target = registerName register tmp
+ in
+ returnSeq code [JMP (OpReg target)]
+ where
+ imm = maybeImm tree
+ target = case imm of Just x -> x
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+genJump (StCLbl lbl)
+ | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
+ | otherwise = returnInstrs [CALL target 0 True, NOP]
+ where
+ target = ImmCLbl lbl
+
+genJump tree
+ = getRegister tree `thenUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ target = registerName register tmp
+ in
+ returnSeq code [JMP (AddrRegReg target g0), NOP]
+
+#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
+ -> StixTree -- the condition on which to branch
+ -> UniqSM InstrBlock
+
+#if alpha_TARGET_ARCH
+
+genCondJump lbl (StPrim op [x, StInt 0])
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG (registerRep register)
+ `thenUs` \ 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 = GT
+ cmpOp CharGeOp = GE
+ cmpOp CharEqOp = EQ
+ cmpOp CharNeOp = NE
+ cmpOp CharLtOp = LT
+ cmpOp CharLeOp = LE
+ cmpOp IntGtOp = GT
+ cmpOp IntGeOp = GE
+ cmpOp IntEqOp = EQ
+ cmpOp IntNeOp = NE
+ cmpOp IntLtOp = LT
+ cmpOp IntLeOp = LE
+ cmpOp WordGtOp = NE
+ cmpOp WordGeOp = ALWAYS
+ cmpOp WordEqOp = EQ
+ cmpOp WordNeOp = NE
+ cmpOp WordLtOp = NEVER
+ cmpOp WordLeOp = EQ
+ cmpOp AddrGtOp = NE
+ cmpOp AddrGeOp = ALWAYS
+ cmpOp AddrEqOp = EQ
+ cmpOp AddrNeOp = NE
+ cmpOp AddrLtOp = NEVER
+ cmpOp AddrLeOp = EQ
+
+genCondJump lbl (StPrim op [x, StDouble 0.0])
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG (registerRep register)
+ `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ value = registerName register tmp
+ pk = registerRep register
+ target = ImmCLbl lbl
+ in
+ returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
+ where
+ cmpOp FloatGtOp = GT
+ cmpOp FloatGeOp = GE
+ cmpOp FloatEqOp = EQ
+ cmpOp FloatNeOp = NE
+ cmpOp FloatLtOp = LT
+ cmpOp FloatLeOp = LE
+ cmpOp DoubleGtOp = GT
+ cmpOp DoubleGeOp = GE
+ cmpOp DoubleEqOp = EQ
+ cmpOp DoubleNeOp = NE
+ cmpOp DoubleLtOp = LT
+ cmpOp DoubleLeOp = LE
+
+genCondJump lbl (StPrim op [x, y])
+ | fltCmpOp op
+ = trivialFCode pr instr x y `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ result = registerName register tmp
+ target = ImmCLbl lbl
+ in
+ returnUs (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, EQ)
+ FloatGeOp -> (FCMP TF LT, EQ)
+ FloatEqOp -> (FCMP TF EQ, NE)
+ FloatNeOp -> (FCMP TF EQ, EQ)
+ FloatLtOp -> (FCMP TF LT, NE)
+ FloatLeOp -> (FCMP TF LE, NE)
+ DoubleGtOp -> (FCMP TF LE, EQ)
+ DoubleGeOp -> (FCMP TF LT, EQ)
+ DoubleEqOp -> (FCMP TF EQ, NE)
+ DoubleNeOp -> (FCMP TF EQ, EQ)
+ DoubleLtOp -> (FCMP TF LT, NE)
+ DoubleLeOp -> (FCMP TF LE, NE)
+
+genCondJump lbl (StPrim op [x, y])
+ = trivialCode instr x y `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ result = registerName register tmp
+ target = ImmCLbl lbl
+ in
+ returnUs (code . mkSeqInstr (BI cond result target))
+ where
+ (instr, cond) = case op of
+ CharGtOp -> (CMP LE, EQ)
+ CharGeOp -> (CMP LT, EQ)
+ CharEqOp -> (CMP EQ, NE)
+ CharNeOp -> (CMP EQ, EQ)
+ CharLtOp -> (CMP LT, NE)
+ CharLeOp -> (CMP LE, NE)
+ IntGtOp -> (CMP LE, EQ)
+ IntGeOp -> (CMP LT, EQ)
+ IntEqOp -> (CMP EQ, NE)
+ IntNeOp -> (CMP EQ, EQ)
+ IntLtOp -> (CMP LT, NE)
+ IntLeOp -> (CMP LE, NE)
+ WordGtOp -> (CMP ULE, EQ)
+ WordGeOp -> (CMP ULT, EQ)
+ WordEqOp -> (CMP EQ, NE)
+ WordNeOp -> (CMP EQ, EQ)
+ WordLtOp -> (CMP ULT, NE)
+ WordLeOp -> (CMP ULE, NE)
+ AddrGtOp -> (CMP ULE, EQ)
+ AddrGeOp -> (CMP ULT, EQ)
+ AddrEqOp -> (CMP EQ, NE)
+ AddrNeOp -> (CMP EQ, EQ)
+ AddrLtOp -> (CMP ULT, NE)
+ AddrLeOp -> (CMP ULE, NE)
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+genCondJump lbl bool
+ = getCondCode bool `thenUs` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ target = ImmCLbl lbl
+ in
+ returnSeq code [JXX cond lbl]
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+genCondJump lbl bool
+ = getCondCode bool `thenUs` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ target = ImmCLbl lbl
+ in
+ returnSeq code (
+ if condFloat condition then
+ [NOP, BF cond False target, NOP]
+ else
+ [BI cond False target, NOP]
+ )
+
+#endif {- sparc_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
+ :: FAST_STRING -- function to call
+ -> PrimRep -- type of the result
+ -> [StixTree] -- arguments (of mixed type)
+ -> UniqSM InstrBlock
+
+#if alpha_TARGET_ARCH
+
+genCCall fn kind args
+ = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
+ `thenUs` \ ((unused,_), argCode) ->
+ let
+ nRegs = length allArgRegs - length unused
+ code = asmParThen (map ($ asmVoid) argCode)
+ in
+ returnSeq code [
+ LDA pv (AddrImm (ImmLab (uppPStr 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
+ @mapAccumLUs@.
+ -}
+ get_arg
+ :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
+ -> StixTree -- Current argument
+ -> UniqSM (([(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 `thenUs` \ register ->
+ let
+ reg = if isFloatingRep pk then fDst else iDst
+ code = registerCode register reg
+ src = registerName register reg
+ pk = registerRep register
+ in
+ returnUs (
+ 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 `thenUs` \ register ->
+ getNewRegNCG (registerRep register)
+ `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ pk = registerRep register
+ sz = primRepToSize pk
+ in
+ returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+genCCall fn kind [StInt i]
+ | fn == SLIT ("PerformGC_wrapper")
+ = getUniqLabelNCG `thenUs` \ lbl ->
+ let
+ call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
+ MOV L (OpImm (ImmCLbl lbl))
+ -- this is hardwired
+ (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
+ JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
+ LABEL lbl]
+ in
+ returnInstrs call
+
+genCCall fn kind args
+ = mapUs get_call_arg args `thenUs` \ argCode ->
+ let
+ nargs = length args
+ code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
+ MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
+ ]
+ ]
+ code2 = asmParThen (map ($ asmVoid) (reverse argCode))
+ call = [CALL fn__2 -- ,
+ -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
+ -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
+ ]
+ in
+ returnSeq (code1 . code2) 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__2 = case (_HEAD_ fn) of
+ '.' -> ImmLit (uppPStr fn)
+ _ -> ImmLab (uppPStr fn)
+
+ ------------
+ get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
+
+ get_call_arg arg
+ = get_op arg `thenUs` \ (code, op, sz) ->
+ returnUs (code . mkSeqInstr (PUSH sz op))
+
+ ------------
+ get_op
+ :: StixTree
+ -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
+
+ get_op (StInt i)
+ = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
+
+ get_op (StInd pk mem)
+ = getAmode mem `thenUs` \ amode ->
+ let
+ code = amodeCode amode --asmVoid
+ addr = amodeAddr amode
+ sz = primRepToSize pk
+ in
+ returnUs (code, OpAddr addr, sz)
+
+ get_op op
+ = getRegister op `thenUs` \ register ->
+ getNewRegNCG (registerRep register)
+ `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ pk = registerRep register
+ sz = primRepToSize pk
+ in
+ returnUs (code, OpReg reg, sz)
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+genCCall fn kind args
+ = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
+ `thenUs` \ ((unused,_), argCode) ->
+ let
+ nRegs = length allArgRegs - length unused
+ call = CALL fn__2 nRegs False
+ code = asmParThen (map ($ asmVoid) argCode)
+ in
+ returnSeq code [call, NOP]
+ 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__2 = case (_HEAD_ fn) of
+ '.' -> ImmLit (uppPStr fn)
+ _ -> ImmLab (uppPStr fn)
+
+ ------------------------------------
+ {- Try to get a value into a specific register (or registers) for
+ a call. 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.) 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
+ @mapAccumL@.
+ -}
+ get_arg
+ :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
+ -> StixTree -- Current argument
+ -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
+
+ -- We have to use up all of our argument registers first...
+
+ get_arg (dst:dsts, offset) arg
+ = getRegister arg `thenUs` \ register ->
+ getNewRegNCG (registerRep register)
+ `thenUs` \ tmp ->
+ let
+ reg = if isFloatingRep pk then tmp else dst
+ code = registerCode register reg
+ src = registerName register reg
+ pk = registerRep register
+ in
+ returnUs (case pk of
+ DoubleRep ->
+ case dsts of
+ [] -> (([], offset + 1), code . mkSeqInstrs [
+ -- conveniently put the second part in the right stack
+ -- location, and load the first part into %o5
+ ST DF src (spRel (offset - 1)),
+ LD W (spRel (offset - 1)) dst])
+ (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
+ ST DF src (spRel (-2)),
+ LD W (spRel (-2)) dst,
+ LD W (spRel (-1)) dst__2])
+ FloatRep -> ((dsts, offset), code . mkSeqInstrs [
+ ST F src (spRel (-2)),
+ LD W (spRel (-2)) dst])
+ _ -> ((dsts, offset), if isFixed register then
+ code . mkSeqInstr (OR False g0 (RIReg src) dst)
+ else code))
+
+ -- Once we have run out of argument registers, we move to the
+ -- stack...
+
+ get_arg ([], offset) arg
+ = getRegister arg `thenUs` \ register ->
+ getNewRegNCG (registerRep register)
+ `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ pk = registerRep register
+ sz = primRepToSize pk
+ words = if pk == DoubleRep then 2 else 1
+ in
+ returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
+
+#endif {- sparc_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 -> StixTree -> StixTree -> UniqSM 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 `thenUs` \ condition ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ --getRegister dst `thenUs` \ register ->
+ let
+ --code2 = registerCode register tmp asmVoid
+ --dst__2 = registerName register tmp
+ code = condCode condition
+ cond = condName condition
+ -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
+ code__2 dst = code . mkSeqInstrs [
+ SETCC cond (OpReg tmp),
+ AND L (OpImm (ImmInt 1)) (OpReg tmp),
+ MOV L (OpReg tmp) (OpReg dst)]
+ in
+ returnUs (Any IntRep code__2)
+
+condFltReg cond x y
+ = getUniqLabelNCG `thenUs` \ lbl1 ->
+ getUniqLabelNCG `thenUs` \ lbl2 ->
+ condFltCode cond x y `thenUs` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = code . mkSeqInstrs [
+ 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
+ returnUs (Any IntRep code__2)
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+condIntReg EQ x (StInt 0)
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstrs [
+ SUB False True g0 (RIReg src) g0,
+ SUB True False g0 (RIImm (ImmInt (-1))) dst]
+ in
+ returnUs (Any IntRep code__2)
+
+condIntReg EQ x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
+ XOR False src1 (RIReg src2) dst,
+ SUB False True g0 (RIReg dst) g0,
+ SUB True False g0 (RIImm (ImmInt (-1))) dst]
+ in
+ returnUs (Any IntRep code__2)
+
+condIntReg NE x (StInt 0)
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstrs [
+ SUB False True g0 (RIReg src) g0,
+ ADD True False g0 (RIImm (ImmInt 0)) dst]
+ in
+ returnUs (Any IntRep code__2)
+
+condIntReg NE x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
+ XOR False src1 (RIReg src2) dst,
+ SUB False True g0 (RIReg dst) g0,
+ ADD True False g0 (RIImm (ImmInt 0)) dst]
+ in
+ returnUs (Any IntRep code__2)
+
+condIntReg cond x y
+ = getUniqLabelNCG `thenUs` \ lbl1 ->
+ getUniqLabelNCG `thenUs` \ lbl2 ->
+ condIntCode cond x y `thenUs` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = code . mkSeqInstrs [
+ 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
+ returnUs (Any IntRep code__2)
+
+condFltReg cond x y
+ = getUniqLabelNCG `thenUs` \ lbl1 ->
+ getUniqLabelNCG `thenUs` \ lbl2 ->
+ condFltCode cond x y `thenUs` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = code . mkSeqInstrs [
+ 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
+ returnUs (Any IntRep code__2)
+
+#endif {- sparc_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)
+ ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
+ ,)))
+ -> StixTree -> StixTree -- the two arguments
+ -> UniqSM Register
+
+trivialFCode
+ :: PrimRep
+ -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
+ ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
+ ,IF_ARCH_i386 (
+ {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
+ (Size -> Operand -> Instr)
+ -> (Size -> Operand -> Instr) {-reversed instr-}
+ -> Instr {-pop-}
+ -> Instr {-reversed instr: pop-}
+ ,)))
+ -> StixTree -> StixTree -- the two arguments
+ -> UniqSM Register
+
+trivialUCode
+ :: IF_ARCH_alpha((RI -> Reg -> Instr)
+ ,IF_ARCH_i386 ((Operand -> Instr)
+ ,IF_ARCH_sparc((RI -> Reg -> Instr)
+ ,)))
+ -> StixTree -- the one argument
+ -> UniqSM Register
+
+trivialUFCode
+ :: PrimRep
+ -> IF_ARCH_alpha((Reg -> Reg -> Instr)
+ ,IF_ARCH_i386 (Instr
+ ,IF_ARCH_sparc((Reg -> Reg -> Instr)
+ ,)))
+ -> StixTree -- the one argument
+ -> UniqSM Register
+
+#if alpha_TARGET_ARCH
+
+trivialCode instr x (StInt y)
+ | fits8Bits y
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ 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
+ returnUs (Any IntRep code__2)
+
+trivialCode instr x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = asmParThen [code1, code2] .
+ mkSeqInstr (instr src1 (RIReg src2) dst)
+ in
+ returnUs (Any IntRep code__2)
+
+------------
+trivialUCode instr x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
+ in
+ returnUs (Any IntRep code__2)
+
+------------
+trivialFCode _ instr x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr (instr src1 src2 dst)
+ in
+ returnUs (Any DoubleRep code__2)
+
+trivialUFCode _ instr x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr src dst)
+ in
+ returnUs (Any DoubleRep code__2)
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+trivialCode instr x y
+ | maybeToBool imm
+ = getRegister x `thenUs` \ register1 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ let
+ fixedname = registerName register1 eax
+ code__2 dst = let code1 = registerCode register1 dst
+ src1 = registerName register1 dst
+ in code1 .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpImm imm__2) (OpReg dst)]
+ else
+ mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
+ in
+ returnUs (Any IntRep code__2)
+ where
+ imm = maybeImm y
+ imm__2 = case imm of Just x -> x
+
+trivialCode instr x y
+ | maybeToBool imm
+ = getRegister y `thenUs` \ register1 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ let
+ fixedname = registerName register1 eax
+ code__2 dst = let code1 = registerCode register1 dst
+ src1 = registerName register1 dst
+ in code1 .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpImm imm__2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
+ in
+ returnUs (Any IntRep code__2)
+ where
+ imm = maybeImm x
+ imm__2 = case imm of Just x -> x
+
+trivialCode instr x (StInd pk mem)
+ = getRegister x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode mem `thenUs` \ amode ->
+ let
+ fixedname = registerName register eax
+ code2 = amodeCode amode asmVoid
+ src2 = amodeAddr amode
+ code__2 dst = let code1 = registerCode register dst asmVoid
+ src1 = registerName register dst
+ in asmParThen [code1, code2] .
+ if isFixed register && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+ in
+ returnUs (Any pk code__2)
+
+trivialCode instr (StInd pk mem) y
+ = getRegister y `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode mem `thenUs` \ amode ->
+ let
+ fixedname = registerName register eax
+ code2 = amodeCode amode asmVoid
+ src2 = amodeAddr amode
+ code__2 dst = let
+ code1 = registerCode register dst asmVoid
+ src1 = registerName register dst
+ in asmParThen [code1, code2] .
+ if isFixed register && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+ in
+ returnUs (Any pk code__2)
+
+trivialCode instr x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ fixedname = registerName register1 eax
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = let
+ code1 = registerCode register1 dst asmVoid
+ src1 = registerName register1 dst
+ in asmParThen [code1, code2] .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpReg src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpReg src2) (OpReg src1))
+ in
+ returnUs (Any IntRep code__2)
+
+-----------
+trivialUCode instr x
+ = getRegister x `thenUs` \ register ->
+-- getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+-- fixedname = registerName register eax
+ code__2 dst = let
+ code = registerCode register dst
+ src = registerName register dst
+ in code . if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ instr (OpReg dst)]
+ else mkSeqInstr (instr (OpReg src))
+ in
+ returnUs (Any IntRep code__2)
+
+-----------
+trivialFCode pk _ instrr _ _ (StInd pk' mem) y
+ = getRegister y `thenUs` \ register2 ->
+ --getNewRegNCG (registerRep register2)
+ -- `thenUs` \ tmp2 ->
+ getAmode mem `thenUs` \ amode ->
+ let
+ code1 = amodeCode amode
+ src1 = amodeAddr amode
+
+ code__2 dst = let
+ code2 = registerCode register2 dst
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid,code2 asmVoid] .
+ mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
+ in
+ returnUs (Any pk code__2)
+
+trivialFCode pk instr _ _ _ x (StInd pk' mem)
+ = getRegister x `thenUs` \ register1 ->
+ --getNewRegNCG (registerRep register1)
+ -- `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
+ code2 = amodeCode amode
+ src2 = amodeAddr amode
+
+ code__2 dst = let
+ code1 = registerCode register1 dst
+ src1 = registerName register1 dst
+ in asmParThen [code2 asmVoid,code1 asmVoid] .
+ mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
+ in
+ returnUs (Any pk code__2)
+
+trivialFCode pk _ _ _ instrpr x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ --getNewRegNCG (registerRep register1)
+ -- `thenUs` \ tmp1 ->
+ --getNewRegNCG (registerRep register2)
+ -- `thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ let
+ pk1 = registerRep register1
+ code1 = registerCode register1 st0 --tmp1
+ src1 = registerName register1 st0 --tmp1
+
+ pk2 = registerRep register2
+
+ code__2 dst = let
+ code2 = registerCode register2 dst
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr instrpr
+ in
+ returnUs (Any pk1 code__2)
+
+-------------
+trivialUFCode pk instr (StInd pk' mem)
+ = getAmode mem `thenUs` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
+ instr]
+ in
+ returnUs (Any pk code__2)
+
+trivialUFCode pk instr x
+ = getRegister x `thenUs` \ register ->
+ --getNewRegNCG pk `thenUs` \ tmp ->
+ let
+ code__2 dst = let
+ code = registerCode register dst
+ src = registerName register dst
+ in code . mkSeqInstrs [instr]
+ in
+ returnUs (Any pk code__2)
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+trivialCode instr x (StInt y)
+ | fits13Bits y
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ 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
+ returnUs (Any IntRep code__2)
+
+trivialCode instr x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = asmParThen [code1, code2] .
+ mkSeqInstr (instr src1 (RIReg src2) dst)
+ in
+ returnUs (Any IntRep code__2)
+
+------------
+trivialFCode pk instr x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG (registerRep register1)
+ `thenUs` \ tmp1 ->
+ getNewRegNCG (registerRep register2)
+ `thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ let
+ promote x = asmInstr (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
+ asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
+ else if pk1 == FloatRep then
+ asmParThen [code1 (promote src1), code2 asmVoid] .
+ mkSeqInstr (instr DF tmp src2 dst)
+ else
+ asmParThen [code1 asmVoid, code2 (promote src2)] .
+ mkSeqInstr (instr DF src1 tmp dst)
+ in
+ returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
+
+------------
+trivialUCode instr x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
+ in
+ returnUs (Any IntRep code__2)
+
+-------------
+trivialUFCode pk instr x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG pk `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr src dst)
+ in
+ returnUs (Any pk code__2)
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Coercing to/from integer/floating-point...}
+%* *
+%************************************************************************
+
+@coerce(Int|Flt)Code@ are simple coercions that don't require any code
+to be generated. Here we just change the type on the Register passed
+on up. The code is machine-independent.
+
+@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.
+
+\begin{code}
+coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
+coerceFltCode :: StixTree -> UniqSM Register
+
+coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
+coerceFP2Int :: StixTree -> UniqSM Register
+
+coerceIntCode pk x
+ = getRegister x `thenUs` \ register ->
+ returnUs (
+ case register of
+ Fixed _ reg code -> Fixed pk reg code
+ Any _ code -> Any pk code
+ )
+
+-------------
+coerceFltCode x
+ = getRegister x `thenUs` \ register ->
+ returnUs (
+ case register of
+ Fixed _ reg code -> Fixed DoubleRep reg code
+ Any _ code -> Any DoubleRep code
+ )
+\end{code}
+
+\begin{code}
+#if alpha_TARGET_ARCH
+
+coerceInt2FP _ x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ 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
+ returnUs (Any DoubleRep code__2)
+
+-------------
+coerceFP2Int x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ 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
+ returnUs (Any IntRep code__2)
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+coerceInt2FP pk x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+
+ code__2 dst = code . mkSeqInstrs [
+ -- to fix: should spill instead of using R1
+ MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+ in
+ returnUs (Any pk code__2)
+
+------------
+coerceFP2Int x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ pk = registerRep register
+
+ code__2 dst = let
+ in code . mkSeqInstrs [
+ FRNDINT,
+ FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
+ MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+ in
+ returnUs (Any IntRep code__2)
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+coerceInt2FP pk x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+
+ code__2 dst = code . mkSeqInstrs [
+ ST W src (spRel (-2)),
+ LD W (spRel (-2)) dst,
+ FxTOy W (primRepToSize pk) dst dst]
+ in
+ returnUs (Any pk code__2)
+
+------------
+coerceFP2Int x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ getNewRegNCG FloatRep `thenUs` \ tmp ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+ pk = registerRep register
+
+ code__2 dst = code . mkSeqInstrs [
+ FxTOy (primRepToSize pk) W src tmp,
+ ST W tmp (spRel (-2)),
+ LD W (spRel (-2)) dst]
+ in
+ returnUs (Any IntRep code__2)
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Coercing integer to @Char@...}
+%* *
+%************************************************************************
+
+Integer to character conversion. Where applicable, we try to do this
+in one step if the original object is in memory.
+
+\begin{code}
+chrCode :: StixTree -> UniqSM Register
+
+#if alpha_TARGET_ARCH
+
+chrCode x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+ code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
+ in
+ returnUs (Any IntRep code__2)
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+chrCode x
+ = getRegister x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ reg ->
+ let
+ fixedname = registerName register eax
+ code__2 dst = let
+ code = registerCode register dst
+ src = registerName register dst
+ in code .
+ if isFixed register && src /= dst
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ AND L (OpImm (ImmInt 255)) (OpReg dst)]
+ else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
+ in
+ returnUs (Any IntRep code__2)
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+chrCode (StInd pk mem)
+ = getAmode mem `thenUs` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ src_off = addrOffset src 3
+ src__2 = case src_off of Just x -> x
+ code__2 dst = if maybeToBool src_off then
+ code . mkSeqInstr (LD BU src__2 dst)
+ else
+ code . mkSeqInstrs [
+ LD (primRepToSize pk) src dst,
+ AND False dst (RIImm (ImmInt 255)) dst]
+ in
+ returnUs (Any pk code__2)
+
+chrCode x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+ code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
+ in
+ returnUs (Any IntRep code__2)
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Absolute value on integers}
+%* *
+%************************************************************************
+
+Absolute value on integers, mostly for gmp size check macros. Again,
+the argument cannot be an StInt, because genericOpt already folded
+constants.
+
+If applicable, do not fill the delay slots here; you will confuse the
+register allocator.
+
+\begin{code}
+absIntCode :: StixTree -> UniqSM Register
+
+#if alpha_TARGET_ARCH
+absIntCode = panic "MachCode.absIntCode: not on Alphas"
+#endif {- alpha_TARGET_ARCH -}
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+absIntCode x
+ = getRegister x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ reg ->
+ getUniqLabelNCG `thenUs` \ lbl ->
+ let
+ code__2 dst = let code = registerCode register dst
+ src = registerName register dst
+ in code . if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ TEST L (OpReg dst) (OpReg dst),
+ JXX GE lbl,
+ NEGI L (OpReg dst),
+ LABEL lbl]
+ else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
+ JXX GE lbl,
+ NEGI L (OpReg src),
+ LABEL lbl]
+ in
+ returnUs (Any IntRep code__2)
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+absIntCode x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ getUniqLabelNCG `thenUs` \ lbl ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+ code__2 dst = code . mkSeqInstrs [
+ SUB False True g0 (RIReg src) dst,
+ BI GE False (ImmCLbl lbl), NOP,
+ OR False g0 (RIReg src) dst,
+ LABEL lbl]
+ in
+ returnUs (Any IntRep code__2)
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
diff --git a/ghc/compiler/nativeGen/MachDesc.lhs b/ghc/compiler/nativeGen/MachDesc.lhs
deleted file mode 100644
index c89d228fb589df6b540382850cdb05a0be0a616e..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/MachDesc.lhs
+++ /dev/null
@@ -1,95 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-
-Machine- and flag- specific bits that the abstract code generator has
-to know about.
-
-No doubt there will be more...
-
-\begin{code}
-#include "HsVersions.h"
-
-module MachDesc (
- Target(..){-(..) for target_STRICT only-}, mkTarget, RegLoc(..),
-
- saveLoc,
-
- fixedHeaderSize, varHeaderSize, stgReg,
- sizeof, volatileSaves, volatileRestores, hpRel,
- amodeToStix, amodeToStix', charLikeClosureSize,
- intLikeClosureSize, mutHS, dataHS, primToStix, macroCode,
- heapCheck
-
- -- and, for self-sufficiency...
- ) where
-
-import AbsCSyn
-import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
-import Outputable
-import OrdList ( OrdList )
-import SMRep ( SMRep )
-import Stix
-import UniqSupply
-import Unique
-import Unpretty ( PprStyle, CSeq )
-import Util
-
-data RegLoc = Save StixTree | Always StixTree
-\end{code}
-
-Think of this as a big runtime class dictionary:
-\begin{code}
-data Target = Target
- Int -- fixedHeaderSize
- (SMRep -> Int) -- varHeaderSize
- (MagicId -> RegLoc) -- stgReg
- (PrimRep -> Int) -- sizeof
- (HeapOffset -> Int) -- hpRel
- (CAddrMode -> StixTree) -- amodeToStix
- (CAddrMode -> StixTree) -- amodeToStix'
- (
- ([MagicId] -> [StixTree]), -- volatileSaves
- ([MagicId] -> [StixTree]), -- volatileRestores
- Int, -- charLikeClosureSize
- Int, -- intLikeClosureSize
- StixTree, -- mutHS
- StixTree, -- dataHS
- ([CAddrMode] -> PrimOp -> [CAddrMode] -> UniqSM StixTreeList),
- -- primToStix
- (CStmtMacro -> [CAddrMode] -> UniqSM StixTreeList),
- -- macroCode
- (StixTree -> StixTree -> StixTree -> UniqSM StixTreeList)
- -- heapCheck
- )
-
-mkTarget = Target
-
-fixedHeaderSize (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = fhs
-varHeaderSize (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vhs x
-stgReg (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = reg x
-sizeof (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = size x
--- used only for wrapper-hungry PrimOps:
-hpRel (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = hprel x
-amodeToStix (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = am x
-amodeToStix' (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = am' x
-
-volatileSaves (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vsave x
--- used only for wrapper-hungry PrimOps:
-volatileRestores (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vrest x
-charLikeClosureSize (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = csz
-intLikeClosureSize (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = isz
-mutHS (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = mhs
-dataHS (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = dhs
-primToStix (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y z = ps x y z
-macroCode (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y = mc x y
-heapCheck (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y z = hc x y z
-\end{code}
-
-Trees for register save locations
-\begin{code}
-saveLoc :: Target -> MagicId -> StixTree
-
-saveLoc target reg = case stgReg target reg of {Always loc -> loc; Save loc -> loc}
-\end{code}
-
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..add0adae06332bed935e6f8a4aeae40467206779
--- /dev/null
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -0,0 +1,676 @@
+%
+% (c) The AQUA Project, Glasgow University, 1993-1996
+%
+\section[MachMisc]{Description of various machine-specific things}
+
+\begin{code}
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module MachMisc (
+
+ fixedHdrSizeInWords, varHdrSizeInWords,
+ charLikeSize, intLikeSize, mutHS, dataHS,
+ sizeOf, primRepToSize,
+
+ eXTRA_STK_ARGS_HERE,
+
+ volatileSaves, volatileRestores,
+
+ storageMgrInfo, smCAFlist, smOldLim, smOldMutables,
+ smStablePtrTable,
+
+ targetMaxDouble, targetMaxInt, targetMinDouble, targetMinInt,
+
+ underscorePrefix,
+ fmtAsmLbl,
+ cvtLitLit,
+ exactLog2,
+
+ Instr(..), IF_ARCH_i386(Operand(..) COMMA,)
+ Cond(..),
+ Size(..)
+
+#if alpha_TARGET_ARCH
+ , RI(..)
+#endif
+#if i386_TARGET_ARCH
+#endif
+#if sparc_TARGET_ARCH
+ , RI(..), riZero
+#endif
+ ) where
+
+import Ubiq{-uitous-}
+import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia
+import NcgLoop ( underscorePrefix, fmtAsmLbl ) -- paranoia
+
+import AbsCSyn ( MagicId(..) )
+import AbsCUtils ( magicIdPrimRep )
+import CmdLineOpts ( opt_SccProfilingOn )
+import Literal ( mkMachInt, Literal(..) )
+import MachRegs ( stgReg, callerSaves, RegLoc(..),
+ Imm(..), Reg(..), Addr
+ )
+import OrdList ( OrdList )
+import PrimRep ( PrimRep(..) )
+import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
+import Stix ( StixTree(..), StixReg(..), sStLitLbl,
+ CodeSegment
+ )
+import Util ( panic )
+\end{code}
+
+\begin{code}
+underscorePrefix :: Bool -- leading underscore on labels?
+
+underscorePrefix
+ = IF_ARCH_alpha(False
+ ,{-else-} IF_ARCH_i386(
+ IF_OS_linuxaout(True
+ , IF_OS_freebsd(True
+ , IF_OS_bsdi(True
+ , {-otherwise-} False)))
+ ,{-else-}IF_ARCH_sparc(
+ IF_OS_sunos4(True, {-otherwise-} False)
+ ,)))
+
+---------------------------
+fmtAsmLbl :: String -> String -- for formatting labels
+
+fmtAsmLbl s
+ = IF_ARCH_alpha(
+ {- The alpha assembler likes temporary labels to look like $L123
+ instead of L123. (Don't toss the L, because then Lf28
+ turns into $f28.)
+ -}
+ '$' : s
+ ,{-otherwise-}
+ s
+ )
+
+---------------------------
+cvtLitLit :: String -> String
+
+-- ToDo: some kind of *careful* attention needed...
+
+cvtLitLit "stdin" = IF_ARCH_alpha("_iob+0" {-probably OK...-}
+ ,IF_ARCH_i386("_IO_stdin_"
+ ,IF_ARCH_sparc("__iob+0x0"{-probably OK...-}
+ ,)))
+cvtLitLit "stdout" = IF_ARCH_alpha("_iob+56"{-dodgy *at best*...-}
+ ,IF_ARCH_i386("_IO_stdout_"
+ ,IF_ARCH_sparc("__iob+0x14"{-dodgy *at best*...-}
+ ,)))
+cvtLitLit "stderr" = IF_ARCH_alpha("_iob+112"{-dodgy *at best*...-}
+ ,IF_ARCH_i386("_IO_stderr_"
+ ,IF_ARCH_sparc("__iob+0x28"{-dodgy *at best*...-}
+ ,)))
+cvtLitLit s
+ | isHex s = s
+ | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
+ where
+ isHex ('0':'x':xs) = all isHexDigit xs
+ isHex _ = False
+ -- Now, where have I seen this before?
+ isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
+\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,???)))
+\end{code}
+
+% ----------------------------------------------------------------
+
+@fixedHdrSizeInWords@ and @varHdrSizeInWords@: these are not dependent
+on target architecture.
+\begin{code}
+fixedHdrSizeInWords :: Int
+
+fixedHdrSizeInWords
+ = 1{-info ptr-} + profFHS + parFHS + tickyFHS
+ -- obviously, we aren't taking non-sequential too seriously yet
+ where
+ profFHS = if opt_SccProfilingOn then 1 else 0
+ parFHS = {-if PAR or GRAN then 1 else-} 0
+ tickyFHS = {-if ticky ... then 1 else-} 0
+
+varHdrSizeInWords :: SMRep -> Int{-in words-}
+
+varHdrSizeInWords sm
+ = case sm of
+ StaticRep _ _ -> 0
+ SpecialisedRep _ _ _ _ -> 0
+ GenericRep _ _ _ -> 0
+ BigTupleRep _ -> 1
+ MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -}
+ DataRep _ -> 1
+ DynamicRep -> 2
+ BlackHoleRep -> 0
+ PhantomRep -> panic "MachMisc.varHdrSizeInWords:phantom"
+\end{code}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+Static closure sizes:
+\begin{code}
+charLikeSize, intLikeSize :: Int
+
+charLikeSize = blahLikeSize CharLikeRep
+intLikeSize = blahLikeSize IntLikeRep
+
+blahLikeSize blah
+ = fromInteger (sizeOf PtrRep)
+ * (fixedHdrSizeInWords + varHdrSizeInWords blahLikeRep + 1)
+ where
+ blahLikeRep = SpecialisedRep blah 0 1 SMNormalForm
+
+--------
+mutHS, dataHS :: StixTree
+
+mutHS = blah_hs (MuTupleRep 0)
+dataHS = blah_hs (DataRep 0)
+
+blah_hs blah
+ = StInt (toInteger words)
+ where
+ words = fixedHdrSizeInWords + varHdrSizeInWords blah
+\end{code}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+Size of a @PrimRep@, in bytes.
+
+\begin{code}
+sizeOf :: PrimRep -> Integer{-in bytes-}
+ -- the result is an Integer only because it's more convenient
+
+sizeOf pr = case (primRepToSize pr) of
+ IF_ARCH_alpha({B -> 1; BU -> 1; {-W -> 2; WU -> 2; L -> 4; SF -> 4;-} _ -> 8},)
+ IF_ARCH_sparc({B -> 1; BU -> 1; {-HW -> 2; HWU -> 2;-} W -> 4; {-D -> 8;-} F -> 4; DF -> 8},)
+ IF_ARCH_i386( {B -> 1; {-S -> 2;-} L -> 4; F -> 4; DF -> 8 },)
+\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] -> [StixTree]
+
+save_cands = [BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg]
+restore_cands = save_cands ++ [StkStubReg,StdUpdRetVecReg]
+
+volatileSaves vols
+ = map save ((filter callerSaves) (save_cands ++ vols))
+ where
+ save x = StAssign (magicIdPrimRep x) loc reg
+ where
+ reg = StReg (StixMagicId x)
+ loc = case stgReg x of
+ Save loc -> loc
+ Always _ -> panic "volatileSaves"
+
+volatileRestores vols
+ = map restore ((filter callerSaves) (restore_cands ++ vols))
+ where
+ restore x = StAssign (magicIdPrimRep x) reg loc
+ where
+ reg = StReg (StixMagicId x)
+ loc = case stgReg x of
+ Save loc -> loc
+ Always _ -> panic "volatileRestores"
+\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 (-2147483647)
+targetMaxInt = mkMachInt 2147483647
+\end{code}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+Storage manager nonsense. Note that the indices are dependent on
+the definition of the smInfo structure in SMinterface.lh
+
+\begin{code}
+storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
+
+storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
+smCAFlist = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST))
+smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES))
+smOldLim = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM))
+smStablePtrTable = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
+\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
+i2w_s x = (x::Int#)
+
+exactLog2 :: Integer -> Maybe Integer
+exactLog2 x
+ = if (x <= 0 || x >= 2147483648) then
+ Nothing
+ else
+ case (fromInteger x) of { I# x# ->
+ if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
+ Nothing
+ else
+ Just (toInteger (I# (pow2 x#)))
+ }
+ where
+ shiftr x y = shiftRA# x y
+
+ pow2 x# | x# ==# 1# = 0#
+ | otherwise = 1# +# pow2 (w2i (i2w x# `shiftr` i2w_s 1#))
+\end{code}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+\begin{code}
+data Cond
+#if alpha_TARGET_ARCH
+ = ALWAYS -- For BI (same as BR)
+ | EQ -- For CMP and BI
+ | GE -- For BI only
+ | GT -- For BI only
+ | LE -- For CMP and BI
+ | LT -- For CMP and BI
+ | 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
+ | EQ
+ | GE
+ | GEU
+ | GT
+ | GU
+ | LE
+ | LEU
+ | LT
+ | LU
+ | NE
+ | NEG
+ | POS
+#endif
+#if sparc_TARGET_ARCH
+ = ALWAYS -- What's really used? ToDo
+ | EQ
+ | GE
+ | GEU
+ | GT
+ | GU
+ | LE
+ | LEU
+ | LT
+ | LU
+ | NE
+ | NEG
+ | NEVER
+ | POS
+ | VC
+ | VS
+#endif
+\end{code}
+
+\begin{code}
+data Size
+#if alpha_TARGET_ARCH
+ = B -- byte
+ | BU
+-- | W -- word (2 bytes): UNUSED
+-- | WU -- : UNUSED
+-- | L -- longword (4 bytes): UNUSED
+ | 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 (lower)
+-- | HB -- higher byte **UNUSED**
+-- | S -- : UNUSED
+ | L
+ | F -- IEEE single-precision floating pt
+ | DF -- IEEE single-precision floating pt
+#endif
+#if sparc_TARGET_ARCH
+ = B -- byte (signed)
+ | BU -- byte (unsigned)
+-- | HW -- halfword, 2 bytes (signed): UNUSED
+-- | HWU -- halfword, 2 bytes (unsigned): UNUSED
+ | W -- word, 4 bytes
+-- | D -- doubleword, 8 bytes: UNUSED
+ | 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 ,)))
+primRepToSize CodePtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize DataPtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize RetRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize CostCentreRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize CharRep = IF_ARCH_alpha( BU, IF_ARCH_i386( L, IF_ARCH_sparc( BU,)))
+primRepToSize IntRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize WordRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize AddrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize FloatRep = IF_ARCH_alpha( TF, IF_ARCH_i386( F, IF_ARCH_sparc( F ,)))
+primRepToSize DoubleRep = IF_ARCH_alpha( TF, IF_ARCH_i386( DF,IF_ARCH_sparc( DF,)))
+primRepToSize ArrayRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize ByteArrayRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize StablePtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize MallocPtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+\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 FAST_STRING -- 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]
+\end{code}
+
+\begin{code}
+#if alpha_TARGET_ARCH
+
+-- data Instr continues...
+
+-- Loads and stores.
+
+ | LD Size Reg Addr -- size, dst, src
+ | LDA Reg Addr -- dst, src
+ | LDAH Reg Addr -- dst, src
+ | LDGP Reg Addr -- dst, src
+ | LDI Size Reg Imm -- size, dst, src
+ | ST Size Reg Addr -- 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 Addr Int
+ | BSR Imm Int
+ | JSR Reg Addr Int
+
+-- Alpha-specific pseudo-ops.
+
+ | FUNBEGIN CLabel
+ | FUNEND CLabel
+
+data RI
+ = RIReg Reg
+ | RIImm Imm
+
+#endif {- alpha_TARGET_ARCH -}
+\end{code}
+
+\begin{code}
+#if i386_TARGET_ARCH
+
+-- data Instr continues...
+
+-- Moves.
+
+ | MOV Size Operand Operand
+ | MOVZX Size Operand Operand -- size is the size of operand 2
+ | MOVSX Size Operand Operand -- size is the size of operand 2
+
+-- 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
+
+-- Multiplication (signed and unsigned), Division (signed and unsigned),
+-- result in %eax, %edx.
+
+ | IMUL Size Operand Operand
+ | IDIV Size Operand
+
+-- 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 Operand Operand -- 1st operand must be an Imm
+ | SAR Size Operand Operand -- 1st operand must be an Imm
+ | SHR Size Operand Operand -- 1st operand must be an Imm
+ | NOP
+
+-- Float Arithmetic. -- ToDo for 386
+
+-- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
+-- right up until we spit them out.
+
+ | SAHF -- stores ah into flags
+ | FABS
+ | FADD Size Operand -- src
+ | FADDP
+ | FIADD Size Addr -- src
+ | FCHS
+ | FCOM Size Operand -- src
+ | FCOS
+ | FDIV Size Operand -- src
+ | FDIVP
+ | FIDIV Size Addr -- src
+ | FDIVR Size Operand -- src
+ | FDIVRP
+ | FIDIVR Size Addr -- src
+ | FICOM Size Addr -- src
+ | FILD Size Addr Reg -- src, dst
+ | FIST Size Addr -- dst
+ | FLD Size Operand -- src
+ | FLD1
+ | FLDZ
+ | FMUL Size Operand -- src
+ | FMULP
+ | FIMUL Size Addr -- src
+ | FRNDINT
+ | FSIN
+ | FSQRT
+ | FST Size Operand -- dst
+ | FSTP Size Operand -- dst
+ | FSUB Size Operand -- src
+ | FSUBP
+ | FISUB Size Addr -- src
+ | FSUBR Size Operand -- src
+ | FSUBRP
+ | FISUBR Size Addr -- src
+ | FTST
+ | FCOMP Size Operand -- src
+ | FUCOMPP
+ | FXCH
+ | FNSTSW
+ | FNOP
+
+-- Comparison
+
+ | TEST Size Operand Operand
+ | CMP Size Operand Operand
+ | SETCC Cond Operand
+
+-- Stack Operations.
+
+ | PUSH Size Operand
+ | POP Size Operand
+
+-- Jumping around.
+
+ | JMP Operand -- target
+ | JXX Cond CLabel -- target
+ | CALL Imm
+
+-- Other things.
+
+ | CLTD -- sign extend %eax into %edx:%eax
+
+data Operand
+ = OpReg Reg -- register
+ | OpImm Imm -- immediate value
+ | OpAddr Addr -- memory reference
+
+#endif {- i386_TARGET_ARCH -}
+\end{code}
+
+\begin{code}
+#if sparc_TARGET_ARCH
+
+-- data Instr continues...
+
+-- Loads and stores.
+
+ | LD Size Addr Reg -- size, src, dst
+ | ST Size Reg Addr -- 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
+
+-- 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 Addr -- target
+ | CALL Imm 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 (FixedReg ILIT(0))) = True
+riZero _ = False
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..b122217d2a065d8fb2a60c626cf8cbe3f0588dbc
--- /dev/null
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -0,0 +1,1022 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\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.)
+
+\begin{code}
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module MachRegs (
+
+ Reg(..),
+ Imm(..),
+ Addr(..),
+ RegLoc(..),
+ RegNo(..),
+
+ addrOffset,
+ argRegs,
+ baseRegOffset,
+ callClobberedRegs,
+ callerSaves,
+ dblImmLit,
+ extractMappedRegNos,
+ freeMappedRegs,
+ freeReg, freeRegs,
+ getNewRegNCG,
+ magicIdRegMaybe,
+ mkReg,
+ realReg,
+ reservedRegs,
+ saveLoc,
+ spRel,
+ stgReg,
+ strImmLit
+
+#if alpha_TARGET_ARCH
+ , allArgRegs
+ , fits8Bits
+ , fReg
+ , gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zero
+#endif
+#if i386_TARGET_ARCH
+ , eax, ebx, ecx, edx, esi, esp
+ , st0, st1, st2, st3, st4, st5, st6, st7
+#endif
+#if sparc_TARGET_ARCH
+ , allArgRegs
+ , fits13Bits
+ , fPair, fpRel, gReg, iReg, lReg, oReg, largeOffsetError
+ , fp, g0, o0, f0
+
+#endif
+ ) where
+
+import Ubiq{-uitous-}
+
+import AbsCSyn ( MagicId(..) )
+import AbsCUtils ( magicIdPrimRep )
+import Pretty ( ppStr, ppRational, ppShow )
+import PrimOp ( PrimOp(..) )
+import PrimRep ( PrimRep(..) )
+import Stix ( sStLitLbl, StixTree(..), StixReg(..),
+ CodeSegment
+ )
+import Unique ( Unique{-instance Ord3-} )
+import UniqSupply ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+ getUnique, returnUs, thenUs, UniqSM(..)
+ )
+import Unpretty ( uppStr, Unpretty(..) )
+import Util ( panic )
+\end{code}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+\begin{code}
+data Imm
+ = ImmInt Int
+ | ImmInteger Integer -- Sigh.
+ | ImmCLbl CLabel -- AbstractC Label (with baggage)
+ | ImmLab Unpretty -- Simple string label (underscore-able)
+ | ImmLit Unpretty -- Simple string
+ IF_ARCH_sparc(
+ | LO Imm -- Possible restrictions...
+ | HI Imm
+ ,)
+
+strImmLit s = ImmLit (uppStr s)
+dblImmLit r
+ = strImmLit (
+ IF_ARCH_alpha({-prepend nothing-}
+ ,IF_ARCH_i386( '0' : 'd' :
+ ,IF_ARCH_sparc('0' : 'r' :,)))
+ ppShow 80 (ppRational r))
+\end{code}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+\begin{code}
+data Addr
+#if alpha_TARGET_ARCH
+ = AddrImm Imm
+ | AddrReg Reg
+ | AddrRegImm Reg Imm
+#endif
+
+#if i386_TARGET_ARCH
+ = Addr Base Index Displacement
+ | ImmAddr Imm Int
+
+type Base = Maybe Reg
+type Index = Maybe (Reg, Int) -- Int is 2, 4 or 8
+type Displacement = Imm
+#endif
+
+#if sparc_TARGET_ARCH
+ = AddrRegReg Reg Reg
+ | AddrRegImm Reg Imm
+#endif
+
+addrOffset :: Addr -> Int -> Maybe Addr
+
+addrOffset addr off
+ = case addr of
+#if alpha_TARGET_ARCH
+ _ -> panic "MachMisc.addrOffset not defined for Alpha"
+#endif
+#if i386_TARGET_ARCH
+ ImmAddr i off0 -> Just (ImmAddr i (off0 + off))
+ Addr r i (ImmInt n) -> Just (Addr r i (ImmInt (n + off)))
+ Addr r i (ImmInteger n)
+ -> Just (Addr r i (ImmInt (fromInteger (n + toInteger off))))
+ _ -> Nothing
+#endif
+#if sparc_TARGET_ARCH
+ AddrRegImm r (ImmInt n)
+ | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2))
+ | otherwise -> Nothing
+ where n2 = n + off
+
+ AddrRegImm r (ImmInteger n)
+ | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))
+ | otherwise -> Nothing
+ where n2 = n + toInteger off
+
+ AddrRegReg r (FixedReg ILIT(0))
+ | fits13Bits off -> Just (AddrRegImm r (ImmInt off))
+ | otherwise -> Nothing
+
+ _ -> Nothing
+
+#endif {-sparc-}
+
+-----------------
+#if alpha_TARGET_ARCH
+
+fits8Bits :: Integer -> Bool
+fits8Bits i = i >= -256 && i < 256
+
+#endif
+
+#if sparc_TARGET_ARCH
+{-# SPECIALIZE
+ fits13Bits :: Int -> Bool
+ #-}
+{-# SPECIALIZE
+ fits13Bits :: Integer -> Bool
+ #-}
+
+fits13Bits :: Integral a => a -> Bool
+fits13Bits x = x >= -4096 && x < 4096
+
+-----------------
+largeOffsetError i
+ = error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n")
+
+#endif {-sparc-}
+\end{code}
+
+% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+@stgReg@: we map STG registers onto appropriate Stix Trees. First, we
+handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@.
+The rest are either in real machine registers or stored as offsets
+from BaseReg.
+
+\begin{code}
+data RegLoc = Save StixTree | Always StixTree
+\end{code}
+
+Trees for register save locations:
+\begin{code}
+saveLoc :: MagicId -> StixTree
+
+saveLoc reg = case (stgReg reg) of {Always loc -> loc; Save loc -> loc}
+\end{code}
+
+\begin{code}
+stgReg :: MagicId -> RegLoc
+
+stgReg x
+ = case (magicIdRegMaybe x) of
+ Just _ -> Save nonReg
+ Nothing -> Always nonReg
+ where
+ offset = baseRegOffset x
+
+ baseLoc = case (magicIdRegMaybe BaseReg) of
+ Just _ -> StReg (StixMagicId BaseReg)
+ Nothing -> sStLitLbl SLIT("MainRegTable")
+
+ nonReg = case x of
+ StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
+ StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
+ BaseReg -> sStLitLbl SLIT("MainRegTable")
+ -- these Hp&HpLim cases perhaps should
+ -- not be here for i386 (???) WDP 96/03
+ Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
+ HpLim -> StInd PtrRep (sStLitLbl
+ (_PK_ ("StorageMgrInfo+" ++ BYTES_PER_WORD_STR)))
+ TagReg -> StInd IntRep (StPrim IntSubOp [infoptr,
+ StInt (1*BYTES_PER_WORD)])
+ where
+ r2 = VanillaReg PtrRep ILIT(2)
+ infoptr = case (stgReg r2) of
+ Always t -> t
+ Save _ -> StReg (StixMagicId r2)
+ _ -> StInd (magicIdPrimRep x)
+ (StPrim IntAddOp [baseLoc,
+ StInt (toInteger (offset*BYTES_PER_WORD))])
+\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.
+
+\begin{code}
+spRel :: Int -- desired stack offset in words, positive or negative
+ -> Addr
+
+spRel n
+#if i386_TARGET_ARCH
+ = Addr (Just esp) Nothing (ImmInt (n * BYTES_PER_WORD))
+#else
+ = AddrRegImm sp (ImmInt (n * BYTES_PER_WORD))
+#endif
+
+#if sparc_TARGET_ARCH
+fpRel :: Int -> Addr
+ -- Duznae work for offsets greater than 13 bits; we just hope for
+ -- the best
+fpRel n
+ = AddrRegImm fp (ImmInt (n * BYTES_PER_WORD))
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Reg]{Real registers}
+%* *
+%************************************************************************
+
+Static Registers correspond to actual machine registers. These should
+be avoided until the last possible moment.
+
+Dynamic registers are allocated on the fly, usually to represent a single
+value in the abstract assembly code (i.e. dynamic registers are usually
+single assignment). Ultimately, they are mapped to available machine
+registers before spitting out the code.
+
+\begin{code}
+data Reg
+ = FixedReg FAST_INT -- A pre-allocated machine register
+
+ | MappedReg FAST_INT -- A dynamically allocated machine register
+
+ | MemoryReg Int PrimRep -- A machine "register" actually held in
+ -- a memory allocated table of
+ -- registers which didn't fit in real
+ -- registers.
+
+ | UnmappedReg Unique PrimRep -- One of an infinite supply of registers,
+ -- always mapped to one of the earlier
+ -- two (?) before we're done.
+
+mkReg :: Unique -> PrimRep -> Reg
+mkReg = UnmappedReg
+
+getNewRegNCG :: PrimRep -> UniqSM Reg
+getNewRegNCG pk
+ = getUnique `thenUs` \ u ->
+ returnUs (UnmappedReg u pk)
+
+instance Text Reg where
+ showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i)
+ showsPrec _ (MappedReg i) = showString "%" . shows IBOX(i)
+ showsPrec _ (MemoryReg i _) = showString "%M" . shows i
+ showsPrec _ (UnmappedReg i _) = showString "%U" . shows i
+
+#ifdef DEBUG
+instance Outputable Reg where
+ ppr sty r = ppStr (show r)
+#endif
+
+cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
+cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i'
+cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i'
+cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmp u u'
+cmpReg r1 r2
+ = let tag1 = tagReg r1
+ tag2 = tagReg r2
+ in
+ if tag1 _LT_ tag2 then LT_ else GT_
+ where
+ tagReg (FixedReg _) = (ILIT(1) :: FAST_INT)
+ tagReg (MappedReg _) = ILIT(2)
+ tagReg (MemoryReg _ _) = ILIT(3)
+ tagReg (UnmappedReg _ _) = ILIT(4)
+
+cmp_i :: Int -> Int -> TAG_
+cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_
+
+cmp_ihash :: FAST_INT -> FAST_INT -> TAG_
+cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_
+
+instance Eq Reg where
+ a == b = case cmpReg a b of { EQ_ -> True; _ -> False }
+ a /= b = case cmpReg a b of { EQ_ -> False; _ -> True }
+
+instance Ord Reg where
+ a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+
+instance NamedThing Reg where
+ -- the *only* method that should be defined is "getItsUnique"!
+ -- (so we can use UniqFMs/UniqSets on Regs
+ getItsUnique (UnmappedReg u _) = u
+ getItsUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
+ getItsUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
+ getItsUnique (MemoryReg i _) = mkPseudoUnique3 i
+\end{code}
+
+\begin{code}
+type RegNo = Int
+
+realReg :: RegNo -> Reg
+realReg n@IBOX(i)
+ = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i
+
+extractMappedRegNos :: [Reg] -> [RegNo]
+
+extractMappedRegNos regs
+ = foldr ex [] regs
+ where
+ ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it
+ ex _ acc = acc -- leave it out
+\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}
+#if alpha_TARGET_ARCH
+fReg :: Int -> Int
+fReg x = (32 + x)
+
+v0, f0, ra, pv, gp, sp, zero :: Reg
+v0 = realReg 0
+f0 = realReg (fReg 0)
+ra = FixedReg ILIT(26)
+pv = t12
+gp = FixedReg ILIT(29)
+sp = FixedReg ILIT(30)
+zero = FixedReg ILIT(31)
+
+t9, t10, t11, t12 :: Reg
+t9 = realReg 23
+t10 = realReg 24
+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).
+- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
+- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
+- Registers 8-15 hold extended floating point values.
+\begin{code}
+#if i386_TARGET_ARCH
+
+gReg,fReg :: Int -> Int
+gReg x = x
+fReg x = (8 + x)
+
+st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg
+eax = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
+ebx = case (gReg 1) of { IBOX(g1) -> FixedReg g1 }
+ecx = case (gReg 2) of { IBOX(g2) -> FixedReg g2 }
+edx = case (gReg 3) of { IBOX(g3) -> FixedReg g3 }
+esi = case (gReg 4) of { IBOX(g4) -> FixedReg g4 }
+edi = case (gReg 5) of { IBOX(g5) -> FixedReg g5 }
+ebp = case (gReg 6) of { IBOX(g6) -> FixedReg g6 }
+esp = case (gReg 7) of { IBOX(g7) -> FixedReg g7 }
+st0 = realReg (fReg 0)
+st1 = realReg (fReg 1)
+st2 = realReg (fReg 2)
+st3 = realReg (fReg 3)
+st4 = realReg (fReg 4)
+st5 = realReg (fReg 5)
+st6 = realReg (fReg 6)
+st7 = realReg (fReg 7)
+
+#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,
+prepared for any eventuality.
+
+\begin{code}
+#if sparc_TARGET_ARCH
+
+gReg,lReg,iReg,oReg,fReg :: Int -> Int
+gReg x = x
+oReg x = (8 + x)
+lReg x = (16 + x)
+iReg x = (24 + x)
+fReg x = (32 + x)
+
+fPair :: Reg -> Reg
+fPair (FixedReg i) = FixedReg (i _ADD_ ILIT(1))
+fPair (MappedReg i) = MappedReg (i _ADD_ ILIT(1))
+
+g0, fp, sp, o0, f0 :: Reg
+g0 = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
+fp = case (iReg 6) of { IBOX(i6) -> FixedReg i6 }
+sp = case (oReg 6) of { IBOX(o6) -> FixedReg o6 }
+o0 = realReg (oReg 0)
+f0 = realReg (fReg 0)
+
+#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 f2 34
+#define f3 35
+#define f4 36
+#define f5 37
+#define f6 38
+#define f7 39
+#define f8 40
+#define f9 41
+#define f10 42
+#define f11 43
+#define f12 44
+#define f13 45
+#define f14 46
+#define f15 47
+#define f16 48
+#define f17 49
+#define f18 50
+#define f19 51
+#define f20 52
+#define f21 53
+#define f22 54
+#define f23 55
+#define f24 56
+#define f25 57
+#define f26 58
+#define f27 59
+#define f28 60
+#define f29 61
+#define f30 62
+#define f31 63
+#endif
+#if i386_TARGET_ARCH
+#define eax 0
+#define ebx 1
+#define ecx 2
+#define edx 3
+#define esi 4
+#define edi 5
+#define ebp 6
+#define esp 7
+#define st0 8
+#define st1 9
+#define st2 10
+#define st3 11
+#define st4 12
+#define st5 13
+#define st6 14
+#define st7 15
+#endif
+#if sparc_TARGET_ARCH
+#define g0 0
+#define g1 1
+#define g2 2
+#define g3 3
+#define g4 4
+#define g5 5
+#define g6 6
+#define g7 7
+#define o0 8
+#define o1 9
+#define o2 10
+#define o3 11
+#define o4 12
+#define o5 13
+#define o6 14
+#define o7 15
+#define l0 16
+#define l1 17
+#define l2 18
+#define l3 19
+#define l4 20
+#define l5 21
+#define l6 22
+#define l7 23
+#define i0 24
+#define i1 25
+#define i2 26
+#define i3 27
+#define i4 28
+#define i5 29
+#define i6 30
+#define i7 31
+#define f0 32
+#define f1 33
+#define f2 34
+#define f3 35
+#define f4 36
+#define f5 37
+#define f6 38
+#define f7 39
+#define f8 40
+#define f9 41
+#define f10 42
+#define f11 43
+#define f12 44
+#define f13 45
+#define f14 46
+#define f15 47
+#define f16 48
+#define f17 49
+#define f18 50
+#define f19 51
+#define f20 52
+#define f21 53
+#define f22 54
+#define f23 55
+#define f24 56
+#define f25 57
+#define f26 58
+#define f27 59
+#define f28 60
+#define f29 61
+#define f30 62
+#define f31 63
+#endif
+\end{code}
+
+\begin{code}
+baseRegOffset :: MagicId -> Int
+
+baseRegOffset StkOReg = OFFSET_StkO
+baseRegOffset (VanillaReg _ ILIT(1)) = OFFSET_R1
+baseRegOffset (VanillaReg _ ILIT(2)) = OFFSET_R2
+baseRegOffset (VanillaReg _ ILIT(3)) = OFFSET_R3
+baseRegOffset (VanillaReg _ ILIT(4)) = OFFSET_R4
+baseRegOffset (VanillaReg _ ILIT(5)) = OFFSET_R5
+baseRegOffset (VanillaReg _ ILIT(6)) = OFFSET_R6
+baseRegOffset (VanillaReg _ ILIT(7)) = OFFSET_R7
+baseRegOffset (VanillaReg _ ILIT(8)) = OFFSET_R8
+baseRegOffset (FloatReg ILIT(1)) = OFFSET_Flt1
+baseRegOffset (FloatReg ILIT(2)) = OFFSET_Flt2
+baseRegOffset (FloatReg ILIT(3)) = OFFSET_Flt3
+baseRegOffset (FloatReg ILIT(4)) = OFFSET_Flt4
+baseRegOffset (DoubleReg ILIT(1)) = OFFSET_Dbl1
+baseRegOffset (DoubleReg ILIT(2)) = OFFSET_Dbl2
+baseRegOffset TagReg = OFFSET_Tag
+baseRegOffset RetReg = OFFSET_Ret
+baseRegOffset SpA = OFFSET_SpA
+baseRegOffset SuA = OFFSET_SuA
+baseRegOffset SpB = OFFSET_SpB
+baseRegOffset SuB = OFFSET_SuB
+baseRegOffset Hp = OFFSET_Hp
+baseRegOffset HpLim = OFFSET_HpLim
+baseRegOffset LivenessReg = OFFSET_Liveness
+#ifdef DEBUG
+baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
+baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg"
+baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg"
+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_StkO
+callerSaves StkOReg = 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_FltReg1
+callerSaves (FloatReg ILIT(1)) = True
+#endif
+#ifdef CALLER_SAVES_FltReg2
+callerSaves (FloatReg ILIT(2)) = True
+#endif
+#ifdef CALLER_SAVES_FltReg3
+callerSaves (FloatReg ILIT(3)) = True
+#endif
+#ifdef CALLER_SAVES_FltReg4
+callerSaves (FloatReg ILIT(4)) = True
+#endif
+#ifdef CALLER_SAVES_DblReg1
+callerSaves (DoubleReg ILIT(1)) = True
+#endif
+#ifdef CALLER_SAVES_DblReg2
+callerSaves (DoubleReg ILIT(2)) = True
+#endif
+#ifdef CALLER_SAVES_Tag
+callerSaves TagReg = True
+#endif
+#ifdef CALLER_SAVES_Ret
+callerSaves RetReg = True
+#endif
+#ifdef CALLER_SAVES_SpA
+callerSaves SpA = True
+#endif
+#ifdef CALLER_SAVES_SuA
+callerSaves SuA = True
+#endif
+#ifdef CALLER_SAVES_SpB
+callerSaves SpB = True
+#endif
+#ifdef CALLER_SAVES_SuB
+callerSaves SuB = True
+#endif
+#ifdef CALLER_SAVES_Hp
+callerSaves Hp = True
+#endif
+#ifdef CALLER_SAVES_HpLim
+callerSaves HpLim = True
+#endif
+#ifdef CALLER_SAVES_Liveness
+callerSaves LivenessReg = True
+#endif
+#ifdef CALLER_SAVES_StdUpdRetVec
+callerSaves StdUpdRetVecReg = True
+#endif
+#ifdef CALLER_SAVES_StkStub
+callerSaves StkStubReg = True
+#endif
+callerSaves _ = False
+\end{code}
+
+\begin{code}
+magicIdRegMaybe :: MagicId -> Maybe Reg
+
+#ifdef REG_Base
+magicIdRegMaybe BaseReg = Just (FixedReg ILIT(REG_Base))
+#endif
+#ifdef REG_StkO
+magicIdRegMaybe StkOReg = Just (FixedReg ILIT(REG_StkOReg))
+#endif
+#ifdef REG_R1
+magicIdRegMaybe (VanillaReg _ ILIT(1)) = Just (FixedReg ILIT(REG_R1))
+#endif
+#ifdef REG_R2
+magicIdRegMaybe (VanillaReg _ ILIT(2)) = Just (FixedReg ILIT(REG_R2))
+#endif
+#ifdef REG_R3
+magicIdRegMaybe (VanillaReg _ ILIT(3)) = Just (FixedReg ILIT(REG_R3))
+#endif
+#ifdef REG_R4
+magicIdRegMaybe (VanillaReg _ ILIT(4)) = Just (FixedReg ILIT(REG_R4))
+#endif
+#ifdef REG_R5
+magicIdRegMaybe (VanillaReg _ ILIT(5)) = Just (FixedReg ILIT(REG_R5))
+#endif
+#ifdef REG_R6
+magicIdRegMaybe (VanillaReg _ ILIT(6)) = Just (FixedReg ILIT(REG_R6))
+#endif
+#ifdef REG_R7
+magicIdRegMaybe (VanillaReg _ ILIT(7)) = Just (FixedReg ILIT(REG_R7))
+#endif
+#ifdef REG_R8
+magicIdRegMaybe (VanillaReg _ ILIT(8)) = Just (FixedReg ILIT(REG_R8))
+#endif
+#ifdef REG_Flt1
+magicIdRegMaybe (FloatReg ILIT(1)) = Just (FixedReg ILIT(REG_Flt1))
+#endif
+#ifdef REG_Flt2
+magicIdRegMaybe (FloatReg ILIT(2)) = Just (FixedReg ILIT(REG_Flt2))
+#endif
+#ifdef REG_Flt3
+magicIdRegMaybe (FloatReg ILIT(3)) = Just (FixedReg ILIT(REG_Flt3))
+#endif
+#ifdef REG_Flt4
+magicIdRegMaybe (FloatReg ILIT(4)) = Just (FixedReg ILIT(REG_Flt4))
+#endif
+#ifdef REG_Dbl1
+magicIdRegMaybe (DoubleReg ILIT(1)) = Just (FixedReg ILIT(REG_Dbl1))
+#endif
+#ifdef REG_Dbl2
+magicIdRegMaybe (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_Dbl2))
+#endif
+#ifdef REG_Tag
+magicIdRegMaybe TagReg = Just (FixedReg ILIT(REG_TagReg))
+#endif
+#ifdef REG_Ret
+magicIdRegMaybe RetReg = Just (FixedReg ILIT(REG_Ret))
+#endif
+#ifdef REG_SpA
+magicIdRegMaybe SpA = Just (FixedReg ILIT(REG_SpA))
+#endif
+#ifdef REG_SuA
+magicIdRegMaybe SuA = Just (FixedReg ILIT(REG_SuA))
+#endif
+#ifdef REG_SpB
+magicIdRegMaybe SpB = Just (FixedReg ILIT(REG_SpB))
+#endif
+#ifdef REG_SuB
+magicIdRegMaybe SuB = Just (FixedReg ILIT(REG_SuB))
+#endif
+#ifdef REG_Hp
+magicIdRegMaybe Hp = Just (FixedReg ILIT(REG_Hp))
+#endif
+#ifdef REG_HpLim
+magicIdRegMaybe HpLim = Just (FixedReg ILIT(REG_HpLim))
+#endif
+#ifdef REG_Liveness
+magicIdRegMaybe LivenessReg = Just (FixedReg ILIT(REG_Liveness))
+#endif
+#ifdef REG_StdUpdRetVec
+magicIdRegMaybe StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec))
+#endif
+#ifdef REG_StkStub
+magicIdRegMaybe StkStubReg = Just (FixedReg ILIT(REG_StkStub))
+#endif
+magicIdRegMaybe _ = Nothing
+\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...)
+
+\begin{code}
+reservedRegs :: [RegNo]
+reservedRegs
+#if alpha_TARGET_ARCH
+ = [NCG_Reserved_I1, NCG_Reserved_I2,
+ NCG_Reserved_F1, NCG_Reserved_F2]
+#endif
+#if i386_TARGET_ARCH
+ = [{-certainly cannot afford any!-}]
+#endif
+#if sparc_TARGET_ARCH
+ = [NCG_Reserved_I1, NCG_Reserved_I2,
+ NCG_Reserved_F1, NCG_Reserved_F2,
+ NCG_Reserved_D1, NCG_Reserved_D2]
+#endif
+
+-------------------------------
+freeRegs :: [Reg]
+freeRegs
+ = freeMappedRegs IF_ARCH_alpha( [0..63],
+ IF_ARCH_i386( [0..15],
+ IF_ARCH_sparc( [0..63],)))
+
+-------------------------------
+callClobberedRegs :: [Reg]
+callClobberedRegs
+ = freeMappedRegs
+#if alpha_TARGET_ARCH
+ [0, 1, 2, 3, 4, 5, 6, 7, 8,
+ 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
+ fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15,
+ fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23,
+ fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30]
+#endif {- alpha_TARGET_ARCH -}
+#if i386_TARGET_ARCH
+ [{-none-}]
+#endif {- i386_TARGET_ARCH -}
+#if sparc_TARGET_ARCH
+ ( oReg 7 :
+ [oReg i | i <- [0..5]] ++
+ [gReg i | i <- [1..7]] ++
+ [fReg i | i <- [0..31]] )
+#endif {- sparc_TARGET_ARCH -}
+
+-------------------------------
+argRegs :: Int -> [Reg]
+
+argRegs 0 = []
+#if alpha_TARGET_ARCH
+argRegs 1 = freeMappedRegs [16, fReg 16]
+argRegs 2 = freeMappedRegs [16, 17, fReg 16, fReg 17]
+argRegs 3 = freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18]
+argRegs 4 = freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19]
+argRegs 5 = freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20]
+argRegs 6 = freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21]
+#endif {- alpha_TARGET_ARCH -}
+#if i386_TARGET_ARCH
+argRegs _ = panic "MachRegs.argRegs: doesn't work on I386"
+#endif {- i386_TARGET_ARCH -}
+#if sparc_TARGET_ARCH
+argRegs 1 = freeMappedRegs (map oReg [0])
+argRegs 2 = freeMappedRegs (map oReg [0,1])
+argRegs 3 = freeMappedRegs (map oReg [0,1,2])
+argRegs 4 = freeMappedRegs (map oReg [0,1,2,3])
+argRegs 5 = freeMappedRegs (map oReg [0,1,2,3,4])
+argRegs 6 = freeMappedRegs (map oReg [0,1,2,3,4,5])
+#endif {- sparc_TARGET_ARCH -}
+argRegs _ = panic "MachRegs.argRegs: don't know about >6 arguments!"
+
+-------------------------------
+
+#if alpha_TARGET_ARCH
+allArgRegs :: [(Reg, Reg)]
+
+allArgRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]]
+#endif {- alpha_TARGET_ARCH -}
+
+#if sparc_TARGET_ARCH
+allArgRegs :: [Reg]
+
+allArgRegs = map realReg [oReg i | i <- [0..5]]
+#endif {- sparc_TARGET_ARCH -}
+
+-------------------------------
+freeMappedRegs :: [Int] -> [Reg]
+
+freeMappedRegs nums
+ = foldr free [] nums
+ where
+ free IBOX(i) acc
+ = if _IS_TRUE_(freeReg i) then (MappedReg i) : acc else acc
+\end{code}
+
+\begin{code}
+freeReg :: FAST_INT -> FAST_BOOL
+
+#if alpha_TARGET_ARCH
+freeReg ILIT(26) = _FALSE_ -- return address (ra)
+freeReg ILIT(28) = _FALSE_ -- reserved for the assembler (at)
+freeReg ILIT(29) = _FALSE_ -- global pointer (gp)
+freeReg ILIT(30) = _FALSE_ -- stack pointer (sp)
+freeReg ILIT(31) = _FALSE_ -- always zero (zero)
+freeReg ILIT(63) = _FALSE_ -- always zero (f31)
+#endif
+
+#if i386_TARGET_ARCH
+freeReg ILIT(esp) = _FALSE_ -- %esp is the C stack pointer
+#endif
+
+#if sparc_TARGET_ARCH
+freeReg ILIT(g0) = _FALSE_ -- %g0 is always 0.
+freeReg ILIT(g5) = _FALSE_ -- %g5 is reserved (ABI).
+freeReg ILIT(g6) = _FALSE_ -- %g6 is reserved (ABI).
+freeReg ILIT(g7) = _FALSE_ -- %g7 is reserved (ABI).
+freeReg ILIT(i6) = _FALSE_ -- %i6 is our frame pointer.
+freeReg ILIT(o6) = _FALSE_ -- %o6 is our stack pointer.
+#endif
+
+#ifdef REG_Base
+freeReg ILIT(REG_Base) = _FALSE_
+#endif
+#ifdef REG_StkO
+freeReg ILIT(REG_StkO) = _FALSE_
+#endif
+#ifdef REG_R1
+freeReg ILIT(REG_R1) = _FALSE_
+#endif
+#ifdef REG_R2
+freeReg ILIT(REG_R2) = _FALSE_
+#endif
+#ifdef REG_R3
+freeReg ILIT(REG_R3) = _FALSE_
+#endif
+#ifdef REG_R4
+freeReg ILIT(REG_R4) = _FALSE_
+#endif
+#ifdef REG_R5
+freeReg ILIT(REG_R5) = _FALSE_
+#endif
+#ifdef REG_R6
+freeReg ILIT(REG_R6) = _FALSE_
+#endif
+#ifdef REG_R7
+freeReg ILIT(REG_R7) = _FALSE_
+#endif
+#ifdef REG_R8
+freeReg ILIT(REG_R8) = _FALSE_
+#endif
+#ifdef REG_Flt1
+freeReg ILIT(REG_Flt1) = _FALSE_
+#endif
+#ifdef REG_Flt2
+freeReg ILIT(REG_Flt2) = _FALSE_
+#endif
+#ifdef REG_Flt3
+freeReg ILIT(REG_Flt3) = _FALSE_
+#endif
+#ifdef REG_Flt4
+freeReg ILIT(REG_Flt4) = _FALSE_
+#endif
+#ifdef REG_Dbl1
+freeReg ILIT(REG_Dbl1) = _FALSE_
+#endif
+#ifdef REG_Dbl2
+freeReg ILIT(REG_Dbl2) = _FALSE_
+#endif
+#ifdef REG_Tag
+freeReg ILIT(REG_Tag) = _FALSE_
+#endif
+#ifdef REG_Ret
+freeReg ILIT(REG_Ret) = _FALSE_
+#endif
+#ifdef REG_SpA
+freeReg ILIT(REG_SpA) = _FALSE_
+#endif
+#ifdef REG_SuA
+freeReg ILIT(REG_SuA) = _FALSE_
+#endif
+#ifdef REG_SpB
+freeReg ILIT(REG_SpB) = _FALSE_
+#endif
+#ifdef REG_SuB
+freeReg ILIT(REG_SuB) = _FALSE_
+#endif
+#ifdef REG_Hp
+freeReg ILIT(REG_Hp) = _FALSE_
+#endif
+#ifdef REG_HpLim
+freeReg ILIT(REG_HpLim) = _FALSE_
+#endif
+#ifdef REG_Liveness
+freeReg ILIT(REG_Liveness) = _FALSE_
+#endif
+#ifdef REG_StdUpdRetVec
+freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
+#endif
+#ifdef REG_StkStub
+freeReg ILIT(REG_StkStub) = _FALSE_
+#endif
+freeReg _ = _TRUE_
+freeReg n
+ -- we hang onto two double regs for dedicated
+ -- use; this is not necessary on Alphas and
+ -- may not be on other non-SPARCs.
+#ifdef REG_Dbl1
+ | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_
+#endif
+#ifdef REG_Dbl2
+ | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_
+#endif
+ | otherwise = _TRUE_
+\end{code}
diff --git a/ghc/compiler/nativeGen/NCG.h b/ghc/compiler/nativeGen/NCG.h
new file mode 100644
index 0000000000000000000000000000000000000000..4b3049b0b2e3c5d4e6457e176ea4afd5f44bb73e
--- /dev/null
+++ b/ghc/compiler/nativeGen/NCG.h
@@ -0,0 +1,150 @@
+#ifndef NCG_H
+#define NCG_H
+
+#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
+
+#define FAST_REG_NO FAST_INT
+
+#include "../../includes/platform.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"
+
+#if alpha_TARGET_ARCH
+# define BYTES_PER_WORD 8
+# define BYTES_PER_WORD_STR "8"
+
+# include "../../includes/alpha-dec-osf1.h"
+#endif
+
+#if i386_TARGET_ARCH
+# define BYTES_PER_WORD 4
+# define BYTES_PER_WORD_STR "4"
+
+# if linuxaout_TARGET_OS
+# include "../../includes/i386-unknown-linuxaout.h"
+# endif
+# if linux_TARGET_OS
+# include "../../includes/i386-unknown-linux.h"
+# endif
+# if freebsd_TARGET_OS
+# include "../../includes/i386-unknown-freebsd.h"
+# endif
+# if netbsd_TARGET_OS
+# include "../../includes/i386-unknown-netbsd.h"
+# endif
+# if bsdi_TARGET_OS
+# include "../../includes/i386-unknown-bsdi.h"
+# endif
+# if solaris2_TARGET_OS
+# include "../../includes/i386-unknown-solaris2.h"
+# endif
+#endif
+
+#if sparc_TARGET_ARCH
+# define BYTES_PER_WORD 4
+# define BYTES_PER_WORD_STR "4"
+
+# if sunos4_TARGET_OS
+# include "../../includes/sparc-sun-sunos4.h"
+# endif
+# if solaris2_TARGET_OS
+# include "../../includes/sparc-sun-solaris2.h"
+# endif
+#endif
+
+---------------------------------------------
+
+#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
+# define IF_ARCH_i386(x,y) y
+#endif
+-- - - - - - - - - - - - - - - - - - - - - -
+#if freebsd_TARGET_OS
+# define IF_OS_freebsd(x,y) x
+#else
+# define IF_OS_freebsd(x,y) y
+#endif
+-- - - - - - - - - - - - - - - - - - - - - -
+#if netbsd_TARGET_OS
+# define IF_OS_netbsd(x,y) x
+#else
+# define IF_OS_netbsd(x,y) y
+#endif
+-- - - - - - - - - - - - - - - - - - - - - -
+#if linux_TARGET_OS
+# define IF_OS_linux(x,y) x
+#else
+# define IF_OS_linux(x,y) y
+#endif
+-- - - - - - - - - - - - - - - - - - - - - -
+#if linuxaout_TARGET_OS
+# define IF_OS_linuxaout(x,y) x
+#else
+# define IF_OS_linuxaout(x,y) y
+#endif
+-- - - - - - - - - - - - - - - - - - - - - -
+#if bsdi_TARGET_OS
+# define IF_OS_bsdi(x,y) x
+#else
+# define IF_OS_bsdi(x,y) y
+#endif
+---------------------------------------------
+#if sparc_TARGET_ARCH
+# define IF_ARCH_sparc(x,y) x
+#else
+# define IF_ARCH_sparc(x,y) y
+#endif
+-- - - - - - - - - - - - - - - - - - - - - -
+#if sunos4_TARGET_OS
+# define IF_OS_sunos4(x,y) x
+#else
+# define IF_OS_sunos4(x,y) y
+#endif
+-- - - - - - - - - - - - - - - - - - - - - -
+-- NB: this will catch i386-*-solaris2, too
+#if solaris2_TARGET_OS
+# define IF_OS_solaris2(x,y) x
+#else
+# define IF_OS_solaris2(x,y) y
+#endif
+---------------------------------------------
+#endif
diff --git a/ghc/compiler/nativeGen/NcgLoop.lhi b/ghc/compiler/nativeGen/NcgLoop.lhi
new file mode 100644
index 0000000000000000000000000000000000000000..9086b3184276179f78d2b45c5f75724f732480a5
--- /dev/null
+++ b/ghc/compiler/nativeGen/NcgLoop.lhi
@@ -0,0 +1,16 @@
+Breaks loops between Stix{Macro,Prim,Integer}.lhs.
+
+Also some CLabel dependencies on MachMisc.
+
+\begin{code}
+interface NcgLoop where
+
+import AbsCSyn ( CAddrMode )
+import Stix ( StixTree )
+import MachMisc ( underscorePrefix, fmtAsmLbl )
+import StixPrim ( amodeToStix )
+
+amodeToStix :: CAddrMode -> StixTree
+underscorePrefix :: Bool
+fmtAsmLbl :: [Char] -> [Char]
+\end{code}
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..f1835a38a28e0688c4fdb73c0f1ac5eec6909535
--- /dev/null
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -0,0 +1,1323 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[PprMach]{Pretty-printing assembly language}
+
+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 "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module PprMach ( pprInstr ) where
+
+import Ubiq{-uitious-}
+
+import MachRegs -- may differ per-platform
+import MachMisc
+
+import CLabel ( pprCLabel_asm, externallyVisibleCLabel )
+import CStrings ( charToC )
+import Maybes ( maybeToBool )
+import OrdList ( OrdList )
+import Stix ( CodeSegment(..), StixTree )
+import Unpretty -- all of it
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@pprReg@: print a @Reg@}
+%* *
+%************************************************************************
+
+For x86, the way we print a register name depends
+on which bit of it we care about. Yurgh.
+\begin{code}
+pprReg :: IF_ARCH_i386(Size ->,) Reg -> Unpretty
+
+pprReg IF_ARCH_i386(s,) r
+ = case r of
+ FixedReg i -> ppr_reg_no IF_ARCH_i386(s,) i
+ MappedReg i -> ppr_reg_no IF_ARCH_i386(s,) i
+ other -> uppStr (show other) -- should only happen when debugging
+ where
+#if alpha_TARGET_ARCH
+ ppr_reg_no :: FAST_REG_NO -> Unpretty
+ ppr_reg_no i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1");
+ ILIT( 2) -> SLIT("$2"); ILIT( 3) -> SLIT("$3");
+ ILIT( 4) -> SLIT("$4"); ILIT( 5) -> SLIT("$5");
+ ILIT( 6) -> SLIT("$6"); ILIT( 7) -> SLIT("$7");
+ ILIT( 8) -> SLIT("$8"); ILIT( 9) -> SLIT("$9");
+ ILIT(10) -> SLIT("$10"); ILIT(11) -> SLIT("$11");
+ ILIT(12) -> SLIT("$12"); ILIT(13) -> SLIT("$13");
+ ILIT(14) -> SLIT("$14"); ILIT(15) -> SLIT("$15");
+ ILIT(16) -> SLIT("$16"); ILIT(17) -> SLIT("$17");
+ ILIT(18) -> SLIT("$18"); ILIT(19) -> SLIT("$19");
+ ILIT(20) -> SLIT("$20"); ILIT(21) -> SLIT("$21");
+ ILIT(22) -> SLIT("$22"); ILIT(23) -> SLIT("$23");
+ ILIT(24) -> SLIT("$24"); ILIT(25) -> SLIT("$25");
+ ILIT(26) -> SLIT("$26"); ILIT(27) -> SLIT("$27");
+ ILIT(28) -> SLIT("$28"); ILIT(29) -> SLIT("$29");
+ ILIT(30) -> SLIT("$30"); ILIT(31) -> SLIT("$31");
+ ILIT(32) -> SLIT("$f0"); ILIT(33) -> SLIT("$f1");
+ ILIT(34) -> SLIT("$f2"); ILIT(35) -> SLIT("$f3");
+ ILIT(36) -> SLIT("$f4"); ILIT(37) -> SLIT("$f5");
+ ILIT(38) -> SLIT("$f6"); ILIT(39) -> SLIT("$f7");
+ ILIT(40) -> SLIT("$f8"); ILIT(41) -> SLIT("$f9");
+ ILIT(42) -> SLIT("$f10"); ILIT(43) -> SLIT("$f11");
+ ILIT(44) -> SLIT("$f12"); ILIT(45) -> SLIT("$f13");
+ ILIT(46) -> SLIT("$f14"); ILIT(47) -> SLIT("$f15");
+ ILIT(48) -> SLIT("$f16"); ILIT(49) -> SLIT("$f17");
+ ILIT(50) -> SLIT("$f18"); ILIT(51) -> SLIT("$f19");
+ ILIT(52) -> SLIT("$f20"); ILIT(53) -> SLIT("$f21");
+ ILIT(54) -> SLIT("$f22"); ILIT(55) -> SLIT("$f23");
+ ILIT(56) -> SLIT("$f24"); ILIT(57) -> SLIT("$f25");
+ ILIT(58) -> SLIT("$f26"); ILIT(59) -> SLIT("$f27");
+ ILIT(60) -> SLIT("$f28"); ILIT(61) -> SLIT("$f29");
+ ILIT(62) -> SLIT("$f30"); ILIT(63) -> SLIT("$f31");
+ _ -> SLIT("very naughty alpha register")
+ })
+#endif
+#if i386_TARGET_ARCH
+ ppr_reg_no :: Size -> FAST_REG_NO -> Unpretty
+ ppr_reg_no B i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl");
+ ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl");
+ _ -> SLIT("very naughty I386 byte register")
+ })
+
+ {- UNUSED:
+ ppr_reg_no HB i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
+ ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh");
+ _ -> SLIT("very naughty I386 high byte register")
+ })
+ -}
+
+{- UNUSED:
+ ppr_reg_no S i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx");
+ ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx");
+ ILIT( 4) -> SLIT("%si"); ILIT( 5) -> SLIT("%di");
+ ILIT( 6) -> SLIT("%bp"); ILIT( 7) -> SLIT("%sp");
+ _ -> SLIT("very naughty I386 word register")
+ })
+-}
+
+ ppr_reg_no L i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx");
+ ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx");
+ ILIT( 4) -> SLIT("%esi"); ILIT( 5) -> SLIT("%edi");
+ ILIT( 6) -> SLIT("%ebp"); ILIT( 7) -> SLIT("%esp");
+ _ -> SLIT("very naughty I386 double word register")
+ })
+
+ ppr_reg_no F i = uppPStr
+ (case i of {
+ --ToDo: rm these (???)
+ ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
+ ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
+ ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
+ ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
+ _ -> SLIT("very naughty I386 float register")
+ })
+
+ ppr_reg_no DF i = uppPStr
+ (case i of {
+ --ToDo: rm these (???)
+ ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
+ ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
+ ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
+ ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
+ _ -> SLIT("very naughty I386 float register")
+ })
+#endif
+#if sparc_TARGET_ARCH
+ ppr_reg_no :: FAST_REG_NO -> Unpretty
+ ppr_reg_no i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1");
+ ILIT( 2) -> SLIT("%g2"); ILIT( 3) -> SLIT("%g3");
+ ILIT( 4) -> SLIT("%g4"); ILIT( 5) -> SLIT("%g5");
+ ILIT( 6) -> SLIT("%g6"); ILIT( 7) -> SLIT("%g7");
+ ILIT( 8) -> SLIT("%o0"); ILIT( 9) -> SLIT("%o1");
+ ILIT(10) -> SLIT("%o2"); ILIT(11) -> SLIT("%o3");
+ ILIT(12) -> SLIT("%o4"); ILIT(13) -> SLIT("%o5");
+ ILIT(14) -> SLIT("%o6"); ILIT(15) -> SLIT("%o7");
+ ILIT(16) -> SLIT("%l0"); ILIT(17) -> SLIT("%l1");
+ ILIT(18) -> SLIT("%l2"); ILIT(19) -> SLIT("%l3");
+ ILIT(20) -> SLIT("%l4"); ILIT(21) -> SLIT("%l5");
+ ILIT(22) -> SLIT("%l6"); ILIT(23) -> SLIT("%l7");
+ ILIT(24) -> SLIT("%i0"); ILIT(25) -> SLIT("%i1");
+ ILIT(26) -> SLIT("%i2"); ILIT(27) -> SLIT("%i3");
+ ILIT(28) -> SLIT("%i4"); ILIT(29) -> SLIT("%i5");
+ ILIT(30) -> SLIT("%i6"); ILIT(31) -> SLIT("%i7");
+ ILIT(32) -> SLIT("%f0"); ILIT(33) -> SLIT("%f1");
+ ILIT(34) -> SLIT("%f2"); ILIT(35) -> SLIT("%f3");
+ ILIT(36) -> SLIT("%f4"); ILIT(37) -> SLIT("%f5");
+ ILIT(38) -> SLIT("%f6"); ILIT(39) -> SLIT("%f7");
+ ILIT(40) -> SLIT("%f8"); ILIT(41) -> SLIT("%f9");
+ ILIT(42) -> SLIT("%f10"); ILIT(43) -> SLIT("%f11");
+ ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13");
+ ILIT(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15");
+ ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17");
+ ILIT(50) -> SLIT("%f18"); ILIT(51) -> SLIT("%f19");
+ ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21");
+ ILIT(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23");
+ ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25");
+ ILIT(58) -> SLIT("%f26"); ILIT(59) -> SLIT("%f27");
+ ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29");
+ ILIT(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31");
+ _ -> SLIT("very naughty sparc register")
+ })
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@pprSize@: print a @Size@}
+%* *
+%************************************************************************
+
+\begin{code}
+pprSize :: Size -> Unpretty
+
+pprSize x = uppPStr (case x of
+#if alpha_TARGET_ARCH
+ B -> SLIT("b")
+ BU -> SLIT("bu")
+-- W -> SLIT("w") UNUSED
+-- WU -> SLIT("wu") UNUSED
+-- L -> SLIT("l") UNUSED
+ Q -> SLIT("q")
+-- FF -> SLIT("f") UNUSED
+-- DF -> SLIT("d") UNUSED
+-- GF -> SLIT("g") UNUSED
+-- SF -> SLIT("s") UNUSED
+ TF -> SLIT("t")
+#endif
+#if i386_TARGET_ARCH
+ B -> SLIT("b")
+-- HB -> SLIT("b") UNUSED
+-- S -> SLIT("w") UNUSED
+ L -> SLIT("l")
+ F -> SLIT("s")
+ DF -> SLIT("l")
+#endif
+#if sparc_TARGET_ARCH
+ B -> SLIT("sb")
+-- HW -> SLIT("hw") UNUSED
+-- BU -> SLIT("ub") UNUSED
+-- HWU -> SLIT("uhw") UNUSED
+ W -> SLIT("")
+ F -> SLIT("")
+-- D -> SLIT("d") UNUSED
+ DF -> SLIT("d")
+#endif
+ )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@pprCond@: print a @Cond@}
+%* *
+%************************************************************************
+
+\begin{code}
+pprCond :: Cond -> Unpretty
+
+pprCond c = uppPStr (case c of {
+#if alpha_TARGET_ARCH
+ EQ -> SLIT("eq");
+ LT -> SLIT("lt");
+ LE -> SLIT("le");
+ ULT -> SLIT("ult");
+ ULE -> SLIT("ule");
+ NE -> SLIT("ne");
+ GT -> SLIT("gt");
+ GE -> SLIT("ge")
+#endif
+#if i386_TARGET_ARCH
+ GEU -> SLIT("ae"); LU -> SLIT("b");
+ EQ -> SLIT("e"); GT -> SLIT("g");
+ GE -> SLIT("ge"); GU -> SLIT("a");
+ LT -> SLIT("l"); LE -> SLIT("le");
+ LEU -> SLIT("be"); NE -> SLIT("ne");
+ NEG -> SLIT("s"); POS -> SLIT("ns");
+ ALWAYS -> SLIT("mp") -- hack
+#endif
+#if sparc_TARGET_ARCH
+ ALWAYS -> SLIT(""); NEVER -> SLIT("n");
+ GEU -> SLIT("geu"); LU -> SLIT("lu");
+ EQ -> SLIT("e"); GT -> SLIT("g");
+ GE -> SLIT("ge"); GU -> SLIT("gu");
+ LT -> SLIT("l"); LE -> SLIT("le");
+ LEU -> SLIT("leu"); NE -> SLIT("ne");
+ NEG -> SLIT("neg"); POS -> SLIT("pos");
+ VC -> SLIT("vc"); VS -> SLIT("vs")
+#endif
+ })
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@pprImm@: print an @Imm@}
+%* *
+%************************************************************************
+
+\begin{code}
+pprImm :: Imm -> Unpretty
+
+pprImm (ImmInt i) = uppInt i
+pprImm (ImmInteger i) = uppInteger i
+pprImm (ImmCLbl l) = pprCLabel_asm l
+pprImm (ImmLit s) = s
+
+pprImm (ImmLab s) | underscorePrefix = uppBeside (uppChar '_') s
+ | otherwise = s
+
+#if sparc_TARGET_ARCH
+pprImm (LO i)
+ = uppBesides [ pp_lo, pprImm i, uppRparen ]
+ where
+ pp_lo = uppPStr (_packCString (A# "%lo("#))
+
+pprImm (HI i)
+ = uppBesides [ pp_hi, pprImm i, uppRparen ]
+ where
+ pp_hi = uppPStr (_packCString (A# "%hi("#))
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@pprAddr@: print an @Addr@}
+%* *
+%************************************************************************
+
+\begin{code}
+pprAddr :: Addr -> Unpretty
+
+#if alpha_TARGET_ARCH
+pprAddr (AddrReg r) = uppParens (pprReg r)
+pprAddr (AddrImm i) = pprImm i
+pprAddr (AddrRegImm r1 i)
+ = uppBeside (pprImm i) (uppParens (pprReg r1))
+#endif
+
+-------------------
+
+#if i386_TARGET_ARCH
+pprAddr (ImmAddr imm off)
+ = let
+ pp_imm = pprImm imm
+ in
+ if (off == 0) then
+ pp_imm
+ else if (off < 0) then
+ uppBeside pp_imm (uppInt off)
+ else
+ uppBesides [pp_imm, uppChar '+', uppInt off]
+
+pprAddr (Addr base index displacement)
+ = let
+ pp_disp = ppr_disp displacement
+ pp_off p = uppBeside pp_disp (uppParens p)
+ pp_reg r = pprReg L r
+ in
+ case (base,index) of
+ (Nothing, Nothing) -> pp_disp
+ (Just b, Nothing) -> pp_off (pp_reg b)
+ (Nothing, Just (r,i)) -> pp_off (uppBesides [pp_reg r, uppComma, uppInt i])
+ (Just b, Just (r,i)) -> pp_off (uppBesides [pp_reg b, uppComma, pp_reg r, uppComma, uppInt i])
+ where
+ ppr_disp (ImmInt 0) = uppNil
+ ppr_disp imm = pprImm imm
+#endif
+
+-------------------
+
+#if sparc_TARGET_ARCH
+pprAddr (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1
+
+pprAddr (AddrRegReg r1 r2)
+ = uppBesides [ pprReg r1, uppChar '+', pprReg r2 ]
+
+pprAddr (AddrRegImm r1 (ImmInt i))
+ | i == 0 = pprReg r1
+ | not (fits13Bits i) = largeOffsetError i
+ | otherwise = uppBesides [ pprReg r1, pp_sign, uppInt i ]
+ where
+ pp_sign = if i > 0 then uppChar '+' else uppNil
+
+pprAddr (AddrRegImm r1 (ImmInteger i))
+ | i == 0 = pprReg r1
+ | not (fits13Bits i) = largeOffsetError i
+ | otherwise = uppBesides [ pprReg r1, pp_sign, uppInteger i ]
+ where
+ pp_sign = if i > 0 then uppChar '+' else uppNil
+
+pprAddr (AddrRegImm r1 imm)
+ = uppBesides [ pprReg r1, uppChar '+', pprImm imm ]
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@pprInstr@: print an @Instr@}
+%* *
+%************************************************************************
+
+\begin{code}
+pprInstr :: Instr -> Unpretty
+
+pprInstr (COMMENT s) = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s)
+
+pprInstr (SEGMENT TextSegment)
+ = uppPStr
+ IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
+ ,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-}
+ ,IF_ARCH_i386(SLIT(".text\n\t.align 2,0x90") {-needs per-OS variation!-}
+ ,)))
+
+pprInstr (SEGMENT DataSegment)
+ = uppPStr
+ IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
+ ,IF_ARCH_sparc(SLIT("\t.data\n\t.align 8") {-<8 will break double constants -}
+ ,IF_ARCH_i386(SLIT(".data\n\t.align 2")
+ ,)))
+
+pprInstr (LABEL clab)
+ = let
+ pp_lab = pprCLabel_asm clab
+ in
+ uppBesides [
+ if not (externallyVisibleCLabel clab) then
+ uppNil
+ else
+ uppBesides [uppPStr
+ IF_ARCH_alpha(SLIT("\t.globl\t")
+ ,IF_ARCH_i386(SLIT(".globl ")
+ ,IF_ARCH_sparc(SLIT("\t.global\t")
+ ,)))
+ , pp_lab, uppChar '\n'],
+ pp_lab,
+ uppChar ':'
+ ]
+
+pprInstr (ASCII False{-no backslash conversion-} str)
+ = uppBesides [ uppStr "\t.asciz \"", uppStr str, uppChar '"' ]
+
+pprInstr (ASCII True str)
+ = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
+ where
+ asciify :: String -> Int -> Unpretty
+
+ asciify [] _ = uppStr ("\\0\"")
+ asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
+ asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
+ asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
+ asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
+ asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
+ asciify (c:(cs@(d:_))) n
+ | isDigit d = uppBeside (uppStr (charToC c)) (asciify cs 0)
+ | otherwise = uppBeside (uppStr (charToC c)) (asciify cs (n-1))
+
+pprInstr (DATA s xs)
+ = uppInterleave (uppChar '\n')
+ [uppBeside (uppPStr pp_size) (pprImm x) | x <- xs]
+ where
+ pp_size = case s of
+#if alpha_TARGET_ARCH
+ B -> SLIT("\t.byte\t")
+ BU -> SLIT("\t.byte\t")
+--UNUSED: W -> SLIT("\t.word\t")
+--UNUSED: WU -> SLIT("\t.word\t")
+--UNUSED: L -> SLIT("\t.long\t")
+ Q -> SLIT("\t.quad\t")
+--UNUSED: FF -> SLIT("\t.f_floating\t")
+--UNUSED: DF -> SLIT("\t.d_floating\t")
+--UNUSED: GF -> SLIT("\t.g_floating\t")
+--UNUSED: SF -> SLIT("\t.s_floating\t")
+ TF -> SLIT("\t.t_floating\t")
+#endif
+#if i386_TARGET_ARCH
+ B -> SLIT("\t.byte\t")
+--UNUSED: HB -> SLIT("\t.byte\t")
+--UNUSED: S -> SLIT("\t.word\t")
+ L -> SLIT("\t.long\t")
+ F -> SLIT("\t.long\t")
+ DF -> SLIT("\t.double\t")
+#endif
+#if sparc_TARGET_ARCH
+ B -> SLIT("\t.byte\t")
+ BU -> SLIT("\t.byte\t")
+ W -> SLIT("\t.word\t")
+ DF -> SLIT("\t.double\t")
+#endif
+
+-- fall through to rest of (machine-specific) pprInstr...
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@pprInstr@ for an Alpha}
+%* *
+%************************************************************************
+
+\begin{code}
+#if alpha_TARGET_ARCH
+
+pprInstr (LD size reg addr)
+ = uppBesides [
+ uppPStr SLIT("\tld"),
+ pprSize size,
+ uppChar '\t',
+ pprReg reg,
+ uppComma,
+ pprAddr addr
+ ]
+
+pprInstr (LDA reg addr)
+ = uppBesides [
+ uppPStr SLIT("\tlda\t"),
+ pprReg reg,
+ uppComma,
+ pprAddr addr
+ ]
+
+pprInstr (LDAH reg addr)
+ = uppBesides [
+ uppPStr SLIT("\tldah\t"),
+ pprReg reg,
+ uppComma,
+ pprAddr addr
+ ]
+
+pprInstr (LDGP reg addr)
+ = uppBesides [
+ uppPStr SLIT("\tldgp\t"),
+ pprReg reg,
+ uppComma,
+ pprAddr addr
+ ]
+
+pprInstr (LDI size reg imm)
+ = uppBesides [
+ uppPStr SLIT("\tldi"),
+ pprSize size,
+ uppChar '\t',
+ pprReg reg,
+ uppComma,
+ pprImm imm
+ ]
+
+pprInstr (ST size reg addr)
+ = uppBesides [
+ uppPStr SLIT("\tst"),
+ pprSize size,
+ uppChar '\t',
+ pprReg reg,
+ uppComma,
+ pprAddr addr
+ ]
+
+pprInstr (CLR reg)
+ = uppBesides [
+ uppPStr SLIT("\tclr\t"),
+ pprReg reg
+ ]
+
+pprInstr (ABS size ri reg)
+ = uppBesides [
+ uppPStr SLIT("\tabs"),
+ pprSize size,
+ uppChar '\t',
+ pprRI ri,
+ uppComma,
+ pprReg reg
+ ]
+
+pprInstr (NEG size ov ri reg)
+ = uppBesides [
+ uppPStr SLIT("\tneg"),
+ pprSize size,
+ if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ pprRI ri,
+ uppComma,
+ pprReg reg
+ ]
+
+pprInstr (ADD size ov reg1 ri reg2)
+ = uppBesides [
+ uppPStr SLIT("\tadd"),
+ pprSize size,
+ if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (SADD size scale reg1 ri reg2)
+ = uppBesides [
+ uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
+ uppPStr SLIT("add"),
+ pprSize size,
+ uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (SUB size ov reg1 ri reg2)
+ = uppBesides [
+ uppPStr SLIT("\tsub"),
+ pprSize size,
+ if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (SSUB size scale reg1 ri reg2)
+ = uppBesides [
+ uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
+ uppPStr SLIT("sub"),
+ pprSize size,
+ uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (MUL size ov reg1 ri reg2)
+ = uppBesides [
+ uppPStr SLIT("\tmul"),
+ pprSize size,
+ if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (DIV size uns reg1 ri reg2)
+ = uppBesides [
+ uppPStr SLIT("\tdiv"),
+ pprSize size,
+ if uns then uppPStr SLIT("u\t") else uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (REM size uns reg1 ri reg2)
+ = uppBesides [
+ uppPStr SLIT("\trem"),
+ pprSize size,
+ if uns then uppPStr SLIT("u\t") else uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (NOT ri reg)
+ = uppBesides [
+ uppPStr SLIT("\tnot"),
+ uppChar '\t',
+ pprRI ri,
+ uppComma,
+ pprReg reg
+ ]
+
+pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
+pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
+pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
+pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
+pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
+pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
+
+pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
+pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
+pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
+
+pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
+pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
+
+pprInstr (NOP) = uppPStr SLIT("\tnop")
+
+pprInstr (CMP cond reg1 ri reg2)
+ = uppBesides [
+ uppPStr SLIT("\tcmp"),
+ pprCond cond,
+ uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (FCLR reg)
+ = uppBesides [
+ uppPStr SLIT("\tfclr\t"),
+ pprReg reg
+ ]
+
+pprInstr (FABS reg1 reg2)
+ = uppBesides [
+ uppPStr SLIT("\tfabs\t"),
+ pprReg reg1,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (FNEG size reg1 reg2)
+ = uppBesides [
+ uppPStr SLIT("\tneg"),
+ pprSize size,
+ uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
+pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
+pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
+pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
+
+pprInstr (CVTxy size1 size2 reg1 reg2)
+ = uppBesides [
+ uppPStr SLIT("\tcvt"),
+ pprSize size1,
+ case size2 of {Q -> uppPStr SLIT("qc"); _ -> pprSize size2},
+ uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (FCMP size cond reg1 reg2 reg3)
+ = uppBesides [
+ uppPStr SLIT("\tcmp"),
+ pprSize size,
+ pprCond cond,
+ uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprReg reg2,
+ uppComma,
+ pprReg reg3
+ ]
+
+pprInstr (FMOV reg1 reg2)
+ = uppBesides [
+ uppPStr SLIT("\tfmov\t"),
+ pprReg reg1,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
+
+pprInstr (BI NEVER reg lab) = uppNil
+
+pprInstr (BI cond reg lab)
+ = uppBesides [
+ uppPStr SLIT("\tb"),
+ pprCond cond,
+ uppChar '\t',
+ pprReg reg,
+ uppComma,
+ pprImm lab
+ ]
+
+pprInstr (BF cond reg lab)
+ = uppBesides [
+ uppPStr SLIT("\tfb"),
+ pprCond cond,
+ uppChar '\t',
+ pprReg reg,
+ uppComma,
+ pprImm lab
+ ]
+
+pprInstr (BR lab)
+ = uppBeside (uppPStr SLIT("\tbr\t")) (pprImm lab)
+
+pprInstr (JMP reg addr hint)
+ = uppBesides [
+ uppPStr SLIT("\tjmp\t"),
+ pprReg reg,
+ uppComma,
+ pprAddr addr,
+ uppComma,
+ uppInt hint
+ ]
+
+pprInstr (BSR imm n)
+ = uppBeside (uppPStr SLIT("\tbsr\t")) (pprImm imm)
+
+pprInstr (JSR reg addr n)
+ = uppBesides [
+ uppPStr SLIT("\tjsr\t"),
+ pprReg reg,
+ uppComma,
+ pprAddr addr
+ ]
+
+pprInstr (FUNBEGIN clab)
+ = uppBesides [
+ if (externallyVisibleCLabel clab) then
+ uppBesides [uppPStr SLIT("\t.globl\t"), pp_lab, uppChar '\n']
+ else
+ uppNil,
+ uppPStr SLIT("\t.ent "),
+ pp_lab,
+ uppChar '\n',
+ pp_lab,
+ pp_ldgp,
+ pp_lab,
+ pp_frame
+ ]
+ where
+ pp_lab = pprCLabel_asm clab
+ pp_ldgp = uppPStr (_packCString (A# ":\n\tldgp $29,0($27)\n"#))
+ pp_frame = uppPStr (_packCString (A# "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
+
+pprInstr (FUNEND clab)
+ = uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
+\end{code}
+
+Continue with Alpha-only printing bits and bobs:
+\begin{code}
+pprRI :: RI -> Unpretty
+
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Unpretty
+
+pprRegRIReg name reg1 ri reg2
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
+
+pprSizeRegRegReg name size reg1 reg2 reg3
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprReg reg2,
+ uppComma,
+ pprReg reg3
+ ]
+
+#endif {-alpha_TARGET_ARCH-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@pprInstr@ for an I386}
+%* *
+%************************************************************************
+
+\begin{code}
+#if i386_TARGET_ARCH
+
+pprInstr (MOV size (OpReg src) (OpReg dst)) -- hack
+ | src == dst
+ = uppPStr SLIT("")
+pprInstr (MOV size src dst)
+ = pprSizeOpOp SLIT("mov") size src dst
+pprInstr (MOVZX size src dst) = pprSizeOpOpCoerce SLIT("movzx") L size src dst
+pprInstr (MOVSX size src dst) = pprSizeOpOpCoerce SLIT("movxs") L size src dst
+
+-- here we do some patching, since the physical registers are only set late
+-- in the code generation.
+pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
+ | reg1 == reg3
+ = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
+pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
+ | reg2 == reg3
+ = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
+pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
+ | reg1 == reg3
+ = pprInstr (ADD size (OpImm displ) dst)
+pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
+
+pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
+ = pprSizeOp SLIT("dec") size dst
+pprInstr (ADD size (OpImm (ImmInt 1)) dst)
+ = pprSizeOp SLIT("inc") size dst
+pprInstr (ADD size src dst)
+ = pprSizeOpOp SLIT("add") 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 (IDIV size op) = pprSizeOp SLIT("idiv") size op
+
+pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
+pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst
+pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst
+pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
+pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
+pprInstr (SHL size imm dst) = pprSizeOpOp SLIT("shl") size imm dst
+pprInstr (SAR size imm dst) = pprSizeOpOp SLIT("sar") size imm dst
+pprInstr (SHR size imm dst) = pprSizeOpOp SLIT("shr") size imm dst
+
+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 (NOP) = uppPStr SLIT("\tnop")
+pprInstr (CLTD) = uppPStr SLIT("\tcltd")
+
+pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
+
+pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
+
+pprInstr (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm imm)
+pprInstr (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand L op)
+
+pprInstr (CALL imm)
+ = uppBesides [ uppPStr SLIT("\tcall "), pprImm imm ]
+
+pprInstr SAHF = uppPStr SLIT("\tsahf")
+pprInstr FABS = uppPStr SLIT("\tfabs")
+
+pprInstr (FADD sz src@(OpAddr _))
+ = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppSP, pprOperand sz src]
+pprInstr (FADD sz src)
+ = uppPStr SLIT("\tfadd")
+pprInstr FADDP
+ = uppPStr SLIT("\tfaddp")
+pprInstr (FMUL sz src)
+ = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppSP, pprOperand sz src]
+pprInstr FMULP
+ = uppPStr SLIT("\tfmulp")
+pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op
+pprInstr FCHS = uppPStr SLIT("\tfchs")
+pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op
+pprInstr FCOS = uppPStr SLIT("\tfcos")
+pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op
+pprInstr (FDIV sz src)
+ = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppSP, pprOperand sz src]
+pprInstr FDIVP
+ = uppPStr SLIT("\tfdivp")
+pprInstr (FDIVR sz src)
+ = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppSP, pprOperand sz src]
+pprInstr FDIVRP
+ = uppPStr SLIT("\tfdivpr")
+pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op
+pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op
+pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg
+pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op
+pprInstr (FLD sz (OpImm (ImmCLbl src)))
+ = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprCLabel_asm src]
+pprInstr (FLD sz src)
+ = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprOperand sz src]
+pprInstr FLD1 = uppPStr SLIT("\tfld1")
+pprInstr FLDZ = uppPStr SLIT("\tfldz")
+pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op
+pprInstr FRNDINT = uppPStr SLIT("\tfrndint")
+pprInstr FSIN = uppPStr SLIT("\tfsin")
+pprInstr FSQRT = uppPStr SLIT("\tfsqrt")
+pprInstr (FST sz dst)
+ = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppSP, pprOperand sz dst]
+pprInstr (FSTP sz dst)
+ = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppSP, pprOperand sz dst]
+pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op
+pprInstr (FSUB sz src)
+ = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppSP, pprOperand sz src]
+pprInstr FSUBP
+ = uppPStr SLIT("\tfsubp")
+pprInstr (FSUBR size src)
+ = pprSizeOp SLIT("fsubr") size src
+pprInstr FSUBRP
+ = uppPStr SLIT("\tfsubpr")
+pprInstr (FISUBR size op)
+ = pprSizeAddr SLIT("fisubr") size op
+pprInstr FTST = uppPStr SLIT("\tftst")
+pprInstr (FCOMP sz op)
+ = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppSP, pprOperand sz op]
+pprInstr FUCOMPP = uppPStr SLIT("\tfucompp")
+pprInstr FXCH = uppPStr SLIT("\tfxch")
+pprInstr FNSTSW = uppPStr SLIT("\tfnstsw %ax")
+pprInstr FNOP = uppPStr SLIT("")
+\end{code}
+
+Continue with I386-only printing bits and bobs:
+\begin{code}
+pprDollImm :: Imm -> Unpretty
+
+pprDollImm i = uppBesides [ uppPStr SLIT("$"), pprImm i]
+
+pprOperand :: Size -> Operand -> Unpretty
+pprOperand s (OpReg r) = pprReg s r
+pprOperand s (OpImm i) = pprDollImm i
+pprOperand s (OpAddr ea) = pprAddr ea
+
+pprSizeOp :: FAST_STRING -> Size -> Operand -> Unpretty
+pprSizeOp name size op1
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppSP,
+ pprOperand size op1
+ ]
+
+pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty
+pprSizeOpOp name size op1 op2
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppSP,
+ pprOperand size op1,
+ uppComma,
+ pprOperand size op2
+ ]
+
+pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Unpretty
+pprSizeOpReg name size op1 reg
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppSP,
+ pprOperand size op1,
+ uppComma,
+ pprReg size reg
+ ]
+
+pprSizeAddr :: FAST_STRING -> Size -> Addr -> Unpretty
+pprSizeAddr name size op
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppSP,
+ pprAddr op
+ ]
+
+pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Unpretty
+pprSizeAddrReg name size op dst
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppSP,
+ pprAddr op,
+ uppComma,
+ pprReg size dst
+ ]
+
+pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty
+pprOpOp name size op1 op2
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name, uppSP,
+ pprOperand size op1,
+ uppComma,
+ pprOperand size op2
+ ]
+
+pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty
+pprSizeOpOpCoerce name size1 size2 op1 op2
+ = uppBesides [ uppChar '\t', uppPStr name, uppSP,
+ pprOperand size1 op1,
+ uppComma,
+ pprOperand size2 op2
+ ]
+
+pprCondInstr :: FAST_STRING -> Cond -> Unpretty -> Unpretty
+pprCondInstr name cond arg
+ = uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppSP, arg]
+
+#endif {-i386_TARGET_ARCH-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@pprInstr@ for a SPARC}
+%* *
+%************************************************************************
+
+\begin{code}
+#if sparc_TARGET_ARCH
+
+-- a clumsy hack for now, to handle possible double alignment problems
+
+pprInstr (LD DF addr reg) | maybeToBool off_addr
+ = uppBesides [
+ pp_ld_lbracket,
+ pprAddr addr,
+ pp_rbracket_comma,
+ pprReg reg,
+
+ uppChar '\n',
+ pp_ld_lbracket,
+ pprAddr addr2,
+ pp_rbracket_comma,
+ pprReg (fPair reg)
+ ]
+ where
+ off_addr = addrOffset addr 4
+ addr2 = case off_addr of Just x -> x
+
+pprInstr (LD size addr reg)
+ = uppBesides [
+ uppPStr SLIT("\tld"),
+ pprSize size,
+ uppChar '\t',
+ uppLbrack,
+ pprAddr addr,
+ pp_rbracket_comma,
+ pprReg reg
+ ]
+
+-- The same clumsy hack as above
+
+pprInstr (ST DF reg addr) | maybeToBool off_addr
+ = uppBesides [
+ uppPStr SLIT("\tst\t"),
+ pprReg reg,
+ pp_comma_lbracket,
+ pprAddr addr,
+
+ uppPStr SLIT("]\n\tst\t"),
+ pprReg (fPair reg),
+ pp_comma_lbracket,
+ pprAddr addr2,
+ uppRbrack
+ ]
+ where
+ off_addr = addrOffset addr 4
+ addr2 = case off_addr of Just x -> x
+
+pprInstr (ST size reg addr)
+ = uppBesides [
+ uppPStr SLIT("\tst"),
+ pprSize size,
+ uppChar '\t',
+ pprReg reg,
+ pp_comma_lbracket,
+ pprAddr addr,
+ uppRbrack
+ ]
+
+pprInstr (ADD x cc reg1 ri reg2)
+ | not x && not cc && riZero ri
+ = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ]
+ | otherwise
+ = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
+
+pprInstr (SUB x cc reg1 ri reg2)
+ | not x && cc && reg2 == g0
+ = uppBesides [ uppPStr SLIT("\tcmp\t"), pprReg reg1, uppComma, pprRI ri ]
+ | not x && not cc && riZero ri
+ = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ]
+ | otherwise
+ = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
+
+pprInstr (AND b reg1 ri reg2) = pprRegRIReg SLIT("and") b reg1 ri reg2
+pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
+
+pprInstr (OR b reg1 ri reg2)
+ | not b && reg1 == g0
+ = uppBesides [ uppPStr SLIT("\tmov\t"), pprRI ri, uppComma, pprReg reg2 ]
+ | otherwise
+ = pprRegRIReg SLIT("or") b reg1 ri reg2
+
+pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
+
+pprInstr (XOR b reg1 ri reg2) = pprRegRIReg SLIT("xor") b reg1 ri reg2
+pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
+
+pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
+pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
+pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
+
+pprInstr (SETHI imm reg)
+ = uppBesides [
+ uppPStr SLIT("\tsethi\t"),
+ pprImm imm,
+ uppComma,
+ pprReg reg
+ ]
+
+pprInstr NOP = uppPStr SLIT("\tnop")
+
+pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
+pprInstr (FABS DF reg1 reg2)
+ = uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2)
+ (if (reg1 == reg2) then uppNil
+ else uppBeside (uppChar '\n')
+ (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
+
+pprInstr (FADD size reg1 reg2 reg3)
+ = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
+pprInstr (FCMP e size reg1 reg2)
+ = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
+pprInstr (FDIV size reg1 reg2 reg3)
+ = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
+
+pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
+pprInstr (FMOV DF reg1 reg2)
+ = uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2)
+ (if (reg1 == reg2) then uppNil
+ else uppBeside (uppChar '\n')
+ (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
+
+pprInstr (FMUL size reg1 reg2 reg3)
+ = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
+
+pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
+pprInstr (FNEG DF reg1 reg2)
+ = uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2)
+ (if (reg1 == reg2) then uppNil
+ else uppBeside (uppChar '\n')
+ (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
+
+pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
+pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
+pprInstr (FxTOy size1 size2 reg1 reg2)
+ = uppBesides [
+ uppPStr SLIT("\tf"),
+ uppPStr
+ (case size1 of
+ W -> SLIT("ito")
+ F -> SLIT("sto")
+ DF -> SLIT("dto")),
+ uppPStr
+ (case size2 of
+ W -> SLIT("i\t")
+ F -> SLIT("s\t")
+ DF -> SLIT("d\t")),
+ pprReg reg1, uppComma, pprReg reg2
+ ]
+
+
+pprInstr (BI cond b lab)
+ = uppBesides [
+ uppPStr SLIT("\tb"), pprCond cond,
+ if b then pp_comma_a else uppNil,
+ uppChar '\t',
+ pprImm lab
+ ]
+
+pprInstr (BF cond b lab)
+ = uppBesides [
+ uppPStr SLIT("\tfb"), pprCond cond,
+ if b then pp_comma_a else uppNil,
+ uppChar '\t',
+ pprImm lab
+ ]
+
+pprInstr (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr addr)
+
+pprInstr (CALL imm n _)
+ = uppBesides [ uppPStr SLIT("\tcall\t"), pprImm imm, uppComma, uppInt n ]
+\end{code}
+
+Continue with SPARC-only printing bits and bobs:
+\begin{code}
+pprRI :: RI -> Unpretty
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty
+pprSizeRegReg name size reg1 reg2
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ (case size of
+ F -> uppPStr SLIT("s\t")
+ DF -> uppPStr SLIT("d\t")),
+ pprReg reg1,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
+pprSizeRegRegReg name size reg1 reg2 reg3
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ (case size of
+ F -> uppPStr SLIT("s\t")
+ DF -> uppPStr SLIT("d\t")),
+ pprReg reg1,
+ uppComma,
+ pprReg reg2,
+ uppComma,
+ pprReg reg3
+ ]
+
+pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty
+pprRegRIReg name b reg1 ri reg2
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ if b then uppPStr SLIT("cc\t") else uppChar '\t',
+ pprReg reg1,
+ uppComma,
+ pprRI ri,
+ uppComma,
+ pprReg reg2
+ ]
+
+pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Unpretty
+pprRIReg name b ri reg1
+ = uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ if b then uppPStr SLIT("cc\t") else uppChar '\t',
+ pprRI ri,
+ uppComma,
+ pprReg reg1
+ ]
+
+pp_ld_lbracket = uppPStr (_packCString (A# "\tld\t["#))
+pp_rbracket_comma = uppPStr (_packCString (A# "],"#))
+pp_comma_lbracket = uppPStr (_packCString (A# ",["#))
+pp_comma_a = uppPStr (_packCString (A# ",a"#))
+
+#endif {-sparc_TARGET_ARCH-}
+\end{code}
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..93cda5c3a1a0e8dfb8dae736496450fc3bf2c629
--- /dev/null
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -0,0 +1,799 @@
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[RegAllocInfo]{Machine-specific info used for register allocation}
+
+The (machine-independent) allocator itself is in @AsmRegAlloc@.
+
+\begin{code}
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module RegAllocInfo (
+ MRegsState(..),
+ mkMRegsState,
+ freeMReg,
+ freeMRegs,
+ possibleMRegs,
+ useMReg,
+ useMRegs,
+
+ RegUsage(..),
+ noUsage,
+ endUsage,
+ regUsage,
+
+ FutureLive(..),
+ RegAssignment(..),
+ RegConflicts(..),
+ RegFuture(..),
+ RegHistory(..),
+ RegInfo(..),
+ RegLiveness(..),
+
+ fstFL,
+ loadReg,
+ patchRegs,
+ regLiveness,
+ spillReg,
+
+ RegSet(..),
+ elementOfRegSet,
+ emptyRegSet,
+ isEmptyRegSet,
+ minusRegSet,
+ mkRegSet,
+ regSetToList,
+ unionRegSets,
+
+ argRegSet,
+ callClobberedRegSet,
+ freeRegSet
+ ) where
+
+import Ubiq{-uitous-}
+
+import MachMisc
+import MachRegs
+import MachCode ( InstrList(..) )
+
+import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet )
+import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} )
+import FiniteMap ( addToFM, lookupFM )
+import OrdList ( mkUnitList, OrdList )
+import PrimRep ( PrimRep(..) )
+import Stix ( StixTree, CodeSegment )
+import UniqSet -- quite a bit of it
+import Unpretty ( uppShow )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Register allocation information}
+%* *
+%************************************************************************
+
+\begin{code}
+type RegSet = UniqSet Reg
+
+mkRegSet :: [Reg] -> RegSet
+emptyRegSet :: RegSet
+unionRegSets, minusRegSet :: RegSet -> RegSet -> RegSet
+elementOfRegSet :: Reg -> RegSet -> Bool
+isEmptyRegSet :: RegSet -> Bool
+regSetToList :: RegSet -> [Reg]
+
+mkRegSet = mkUniqSet
+emptyRegSet = emptyUniqSet
+unionRegSets = unionUniqSets
+minusRegSet = minusUniqSet
+elementOfRegSet = elementOfUniqSet
+isEmptyRegSet = isEmptyUniqSet
+regSetToList = uniqSetToList
+
+freeRegSet, callClobberedRegSet :: RegSet
+argRegSet :: Int -> RegSet
+
+freeRegSet = mkRegSet freeRegs
+callClobberedRegSet = mkRegSet callClobberedRegs
+argRegSet n = mkRegSet (argRegs n)
+
+type RegAssignment = FiniteMap Reg Reg
+type RegConflicts = FiniteMap Int RegSet
+
+data FutureLive = FL RegSet (FiniteMap CLabel RegSet)
+
+fstFL (FL a b) = a
+
+data RegHistory a
+ = RH a
+ Int
+ RegAssignment
+
+data RegFuture
+ = RF RegSet -- in use
+ FutureLive -- future
+ RegConflicts
+
+data RegInfo a
+ = RI RegSet -- in use
+ RegSet -- sources
+ RegSet -- destinations
+ [Reg] -- last used
+ RegConflicts
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Register allocation information}
+%* *
+%************************************************************************
+
+COMMENT ON THE EXTRA BitSet FOR SPARC MRegsState: Getting the conflicts
+right is a bit tedious for doubles. We'd have to add a conflict
+function to the MachineRegisters class, and we'd have to put a PrimRep
+in the MappedReg datatype, or use some kludge (e.g. register 64 + n is
+really the same as 32 + n, except that it's used for a double, so it
+also conflicts with 33 + n) to deal with it. It's just not worth the
+bother, so we just partition the free floating point registers into
+two sets: one for single precision and one for double precision. We
+never seem to run out of floating point registers anyway.
+
+\begin{code}
+data MRegsState
+ = MRs BitSet -- integer registers
+ BitSet -- floating-point registers
+ IF_ARCH_sparc(BitSet,) -- double registers handled separately
+\end{code}
+
+\begin{code}
+#if alpha_TARGET_ARCH
+# define INT_FLPT_CUTOFF 32
+#endif
+#if i386_TARGET_ARCH
+# define INT_FLPT_CUTOFF 8
+#endif
+#if sparc_TARGET_ARCH
+# define INT_FLPT_CUTOFF 32
+# define SNGL_DBL_CUTOFF 48
+#endif
+
+mkMRegsState :: [RegNo] -> MRegsState
+possibleMRegs :: PrimRep -> MRegsState -> [RegNo]
+useMReg :: MRegsState -> FAST_REG_NO -> MRegsState
+useMRegs :: MRegsState -> [RegNo] -> MRegsState
+freeMReg :: MRegsState -> FAST_REG_NO -> MRegsState
+freeMRegs :: MRegsState -> [RegNo] -> MRegsState
+
+mkMRegsState xs
+ = MRs (mkBS is) (mkBS fs2) IF_ARCH_sparc((mkBS ds2),)
+ where
+ (is, fs) = partition (< INT_FLPT_CUTOFF) xs
+#if sparc_TARGET_ARCH
+ (ss, ds) = partition (< SNGL_DBL_CUTOFF) fs
+ fs2 = map (subtract INT_FLPT_CUTOFF) ss
+ ds2 = map (subtract INT_FLPT_CUTOFF) (filter even ds)
+#else
+ fs2 = map (subtract INT_FLPT_CUTOFF) fs
+#endif
+
+------------------------------------------------
+#if sparc_TARGET_ARCH
+possibleMRegs FloatRep (MRs _ ss _) = [ x + INT_FLPT_CUTOFF | x <- listBS ss]
+possibleMRegs DoubleRep (MRs _ _ ds) = [ x + INT_FLPT_CUTOFF | x <- listBS ds]
+possibleMRegs _ (MRs is _ _) = listBS is
+#else
+possibleMRegs FloatRep (MRs _ fs) = [ x + INT_FLPT_CUTOFF | x <- listBS fs]
+possibleMRegs DoubleRep (MRs _ fs) = [ x + INT_FLPT_CUTOFF | x <- listBS fs]
+possibleMRegs _ (MRs is _) = listBS is
+#endif
+
+------------------------------------------------
+#if sparc_TARGET_ARCH
+useMReg (MRs is ss ds) n
+ = if (n _LT_ ILIT(INT_FLPT_CUTOFF)) then
+ MRs (is `minusBS` unitBS IBOX(n)) ss ds
+ else if (n _LT_ ILIT(SNGL_DBL_CUTOFF)) then
+ MRs is (ss `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) ds
+ else
+ MRs is ss (ds `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF))))
+#else
+useMReg (MRs is fs) n
+ = if (n _LT_ ILIT(INT_FLPT_CUTOFF))
+ then MRs (is `minusBS` unitBS IBOX(n)) fs
+ else MRs is (fs `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF))))
+#endif
+
+------------------------------------------------
+#if sparc_TARGET_ARCH
+useMRegs (MRs is ss ds) xs
+ = MRs (is `minusBS` is2) (ss `minusBS` ss2) (ds `minusBS` ds2)
+ where
+ MRs is2 ss2 ds2 = mkMRegsState xs
+#else
+useMRegs (MRs is fs) xs
+ = MRs (is `minusBS` is2) (fs `minusBS` fs2)
+ where
+ MRs is2 fs2 = mkMRegsState xs
+#endif
+
+------------------------------------------------
+#if sparc_TARGET_ARCH
+freeMReg (MRs is ss ds) n
+ = if (n _LT_ ILIT(INT_FLPT_CUTOFF)) then
+ MRs (is `unionBS` unitBS IBOX(n)) ss ds
+ else if (n _LT_ ILIT(SNGL_DBL_CUTOFF)) then
+ MRs is (ss `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) ds
+ else
+ MRs is ss (ds `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF))))
+#else
+freeMReg (MRs is fs) n
+ = if (n _LT_ ILIT(INT_FLPT_CUTOFF))
+ then MRs (is `unionBS` unitBS IBOX(n)) fs
+ else MRs is (fs `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF))))
+#endif
+
+------------------------------------------------
+#if sparc_TARGET_ARCH
+freeMRegs (MRs is ss ds) xs
+ = MRs (is `unionBS` is2) (ss `unionBS` ss2) (ds `unionBS` ds2)
+ where
+ MRs is2 ss2 ds2 = mkMRegsState xs
+#else
+freeMRegs (MRs is fs) xs
+ = MRs (is `unionBS` is2) (fs `unionBS` fs2)
+ where
+ MRs is2 fs2 = mkMRegsState xs
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@RegUsage@ type; @noUsage@, @endUsage@, @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!)
+
+An important point: The @regUsage@ function for a particular
+assembly language must not refer to fixed registers, such as Hp, SpA,
+etc. The source and destination MRegsStates should only refer to
+dynamically allocated registers or static registers from the free
+list. As far as we are concerned, the fixed registers simply don't
+exist (for allocation purposes, anyway).
+
+\begin{code}
+data RegUsage = RU RegSet RegSet
+
+noUsage, endUsage :: RegUsage
+noUsage = RU emptyRegSet emptyRegSet
+endUsage = RU emptyRegSet freeRegSet
+
+regUsage :: Instr -> RegUsage
+
+#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])
+-- LD W reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED
+-- LD WU reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED
+ LD sz reg addr -> usage (regAddr addr, [reg])
+ LDA reg addr -> usage (regAddr addr, [reg])
+ LDAH reg addr -> usage (regAddr addr, [reg])
+ LDGP reg addr -> usage (regAddr addr, [reg])
+ LDI sz reg imm -> usage ([], [reg])
+ ST B reg addr -> usage (reg : regAddr addr, [t9, t10])
+-- ST W reg addr -> usage (reg : regAddr addr, [t9, t10]) : UNUSED
+ ST sz reg addr -> usage (reg : regAddr addr, [])
+ CLR reg -> usage ([], [reg])
+ ABS sz ri reg -> usage (regRI ri, [reg])
+ NEG sz ov ri reg -> usage (regRI ri, [reg])
+ ADD sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SUB sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ MUL sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ DIV sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
+ REM sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
+ NOT ri reg -> usage (regRI ri, [reg])
+ AND r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ ANDNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ OR r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ ORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ XOR r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ XORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SLL r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SRL r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SRA r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ ZAP r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ ZAPNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ CMP co r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ FCLR reg -> usage ([], [reg])
+ FABS r1 r2 -> usage ([r1], [r2])
+ FNEG sz r1 r2 -> usage ([r1], [r2])
+ FADD sz r1 r2 r3 -> usage ([r1, r2], [r3])
+ FDIV sz r1 r2 r3 -> usage ([r1, r2], [r3])
+ FMUL sz r1 r2 r3 -> usage ([r1, r2], [r3])
+ FSUB sz r1 r2 r3 -> usage ([r1, r2], [r3])
+ CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2])
+ FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3])
+ FMOV r1 r2 -> usage ([r1], [r2])
+
+
+ -- We assume that all local jumps will be BI/BF/BR. JMP must be out-of-line.
+ BI cond reg lbl -> usage ([reg], [])
+ BF cond reg lbl -> usage ([reg], [])
+ JMP reg addr hint -> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet
+
+ BSR _ n -> RU (argRegSet n) callClobberedRegSet
+ JSR reg addr n -> RU (argRegSet n) callClobberedRegSet
+
+ _ -> noUsage
+
+ where
+ usage (src, dst) = RU (mkRegSet (filter interesting src))
+ (mkRegSet (filter interesting dst))
+
+ interesting (FixedReg _) = False
+ interesting _ = True
+
+ regAddr (AddrReg r1) = [r1]
+ regAddr (AddrRegImm r1 _) = [r1]
+ regAddr (AddrImm _) = []
+
+ regRI (RIReg r) = [r]
+ regRI _ = []
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+regUsage instr = case instr of
+ MOV sz src dst -> usage2 src dst
+ MOVZX sz src dst -> usage2 src dst
+ MOVSX sz src dst -> usage2 src dst
+ LEA sz src dst -> usage2 src dst
+ ADD sz src dst -> usage2 src dst
+ SUB sz src dst -> usage2 src dst
+ IMUL sz src dst -> usage2 src dst
+ IDIV sz src -> usage (eax:edx:opToReg src) [eax,edx]
+ AND sz src dst -> usage2 src dst
+ OR sz src dst -> usage2 src dst
+ XOR sz src dst -> usage2 src dst
+ NOT sz op -> usage1 op
+ NEGI sz op -> usage1 op
+ SHL sz imm dst -> usage1 dst -- imm has to be an Imm
+ SAR sz imm dst -> usage1 dst -- imm has to be an Imm
+ SHR sz imm dst -> usage1 dst -- imm has to be an Imm
+ PUSH sz op -> usage (opToReg op) []
+ POP sz op -> usage [] (opToReg op)
+ TEST sz src dst -> usage (opToReg src ++ opToReg dst) []
+ CMP sz src dst -> usage (opToReg src ++ opToReg dst) []
+ SETCC cond op -> usage [] (opToReg op)
+ JXX cond label -> usage [] []
+ JMP op -> usage (opToReg op) freeRegs
+ CALL imm -> usage [] callClobberedRegs
+ CLTD -> usage [eax] [edx]
+ NOP -> usage [] []
+ SAHF -> usage [eax] []
+ FABS -> usage [st0] [st0]
+ FADD sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
+ FADDP -> usage [st0,st1] [st0] -- allFPRegs
+ FIADD sz asrc -> usage (addrToRegs asrc) [st0]
+ FCHS -> usage [st0] [st0]
+ FCOM sz src -> usage (st0:opToReg src) []
+ FCOS -> usage [st0] [st0]
+ FDIV sz src -> usage (st0:opToReg src) [st0]
+ FDIVP -> usage [st0,st1] [st0]
+ FDIVRP -> usage [st0,st1] [st0]
+ FIDIV sz asrc -> usage (addrToRegs asrc) [st0]
+ FDIVR sz src -> usage (st0:opToReg src) [st0]
+ FIDIVR sz asrc -> usage (addrToRegs asrc) [st0]
+ FICOM sz asrc -> usage (addrToRegs asrc) []
+ FILD sz asrc dst -> usage (addrToRegs asrc) [dst] -- allFPRegs
+ FIST sz adst -> usage (st0:addrToRegs adst) []
+ FLD sz src -> usage (opToReg src) [st0] -- allFPRegs
+ FLD1 -> usage [] [st0] -- allFPRegs
+ FLDZ -> usage [] [st0] -- allFPRegs
+ FMUL sz src -> usage (st0:opToReg src) [st0]
+ FMULP -> usage [st0,st1] [st0]
+ FIMUL sz asrc -> usage (addrToRegs asrc) [st0]
+ FRNDINT -> usage [st0] [st0]
+ FSIN -> usage [st0] [st0]
+ FSQRT -> usage [st0] [st0]
+ FST sz (OpReg r) -> usage [st0] [r]
+ FST sz dst -> usage (st0:opToReg dst) []
+ FSTP sz (OpReg r) -> usage [st0] [r] -- allFPRegs
+ FSTP sz dst -> usage (st0:opToReg dst) [] -- allFPRegs
+ FSUB sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
+ FSUBR sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
+ FISUB sz asrc -> usage (addrToRegs asrc) [st0]
+ FSUBP -> usage [st0,st1] [st0] -- allFPRegs
+ FSUBRP -> usage [st0,st1] [st0] -- allFPRegs
+ FISUBR sz asrc -> usage (addrToRegs asrc) [st0]
+ FTST -> usage [st0] []
+ FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs
+ FUCOMPP -> usage [st0, st1] [] -- allFPRegs
+ FXCH -> usage [st0, st1] [st0, st1]
+ FNSTSW -> usage [] [eax]
+ _ -> noUsage
+ where
+ usage2 :: Operand -> Operand -> RegUsage
+ usage2 op (OpReg reg) = usage (opToReg op) [reg]
+ usage2 op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) []
+ usage2 op (OpImm imm) = usage (opToReg op) []
+ usage1 :: Operand -> RegUsage
+ usage1 (OpReg reg) = usage [reg] [reg]
+ usage1 (OpAddr ea) = usage (addrToRegs ea) []
+ allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7]
+
+ --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
+ callClobberedRegs = [eax]
+
+-- General purpose register collecting functions.
+
+ opToReg (OpReg reg) = [reg]
+ opToReg (OpImm imm) = []
+ opToReg (OpAddr ea) = addrToRegs ea
+
+ addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index
+ where baseToReg Nothing = []
+ baseToReg (Just r) = [r]
+ indexToReg Nothing = []
+ indexToReg (Just (r,_)) = [r]
+ addrToRegs (ImmAddr _ _) = []
+
+ usage src dst = RU (mkRegSet (filter interesting src))
+ (mkRegSet (filter interesting dst))
+
+ interesting (FixedReg _) = False
+ interesting _ = True
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+regUsage instr = case instr of
+ LD sz addr reg -> usage (regAddr addr, [reg])
+ ST sz reg addr -> usage (reg : regAddr addr, [])
+ ADD x cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SUB x cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ AND b r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ ANDN b r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ OR b r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ ORN b r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ XOR b r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ XNOR b r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SLL r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SRL r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SRA r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SETHI imm reg -> usage ([], [reg])
+ FABS s r1 r2 -> usage ([r1], [r2])
+ FADD s r1 r2 r3 -> usage ([r1, r2], [r3])
+ FCMP e s r1 r2 -> usage ([r1, r2], [])
+ FDIV s r1 r2 r3 -> usage ([r1, r2], [r3])
+ FMOV s r1 r2 -> usage ([r1], [r2])
+ FMUL s r1 r2 r3 -> usage ([r1, r2], [r3])
+ FNEG s r1 r2 -> usage ([r1], [r2])
+ FSQRT s r1 r2 -> usage ([r1], [r2])
+ FSUB s r1 r2 r3 -> usage ([r1, r2], [r3])
+ FxTOy s1 s2 r1 r2 -> usage ([r1], [r2])
+
+ -- We assume that all local jumps will be BI/BF. JMP must be out-of-line.
+ JMP addr -> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet
+
+ CALL _ n True -> endUsage
+ CALL _ n False -> RU (argRegSet n) callClobberedRegSet
+
+ _ -> noUsage
+ where
+ usage (src, dst) = RU (mkRegSet (filter interesting src))
+ (mkRegSet (filter interesting dst))
+
+ interesting (FixedReg _) = False
+ interesting _ = True
+
+ regAddr (AddrRegReg r1 r2) = [r1, r2]
+ regAddr (AddrRegImm r1 _) = [r1]
+
+ regRI (RIReg r) = [r]
+ regRI _ = []
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@RegLiveness@ type; @regLiveness@ function}
+%* *
+%************************************************************************
+
+@regLiveness@ takes future liveness information and modifies it
+according to the semantics of branches and labels. (An out-of-line
+branch clobbers the liveness passed back by the following instruction;
+a forward local branch passes back the liveness from the target label;
+a conditional branch merges the liveness from the target and the
+liveness from its successor; a label stashes away the current liveness
+in the future liveness environment).
+
+\begin{code}
+data RegLiveness = RL RegSet FutureLive
+
+regLiveness :: Instr -> RegLiveness -> RegLiveness
+
+regLiveness instr info@(RL live future@(FL all env))
+ = let
+ lookup lbl
+ = case (lookupFM env lbl) of
+ Just rs -> rs
+ Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel_asm lbl)) ++
+ " in future?") emptyRegSet
+ in
+ case instr of -- the rest is machine-specific...
+
+#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 -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+ JXX _ lbl -> RL (lookup lbl `unionRegSets` live) future
+ JMP _ -> RL emptyRegSet future
+ CALL _ -> RL live future
+ LABEL lbl -> RL live (FL (all `unionRegSets` live) (addToFM env lbl live))
+ _ -> info
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+ -- We assume that all local jumps will be BI/BF. JMP must be out-of-line.
+
+ BI ALWAYS _ (ImmCLbl lbl) -> RL (lookup lbl) future
+ BI _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionRegSets` live) future
+ BF ALWAYS _ (ImmCLbl lbl) -> RL (lookup lbl) future
+ BF _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionRegSets` live) future
+ JMP _ -> RL emptyRegSet future
+ CALL _ i True -> RL emptyRegSet future
+ CALL _ i False -> RL live future
+ LABEL lbl -> RL live (FL (all `unionRegSets` live) (addToFM env lbl live))
+ _ -> info
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@patchRegs@ function}
+%* *
+%************************************************************************
+
+@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
+
+patchRegs instr env = case instr of
+ LD sz reg addr -> LD sz (env reg) (fixAddr addr)
+ LDA reg addr -> LDA (env reg) (fixAddr addr)
+ LDAH reg addr -> LDAH (env reg) (fixAddr addr)
+ LDGP reg addr -> LDGP (env reg) (fixAddr addr)
+ LDI sz reg imm -> LDI sz (env reg) imm
+ ST sz reg addr -> ST sz (env reg) (fixAddr addr)
+ CLR reg -> CLR (env reg)
+ ABS sz ar reg -> ABS sz (fixRI ar) (env reg)
+ NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg)
+ ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2)
+ SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2)
+ SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2)
+ SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2)
+ MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2)
+ DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2)
+ REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2)
+ NOT ar reg -> NOT (fixRI ar) (env reg)
+ AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2)
+ ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2)
+ OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2)
+ ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2)
+ XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2)
+ XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2)
+ SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
+ SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
+ SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
+ ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2)
+ ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2)
+ CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2)
+ FCLR reg -> FCLR (env reg)
+ FABS r1 r2 -> FABS (env r1) (env r2)
+ FNEG s r1 r2 -> FNEG s (env r1) (env r2)
+ FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
+ FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
+ FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
+ FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
+ CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2)
+ FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3)
+ FMOV r1 r2 -> FMOV (env r1) (env r2)
+ BI cond reg lbl -> BI cond (env reg) lbl
+ BF cond reg lbl -> BF cond (env reg) lbl
+ JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint
+ JSR reg addr i -> JSR (env reg) (fixAddr addr) i
+ _ -> instr
+ where
+ fixAddr (AddrReg r1) = AddrReg (env r1)
+ fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
+ fixAddr other = other
+
+ fixRI (RIReg r) = RIReg (env r)
+ fixRI other = other
+
+#endif {- alpha_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if i386_TARGET_ARCH
+
+patchRegs instr env = case instr of
+ MOV sz src dst -> patch2 (MOV sz) src dst
+ MOVZX sz src dst -> patch2 (MOVZX sz) src dst
+ MOVSX sz src dst -> patch2 (MOVSX sz) src dst
+ LEA sz src dst -> patch2 (LEA sz) src dst
+ ADD sz src dst -> patch2 (ADD sz) src dst
+ SUB sz src dst -> patch2 (SUB sz) src dst
+ IMUL sz src dst -> patch2 (IMUL sz) src dst
+ IDIV sz src -> patch1 (IDIV sz) src
+ 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
+ NOT sz op -> patch1 (NOT sz) op
+ NEGI sz op -> patch1 (NEGI sz) op
+ SHL sz imm dst -> patch1 (SHL sz imm) dst
+ SAR sz imm dst -> patch1 (SAR sz imm) dst
+ SHR sz imm dst -> patch1 (SHR sz imm) dst
+ TEST sz src dst -> patch2 (TEST sz) src dst
+ CMP sz src dst -> patch2 (CMP 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 op -> patch1 JMP op
+ FADD sz src -> FADD sz (patchOp src)
+ FIADD sz asrc -> FIADD sz (lookupAddr asrc)
+ FCOM sz src -> patch1 (FCOM sz) src
+ FDIV sz src -> FDIV sz (patchOp src)
+ --FDIVP sz src -> FDIVP sz (patchOp src)
+ FIDIV sz asrc -> FIDIV sz (lookupAddr asrc)
+ FDIVR sz src -> FDIVR sz (patchOp src)
+ --FDIVRP sz src -> FDIVRP sz (patchOp src)
+ FIDIVR sz asrc -> FIDIVR sz (lookupAddr asrc)
+ FICOM sz asrc -> FICOM sz (lookupAddr asrc)
+ FILD sz asrc dst -> FILD sz (lookupAddr asrc) (env dst)
+ FIST sz adst -> FIST sz (lookupAddr adst)
+ FLD sz src -> patch1 (FLD sz) (patchOp src)
+ FMUL sz src -> FMUL sz (patchOp src)
+ --FMULP sz src -> FMULP sz (patchOp src)
+ FIMUL sz asrc -> FIMUL sz (lookupAddr asrc)
+ FST sz dst -> FST sz (patchOp dst)
+ FSTP sz dst -> FSTP sz (patchOp dst)
+ FSUB sz src -> FSUB sz (patchOp src)
+ --FSUBP sz src -> FSUBP sz (patchOp src)
+ FISUB sz asrc -> FISUB sz (lookupAddr asrc)
+ FSUBR sz src -> FSUBR sz (patchOp src)
+ --FSUBRP sz src -> FSUBRP sz (patchOp src)
+ FISUBR sz asrc -> FISUBR sz (lookupAddr asrc)
+ FCOMP sz src -> FCOMP sz (patchOp src)
+ _ -> instr
+ where
+ 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
+ patchOp (OpAddr ea) = OpAddr (lookupAddr ea)
+
+ lookupAddr (ImmAddr imm off) = ImmAddr imm off
+ lookupAddr (Addr base index disp)
+ = Addr (lookupBase base) (lookupIndex index) disp
+ where
+ lookupBase Nothing = Nothing
+ lookupBase (Just r) = Just (env r)
+
+ lookupIndex Nothing = Nothing
+ lookupIndex (Just (r,i)) = Just (env r, i)
+
+#endif {- i386_TARGET_ARCH -}
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+#if sparc_TARGET_ARCH
+
+patchRegs instr env = case instr of
+ LD sz addr reg -> LD sz (fixAddr addr) (env reg)
+ ST sz reg addr -> ST sz (env reg) (fixAddr addr)
+ ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
+ SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2)
+ AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2)
+ ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2)
+ OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2)
+ ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2)
+ XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2)
+ XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2)
+ SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
+ SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
+ SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
+ SETHI imm reg -> SETHI imm (env reg)
+ FABS s r1 r2 -> FABS s (env r1) (env r2)
+ FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
+ FCMP e s r1 r2 -> FCMP e s (env r1) (env r2)
+ FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
+ FMOV s r1 r2 -> FMOV s (env r1) (env r2)
+ FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
+ FNEG s r1 r2 -> FNEG s (env r1) (env r2)
+ FSQRT s r1 r2 -> FSQRT s (env r1) (env r2)
+ FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
+ FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
+ JMP addr -> JMP (fixAddr addr)
+ _ -> instr
+ where
+ fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
+ fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
+
+ fixRI (RIReg r) = RIReg (env r)
+ fixRI other = other
+
+#endif {- sparc_TARGET_ARCH -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@spillReg@ and @loadReg@ functions}
+%* *
+%************************************************************************
+
+Spill to memory, and load it back...
+
+\begin{code}
+spillReg, loadReg :: Reg -> Reg -> InstrList
+
+spillReg dyn (MemoryReg i pk)
+ = let
+ sz = primRepToSize pk
+ in
+ mkUnitList (
+ {-Alpha: spill below the stack pointer (?)-}
+ IF_ARCH_alpha( ST sz dyn (spRel i)
+
+ {-I386: spill below stack pointer leaving 2 words/spill-}
+ ,IF_ARCH_i386 ( MOV sz (OpReg dyn) (OpAddr (spRel (-2 * i)))
+
+ {-SPARC: spill below frame pointer leaving 2 words/spill-}
+ ,IF_ARCH_sparc( ST sz dyn (fpRel (-2 * i))
+ ,)))
+ )
+
+----------------------------
+loadReg (MemoryReg i pk) dyn
+ = let
+ sz = primRepToSize pk
+ in
+ mkUnitList (
+ IF_ARCH_alpha( LD sz dyn (spRel i)
+ ,IF_ARCH_i386 ( MOV sz (OpAddr (spRel (-2 * i))) (OpReg dyn)
+ ,IF_ARCH_sparc( LD sz (fpRel (-2 * i)) dyn
+ ,)))
+ )
+\end{code}
diff --git a/ghc/compiler/nativeGen/SparcCode.lhs b/ghc/compiler/nativeGen/SparcCode.lhs
deleted file mode 100644
index 203807e5d0f8394229705df1f0be6ddb35297f22..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/SparcCode.lhs
+++ /dev/null
@@ -1,1389 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-
-\section[SparcCode]{The Native (Sparc) Machine Code}
-
-\begin{code}
-#define ILIT2(x) ILIT(x)
-#include "HsVersions.h"
-
-module SparcCode (
- Addr(..),Cond(..),Imm(..),RI(..),Size(..),
- SparcCode(..),SparcInstr(..),SparcRegs,
- strImmLit,
-
- printLabeledCodes,
-
- baseRegOffset, stgRegMap, callerSaves,
-
- is13Bits, offset,
-
- kindToSize,
-
- g0, o0, f0, fp, sp, argRegs,
-
- freeRegs, reservedRegs
-
- -- and, for self-sufficiency ...
- ) where
-
-IMPORT_Trace
-
-import AbsCSyn ( MagicId(..) )
-import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..),
- Reg(..), RegUsage(..), RegLiveness(..)
- )
-import BitSet
-import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
-import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
-import FiniteMap
-import Maybes ( Maybe(..), maybeToBool )
-import OrdList ( OrdList, mkUnitList, flattenOrdList )
-import Outputable
-import UniqSet
-import Stix
-import Unpretty
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SparcReg]{The Native (Sparc) Machine Register Table}
-%* *
-%************************************************************************
-
-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, prepared for any eventuality.
-
-ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM)
-
-\begin{code}
-
-gReg,lReg,iReg,oReg,fReg :: Int -> Int
-gReg x = x
-oReg x = (8 + x)
-lReg x = (16 + x)
-iReg x = (24 + x)
-fReg x = (32 + x)
-
-fPair :: Reg -> Reg
-fPair (FixedReg i) = FixedReg (i _ADD_ ILIT(1))
-fPair (MappedReg i) = MappedReg (i _ADD_ ILIT(1))
-
-g0, fp, sp, o0, f0 :: Reg
-g0 = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
-fp = case (iReg 6) of { IBOX(i6) -> FixedReg i6 }
-sp = case (oReg 6) of { IBOX(o6) -> FixedReg o6 }
-o0 = realReg (oReg 0)
-f0 = realReg (fReg 0)
-
-argRegs :: [Reg]
-argRegs = map realReg [oReg i | i <- [0..5]]
-
-realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TheSparcCode]{The datatype for sparc assembly language}
-%* *
-%************************************************************************
-
-Here is a definition of the Sparc assembly language.
-
-\begin{code}
-
-data Imm = ImmInt Int
- | ImmInteger Integer -- Sigh.
- | ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLab Unpretty -- Simple string label (underscored)
- | ImmLit Unpretty -- Simple string
- | LO Imm -- Possible restrictions
- | HI Imm
- deriving ()
-
-strImmLit s = ImmLit (uppStr s)
-
-data Addr = AddrRegReg Reg Reg
- | AddrRegImm Reg Imm
- deriving ()
-
-data Cond = ALWAYS
- | NEVER
- | GEU
- | LU
- | EQ
- | GT
- | GE
- | GU
- | LT
- | LE
- | LEU
- | NE
- | NEG
- | POS
- | VC
- | VS
- deriving ()
-
-data RI = RIReg Reg
- | RIImm Imm
- deriving ()
-
-riZero :: RI -> Bool
-riZero (RIImm (ImmInt 0)) = True
-riZero (RIImm (ImmInteger 0)) = True
-riZero (RIReg (FixedReg ILIT(0))) = True
-riZero _ = False
-
-data Size = SB
- | HW
- | UB
- | UHW
- | W
- | D
- | F
- | DF
- deriving ()
-
-data SparcInstr =
-
--- Loads and stores.
-
- LD Size Addr Reg -- size, src, dst
- | ST Size Reg Addr -- 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
-
--- 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 Addr -- target
- | CALL Imm Int Bool -- target, args, terminal
-
--- Pseudo-ops.
-
- | LABEL CLabel
- | COMMENT FAST_STRING
- | SEGMENT CodeSegment
- | ASCII Bool String -- needs backslash conversion?
- | DATA Size [Imm]
-
-type SparcCode = OrdList SparcInstr
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TheSparcPretty]{Pretty-printing the Sparc Assembly Language}
-%* *
-%************************************************************************
-
-\begin{code}
-
-printLabeledCodes :: PprStyle -> [SparcInstr] -> Unpretty
-printLabeledCodes sty codes = uppAboves (map (pprSparcInstr sty) codes)
-
-\end{code}
-
-Printing the pieces...
-
-\begin{code}
-
-pprReg :: Reg -> Unpretty
-
-pprReg (FixedReg i) = pprSparcReg i
-pprReg (MappedReg i) = pprSparcReg i
-pprReg other = uppStr (show other) -- should only happen when debugging
-
-pprSparcReg :: FAST_INT -> Unpretty
-pprSparcReg i = uppPStr
- (case i of {
- ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1");
- ILIT( 2) -> SLIT("%g2"); ILIT( 3) -> SLIT("%g3");
- ILIT( 4) -> SLIT("%g4"); ILIT( 5) -> SLIT("%g5");
- ILIT( 6) -> SLIT("%g6"); ILIT( 7) -> SLIT("%g7");
- ILIT( 8) -> SLIT("%o0"); ILIT( 9) -> SLIT("%o1");
- ILIT(10) -> SLIT("%o2"); ILIT(11) -> SLIT("%o3");
- ILIT(12) -> SLIT("%o4"); ILIT(13) -> SLIT("%o5");
- ILIT(14) -> SLIT("%o6"); ILIT(15) -> SLIT("%o7");
- ILIT(16) -> SLIT("%l0"); ILIT(17) -> SLIT("%l1");
- ILIT(18) -> SLIT("%l2"); ILIT(19) -> SLIT("%l3");
- ILIT(20) -> SLIT("%l4"); ILIT(21) -> SLIT("%l5");
- ILIT(22) -> SLIT("%l6"); ILIT(23) -> SLIT("%l7");
- ILIT(24) -> SLIT("%i0"); ILIT(25) -> SLIT("%i1");
- ILIT(26) -> SLIT("%i2"); ILIT(27) -> SLIT("%i3");
- ILIT(28) -> SLIT("%i4"); ILIT(29) -> SLIT("%i5");
- ILIT(30) -> SLIT("%i6"); ILIT(31) -> SLIT("%i7");
- ILIT(32) -> SLIT("%f0"); ILIT(33) -> SLIT("%f1");
- ILIT(34) -> SLIT("%f2"); ILIT(35) -> SLIT("%f3");
- ILIT(36) -> SLIT("%f4"); ILIT(37) -> SLIT("%f5");
- ILIT(38) -> SLIT("%f6"); ILIT(39) -> SLIT("%f7");
- ILIT(40) -> SLIT("%f8"); ILIT(41) -> SLIT("%f9");
- ILIT(42) -> SLIT("%f10"); ILIT(43) -> SLIT("%f11");
- ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13");
- ILIT(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15");
- ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17");
- ILIT(50) -> SLIT("%f18"); ILIT(51) -> SLIT("%f19");
- ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21");
- ILIT(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23");
- ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25");
- ILIT(58) -> SLIT("%f26"); ILIT(59) -> SLIT("%f27");
- ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29");
- ILIT(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31");
- _ -> SLIT("very naughty sparc register")
- })
-
-pprCond :: Cond -> Unpretty
-pprCond x = uppPStr
- (case x of {
- ALWAYS -> SLIT(""); NEVER -> SLIT("n");
- GEU -> SLIT("geu"); LU -> SLIT("lu");
- EQ -> SLIT("e"); GT -> SLIT("g");
- GE -> SLIT("ge"); GU -> SLIT("gu");
- LT -> SLIT("l"); LE -> SLIT("le");
- LEU -> SLIT("leu"); NE -> SLIT("ne");
- NEG -> SLIT("neg"); POS -> SLIT("pos");
- VC -> SLIT("vc"); VS -> SLIT("vs")
- })
-
-pprImm :: PprStyle -> Imm -> Unpretty
-
-pprImm sty (ImmInt i) = uppInt i
-pprImm sty (ImmInteger i) = uppInteger i
-
-pprImm sty (LO i) =
- uppBesides [
- pp_lo,
- pprImm sty i,
- uppRparen
- ]
- where
-#ifdef USE_FAST_STRINGS
- pp_lo = uppPStr (_packCString (A# "%lo("#))
-#else
- pp_lo = uppStr "%lo("
-#endif
-
-pprImm sty (HI i) =
- uppBesides [
- pp_hi,
- pprImm sty i,
- uppRparen
- ]
- where
-#ifdef USE_FAST_STRINGS
- pp_hi = uppPStr (_packCString (A# "%hi("#))
-#else
- pp_hi = uppStr "%hi("
-#endif
-
-pprImm sty (ImmCLbl l) = pprCLabel sty l
-
-pprImm (PprForAsm _ False _) (ImmLab s) = s
-pprImm _ (ImmLab s) = uppBeside (uppChar '_') s
-
-pprImm sty (ImmLit s) = s
-
-pprAddr :: PprStyle -> Addr -> Unpretty
-pprAddr sty (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1
-
-pprAddr sty (AddrRegReg r1 r2) =
- uppBesides [
- pprReg r1,
- uppChar '+',
- pprReg r2
- ]
-
-pprAddr sty (AddrRegImm r1 (ImmInt i))
- | i == 0 = pprReg r1
- | i < -4096 || i > 4095 = large_offset_error i
- | i < 0 =
- uppBesides [
- pprReg r1,
- uppChar '-',
- uppInt (-i)
- ]
-
-pprAddr sty (AddrRegImm r1 (ImmInteger i))
- | i == 0 = pprReg r1
- | i < -4096 || i > 4095 = large_offset_error i
- | i < 0 =
- uppBesides [
- pprReg r1,
- uppChar '-',
- uppInteger (-i)
- ]
-
-pprAddr sty (AddrRegImm r1 imm) =
- uppBesides [
- pprReg r1,
- uppChar '+',
- pprImm sty imm
- ]
-
-large_offset_error i
- = error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n")
-
-pprRI :: PprStyle -> RI -> Unpretty
-pprRI sty (RIReg r) = pprReg r
-pprRI sty (RIImm r) = pprImm sty r
-
-pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty
-pprSizeRegReg name size reg1 reg2 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- (case size of
- F -> uppPStr SLIT("s\t")
- DF -> uppPStr SLIT("d\t")),
- pprReg reg1,
- uppComma,
- pprReg reg2
- ]
-
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
-pprSizeRegRegReg name size reg1 reg2 reg3 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- (case size of
- F -> uppPStr SLIT("s\t")
- DF -> uppPStr SLIT("d\t")),
- pprReg reg1,
- uppComma,
- pprReg reg2,
- uppComma,
- pprReg reg3
- ]
-
-pprRegRIReg :: PprStyle -> FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty
-pprRegRIReg sty name b reg1 ri reg2 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- if b then uppPStr SLIT("cc\t") else uppChar '\t',
- pprReg reg1,
- uppComma,
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
-
-pprRIReg :: PprStyle -> FAST_STRING -> Bool -> RI -> Reg -> Unpretty
-pprRIReg sty name b ri reg1 =
- uppBesides [
- uppChar '\t',
- uppPStr name,
- if b then uppPStr SLIT("cc\t") else uppChar '\t',
- pprRI sty ri,
- uppComma,
- pprReg reg1
- ]
-
-pprSize :: Size -> Unpretty
-pprSize x = uppPStr
- (case x of
- SB -> SLIT("sb")
- HW -> SLIT("hw")
- UB -> SLIT("ub")
- UHW -> SLIT("uhw")
- W -> SLIT("")
- F -> SLIT("")
- D -> SLIT("d")
- DF -> SLIT("d")
- )
-
-#ifdef USE_FAST_STRINGS
-pp_ld_lbracket = uppPStr (_packCString (A# "\tld\t["#))
-pp_rbracket_comma = uppPStr (_packCString (A# "],"#))
-pp_comma_lbracket = uppPStr (_packCString (A# ",["#))
-pp_comma_a = uppPStr (_packCString (A# ",a"#))
-#else
-pp_ld_lbracket = uppStr "\tld\t["
-pp_rbracket_comma = uppStr "],"
-pp_comma_lbracket = uppStr ",["
-pp_comma_a = uppStr ",a"
-#endif
-
-pprSparcInstr :: PprStyle -> SparcInstr -> Unpretty
-
--- a clumsy hack for now, to handle possible alignment problems
-
-pprSparcInstr sty (LD DF addr reg) | maybeToBool addrOff =
- uppBesides [
- pp_ld_lbracket,
- pprAddr sty addr,
- pp_rbracket_comma,
- pprReg reg,
-
- uppChar '\n',
- pp_ld_lbracket,
- pprAddr sty addr2,
- pp_rbracket_comma,
- pprReg (fPair reg)
- ]
- where
- addrOff = offset addr 4
- addr2 = case addrOff of Just x -> x
-
-pprSparcInstr sty (LD size addr reg) =
- uppBesides [
- uppPStr SLIT("\tld"),
- pprSize size,
- uppChar '\t',
- uppLbrack,
- pprAddr sty addr,
- pp_rbracket_comma,
- pprReg reg
- ]
-
--- The same clumsy hack as above
-
-pprSparcInstr sty (ST DF reg addr) | maybeToBool addrOff =
- uppBesides [
- uppPStr SLIT("\tst\t"),
- pprReg reg,
- pp_comma_lbracket,
- pprAddr sty addr,
-
- uppPStr SLIT("]\n\tst\t"),
- pprReg (fPair reg),
- pp_comma_lbracket,
- pprAddr sty addr2,
- uppRbrack
- ]
- where
- addrOff = offset addr 4
- addr2 = case addrOff of Just x -> x
-
-pprSparcInstr sty (ST size reg addr) =
- uppBesides [
- uppPStr SLIT("\tst"),
- pprSize size,
- uppChar '\t',
- pprReg reg,
- pp_comma_lbracket,
- pprAddr sty addr,
- uppRbrack
- ]
-
-pprSparcInstr sty (ADD x cc reg1 ri reg2)
- | not x && not cc && riZero ri =
- uppBesides [
- uppPStr SLIT("\tmov\t"),
- pprReg reg1,
- uppComma,
- pprReg reg2
- ]
- | otherwise = pprRegRIReg sty (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
-
-pprSparcInstr sty (SUB x cc reg1 ri reg2)
- | not x && cc && reg2 == g0 =
- uppBesides [
- uppPStr SLIT("\tcmp\t"),
- pprReg reg1,
- uppComma,
- pprRI sty ri
- ]
- | not x && not cc && riZero ri =
- uppBesides [
- uppPStr SLIT("\tmov\t"),
- pprReg reg1,
- uppComma,
- pprReg reg2
- ]
- | otherwise = pprRegRIReg sty (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
-
-pprSparcInstr sty (AND b reg1 ri reg2) = pprRegRIReg sty SLIT("and") b reg1 ri reg2
-pprSparcInstr sty (ANDN b reg1 ri reg2) = pprRegRIReg sty SLIT("andn") b reg1 ri reg2
-
-pprSparcInstr sty (OR b reg1 ri reg2)
- | not b && reg1 == g0 =
- uppBesides [
- uppPStr SLIT("\tmov\t"),
- pprRI sty ri,
- uppComma,
- pprReg reg2
- ]
- | otherwise = pprRegRIReg sty SLIT("or") b reg1 ri reg2
-
-pprSparcInstr sty (ORN b reg1 ri reg2) = pprRegRIReg sty SLIT("orn") b reg1 ri reg2
-
-pprSparcInstr sty (XOR b reg1 ri reg2) = pprRegRIReg sty SLIT("xor") b reg1 ri reg2
-pprSparcInstr sty (XNOR b reg1 ri reg2) = pprRegRIReg sty SLIT("xnor") b reg1 ri reg2
-
-pprSparcInstr sty (SLL reg1 ri reg2) = pprRegRIReg sty SLIT("sll") False reg1 ri reg2
-pprSparcInstr sty (SRL reg1 ri reg2) = pprRegRIReg sty SLIT("srl") False reg1 ri reg2
-pprSparcInstr sty (SRA reg1 ri reg2) = pprRegRIReg sty SLIT("sra") False reg1 ri reg2
-
-pprSparcInstr sty (SETHI imm reg) =
- uppBesides [
- uppPStr SLIT("\tsethi\t"),
- pprImm sty imm,
- uppComma,
- pprReg reg
- ]
-
-pprSparcInstr sty (NOP) = uppPStr SLIT("\tnop")
-
-pprSparcInstr sty (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
-pprSparcInstr sty (FABS DF reg1 reg2) =
- uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
- (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
-
-pprSparcInstr sty (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
-pprSparcInstr sty (FCMP e size reg1 reg2) =
- pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
-pprSparcInstr sty (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
-
-pprSparcInstr sty (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
-pprSparcInstr sty (FMOV DF reg1 reg2) =
- uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
- (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
-
-pprSparcInstr sty (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
-
-pprSparcInstr sty (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
-pprSparcInstr sty (FNEG DF reg1 reg2) =
- uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
- (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
-
-pprSparcInstr sty (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
-pprSparcInstr sty (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
-pprSparcInstr sty (FxTOy size1 size2 reg1 reg2) =
- uppBesides [
- uppPStr SLIT("\tf"),
- uppPStr
- (case size1 of
- W -> SLIT("ito")
- F -> SLIT("sto")
- DF -> SLIT("dto")),
- uppPStr
- (case size2 of
- W -> SLIT("i\t")
- F -> SLIT("s\t")
- DF -> SLIT("d\t")),
- pprReg reg1,
- uppComma,
- pprReg reg2
- ]
-
-
-pprSparcInstr sty (BI cond b lab) =
- uppBesides [
- uppPStr SLIT("\tb"), pprCond cond,
- if b then pp_comma_a else uppNil,
- uppChar '\t',
- pprImm sty lab
- ]
-
-pprSparcInstr sty (BF cond b lab) =
- uppBesides [
- uppPStr SLIT("\tfb"), pprCond cond,
- if b then pp_comma_a else uppNil,
- uppChar '\t',
- pprImm sty lab
- ]
-
-pprSparcInstr sty (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr sty addr)
-
-pprSparcInstr sty (CALL imm n _) =
- uppBesides [
- uppPStr SLIT("\tcall\t"),
- pprImm sty imm,
- uppComma,
- uppInt n
- ]
-
-pprSparcInstr sty (LABEL clab) =
- uppBesides [
- if (externallyVisibleCLabel clab) then
- uppBesides [uppPStr SLIT("\t.global\t"), pprLab, uppChar '\n']
- else
- uppNil,
- pprLab,
- uppChar ':'
- ]
- where pprLab = pprCLabel sty clab
-
-pprSparcInstr sty (COMMENT s) = uppBeside (uppPStr SLIT("! ")) (uppPStr s)
-
-pprSparcInstr sty (SEGMENT TextSegment)
- = uppPStr SLIT("\t.text\n\t.align 4")
-
-pprSparcInstr sty (SEGMENT DataSegment)
- = uppPStr SLIT("\t.data\n\t.align 8") -- Less than 8 will break double constants
-
-pprSparcInstr sty (ASCII False str) =
- uppBesides [
- uppStr "\t.asciz \"",
- uppStr str,
- uppChar '"'
- ]
-
-pprSparcInstr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
- where
- asciify :: String -> Int -> Unpretty
- asciify [] _ = uppStr ("\\0\"")
- asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
- asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
- asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
- asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
- asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
- asciify (c:(cs@(d:_))) n | isDigit d =
- uppBeside (uppStr (charToC c)) (asciify cs 0)
- | otherwise =
- uppBeside (uppStr (charToC c)) (asciify cs (n-1))
-
-pprSparcInstr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs)
- where pp_item x = case s of
- SB -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
- UB -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
- W -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x)
- DF -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Schedule]{Register allocation information}
-%* *
-%************************************************************************
-
-Getting the conflicts right is a bit tedious for doubles. We'd have to
-add a conflict function to the MachineRegisters class, and we'd have to
-put a PrimRep in the MappedReg datatype, or use some kludge (e.g. register
-64 + n is really the same as 32 + n, except that it's used for a double,
-so it also conflicts with 33 + n) to deal with it. It's just not worth the
-bother, so we just partition the free floating point registers into two
-sets: one for single precision and one for double precision. We never seem
-to run out of floating point registers anyway.
-
-\begin{code}
-
-data SparcRegs = SRegs BitSet BitSet BitSet
-
-instance MachineRegisters SparcRegs where
- mkMRegs xs = SRegs (mkBS ints) (mkBS singles') (mkBS doubles')
- where
- (ints, floats) = partition (< 32) xs
- (singles, doubles) = partition (< 48) floats
- singles' = map (subtract 32) singles
- doubles' = map (subtract 32) (filter even doubles)
-
- possibleMRegs FloatRep (SRegs _ singles _) = [ x + 32 | x <- listBS singles]
- possibleMRegs DoubleRep (SRegs _ _ doubles) = [ x + 32 | x <- listBS doubles]
- possibleMRegs _ (SRegs ints _ _) = listBS ints
-
- useMReg (SRegs ints singles doubles) n =
- if n _LT_ ILIT(32) then SRegs (ints `minusBS` singletonBS IBOX(n)) singles doubles
- else if n _LT_ ILIT(48) then SRegs ints (singles `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) doubles
- else SRegs ints singles (doubles `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32))))
-
- useMRegs (SRegs ints singles doubles) xs =
- SRegs (ints `minusBS` ints')
- (singles `minusBS` singles')
- (doubles `minusBS` doubles')
- where
- SRegs ints' singles' doubles' = mkMRegs xs
-
- freeMReg (SRegs ints singles doubles) n =
- if n _LT_ ILIT(32) then SRegs (ints `unionBS` singletonBS IBOX(n)) singles doubles
- else if n _LT_ ILIT(48) then SRegs ints (singles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) doubles
- else SRegs ints singles (doubles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32))))
-
- freeMRegs (SRegs ints singles doubles) xs =
- SRegs (ints `unionBS` ints')
- (singles `unionBS` singles')
- (doubles `unionBS` doubles')
- where
- SRegs ints' singles' doubles' = mkMRegs xs
-
-instance MachineCode SparcInstr where
- regUsage = sparcRegUsage
- regLiveness = sparcRegLiveness
- patchRegs = sparcPatchRegs
-
- -- We spill just below the frame pointer, leaving two words per spill location.
- spillReg dyn (MemoryReg i pk) = mkUnitList (ST (kindToSize pk) dyn (fpRel (-2 * i)))
- loadReg (MemoryReg i pk) dyn = mkUnitList (LD (kindToSize pk) (fpRel (-2 * i)) dyn)
-
--- Duznae work for offsets greater than 13 bits; we just hope for the best
-fpRel :: Int -> Addr
-fpRel n = AddrRegImm fp (ImmInt (n * 4))
-
-kindToSize :: PrimRep -> Size
-kindToSize PtrRep = W
-kindToSize CodePtrRep = W
-kindToSize DataPtrRep = W
-kindToSize RetRep = W
-kindToSize CostCentreRep = W
-kindToSize CharRep = UB
-kindToSize IntRep = W
-kindToSize WordRep = W
-kindToSize AddrRep = W
-kindToSize FloatRep = F
-kindToSize DoubleRep = DF
-kindToSize ArrayRep = W
-kindToSize ByteArrayRep = W
-kindToSize StablePtrRep = W
-kindToSize MallocPtrRep = W
-
-\end{code}
-
-@sparcRegUsage@ 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!)
-
-\begin{code}
-
-sparcRegUsage :: SparcInstr -> RegUsage
-sparcRegUsage instr = case instr of
- LD sz addr reg -> usage (regAddr addr, [reg])
- ST sz reg addr -> usage (reg : regAddr addr, [])
- ADD x cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SUB x cc r1 ar r2 -> usage (r1 : regRI ar, [r2])
- AND b r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ANDN b r1 ar r2 -> usage (r1 : regRI ar, [r2])
- OR b r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ORN b r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XOR b r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XNOR b r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SLL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRA r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SETHI imm reg -> usage ([], [reg])
- FABS s r1 r2 -> usage ([r1], [r2])
- FADD s r1 r2 r3 -> usage ([r1, r2], [r3])
- FCMP e s r1 r2 -> usage ([r1, r2], [])
- FDIV s r1 r2 r3 -> usage ([r1, r2], [r3])
- FMOV s r1 r2 -> usage ([r1], [r2])
- FMUL s r1 r2 r3 -> usage ([r1, r2], [r3])
- FNEG s r1 r2 -> usage ([r1], [r2])
- FSQRT s r1 r2 -> usage ([r1], [r2])
- FSUB s r1 r2 r3 -> usage ([r1, r2], [r3])
- FxTOy s1 s2 r1 r2 -> usage ([r1], [r2])
-
- -- We assume that all local jumps will be BI/BF. JMP must be out-of-line.
- JMP addr -> RU (mkUniqSet (filter interesting (regAddr addr))) freeSet
-
- CALL _ n True -> endUsage
- CALL _ n False -> RU (argSet n) callClobberedSet
-
- _ -> noUsage
-
- where
- usage (src, dst) = RU (mkUniqSet (filter interesting src))
- (mkUniqSet (filter interesting dst))
-
- interesting (FixedReg _) = False
- interesting _ = True
-
- regAddr (AddrRegReg r1 r2) = [r1, r2]
- regAddr (AddrRegImm r1 _) = [r1]
-
- regRI (RIReg r) = [r]
- regRI _ = []
-
-freeRegs :: [Reg]
-freeRegs = freeMappedRegs (\ x -> x) [0..63]
-
-freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg]
-
-freeMappedRegs modify nums
- = foldr free [] nums
- where
- free n acc
- = let
- modified_i = case (modify n) of { IBOX(x) -> x }
- in
- if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc
-
-freeSet :: UniqSet Reg
-freeSet = mkUniqSet freeRegs
-
-noUsage :: RegUsage
-noUsage = RU emptyUniqSet emptyUniqSet
-
-endUsage :: RegUsage
-endUsage = RU emptyUniqSet freeSet
-
--- Color me CAF-like
-argSet :: Int -> UniqSet Reg
-argSet 0 = emptyUniqSet
-argSet 1 = mkUniqSet (freeMappedRegs oReg [0])
-argSet 2 = mkUniqSet (freeMappedRegs oReg [0,1])
-argSet 3 = mkUniqSet (freeMappedRegs oReg [0,1,2])
-argSet 4 = mkUniqSet (freeMappedRegs oReg [0,1,2,3])
-argSet 5 = mkUniqSet (freeMappedRegs oReg [0,1,2,3,4])
-argSet 6 = mkUniqSet (freeMappedRegs oReg [0,1,2,3,4,5])
-
-callClobberedSet :: UniqSet Reg
-callClobberedSet = mkUniqSet callClobberedRegs
- where
- callClobberedRegs = freeMappedRegs (\x -> x)
- ( oReg 7 :
- [oReg i | i <- [0..5]] ++
- [gReg i | i <- [1..7]] ++
- [fReg i | i <- [0..31]] )
-
-\end{code}
-
-@sparcRegLiveness@ takes future liveness information and modifies it according to
-the semantics of branches and labels. (An out-of-line branch clobbers the liveness
-passed back by the following instruction; a forward local branch passes back the
-liveness from the target label; a conditional branch merges the liveness from the
-target and the liveness from its successor; a label stashes away the current liveness
-in the future liveness environment).
-
-\begin{code}
-sparcRegLiveness :: SparcInstr -> RegLiveness -> RegLiveness
-sparcRegLiveness instr info@(RL live future@(FL all env)) = case instr of
-
- -- We assume that all local jumps will be BI/BF. JMP must be out-of-line.
-
- BI ALWAYS _ (ImmCLbl lbl) -> RL (lookup lbl) future
- BI _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionUniqSets` live) future
- BF ALWAYS _ (ImmCLbl lbl) -> RL (lookup lbl) future
- BF _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionUniqSets` live) future
- JMP _ -> RL emptyUniqSet future
- CALL _ i True -> RL emptyUniqSet future
- CALL _ i False -> RL live future
- LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
- _ -> info
-
- where
- lookup lbl = case lookupFM env lbl of
- Just regs -> regs
- Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
- " in future?") emptyUniqSet
-
-\end{code}
-
-@sparcPatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and
-changes all register references according to the supplied environment.
-
-\begin{code}
-
-sparcPatchRegs :: SparcInstr -> (Reg -> Reg) -> SparcInstr
-sparcPatchRegs instr env = case instr of
- LD sz addr reg -> LD sz (fixAddr addr) (env reg)
- ST sz reg addr -> ST sz (env reg) (fixAddr addr)
- ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
- SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2)
- AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2)
- ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2)
- OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2)
- ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2)
- XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2)
- XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2)
- SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
- SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
- SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
- SETHI imm reg -> SETHI imm (env reg)
- FABS s r1 r2 -> FABS s (env r1) (env r2)
- FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
- FCMP e s r1 r2 -> FCMP e s (env r1) (env r2)
- FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
- FMOV s r1 r2 -> FMOV s (env r1) (env r2)
- FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
- FNEG s r1 r2 -> FNEG s (env r1) (env r2)
- FSQRT s r1 r2 -> FSQRT s (env r1) (env r2)
- FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
- FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
- JMP addr -> JMP (fixAddr addr)
- _ -> instr
-
- where
- fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
- fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
-
- fixRI (RIReg r) = RIReg (env r)
- fixRI other = other
-\end{code}
-
-Sometimes, we want to be able to modify addresses at compile time.
-(Okay, just for chrCode of a fetch.)
-
-\begin{code}
-{-# SPECIALIZE
- is13Bits :: Int -> Bool
- #-}
-{-# SPECIALIZE
- is13Bits :: Integer -> Bool
- #-}
-
-is13Bits :: Integral a => a -> Bool
-is13Bits x = x >= -4096 && x < 4096
-
-offset :: Addr -> Int -> Maybe Addr
-
-offset (AddrRegImm reg (ImmInt n)) off
- | is13Bits n2 = Just (AddrRegImm reg (ImmInt n2))
- | otherwise = Nothing
- where n2 = n + off
-
-offset (AddrRegImm reg (ImmInteger n)) off
- | is13Bits n2 = Just (AddrRegImm reg (ImmInt (fromInteger n2)))
- | otherwise = Nothing
- where n2 = n + toInteger off
-
-offset (AddrRegReg reg (FixedReg ILIT(0))) off
- | is13Bits off = Just (AddrRegImm reg (ImmInt off))
- | otherwise = Nothing
-
-offset _ _ = Nothing
-
-\end{code}
-
-If you value your sanity, do not venture below this line.
-
-\begin{code}
-
--- platform.h is generate and tells us what the target architecture is
-#include "../../includes/platform.h"
-#include "../../includes/MachRegs.h"
-#if sunos4_TARGET_OS
-#include "../../includes/sparc-sun-sunos4.h"
-#else
-#include "../../includes/sparc-sun-solaris2.h"
-#endif
-
--- Redefine the literals used for Sparc register names in the header
--- files. Gag me with a spoon, eh?
-
-#define g0 0
-#define g1 1
-#define g2 2
-#define g3 3
-#define g4 4
-#define g5 5
-#define g6 6
-#define g7 7
-#define o0 8
-#define o1 9
-#define o2 10
-#define o3 11
-#define o4 12
-#define o5 13
-#define o6 14
-#define o7 15
-#define l0 16
-#define l1 17
-#define l2 18
-#define l3 19
-#define l4 20
-#define l5 21
-#define l6 22
-#define l7 23
-#define i0 24
-#define i1 25
-#define i2 26
-#define i3 27
-#define i4 28
-#define i5 29
-#define i6 30
-#define i7 31
-#define f0 32
-#define f1 33
-#define f2 34
-#define f3 35
-#define f4 36
-#define f5 37
-#define f6 38
-#define f7 39
-#define f8 40
-#define f9 41
-#define f10 42
-#define f11 43
-#define f12 44
-#define f13 45
-#define f14 46
-#define f15 47
-#define f16 48
-#define f17 49
-#define f18 50
-#define f19 51
-#define f20 52
-#define f21 53
-#define f22 54
-#define f23 55
-#define f24 56
-#define f25 57
-#define f26 58
-#define f27 59
-#define f28 60
-#define f29 61
-#define f30 62
-#define f31 63
-
-baseRegOffset :: MagicId -> Int
-baseRegOffset StkOReg = OFFSET_StkO
-baseRegOffset (VanillaReg _ ILIT2(1)) = OFFSET_R1
-baseRegOffset (VanillaReg _ ILIT2(2)) = OFFSET_R2
-baseRegOffset (VanillaReg _ ILIT2(3)) = OFFSET_R3
-baseRegOffset (VanillaReg _ ILIT2(4)) = OFFSET_R4
-baseRegOffset (VanillaReg _ ILIT2(5)) = OFFSET_R5
-baseRegOffset (VanillaReg _ ILIT2(6)) = OFFSET_R6
-baseRegOffset (VanillaReg _ ILIT2(7)) = OFFSET_R7
-baseRegOffset (VanillaReg _ ILIT2(8)) = OFFSET_R8
-baseRegOffset (FloatReg ILIT2(1)) = OFFSET_Flt1
-baseRegOffset (FloatReg ILIT2(2)) = OFFSET_Flt2
-baseRegOffset (FloatReg ILIT2(3)) = OFFSET_Flt3
-baseRegOffset (FloatReg ILIT2(4)) = OFFSET_Flt4
-baseRegOffset (DoubleReg ILIT2(1)) = OFFSET_Dbl1
-baseRegOffset (DoubleReg ILIT2(2)) = OFFSET_Dbl2
-baseRegOffset TagReg = OFFSET_Tag
-baseRegOffset RetReg = OFFSET_Ret
-baseRegOffset SpA = OFFSET_SpA
-baseRegOffset SuA = OFFSET_SuA
-baseRegOffset SpB = OFFSET_SpB
-baseRegOffset SuB = OFFSET_SuB
-baseRegOffset Hp = OFFSET_Hp
-baseRegOffset HpLim = OFFSET_HpLim
-baseRegOffset LivenessReg = OFFSET_Liveness
---baseRegOffset ActivityReg = OFFSET_Activity
-#ifdef DEBUG
-baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
-baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg"
-baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg"
-baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre"
-baseRegOffset VoidReg = panic "baseRegOffset:VoidReg"
-#endif
-
-callerSaves :: MagicId -> Bool
-#ifdef CALLER_SAVES_Base
-callerSaves BaseReg = True
-#endif
-#ifdef CALLER_SAVES_StkO
-callerSaves StkOReg = True
-#endif
-#ifdef CALLER_SAVES_R1
-callerSaves (VanillaReg _ ILIT2(1)) = True
-#endif
-#ifdef CALLER_SAVES_R2
-callerSaves (VanillaReg _ ILIT2(2)) = True
-#endif
-#ifdef CALLER_SAVES_R3
-callerSaves (VanillaReg _ ILIT2(3)) = True
-#endif
-#ifdef CALLER_SAVES_R4
-callerSaves (VanillaReg _ ILIT2(4)) = True
-#endif
-#ifdef CALLER_SAVES_R5
-callerSaves (VanillaReg _ ILIT2(5)) = True
-#endif
-#ifdef CALLER_SAVES_R6
-callerSaves (VanillaReg _ ILIT2(6)) = True
-#endif
-#ifdef CALLER_SAVES_R7
-callerSaves (VanillaReg _ ILIT2(7)) = True
-#endif
-#ifdef CALLER_SAVES_R8
-callerSaves (VanillaReg _ ILIT2(8)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg1
-callerSaves (FloatReg ILIT2(1)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg2
-callerSaves (FloatReg ILIT2(2)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg3
-callerSaves (FloatReg ILIT2(3)) = True
-#endif
-#ifdef CALLER_SAVES_FltReg4
-callerSaves (FloatReg ILIT2(4)) = True
-#endif
-#ifdef CALLER_SAVES_DblReg1
-callerSaves (DoubleReg ILIT2(1)) = True
-#endif
-#ifdef CALLER_SAVES_DblReg2
-callerSaves (DoubleReg ILIT2(2)) = True
-#endif
-#ifdef CALLER_SAVES_Tag
-callerSaves TagReg = True
-#endif
-#ifdef CALLER_SAVES_Ret
-callerSaves RetReg = True
-#endif
-#ifdef CALLER_SAVES_SpA
-callerSaves SpA = True
-#endif
-#ifdef CALLER_SAVES_SuA
-callerSaves SuA = True
-#endif
-#ifdef CALLER_SAVES_SpB
-callerSaves SpB = True
-#endif
-#ifdef CALLER_SAVES_SuB
-callerSaves SuB = True
-#endif
-#ifdef CALLER_SAVES_Hp
-callerSaves Hp = True
-#endif
-#ifdef CALLER_SAVES_HpLim
-callerSaves HpLim = True
-#endif
-#ifdef CALLER_SAVES_Liveness
-callerSaves LivenessReg = True
-#endif
-#ifdef CALLER_SAVES_Activity
---callerSaves ActivityReg = True
-#endif
-#ifdef CALLER_SAVES_StdUpdRetVec
-callerSaves StdUpdRetVecReg = True
-#endif
-#ifdef CALLER_SAVES_StkStub
-callerSaves StkStubReg = True
-#endif
-callerSaves _ = False
-
-stgRegMap :: MagicId -> Maybe Reg
-#ifdef REG_Base
-stgRegMap BaseReg = Just (FixedReg ILIT(REG_Base))
-#endif
-#ifdef REG_StkO
-stgRegMap StkOReg = Just (FixedReg ILIT(REG_StkOReg))
-#endif
-#ifdef REG_R1
-stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1))
-#endif
-#ifdef REG_R2
-stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2))
-#endif
-#ifdef REG_R3
-stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3))
-#endif
-#ifdef REG_R4
-stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4))
-#endif
-#ifdef REG_R5
-stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5))
-#endif
-#ifdef REG_R6
-stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6))
-#endif
-#ifdef REG_R7
-stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7))
-#endif
-#ifdef REG_R8
-stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8))
-#endif
-#ifdef REG_Flt1
-stgRegMap (FloatReg ILIT2(1)) = Just (FixedReg ILIT(REG_Flt1))
-#endif
-#ifdef REG_Flt2
-stgRegMap (FloatReg ILIT2(2)) = Just (FixedReg ILIT(REG_Flt2))
-#endif
-#ifdef REG_Flt3
-stgRegMap (FloatReg ILIT2(3)) = Just (FixedReg ILIT(REG_Flt3))
-#endif
-#ifdef REG_Flt4
-stgRegMap (FloatReg ILIT2(4)) = Just (FixedReg ILIT(REG_Flt4))
-#endif
-#ifdef REG_Dbl1
-stgRegMap (DoubleReg ILIT2(1)) = Just (FixedReg ILIT(REG_Dbl1))
-#endif
-#ifdef REG_Dbl2
-stgRegMap (DoubleReg ILIT2(2)) = Just (FixedReg ILIT(REG_Dbl2))
-#endif
-#ifdef REG_Tag
-stgRegMap TagReg = Just (FixedReg ILIT(REG_TagReg))
-#endif
-#ifdef REG_Ret
-stgRegMap RetReg = Just (FixedReg ILIT(REG_Ret))
-#endif
-#ifdef REG_SpA
-stgRegMap SpA = Just (FixedReg ILIT(REG_SpA))
-#endif
-#ifdef REG_SuA
-stgRegMap SuA = Just (FixedReg ILIT(REG_SuA))
-#endif
-#ifdef REG_SpB
-stgRegMap SpB = Just (FixedReg ILIT(REG_SpB))
-#endif
-#ifdef REG_SuB
-stgRegMap SuB = Just (FixedReg ILIT(REG_SuB))
-#endif
-#ifdef REG_Hp
-stgRegMap Hp = Just (FixedReg ILIT(REG_Hp))
-#endif
-#ifdef REG_HpLim
-stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim))
-#endif
-#ifdef REG_Liveness
-stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness))
-#endif
-#ifdef REG_Activity
---stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity))
-#endif
-#ifdef REG_StdUpdRetVec
-stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec))
-#endif
-#ifdef REG_StkStub
-stgRegMap StkStubReg = Just (FixedReg ILIT(REG_StkStub))
-#endif
-stgRegMap _ = Nothing
-
-\end{code}
-
-Here is the list of registers we can use in register allocation.
-
-\begin{code}
-
-freeReg :: FAST_INT -> FAST_BOOL
-
-freeReg ILIT(g0) = _FALSE_ -- %g0 is always 0.
-freeReg ILIT(g5) = _FALSE_ -- %g5 is reserved (ABI).
-freeReg ILIT(g6) = _FALSE_ -- %g6 is reserved (ABI).
-freeReg ILIT(g7) = _FALSE_ -- %g7 is reserved (ABI).
-freeReg ILIT(i6) = _FALSE_ -- %i6 is our frame pointer.
-freeReg ILIT(o6) = _FALSE_ -- %o6 is our stack pointer.
-
-#ifdef REG_Base
-freeReg ILIT(REG_Base) = _FALSE_
-#endif
-#ifdef REG_StkO
-freeReg ILIT(REG_StkO) = _FALSE_
-#endif
-#ifdef REG_R1
-freeReg ILIT(REG_R1) = _FALSE_
-#endif
-#ifdef REG_R2
-freeReg ILIT(REG_R2) = _FALSE_
-#endif
-#ifdef REG_R3
-freeReg ILIT(REG_R3) = _FALSE_
-#endif
-#ifdef REG_R4
-freeReg ILIT(REG_R4) = _FALSE_
-#endif
-#ifdef REG_R5
-freeReg ILIT(REG_R5) = _FALSE_
-#endif
-#ifdef REG_R6
-freeReg ILIT(REG_R6) = _FALSE_
-#endif
-#ifdef REG_R7
-freeReg ILIT(REG_R7) = _FALSE_
-#endif
-#ifdef REG_R8
-freeReg ILIT(REG_R8) = _FALSE_
-#endif
-#ifdef REG_Flt1
-freeReg ILIT(REG_Flt1) = _FALSE_
-#endif
-#ifdef REG_Flt2
-freeReg ILIT(REG_Flt2) = _FALSE_
-#endif
-#ifdef REG_Flt3
-freeReg ILIT(REG_Flt3) = _FALSE_
-#endif
-#ifdef REG_Flt4
-freeReg ILIT(REG_Flt4) = _FALSE_
-#endif
-#ifdef REG_Dbl1
-freeReg ILIT(REG_Dbl1) = _FALSE_
-#endif
-#ifdef REG_Dbl2
-freeReg ILIT(REG_Dbl2) = _FALSE_
-#endif
-#ifdef REG_Tag
-freeReg ILIT(REG_Tag) = _FALSE_
-#endif
-#ifdef REG_Ret
-freeReg ILIT(REG_Ret) = _FALSE_
-#endif
-#ifdef REG_SpA
-freeReg ILIT(REG_SpA) = _FALSE_
-#endif
-#ifdef REG_SuA
-freeReg ILIT(REG_SuA) = _FALSE_
-#endif
-#ifdef REG_SpB
-freeReg ILIT(REG_SpB) = _FALSE_
-#endif
-#ifdef REG_SuB
-freeReg ILIT(REG_SuB) = _FALSE_
-#endif
-#ifdef REG_Hp
-freeReg ILIT(REG_Hp) = _FALSE_
-#endif
-#ifdef REG_HpLim
-freeReg ILIT(REG_HpLim) = _FALSE_
-#endif
-#ifdef REG_Liveness
-freeReg ILIT(REG_Liveness) = _FALSE_
-#endif
-#ifdef REG_Activity
---freeReg ILIT(REG_Activity) = _FALSE_
-#endif
-#ifdef REG_StdUpdRetVec
-freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
-#endif
-#ifdef REG_StkStub
-freeReg ILIT(REG_StkStub) = _FALSE_
-#endif
-freeReg n
-#ifdef REG_Dbl1
- | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_
-#endif
-#ifdef REG_Dbl2
- | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_
-#endif
- | otherwise = _TRUE_
-
-reservedRegs :: [Int]
-reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2,
- NCG_Reserved_F1, NCG_Reserved_F2,
- NCG_Reserved_D1, NCG_Reserved_D2]
-
-\end{code}
-
diff --git a/ghc/compiler/nativeGen/SparcDesc.lhs b/ghc/compiler/nativeGen/SparcDesc.lhs
deleted file mode 100644
index 8445399b6077f404eb6cc00ee076eda18e0e3db3..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/SparcDesc.lhs
+++ /dev/null
@@ -1,197 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[SparcDesc]{The Sparc Machine Description}
-
-\begin{code}
-#include "HsVersions.h"
-
-module SparcDesc (
- mkSparc
-
- -- and assorted nonsense referenced by the class methods
- ) where
-
-import AbsCSyn
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..),
- RegLiveness(..), RegUsage(..), FutureLive(..)
- )
-import CLabel ( CLabel )
-import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
-import HeapOffs ( hpRelToInt )
-import MachDesc
-import Maybes ( Maybe(..) )
-import OrdList
-import Outputable
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import SparcCode
-import SparcGen ( sparcCodeGen )
-import Stix
-import StixMacro
-import StixPrim
-import UniqSupply
-import Util
-\end{code}
-
-Header sizes depend only on command-line options, not on the target
-architecture. (I think.)
-
-\begin{code}
-
-fhs :: (GlobalSwitch -> SwitchResult) -> Int
-
-fhs switches = 1 + profFHS + ageFHS
- where
- profFHS = if switchIsOn switches SccProfilingOn then 1 else 0
- ageFHS = if switchIsOn switches SccProfilingOn then 1 else 0
-
-vhs :: (GlobalSwitch -> SwitchResult) -> SMRep -> Int
-
-vhs switches sm = case sm of
- StaticRep _ _ -> 0
- SpecialisedRep _ _ _ _ -> 0
- GenericRep _ _ _ -> 0
- BigTupleRep _ -> 1
- MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -}
- DataRep _ -> 1
- DynamicRep -> 2
- BlackHoleRep -> 0
- PhantomRep -> panic "vhs:phantom"
-
-\end{code}
-
-Here we map STG registers onto appropriate Stix Trees. First, we
-handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@.
-The rest are either in real machine registers or stored as offsets
-from BaseReg.
-
-\begin{code}
-
-sparcReg :: (GlobalSwitch -> SwitchResult) -> MagicId -> RegLoc
-
-sparcReg switches x =
- case stgRegMap x of
- Just reg -> Save nonReg
- Nothing -> Always nonReg
- where nonReg = case x of
- StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
- StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
- BaseReg -> sStLitLbl SLIT("MainRegTable")
- Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
- HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+4"))
- TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*4)])
- where
- r2 = VanillaReg PtrRep ILIT(2)
- infoptr = case sparcReg switches r2 of
- Always tree -> tree
- Save _ -> StReg (StixMagicId r2)
- _ -> StInd (kindFromMagicId x)
- (StPrim IntAddOp [baseLoc, StInt (toInteger (offset*4))])
- baseLoc = case stgRegMap BaseReg of
- Just _ -> StReg (StixMagicId BaseReg)
- Nothing -> sStLitLbl SLIT("MainRegTable")
- offset = baseRegOffset x
-
-\end{code}
-
-Sizes in bytes.
-
-\begin{code}
-
-size pk = case kindToSize pk of
- {SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8}
-
-\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.
-
-\begin{code}
-
-vsaves switches vols =
- map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
- where
- save x = StAssign (kindFromMagicId x) loc reg
- where reg = StReg (StixMagicId x)
- loc = case sparcReg switches x of
- Save loc -> loc
- Always loc -> panic "vsaves"
-
-vrests switches vols =
- map restore ((filter callerSaves)
- ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols))
- where
- restore x = StAssign (kindFromMagicId x) reg loc
- where reg = StReg (StixMagicId x)
- loc = case sparcReg switches x of
- Save loc -> loc
- Always loc -> panic "vrests"
-
-\end{code}
-
-Static closure sizes.
-
-\begin{code}
-
-charLikeSize, intLikeSize :: Target -> Int
-
-charLikeSize target =
- size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
- where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
-
-intLikeSize target =
- size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
- where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
-
-mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
-
-mhs switches = StInt (toInteger words)
- where
- words = fhs switches + vhs switches (MuTupleRep 0)
-
-dhs switches = StInt (toInteger words)
- where
- words = fhs switches + vhs switches (DataRep 0)
-
-\end{code}
-
-Setting up a sparc target.
-
-\begin{code}
-
-mkSparc :: Bool
- -> (GlobalSwitch -> SwitchResult)
- -> (Target,
- (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
- Bool, -- underscore
- (String -> String)) -- fmtAsmLbl
-
-mkSparc decentOS switches =
- let
- fhs' = fhs switches
- vhs' = vhs switches
- sparcReg' = sparcReg switches
- vsaves' = vsaves switches
- vrests' = vrests switches
- hprel = hpRelToInt target
- as = amodeCode target
- as' = amodeCode' target
- csz = charLikeSize target
- isz = intLikeSize target
- mhs' = mhs switches
- dhs' = dhs switches
- ps = genPrimCode target
- mc = genMacroCode target
- hc = doHeapCheck
- target = mkTarget {-switches-} fhs' vhs' sparcReg' {-id-} size
- hprel as as'
- (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
- {-sparcCodeGen decentOS id-}
- in
- (target, sparcCodeGen, decentOS, id)
-\end{code}
diff --git a/ghc/compiler/nativeGen/SparcGen.lhs b/ghc/compiler/nativeGen/SparcGen.lhs
deleted file mode 100644
index f5046d79e10f831afe03450cc6c8cacad9a139e2..0000000000000000000000000000000000000000
--- a/ghc/compiler/nativeGen/SparcGen.lhs
+++ /dev/null
@@ -1,1289 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-
-\begin{code}
-#include "HsVersions.h"
-
-module SparcGen (
- sparcCodeGen,
-
- -- and, for self-sufficiency
- PprStyle, StixTree, CSeq
- ) where
-
-IMPORT_Trace
-
-import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos,
- Reg(..), RegLiveness(..), RegUsage(..),
- FutureLive(..), MachineRegisters(..), MachineCode(..)
- )
-import CLabel ( CLabel, isAsmTemp )
-import SparcCode {- everything -}
-import MachDesc
-import Maybes ( maybeToBool, Maybe(..) )
-import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
-import Outputable
-import SparcDesc
-import Stix
-import UniqSupply
-import Pretty
-import Unpretty
-import Util
-
-type CodeBlock a = (OrdList a -> OrdList a)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SparcCodeGen]{Generating Sparc Code}
-%* *
-%************************************************************************
-
-This is the top-level code-generation function for the Sparc.
-
-\begin{code}
-
-sparcCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
-sparcCodeGen sty trees =
- mapUs genSparcCode trees `thenUs` \ dynamicCodes ->
- let
- staticCodes = scheduleSparcCode dynamicCodes
- pretty = printLabeledCodes sty staticCodes
- in
- returnUs pretty
-
-\end{code}
-
-This bit does the code scheduling. The scheduler must also deal with
-register allocation of temporaries. Much parallelism can be exposed via
-the OrdList, but more might occur, so further analysis might be needed.
-
-\begin{code}
-
-scheduleSparcCode :: [SparcCode] -> [SparcInstr]
-scheduleSparcCode = concat . map (runRegAllocate freeSparcRegs reservedRegs)
- where
- freeSparcRegs :: SparcRegs
- freeSparcRegs = mkMRegs (extractMappedRegNos freeRegs)
-
-
-\end{code}
-
-Registers 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 Reg PrimRep (CodeBlock SparcInstr)
- | Any PrimRep (Reg -> (CodeBlock SparcInstr))
-
-registerCode :: Register -> Reg -> CodeBlock SparcInstr
-registerCode (Fixed _ _ code) reg = code
-registerCode (Any _ code) reg = code reg
-
-registerName :: Register -> Reg -> Reg
-registerName (Fixed reg _ _) _ = reg
-registerName (Any _ _) reg = reg
-
-registerKind :: Register -> PrimRep
-registerKind (Fixed _ pk _) = pk
-registerKind (Any pk _) = pk
-
-isFixed :: Register -> Bool
-isFixed (Fixed _ _ _) = True
-isFixed (Any _ _) = False
-
-\end{code}
-
-Memory addressing modes passed up the tree.
-
-\begin{code}
-
-data Amode = Amode Addr (CodeBlock SparcInstr)
-
-amodeAddr (Amode addr _) = addr
-amodeCode (Amode _ code) = code
-
-\end{code}
-
-Condition codes passed up the tree.
-
-\begin{code}
-
-data Condition = Condition Bool Cond (CodeBlock SparcInstr)
-
-condName (Condition _ cond _) = cond
-condFloat (Condition float _ _) = float
-condCode (Condition _ _ code) = code
-
-\end{code}
-
-General things for putting together code sequences.
-
-\begin{code}
-
-asmVoid :: OrdList SparcInstr
-asmVoid = mkEmptyList
-
-asmInstr :: SparcInstr -> SparcCode
-asmInstr i = mkUnitList i
-
-asmSeq :: [SparcInstr] -> SparcCode
-asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
-
-asmParThen :: [SparcCode] -> (CodeBlock SparcInstr)
-asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-
-returnInstr :: SparcInstr -> UniqSM (CodeBlock SparcInstr)
-returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-
-returnInstrs :: [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
-returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-
-returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
-returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
-
-mkSeqInstr :: SparcInstr -> (CodeBlock SparcInstr)
-mkSeqInstr instr code = mkSeqList (asmInstr instr) code
-
-mkSeqInstrs :: [SparcInstr] -> (CodeBlock SparcInstr)
-mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
-
-\end{code}
-
-Top level sparc code generator for a chunk of stix code.
-
-\begin{code}
-
-genSparcCode :: [StixTree] -> UniqSM (SparcCode)
-
-genSparcCode trees =
- mapUs getCode trees `thenUs` \ blocks ->
- returnUs (foldr (.) id blocks asmVoid)
-
-\end{code}
-
-Code extractor for an entire stix tree---stix statement level.
-
-\begin{code}
-
-getCode
- :: StixTree -- a stix statement
- -> UniqSM (CodeBlock SparcInstr)
-
-getCode (StSegment seg) = returnInstr (SEGMENT seg)
-
-getCode (StAssign pk dst src)
- | isFloatingRep pk = assignFltCode pk dst src
- | otherwise = assignIntCode pk dst src
-
-getCode (StLabel lab) = returnInstr (LABEL lab)
-
-getCode (StFunBegin lab) = returnInstr (LABEL lab)
-
-getCode (StFunEnd lab) = returnUs id
-
-getCode (StJump arg) = genJump arg
-
-getCode (StFallThrough lbl) = returnUs id
-
-getCode (StCondJump lbl arg) = genCondJump lbl arg
-
-getCode (StData kind args) =
- mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
- returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
- (foldr1 (.) codes xs))
- where
- getData :: StixTree -> UniqSM (CodeBlock SparcInstr, Imm)
- getData (StInt i) = returnUs (id, ImmInteger i)
- getData (StDouble d) = returnUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
- getData (StLitLbl s) = returnUs (id, ImmLab s)
- getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
- getData (StString s) =
- getUniqLabelNCG `thenUs` \ lbl ->
- returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
- getData (StCLbl l) = returnUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
-
-getCode (StComment s) = returnInstr (COMMENT s)
-
-\end{code}
-
-Generate code to get a subtree into a register.
-
-\begin{code}
-
-getReg :: StixTree -> UniqSM Register
-
-getReg (StReg (StixMagicId stgreg)) =
- case stgRegMap stgreg of
- Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
- -- cannae be Nothing
-
-getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
-
-getReg (StDouble d) =
- getUniqLabelNCG `thenUs` \ lbl ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- DATA DF [strImmLit ('0' : 'r' : ppShow 80 (ppRational d))],
- SEGMENT TextSegment,
- SETHI (HI (ImmCLbl lbl)) tmp,
- LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
- in
- returnUs (Any DoubleRep code)
-
-getReg (StString s) =
- getUniqLabelNCG `thenUs` \ lbl ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII True (_UNPK_ s),
- SEGMENT TextSegment,
- SETHI (HI (ImmCLbl lbl)) dst,
- OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
- in
- returnUs (Any PtrRep code)
-
-getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
- getUniqLabelNCG `thenUs` \ lbl ->
- let code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII False (init xs),
- SEGMENT TextSegment,
- SETHI (HI (ImmCLbl lbl)) dst,
- OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
- in
- returnUs (Any PtrRep code)
- where
- xs = _UNPK_ (_TAIL_ s)
-
-getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
-
-getReg (StCall fn kind args) =
- genCCall fn kind args `thenUs` \ call ->
- returnUs (Fixed reg kind call)
- where
- reg = if isFloatingRep kind then f0 else o0
-
-getReg (StPrim primop args) =
- case primop of
-
- CharGtOp -> condIntReg GT args
- CharGeOp -> condIntReg GE args
- CharEqOp -> condIntReg EQ args
- CharNeOp -> condIntReg NE args
- CharLtOp -> condIntReg LT args
- CharLeOp -> condIntReg LE args
-
- IntAddOp -> trivialCode (ADD False False) args
-
- IntSubOp -> trivialCode (SUB False False) args
- IntMulOp -> call SLIT(".umul") IntRep
- IntQuotOp -> call SLIT(".div") IntRep
- IntRemOp -> call SLIT(".rem") IntRep
- IntNegOp -> trivialUCode (SUB False False g0) args
- IntAbsOp -> absIntCode args
-
- AndOp -> trivialCode (AND False) args
- OrOp -> trivialCode (OR False) args
- NotOp -> trivialUCode (XNOR False g0) args
- SllOp -> trivialCode SLL args
- SraOp -> trivialCode SRA args
- SrlOp -> trivialCode SRL args
- ISllOp -> panic "SparcGen:isll"
- ISraOp -> panic "SparcGen:isra"
- ISrlOp -> panic "SparcGen:isrl"
-
- IntGtOp -> condIntReg GT args
- IntGeOp -> condIntReg GE args
- IntEqOp -> condIntReg EQ args
- IntNeOp -> condIntReg NE args
- IntLtOp -> condIntReg LT args
- IntLeOp -> condIntReg LE args
-
- WordGtOp -> condIntReg GU args
- WordGeOp -> condIntReg GEU args
- WordEqOp -> condIntReg EQ args
- WordNeOp -> condIntReg NE args
- WordLtOp -> condIntReg LU args
- WordLeOp -> condIntReg LEU args
-
- AddrGtOp -> condIntReg GU args
- AddrGeOp -> condIntReg GEU args
- AddrEqOp -> condIntReg EQ args
- AddrNeOp -> condIntReg NE args
- AddrLtOp -> condIntReg LU args
- AddrLeOp -> condIntReg LEU args
-
- FloatAddOp -> trivialFCode FloatRep FADD args
- FloatSubOp -> trivialFCode FloatRep FSUB args
- FloatMulOp -> trivialFCode FloatRep FMUL args
- FloatDivOp -> trivialFCode FloatRep FDIV args
- FloatNegOp -> trivialUFCode FloatRep (FNEG F) args
-
- FloatGtOp -> condFltReg GT args
- FloatGeOp -> condFltReg GE args
- FloatEqOp -> condFltReg EQ args
- FloatNeOp -> condFltReg NE args
- FloatLtOp -> condFltReg LT args
- FloatLeOp -> condFltReg LE args
-
- FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
- FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
- FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleRep
-
- FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
- FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
- FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
-
- FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
- FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
- FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
-
- FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
- FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
- FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
-
- FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
-
- DoubleAddOp -> trivialFCode DoubleRep FADD args
- DoubleSubOp -> trivialFCode DoubleRep FSUB args
- DoubleMulOp -> trivialFCode DoubleRep FMUL args
- DoubleDivOp -> trivialFCode DoubleRep FDIV args
- DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) args
-
- DoubleGtOp -> condFltReg GT args
- DoubleGeOp -> condFltReg GE args
- DoubleEqOp -> condFltReg EQ args
- DoubleNeOp -> condFltReg NE args
- DoubleLtOp -> condFltReg LT args
- DoubleLeOp -> condFltReg LE args
-
- DoubleExpOp -> call SLIT("exp") DoubleRep
- DoubleLogOp -> call SLIT("log") DoubleRep
- DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
-
- DoubleSinOp -> call SLIT("sin") DoubleRep
- DoubleCosOp -> call SLIT("cos") DoubleRep
- DoubleTanOp -> call SLIT("tan") DoubleRep
-
- DoubleAsinOp -> call SLIT("asin") DoubleRep
- DoubleAcosOp -> call SLIT("acos") DoubleRep
- DoubleAtanOp -> call SLIT("atan") DoubleRep
-
- DoubleSinhOp -> call SLIT("sinh") DoubleRep
- DoubleCoshOp -> call SLIT("cosh") DoubleRep
- DoubleTanhOp -> call SLIT("tanh") DoubleRep
-
- DoublePowerOp -> call SLIT("pow") DoubleRep
-
- OrdOp -> coerceIntCode IntRep args
- ChrOp -> chrCode args
-
- Float2IntOp -> coerceFP2Int args
- Int2FloatOp -> coerceInt2FP FloatRep args
- Double2IntOp -> coerceFP2Int args
- Int2DoubleOp -> coerceInt2FP DoubleRep args
-
- Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) args
- Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) args
-
- where
- call fn pk = getReg (StCall fn pk args)
- promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
- where
- promote x = StPrim Float2DoubleOp [x]
-
-getReg (StInd pk mem) =
- getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = kindToSize pk
- code__2 dst = code . mkSeqInstr (LD size src dst)
- in
- returnUs (Any pk code__2)
-
-getReg (StInt i)
- | is13Bits i =
- let
- src = ImmInt (fromInteger i)
- code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
- in
- returnUs (Any IntRep code)
-
-getReg leaf
- | maybeToBool imm =
- let
- code dst = mkSeqInstrs [
- SETHI (HI imm__2) dst,
- OR False dst (RIImm (LO imm__2)) dst]
- in
- returnUs (Any PtrRep code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-\end{code}
-
-Now, given a tree (the argument to an StInd) that references memory,
-produce a suitable addressing mode.
-
-\begin{code}
-
-getAmode :: StixTree -> UniqSM Amode
-
-getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
-
-getAmode (StPrim IntSubOp [x, StInt i])
- | is13Bits (-i) =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg x `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- returnUs (Amode (AddrRegImm reg off) code)
-
-
-getAmode (StPrim IntAddOp [x, StInt i])
- | is13Bits i =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg x `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- returnUs (Amode (AddrRegImm reg off) code)
-
-getAmode (StPrim IntAddOp [x, y]) =
- getNewRegNCG PtrRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- reg1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- reg2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2]
- in
- returnUs (Amode (AddrRegReg reg1 reg2) code__2)
-
-getAmode leaf
- | maybeToBool imm =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- let
- code = mkSeqInstr (SETHI (HI imm__2) tmp)
- in
- returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other =
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- getReg other `thenUs` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt 0
- in
- returnUs (Amode (AddrRegImm reg off) code)
-
-\end{code}
-
-Try to get a value into a specific register (or registers) for a call. 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.) 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, @getCallArg@ can be applied
-to all of a call's arguments using @mapAccumL@.
-
-\begin{code}
-
-getCallArg
- :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
- -> StixTree -- Current argument
- -> UniqSM (([Reg],Int), CodeBlock SparcInstr) -- Updated accumulator and code
-
--- We have to use up all of our argument registers first.
-
-getCallArg (dst:dsts, offset) arg =
- getReg arg `thenUs` \ register ->
- getNewRegNCG (registerKind register)
- `thenUs` \ tmp ->
- let
- reg = if isFloatingRep pk then tmp else dst
- code = registerCode register reg
- src = registerName register reg
- pk = registerKind register
- in
- returnUs (case pk of
- DoubleRep ->
- case dsts of
- [] -> (([], offset + 1), code . mkSeqInstrs [
- -- conveniently put the second part in the right stack
- -- location, and load the first part into %o5
- ST DF src (spRel (offset - 1)),
- LD W (spRel (offset - 1)) dst])
- (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
- ST DF src (spRel (-2)),
- LD W (spRel (-2)) dst,
- LD W (spRel (-1)) dst__2])
- FloatRep -> ((dsts, offset), code . mkSeqInstrs [
- ST F src (spRel (-2)),
- LD W (spRel (-2)) dst])
- _ -> ((dsts, offset), if isFixed register then
- code . mkSeqInstr (OR False g0 (RIReg src) dst)
- else code))
-
--- Once we have run out of argument registers, we move to the stack
-
-getCallArg ([], offset) arg =
- getReg arg `thenUs` \ register ->
- getNewRegNCG (registerKind register)
- `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerKind register
- sz = kindToSize pk
- words = if pk == DoubleRep then 2 else 1
- in
- returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
-
-\end{code}
-
-Set up a condition code for a conditional branch.
-
-\begin{code}
-
-getCondition :: StixTree -> UniqSM Condition
-
-getCondition (StPrim primop args) =
- case primop of
-
- CharGtOp -> condIntCode GT args
- CharGeOp -> condIntCode GE args
- CharEqOp -> condIntCode EQ args
- CharNeOp -> condIntCode NE args
- CharLtOp -> condIntCode LT args
- CharLeOp -> condIntCode LE args
-
- IntGtOp -> condIntCode GT args
- IntGeOp -> condIntCode GE args
- IntEqOp -> condIntCode EQ args
- IntNeOp -> condIntCode NE args
- IntLtOp -> condIntCode LT args
- IntLeOp -> condIntCode LE args
-
- WordGtOp -> condIntCode GU args
- WordGeOp -> condIntCode GEU args
- WordEqOp -> condIntCode EQ args
- WordNeOp -> condIntCode NE args
- WordLtOp -> condIntCode LU args
- WordLeOp -> condIntCode LEU args
-
- AddrGtOp -> condIntCode GU args
- AddrGeOp -> condIntCode GEU args
- AddrEqOp -> condIntCode EQ args
- AddrNeOp -> condIntCode NE args
- AddrLtOp -> condIntCode LU args
- AddrLeOp -> condIntCode LEU args
-
- FloatGtOp -> condFltCode GT args
- FloatGeOp -> condFltCode GE args
- FloatEqOp -> condFltCode EQ args
- FloatNeOp -> condFltCode NE args
- FloatLtOp -> condFltCode LT args
- FloatLeOp -> condFltCode LE args
-
- DoubleGtOp -> condFltCode GT args
- DoubleGeOp -> condFltCode GE args
- DoubleEqOp -> condFltCode EQ args
- DoubleNeOp -> condFltCode NE args
- DoubleLtOp -> condFltCode LT args
- DoubleLeOp -> condFltCode LE args
-
-\end{code}
-
-Turn a boolean expression into a condition, to be passed
-back up the tree.
-
-\begin{code}
-
-condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
-
-condIntCode cond [x, StInt y]
- | is13Bits y =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
- in
- returnUs (Condition False cond code__2)
-
-condIntCode cond [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (SUB False True src1 (RIReg src2) g0)
- in
- returnUs (Condition False cond code__2)
-
-condFltCode cond [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG (registerKind register1)
- `thenUs` \ tmp1 ->
- getNewRegNCG (registerKind register2)
- `thenUs` \ tmp2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
- let
- promote x = asmInstr (FxTOy F DF x tmp)
-
- pk1 = registerKind register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- pk2 = registerKind register2
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 =
- if pk1 == pk2 then
- asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr (FCMP True (kindToSize pk1) src1 src2)
- else if pk1 == FloatRep then
- asmParThen [code1 (promote src1), code2 asmVoid] .
- mkSeqInstr (FCMP True DF tmp src2)
- else
- asmParThen [code1 asmVoid, code2 (promote src2)] .
- mkSeqInstr (FCMP True DF src1 tmp)
- in
- returnUs (Condition True cond code__2)
-
-\end{code}
-
-Turn those condition codes into integers now (when they appear on
-the right hand side of an assignment).
-
-Do not fill the delay slots here; you will confuse the register allocator.
-
-\begin{code}
-
-condIntReg :: Cond -> [StixTree] -> UniqSM Register
-
-condIntReg EQ [x, StInt 0] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstrs [
- SUB False True g0 (RIReg src) g0,
- SUB True False g0 (RIImm (ImmInt (-1))) dst]
- in
- returnUs (Any IntRep code__2)
-
-condIntReg EQ [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
- XOR False src1 (RIReg src2) dst,
- SUB False True g0 (RIReg dst) g0,
- SUB True False g0 (RIImm (ImmInt (-1))) dst]
- in
- returnUs (Any IntRep code__2)
-
-condIntReg NE [x, StInt 0] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstrs [
- SUB False True g0 (RIReg src) g0,
- ADD True False g0 (RIImm (ImmInt 0)) dst]
- in
- returnUs (Any IntRep code__2)
-
-condIntReg NE [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
- XOR False src1 (RIReg src2) dst,
- SUB False True g0 (RIReg dst) g0,
- ADD True False g0 (RIImm (ImmInt 0)) dst]
- in
- returnUs (Any IntRep code__2)
-
-condIntReg cond args =
- getUniqLabelNCG `thenUs` \ lbl1 ->
- getUniqLabelNCG `thenUs` \ lbl2 ->
- condIntCode cond args `thenUs` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code . mkSeqInstrs [
- 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
- returnUs (Any IntRep code__2)
-
-condFltReg :: Cond -> [StixTree] -> UniqSM Register
-
-condFltReg cond args =
- getUniqLabelNCG `thenUs` \ lbl1 ->
- getUniqLabelNCG `thenUs` \ lbl2 ->
- condFltCode cond args `thenUs` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- code__2 dst = code . mkSeqInstrs [
- 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
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-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}
-
-assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
-
-assignIntCode pk (StInd _ dst) src =
- getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getReg src `thenUs` \ register ->
- let
- code1 = amodeCode amode asmVoid
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp asmVoid
- src__2 = registerName register tmp
- sz = kindToSize pk
- code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- returnUs code__2
-
-assignIntCode pk dst src =
- getReg dst `thenUs` \ register1 ->
- getReg src `thenUs` \ register2 ->
- let
- dst__2 = registerName register1 g0
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2 then
- code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
- else code
- in
- returnUs code__2
-
-assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
-
-assignFltCode pk (StInd _ dst) src =
- getNewRegNCG pk `thenUs` \ tmp ->
- getAmode dst `thenUs` \ amode ->
- getReg src `thenUs` \ register ->
- let
- sz = kindToSize pk
- dst__2 = amodeAddr amode
-
- code1 = amodeCode amode asmVoid
- code2 = registerCode register tmp asmVoid
-
- src__2 = registerName register tmp
- pk__2 = registerKind register
- sz__2 = kindToSize pk__2
-
- code__2 = asmParThen [code1, code2] .
- if pk == pk__2 then
- mkSeqInstr (ST sz src__2 dst__2)
- else
- mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
- in
- returnUs code__2
-
-assignFltCode pk dst src =
- getReg dst `thenUs` \ register1 ->
- getReg src `thenUs` \ register2 ->
- getNewRegNCG (registerKind register2)
- `thenUs` \ tmp ->
- let
- sz = kindToSize 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
- pk__2 = registerKind register2
- sz__2 = kindToSize pk__2
-
- code__2 = if pk /= pk__2 then code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
- else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2)
- else code
- in
- returnUs code__2
-
-\end{code}
-
-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, so we use call.
-
-Do not fill the delay slots here; you will confuse the register allocator.
-
-\begin{code}
-
-genJump
- :: StixTree -- the branch target
- -> UniqSM (CodeBlock SparcInstr)
-
-genJump (StCLbl lbl)
- | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
- | otherwise = returnInstrs [CALL target 0 True, NOP]
- where
- target = ImmCLbl lbl
-
-genJump tree =
- getReg tree `thenUs` \ register ->
- getNewRegNCG PtrRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- target = registerName register tmp
- in
- returnSeq code [JMP (AddrRegReg target g0), NOP]
-
-\end{code}
-
-Conditional jumps are always to local labels, so we can use
-branch instructions. 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@.
-
-Do not fill the delay slots here; you will confuse the register allocator.
-
-\begin{code}
-
-genCondJump
- :: CLabel -- the branch target
- -> StixTree -- the condition on which to branch
- -> UniqSM (CodeBlock SparcInstr)
-
-genCondJump lbl bool =
- getCondition bool `thenUs` \ condition ->
- let
- code = condCode condition
- cond = condName condition
- target = ImmCLbl lbl
- in
- if condFloat condition then
- returnSeq code [NOP, BF cond False target, NOP]
- else
- returnSeq code [BI cond False target, NOP]
-
-\end{code}
-
-Now the biggest nightmare---calls. Most of the nastiness is buried in
-getCallArg, which moves the arguments to the correct registers/stack
-locations. Apart from that, the code is easy.
-
-Do not fill the delay slots here; you will confuse the register allocator.
-
-\begin{code}
-
-genCCall
- :: FAST_STRING -- function to call
- -> PrimRep -- type of the result
- -> [StixTree] -- arguments (of mixed type)
- -> UniqSM (CodeBlock SparcInstr)
-
-genCCall fn kind args =
- mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
- `thenUs` \ ((unused,_), argCode) ->
- let
- nRegs = length argRegs - length unused
- call = CALL fn__2 nRegs False
- code = asmParThen (map ($ asmVoid) argCode)
- in
- returnSeq code [call, NOP]
- where
- -- function names that begin with '.' are assumed to be special internally
- -- generated names like '.mul,' which don't get an underscore prefix
- fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
-
- mapAccumLNCG f b [] = returnUs (b, [])
- mapAccumLNCG f b (x:xs) =
- f b x `thenUs` \ (b__2, x__2) ->
- mapAccumLNCG f b__2 xs `thenUs` \ (b__3, xs__2) ->
- returnUs (b__3, x__2:xs__2)
-
-\end{code}
-
-Trivial (dyadic) instructions. Only look for constants on the right hand
-side, because that's where the generic optimizer will have put them.
-
-\begin{code}
-
-trivialCode
- :: (Reg -> RI -> Reg -> SparcInstr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialCode instr [x, StInt y]
- | is13Bits y =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ 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
- returnUs (Any IntRep code__2)
-
-trivialCode instr [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG IntRep `thenUs` \ tmp1 ->
- getNewRegNCG IntRep `thenUs` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] .
- mkSeqInstr (instr src1 (RIReg src2) dst)
- in
- returnUs (Any IntRep code__2)
-
-trivialFCode
- :: PrimRep
- -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialFCode pk instr [x, y] =
- getReg x `thenUs` \ register1 ->
- getReg y `thenUs` \ register2 ->
- getNewRegNCG (registerKind register1)
- `thenUs` \ tmp1 ->
- getNewRegNCG (registerKind register2)
- `thenUs` \ tmp2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
- let
- promote x = asmInstr (FxTOy F DF x tmp)
-
- pk1 = registerKind register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- pk2 = registerKind register2
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 dst =
- if pk1 == pk2 then
- asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr (instr (kindToSize pk) src1 src2 dst)
- else if pk1 == FloatRep then
- asmParThen [code1 (promote src1), code2 asmVoid] .
- mkSeqInstr (instr DF tmp src2 dst)
- else
- asmParThen [code1 asmVoid, code2 (promote src2)] .
- mkSeqInstr (instr DF src1 tmp dst)
- in
- returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
-
-\end{code}
-
-Trivial unary instructions. Note that we don't have to worry about
-matching an StInt as the argument, because genericOpt will already
-have handled the constant-folding.
-
-\begin{code}
-
-trivialUCode
- :: (RI -> Reg -> SparcInstr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialUCode instr [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
- in
- returnUs (Any IntRep code__2)
-
-trivialUFCode
- :: PrimRep
- -> (Reg -> Reg -> SparcInstr)
- -> [StixTree]
- -> UniqSM Register
-
-trivialUFCode pk instr [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG pk `thenUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr src dst)
- in
- returnUs (Any pk code__2)
-
-\end{code}
-
-Absolute value on integers, mostly for gmp size check macros. Again,
-the argument cannot be an StInt, because genericOpt already folded
-constants.
-
-Do not fill the delay slots here; you will confuse the register allocator.
-
-\begin{code}
-
-absIntCode :: [StixTree] -> UniqSM Register
-absIntCode [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code . mkSeqInstrs [
- SUB False True g0 (RIReg src) dst,
- BI GE False (ImmCLbl lbl), NOP,
- OR False g0 (RIReg src) dst,
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-Simple integer coercions that don't require any code to be generated.
-Here we just change the type on the register passed on up
-
-\begin{code}
-
-coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
-coerceIntCode pk [x] =
- getReg x `thenUs` \ register ->
- case register of
- Fixed reg _ code -> returnUs (Fixed reg pk code)
- Any _ code -> returnUs (Any pk code)
-
-\end{code}
-
-Integer to character conversion. We try to do this in one step if
-the original object is in memory.
-
-\begin{code}
-
-chrCode :: [StixTree] -> UniqSM Register
-chrCode [StInd pk mem] =
- getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- srcOff = offset src 3
- src__2 = case srcOff of Just x -> x
- code__2 dst = if maybeToBool srcOff then
- code . mkSeqInstr (LD UB src__2 dst)
- else
- code . mkSeqInstrs [
- LD (kindToSize pk) src dst,
- AND False dst (RIImm (ImmInt 255)) dst]
- in
- returnUs (Any pk code__2)
-
-chrCode [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
- in
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-More complicated integer/float conversions. Here we have to store
-temporaries in memory to move between the integer and the floating
-point register sets.
-
-\begin{code}
-
-coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
-coerceInt2FP pk [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
-
- code__2 dst = code . mkSeqInstrs [
- ST W src (spRel (-2)),
- LD W (spRel (-2)) dst,
- FxTOy W (kindToSize pk) dst dst]
- in
- returnUs (Any pk code__2)
-
-coerceFP2Int :: [StixTree] -> UniqSM Register
-coerceFP2Int [x] =
- getReg x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- getNewRegNCG FloatRep `thenUs` \ tmp ->
- let
- code = registerCode register reg
- src = registerName register reg
- pk = registerKind register
-
- code__2 dst = code . mkSeqInstrs [
- FxTOy (kindToSize pk) W src tmp,
- ST W tmp (spRel (-2)),
- LD W (spRel (-2)) dst]
- in
- returnUs (Any IntRep code__2)
-
-\end{code}
-
-Some random little helpers.
-
-\begin{code}
-
-maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i)
- | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
- | otherwise = Just (ImmInteger i)
-maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
-maybeImm (StCLbl l) = Just (ImmCLbl l)
-maybeImm _ = Nothing
-
-mangleIndexTree :: StixTree -> StixTree
-
-mangleIndexTree (StIndex pk base (StInt i)) =
- StPrim IntAddOp [base, off]
- where
- off = StInt (i * size pk)
- size :: PrimRep -> Integer
- size pk = case kindToSize pk of
- {SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8}
-
-mangleIndexTree (StIndex pk base off) =
- case pk of
- CharRep -> StPrim IntAddOp [base, off]
- _ -> StPrim IntAddOp [base, off__2]
- where
- off__2 = StPrim SllOp [off, StInt (shift pk)]
- shift :: PrimRep -> Integer
- shift DoubleRep = 3
- shift _ = 2
-
-cvtLitLit :: String -> String
-cvtLitLit "stdin" = "__iob+0x0" -- This one is probably okay...
-cvtLitLit "stdout" = "__iob+0x14" -- but these next two are dodgy at best
-cvtLitLit "stderr" = "__iob+0x28"
-cvtLitLit s
- | isHex s = s
- | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
- where
- isHex ('0':'x':xs) = all isHexDigit xs
- isHex _ = False
- -- Now, where have I seen this before?
- isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
-
-
-\end{code}
-
-spRel gives us a stack relative addressing mode for volatile temporaries
-and for excess call arguments.
-
-\begin{code}
-
-spRel
- :: Int -- desired stack offset in words, positive or negative
- -> Addr
-spRel n = AddrRegImm sp (ImmInt (n * 4))
-
-stackArgLoc = 23 :: Int -- where to stack extra call arguments (beyond 6x32 bits)
-
-\end{code}
-
-\begin{code}
-
-getNewRegNCG :: PrimRep -> UniqSM Reg
-getNewRegNCG pk =
- getUnique `thenUs` \ u ->
- returnUs (mkReg u pk)
-
-\end{code}
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index 8269dbdb3d8f0ab3c6190c623c513eae7d006ee8..f187e9fe1d79e19f2f94ced4538f2caabdfbd389 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -1,5 +1,5 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\begin{code}
@@ -11,158 +11,142 @@ module Stix (
stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg,
--- stgActivityReg,
stgStdUpdRetVecReg, stgStkStubReg,
getUniqLabelNCG
-
- -- And for self-sufficiency, by golly...
) where
-import AbsCSyn ( MagicId(..), kindFromMagicId, node, infoptr )
-import PrelInfo ( showPrimOp, PrimOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import CLabel ( CLabel, mkAsmTempLabel )
-import Outputable
-import UniqSupply
-import Unpretty
-import Util
+import Ubiq{-uitous-}
+
+import AbsCSyn ( node, infoptr, MagicId(..) )
+import AbsCUtils ( magicIdPrimRep )
+import CLabel ( mkAsmTempLabel )
+import UniqSupply ( returnUs, thenUs, getUnique, UniqSM(..) )
+import Unpretty ( uppPStr, Unpretty(..) )
\end{code}
Here is the tag at the nodes of our @StixTree@. Notice its
relationship with @PrimOp@ in prelude/PrimOp.
\begin{code}
+data StixTree
+ = -- Segment (text or data)
-data StixTree =
-
- -- Segment (text or data)
+ StSegment CodeSegment
- StSegment CodeSegment
+ -- We can tag the leaves with constants/immediates.
- -- We can tag the leaves with constants/immediates.
+ | StInt Integer -- ** add Kind at some point
+ | StDouble Rational
+ | StString FAST_STRING
+ | StLitLbl Unpretty -- literal labels
+ -- (will be _-prefixed on some machines)
+ | StLitLit FAST_STRING -- innards from CLitLit
+ | StCLbl CLabel -- labels that we might index into
- | StInt Integer -- ** add Kind at some point
- | StDouble Rational
- | StString FAST_STRING
- | StLitLbl Unpretty -- literal labels (will be _-prefixed on some machines)
- | StLitLit FAST_STRING -- innards from CLitLit
- | StCLbl CLabel -- labels that we might index into
+ -- Abstract registers of various kinds
- -- Abstract registers of various kinds
+ | StReg StixReg
- | StReg StixReg
+ -- A typed offset from a base location
- -- A typed offset from a base location
+ | StIndex PrimRep StixTree StixTree -- kind, base, offset
- | StIndex PrimRep StixTree StixTree -- kind, base, offset
+ -- An indirection from an address to its contents.
- -- An indirection from an address to its contents.
+ | StInd PrimRep StixTree
- | StInd PrimRep StixTree
+ -- Assignment is typed to determine size and register placement
- -- Assignment is typed to determine size and register placement
+ | StAssign PrimRep StixTree StixTree -- dst, src
- | StAssign PrimRep StixTree StixTree -- dst, src
+ -- A simple assembly label that we might jump to.
- -- A simple assembly label that we might jump to.
+ | StLabel CLabel
- | StLabel CLabel
+ -- A function header and footer
- -- A function header and footer
+ | StFunBegin CLabel
+ | StFunEnd CLabel
- | StFunBegin CLabel
- | StFunEnd CLabel
+ -- An unconditional jump. This instruction is terminal.
+ -- Dynamic targets are allowed
- -- An unconditional jump. This instruction is terminal.
- -- Dynamic targets are allowed
+ | StJump StixTree
- | StJump StixTree
+ -- A fall-through, from slow to fast
- -- A fall-through, from slow to fast
+ | StFallThrough CLabel
- | StFallThrough CLabel
+ -- A conditional jump. This instruction can be non-terminal :-)
+ -- Only static, local, forward labels are allowed
- -- A conditional jump. This instruction can be non-terminal :-)
- -- Only static, local, forward labels are allowed
+ | StCondJump CLabel StixTree
- | StCondJump CLabel StixTree
+ -- Raw data (as in an info table).
- -- Raw data (as in an info table).
+ | StData PrimRep [StixTree]
- | StData PrimRep [StixTree]
+ -- Primitive Operations
- -- Primitive Operations
+ | StPrim PrimOp [StixTree]
- | StPrim PrimOp [StixTree]
+ -- Calls to C functions
- -- Calls to C functions
+ | StCall FAST_STRING PrimRep [StixTree]
- | StCall FAST_STRING PrimRep [StixTree]
+ -- Assembly-language comments
- -- Comments, of course
-
- | StComment FAST_STRING -- For assembly comments
-
- deriving ()
+ | StComment FAST_STRING
sStLitLbl :: FAST_STRING -> StixTree
sStLitLbl s = StLitLbl (uppPStr s)
\end{code}
Stix registers can have two forms. They {\em may} or {\em may not}
-map to real, machine level registers.
+map to real, machine-level registers.
\begin{code}
+data StixReg
+ = StixMagicId MagicId -- Regs which are part of the abstract machine model
-data StixReg = StixMagicId MagicId -- Regs which are part of the abstract machine model
-
- | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
+ | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
-- the abstract C.
- deriving ()
-
\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).
+segment (or that it has no segments at all, and we can lump these
+together).
\begin{code}
-
-data CodeSegment = DataSegment | TextSegment deriving (Eq)
+data CodeSegment = DataSegment | TextSegment deriving Eq
type StixTreeList = [StixTree] -> [StixTree]
-
\end{code}
--- Stix Trees for STG registers
-
+Stix Trees for STG registers:
\begin{code}
-
-stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, stgSuA,
- stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg{-, stgActivityReg-}, stgStdUpdRetVecReg,
- stgStkStubReg :: StixTree
-
-stgBaseReg = StReg (StixMagicId BaseReg)
-stgStkOReg = StReg (StixMagicId StkOReg)
-stgNode = StReg (StixMagicId node)
-stgInfoPtr = StReg (StixMagicId infoptr)
-stgTagReg = StReg (StixMagicId TagReg)
-stgRetReg = StReg (StixMagicId RetReg)
-stgSpA = StReg (StixMagicId SpA)
-stgSuA = StReg (StixMagicId SuA)
-stgSpB = StReg (StixMagicId SpB)
-stgSuB = StReg (StixMagicId SuB)
-stgHp = StReg (StixMagicId Hp)
-stgHpLim = StReg (StixMagicId HpLim)
-stgLivenessReg = StReg (StixMagicId LivenessReg)
---stgActivityReg = StReg (StixMagicId ActivityReg)
-stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg)
-stgStkStubReg = StReg (StixMagicId StkStubReg)
+stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA,
+ stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg,
+ stgStdUpdRetVecReg, stgStkStubReg :: StixTree
+
+stgBaseReg = StReg (StixMagicId BaseReg)
+stgStkOReg = StReg (StixMagicId StkOReg)
+stgNode = StReg (StixMagicId node)
+stgInfoPtr = StReg (StixMagicId infoptr)
+stgTagReg = StReg (StixMagicId TagReg)
+stgRetReg = StReg (StixMagicId RetReg)
+stgSpA = StReg (StixMagicId SpA)
+stgSuA = StReg (StixMagicId SuA)
+stgSpB = StReg (StixMagicId SpB)
+stgSuB = StReg (StixMagicId SuB)
+stgHp = StReg (StixMagicId Hp)
+stgHpLim = StReg (StixMagicId HpLim)
+stgLivenessReg = StReg (StixMagicId LivenessReg)
+stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg)
+stgStkStubReg = StReg (StixMagicId StkStubReg)
getUniqLabelNCG :: UniqSM CLabel
-getUniqLabelNCG =
- getUnique `thenUs` \ u ->
- returnUs (mkAsmTempLabel u)
-
+getUniqLabelNCG
+ = getUnique `thenUs` \ u ->
+ returnUs (mkAsmTempLabel u)
\end{code}
diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs
index e82716778b9b2b29952e30471f4f8ecbbecd34d6..82b88c67608f377109d39137075804fd884f98d0 100644
--- a/ghc/compiler/nativeGen/StixInfo.lhs
+++ b/ghc/compiler/nativeGen/StixInfo.lhs
@@ -1,24 +1,32 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\begin{code}
#include "HsVersions.h"
-module StixInfo (
- genCodeInfoTable
- ) where
-
-import AbsCSyn
-import ClosureInfo
-import MachDesc
-import Maybes ( maybeToBool, Maybe(..) )
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Stix
-import UniqSupply
-import Unpretty
-import Util
-
+module StixInfo ( genCodeInfoTable ) where
+
+import Ubiq{-uitious-}
+
+import AbsCSyn ( AbstractC(..), CAddrMode, ReturnInfo,
+ RegRelative, MagicId, CStmtMacro
+ )
+import ClosureInfo ( closurePtrsSize, closureSizeWithoutFixedHdr,
+ closureNonHdrSize, closureSemiTag, maybeSelectorInfo,
+ closureSMRep, closureLabelFromCI,
+ infoTableLabelFromCI
+ )
+import HeapOffs ( hpRelToInt )
+import Maybes ( maybeToBool )
+import PrimRep ( PrimRep(..) )
+import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
+ isSpecRep
+ )
+import Stix -- all of it
+import StixPrim ( amodeToStix )
+import UniqSupply ( returnUs, UniqSM(..) )
+import Unpretty ( uppBesides, uppPStr, uppInt, uppChar )
\end{code}
Generating code for info tables (arrays of data).
@@ -36,14 +44,11 @@ data___rtbl = sStLitLbl SLIT("Data___rtbl")
dyn___rtbl = sStLitLbl SLIT("Dyn___rtbl")
genCodeInfoTable
- :: {-Target-}
- (HeapOffset -> Int) -- needed bit of Target
- -> (CAddrMode -> StixTree) -- ditto
- -> AbstractC
+ :: AbstractC
-> UniqSM StixTreeList
-genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr _) =
- returnUs (\xs -> info : lbl : xs)
+genCodeInfoTable (CClosureInfoAndCode cl_info _ _ upd cl_descr _)
+ = returnUs (\xs -> info : lbl : xs)
where
info = StData PtrRep table
@@ -133,11 +138,10 @@ genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr
size = if isSpecRep sm_rep
then closureNonHdrSize cl_info
- else hp_rel (closureSizeWithoutFixedHdr cl_info)
+ else hpRelToInt (closureSizeWithoutFixedHdr cl_info)
ptrs = closurePtrsSize cl_info
- upd_code = amode2stix upd
+ upd_code = amodeToStix upd
info_unused = StInt (-1)
-
\end{code}
diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index 91d68d0cd2fb53b6b21f57100bc086f602c3620a..fe9ec744e88a481891e457ae9ae7bb9d763b37b6 100644
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -1,38 +1,41 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\begin{code}
#include "HsVersions.h"
module StixInteger (
- gmpTake1Return1, gmpTake2Return1, gmpTake2Return2,
- gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
+ gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare,
+ gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
encodeFloatingKind, decodeFloatingKind
) where
-IMPORT_Trace -- ToDo: rm debugging
-
-import AbsCSyn
-import CgCompInfo ( mIN_MP_INT_SIZE )
-import MachDesc
-import Pretty
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind(..) )
-import Stix
-import UniqSupply
-import Util
-
+import Ubiq{-uitous-}
+import NcgLoop ( amodeToStix )
+
+import MachMisc
+import MachRegs
+
+import AbsCSyn -- bits and bobs...
+import CgCompInfo ( mIN_MP_INT_SIZE )
+import Literal ( Literal(..) )
+import OrdList ( OrdList )
+import PrimOp ( PrimOp(..) )
+import PrimRep ( PrimRep(..) )
+import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
+import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim,
+ StixTree(..), StixTreeList(..),
+ CodeSegment, StixReg
+ )
+import StixMacro ( macroCode, heapCheck )
+import UniqSupply ( returnUs, thenUs, UniqSM(..) )
+import Util ( panic )
\end{code}
\begin{code}
-
gmpTake1Return1
- :: Target
- -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
+ :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
-> FAST_STRING -- function name
-> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
-- argument (4 parts)
@@ -47,124 +50,109 @@ init2 = StCall SLIT("mpz_init") VoidRep [result2]
init3 = StCall SLIT("mpz_init") VoidRep [result3]
init4 = StCall SLIT("mpz_init") VoidRep [result4]
--- hacking with Uncle Will:
-#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
-
-gmpTake1Return1 target_STRICT res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) =
- let
- a2stix = amodeToStix target
- data_hs = dataHS target
-
- ar = a2stix car
- sr = a2stix csr
- dr = a2stix cdr
- liveness= a2stix clive
- aa = a2stix caa
- sa = a2stix csa
- da = a2stix cda
-
- space = mpSpace data_hs 2 1 [sa]
+gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
+ = let
+ ar = amodeToStix car
+ sr = amodeToStix csr
+ dr = amodeToStix cdr
+ liveness= amodeToStix clive
+ aa = amodeToStix caa
+ sa = amodeToStix csa
+ da = amodeToStix cda
+
+ space = mpSpace 2 1 [sa]
oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
- safeHp = saveLoc target Hp
+ safeHp = saveLoc Hp
save = StAssign PtrRep safeHp oldHp
- (a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da)
+ (a1,a2,a3) = toStruct argument1 (aa,sa,da)
mpz_op = StCall rtn VoidRep [result2, argument1]
restore = StAssign PtrRep stgHp safeHp
- (r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr)
+ (r1,r2,r3) = fromStruct result2 (ar,sr,dr)
in
- heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
+ heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnUs (heap_chk .
- (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
+ returnUs (heap_chk .
+ (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
gmpTake2Return1
- :: Target
- -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
+ :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
-> FAST_STRING -- function name
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- liveness + 2 arguments (3 parts each)
-> UniqSM StixTreeList
-gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
- let
- a2stix = amodeToStix target
- data_hs = dataHS target
-
- ar = a2stix car
- sr = a2stix csr
- dr = a2stix cdr
- liveness= a2stix clive
- aa1 = a2stix caa1
- sa1 = a2stix csa1
- da1 = a2stix cda1
- aa2 = a2stix caa2
- sa2 = a2stix csa2
- da2 = a2stix cda2
-
- space = mpSpace data_hs 3 1 [sa1, sa2]
+gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
+ = let
+ ar = amodeToStix car
+ sr = amodeToStix csr
+ dr = amodeToStix cdr
+ liveness= amodeToStix clive
+ aa1 = amodeToStix caa1
+ sa1 = amodeToStix csa1
+ da1 = amodeToStix cda1
+ aa2 = amodeToStix caa2
+ sa2 = amodeToStix csa2
+ da2 = amodeToStix cda2
+
+ space = mpSpace 3 1 [sa1, sa2]
oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
- safeHp = saveLoc target Hp
+ safeHp = saveLoc Hp
save = StAssign PtrRep safeHp oldHp
- (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
restore = StAssign PtrRep stgHp safeHp
- (r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr)
+ (r1,r2,r3) = fromStruct result3 (ar,sr,dr)
in
- heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
+ heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnUs (heap_chk .
- (\xs -> a1 : a2 : a3 : a4 : a5 : a6
- : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
+ returnUs (heap_chk .
+ (\xs -> a1 : a2 : a3 : a4 : a5 : a6
+ : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
gmpTake2Return2
- :: Target
- -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ :: (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- 2 results (3 parts each)
-> FAST_STRING -- function name
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- liveness + 2 arguments (3 parts each)
-> UniqSM StixTreeList
-gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2)
- rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
- let
- a2stix = amodeToStix target
- data_hs = dataHS target
-
- ar1 = a2stix car1
- sr1 = a2stix csr1
- dr1 = a2stix cdr1
- ar2 = a2stix car2
- sr2 = a2stix csr2
- dr2 = a2stix cdr2
- liveness= a2stix clive
- aa1 = a2stix caa1
- sa1 = a2stix csa1
- da1 = a2stix cda1
- aa2 = a2stix caa2
- sa2 = a2stix csa2
- da2 = a2stix cda2
-
- space = StPrim IntMulOp [mpSpace data_hs 2 1 [sa1, sa2], StInt 2]
+gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2)
+ rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
+ = let
+ ar1 = amodeToStix car1
+ sr1 = amodeToStix csr1
+ dr1 = amodeToStix cdr1
+ ar2 = amodeToStix car2
+ sr2 = amodeToStix csr2
+ dr2 = amodeToStix cdr2
+ liveness= amodeToStix clive
+ aa1 = amodeToStix caa1
+ sa1 = amodeToStix csa1
+ da1 = amodeToStix cda1
+ aa2 = amodeToStix caa2
+ sa2 = amodeToStix csa2
+ da2 = amodeToStix cda2
+
+ space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2]
oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
- safeHp = saveLoc target Hp
+ safeHp = saveLoc Hp
save = StAssign PtrRep safeHp oldHp
- (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
restore = StAssign PtrRep stgHp safeHp
- (r1,r2,r3) = fromStruct data_hs result3 (ar1,sr1,dr1)
- (r4,r5,r6) = fromStruct data_hs result4 (ar2,sr2,dr2)
+ (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
+ (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
in
- heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk .
- (\xs -> a1 : a2 : a3 : a4 : a5 : a6
- : save : init3 : init4 : mpz_op
- : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
+ heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
+ returnUs (heap_chk .
+ (\xs -> a1 : a2 : a3 : a4 : a5 : a6
+ : save : init3 : init4 : mpz_op
+ : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
\end{code}
Although gmpCompare doesn't allocate space, it does temporarily use
@@ -173,92 +161,79 @@ enclosing routine has already guaranteed that this space will be
available. (See ``primOpHeapRequired.'')
\begin{code}
-
gmpCompare
- :: Target
- -> CAddrMode -- result (boolean)
+ :: CAddrMode -- result (boolean)
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- alloc hp + 2 arguments (3 parts each)
-> UniqSM StixTreeList
-gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
- let
- a2stix = amodeToStix target
- data_hs = dataHS target
-
- result = a2stix res
- hp = a2stix chp
- aa1 = a2stix caa1
- sa1 = a2stix csa1
- da1 = a2stix cda1
- aa2 = a2stix caa2
- sa2 = a2stix csa2
- da2 = a2stix cda2
+gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2)
+ = let
+ result = amodeToStix res
+ hp = amodeToStix chp
+ aa1 = amodeToStix caa1
+ sa1 = amodeToStix csa1
+ da1 = amodeToStix cda1
+ aa2 = amodeToStix caa2
+ sa2 = amodeToStix csa2
+ da2 = amodeToStix cda2
argument1 = hp
argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
- (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
r1 = StAssign IntRep result mpz_cmp
in
- returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
-
+ returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
\end{code}
See the comment above regarding the heap check (or lack thereof).
\begin{code}
-
gmpInteger2Int
- :: Target
- -> CAddrMode -- result
+ :: CAddrMode -- result
-> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
-> UniqSM StixTreeList
-gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) =
- let
- a2stix = amodeToStix target
- data_hs = dataHS target
+gmpInteger2Int res args@(chp, caa,csa,cda)
+ = let
+ result = amodeToStix res
+ hp = amodeToStix chp
+ aa = amodeToStix caa
+ sa = amodeToStix csa
+ da = amodeToStix cda
- result = a2stix res
- hp = a2stix chp
- aa = a2stix caa
- sa = a2stix csa
- da = a2stix cda
-
- (a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
+ (a1,a2,a3) = toStruct hp (aa,sa,da)
mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
r1 = StAssign IntRep result mpz_get_si
in
- returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
+ returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
+--------------
gmpInt2Integer
- :: Target
- -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
+ :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
-> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
-> UniqSM StixTreeList
-gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) =
- getUniqLabelNCG `thenUs` \ zlbl ->
+gmpInt2Integer res@(car,csr,cdr) args@(chp, n)
+ = getUniqLabelNCG `thenUs` \ zlbl ->
getUniqLabelNCG `thenUs` \ nlbl ->
getUniqLabelNCG `thenUs` \ jlbl ->
let
- a2stix = amodeToStix target
-
- ar = a2stix car
- sr = a2stix csr
- dr = a2stix cdr
- hp = a2stix chp
- i = a2stix n
+ ar = amodeToStix car
+ sr = amodeToStix csr
+ dr = amodeToStix cdr
+ hp = amodeToStix chp
+ i = amodeToStix n
h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
- size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE
+ size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE
h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
(StInt (toInteger size))
- cts = StInd IntRep (StIndex IntRep hp (dataHS target))
+ cts = StInd IntRep (StIndex IntRep hp dataHS)
test1 = StPrim IntEqOp [i, StInt 0]
test2 = StPrim IntLtOp [i, StInt 0]
cjmp1 = StCondJump zlbl test1
@@ -280,84 +255,75 @@ gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) =
a1 = StAssign IntRep ar (StInt 1)
a2 = StAssign PtrRep dr hp
in
- returnUs (\xs ->
- case n of
- CLit (MachInt c _) ->
- if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
- else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
- else h1 : h2 : n1 : n2 : a1 : a2 : xs
- _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
- : n0 : n1 : n2 : n3 : z0 : z1
- : a0 : a1 : a2 : xs)
+ returnUs (\xs ->
+ case n of
+ CLit (MachInt c _) ->
+ if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
+ else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
+ else h1 : h2 : n1 : n2 : a1 : a2 : xs
+ _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
+ : n0 : n1 : n2 : n3 : z0 : z1
+ : a0 : a1 : a2 : xs)
gmpString2Integer
- :: Target
- -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
+ :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
-> (CAddrMode, CAddrMode) -- liveness, string
-> UniqSM StixTreeList
-gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) =
- getUniqLabelNCG `thenUs` \ ulbl ->
+gmpString2Integer res@(car,csr,cdr) (liveness, str)
+ = getUniqLabelNCG `thenUs` \ ulbl ->
let
- a2stix = amodeToStix target
- data_hs = dataHS target
-
- ar = a2stix car
- sr = a2stix csr
- dr = a2stix cdr
+ ar = amodeToStix car
+ sr = amodeToStix csr
+ dr = amodeToStix cdr
len = case str of
(CString s) -> _LENGTH_ s
(CLit (MachStr s)) -> _LENGTH_ s
_ -> panic "String2Integer"
space = len `quot` 8 + 17 + mpIntSize +
- varHeaderSize target (DataRep 0) + fixedHeaderSize target
+ varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords
oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
- safeHp = saveLoc target Hp
+ safeHp = saveLoc Hp
save = StAssign PtrRep safeHp oldHp
result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
set_str = StCall SLIT("mpz_init_set_str") IntRep
- [result, a2stix str, StInt 10]
+ [result, amodeToStix str, StInt 10]
test = StPrim IntEqOp [set_str, StInt 0]
cjmp = StCondJump ulbl test
abort = StCall SLIT("abort") VoidRep []
join = StLabel ulbl
restore = StAssign PtrRep stgHp safeHp
- (a1,a2,a3) = fromStruct data_hs result (ar,sr,dr)
+ (a1,a2,a3) = fromStruct result (ar,sr,dr)
in
- macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
- `thenUs` \ heap_chk ->
+ macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
+ `thenUs` \ heap_chk ->
- returnUs (heap_chk .
- (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
+ returnUs (heap_chk .
+ (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
encodeFloatingKind
:: PrimRep
- -> Target
-> CAddrMode -- result
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- heap pointer for result, integer argument (3 parts), exponent
-> UniqSM StixTreeList
-encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
- let
- a2stix = amodeToStix target
- size_of = sizeof target
- data_hs = dataHS target
-
- result = a2stix res
- hp = a2stix chp
- aa = a2stix caa
- sa = a2stix csa
- da = a2stix cda
- expon = a2stix cexpon
-
- pk' = if size_of FloatRep == size_of DoubleRep
+encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
+ = let
+ result = amodeToStix res
+ hp = amodeToStix chp
+ aa = amodeToStix caa
+ sa = amodeToStix csa
+ da = amodeToStix cda
+ expon = amodeToStix cexpon
+
+ pk' = if sizeOf FloatRep == sizeOf DoubleRep
then DoubleRep
else pk
- (a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
+ (a1,a2,a3) = toStruct hp (aa,sa,da)
fn = case pk' of
FloatRep -> SLIT("__encodeFloat")
DoubleRep -> SLIT("__encodeDouble")
@@ -365,31 +331,26 @@ encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
encode = StCall fn pk' [hp, expon]
r1 = StAssign pk' result encode
in
- returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
+ returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
decodeFloatingKind
:: PrimRep
- -> Target
-> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
-- exponent result, integer result (3 parts)
-> (CAddrMode, CAddrMode)
-- heap pointer for exponent, floating argument
-> UniqSM StixTreeList
-decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
- let
- a2stix = amodeToStix target
- size_of = sizeof target
- data_hs = dataHS target
-
- exponr = a2stix cexponr
- ar = a2stix car
- sr = a2stix csr
- dr = a2stix cdr
- hp = a2stix chp
- arg = a2stix carg
-
- pk' = if size_of FloatRep == size_of DoubleRep
+decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
+ = let
+ exponr = amodeToStix cexponr
+ ar = amodeToStix car
+ sr = amodeToStix csr
+ dr = amodeToStix cdr
+ hp = amodeToStix chp
+ arg = amodeToStix carg
+
+ pk' = if sizeOf FloatRep == sizeOf DoubleRep
then DoubleRep
else pk
setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
@@ -398,10 +359,10 @@ decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
DoubleRep -> SLIT("__decodeDouble")
_ -> panic "decodeFloatingKind"
decode = StCall fn VoidRep [mantissa, hp, arg]
- (a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr)
+ (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
a4 = StAssign IntRep exponr (StInd IntRep hp)
in
- returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
+ returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
mpData_mantissa = mpData mantissa
@@ -410,7 +371,6 @@ mpData_mantissa = mpData mantissa
Support for the Gnu GMP multi-precision package.
\begin{code}
-
mpIntSize = 3 :: Int
mpAlloc, mpSize, mpData :: StixTree -> StixTree
@@ -419,57 +379,54 @@ mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
mpSpace
- :: StixTree -- dataHs from Target
- -> Int -- gmp structures needed
+ :: Int -- gmp structures needed
-> Int -- number of results
-> [StixTree] -- sizes to add for estimating result size
-> StixTree -- total space
-mpSpace data_hs gmp res sizes =
- foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
+mpSpace gmp res sizes
+ = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
where
sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
- hdrs = StPrim IntMulOp [data_hs, StInt (toInteger res)]
-
+ hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
\end{code}
-We don't have a truly portable way of allocating local temporaries, so we
-cheat and use space at the end of the heap. (Thus, negative offsets from
-HpLim are our temporaries.) Note that you must have performed a heap check
-which includes the space needed for these temporaries before you use them.
+We don't have a truly portable way of allocating local temporaries, so
+we cheat and use space at the end of the heap. (Thus, negative
+offsets from HpLim are our temporaries.) Note that you must have
+performed a heap check which includes the space needed for these
+temporaries before you use them.
\begin{code}
mpStruct :: Int -> StixTree
mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
toStruct
- :: StixTree -- dataHS, from Target
- -> StixTree
+ :: StixTree
-> (StixTree, StixTree, StixTree)
-> (StixTree, StixTree, StixTree)
-toStruct data_hs str (alloc,size,arr) =
- let
+toStruct str (alloc,size,arr)
+ = let
f1 = StAssign IntRep (mpAlloc str) alloc
f2 = StAssign IntRep (mpSize str) size
- f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr data_hs)
+ f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS)
in
- (f1, f2, f3)
+ (f1, f2, f3)
fromStruct
- :: StixTree -- dataHS, from Target
- -> StixTree
+ :: StixTree
-> (StixTree, StixTree, StixTree)
-> (StixTree, StixTree, StixTree)
-fromStruct data_hs str (alloc,size,arr) =
- let
+fromStruct str (alloc,size,arr)
+ = let
e1 = StAssign IntRep alloc (mpAlloc str)
e2 = StAssign IntRep size (mpSize str)
e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
- (StPrim IntNegOp [data_hs]))
+ (StPrim IntNegOp [dataHS]))
in
- (e1, e2, e3)
+ (e1, e2, e3)
\end{code}
diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index b244110f0277c3593c10937bd9506b3623dce014..4e7b47f8a0dfa1b1c5bd1f4c1ab714b004395214 100644
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -1,27 +1,27 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\begin{code}
#include "HsVersions.h"
-module StixMacro (
- genMacroCode, doHeapCheck, smStablePtrTable,
+module StixMacro ( macroCode, heapCheck ) where
- Target, StixTree, UniqSupply, CAddrMode, CExprMacro,
- CStmtMacro
- ) where
+import Ubiq{-uitious-}
+import NcgLoop ( amodeToStix )
-import AbsCSyn
-import PrelInfo ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import MachDesc {- lots -}
-import CgCompInfo ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE )
+import MachMisc
+import MachRegs
+
+import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
+import CgCompInfo ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
+ sTD_UF_SIZE
+ )
+import OrdList ( OrdList )
+import PrimOp ( PrimOp(..) )
+import PrimRep ( PrimRep(..) )
import Stix
-import UniqSupply
-import Util
+import UniqSupply ( returnUs, thenUs, UniqSM(..) )
\end{code}
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
@@ -33,43 +33,31 @@ closure address.
mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
mkIntCLit_3 = mkIntCLit 3
--- hacking with Uncle Will:
-#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
-
-genMacroCode
- :: Target
- -> CStmtMacro -- statement macro
+macroCode
+ :: CStmtMacro -- statement macro
-> [CAddrMode] -- args
-> UniqSM StixTreeList
-genMacroCode target_STRICT macro args
- = genmacro macro args
- where
- a2stix = amodeToStix target
- stg_reg = stgReg target
-
- -- real thing: here we go -----------------------
-
- genmacro ARGS_CHK_A_LOAD_NODE args =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let [words, lbl] = map a2stix args
- temp = StIndex PtrRep stgSpA words
- test = StPrim AddrGeOp [stgSuA, temp]
- cjmp = StCondJump ulbl test
- assign = StAssign PtrRep stgNode lbl
- join = StLabel ulbl
+macroCode ARGS_CHK_A_LOAD_NODE args
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let
+ [words, lbl] = map amodeToStix args
+ temp = StIndex PtrRep stgSpA words
+ test = StPrim AddrGeOp [stgSuA, temp]
+ cjmp = StCondJump ulbl test
+ assign = StAssign PtrRep stgNode lbl
+ join = StLabel ulbl
in
- returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
+ returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
- genmacro ARGS_CHK_A [words] =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let temp = StIndex PtrRep stgSpA (a2stix words)
+macroCode ARGS_CHK_A [words]
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let temp = StIndex PtrRep stgSpA (amodeToStix words)
test = StPrim AddrGeOp [stgSuA, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
- returnUs (\xs -> cjmp : updatePAP : join : xs)
-
+ returnUs (\xs -> cjmp : updatePAP : join : xs)
\end{code}
Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
@@ -79,43 +67,43 @@ also loads R1 with an appropriate closure address. Note that the
directions are swapped relative to the A stack.
\begin{code}
-
- genmacro ARGS_CHK_B_LOAD_NODE args =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let [words, lbl] = map a2stix args
+macroCode ARGS_CHK_B_LOAD_NODE args
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let
+ [words, lbl] = map amodeToStix args
temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
test = StPrim AddrGeOp [stgSpB, temp]
cjmp = StCondJump ulbl test
assign = StAssign PtrRep stgNode lbl
join = StLabel ulbl
in
- returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
+ returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
- genmacro ARGS_CHK_B [words] =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let temp = StIndex PtrRep stgSuB (StPrim IntNegOp [a2stix words])
+macroCode ARGS_CHK_B [words]
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let
+ temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
test = StPrim AddrGeOp [stgSpB, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
- returnUs (\xs -> cjmp : updatePAP : join : xs)
-
+ returnUs (\xs -> cjmp : updatePAP : join : xs)
\end{code}
The @HEAP_CHK@ macro checks to see that there are enough words
available in the heap (before reaching @HpLim@). When a heap check
fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The
-call wrapper saves all of our volatile registers so that we don't have to.
+call wrapper saves all of our volatile registers so that we don't have
+to.
-Since there are @HEAP_CHK@s buried at unfortunate places in the integer
-primOps, this is just a wrapper.
+Since there are @HEAP_CHK@s buried at unfortunate places in the
+integer primOps, this is just a wrapper.
\begin{code}
-
- genmacro HEAP_CHK args =
- let [liveness,words,reenter] = map a2stix args
+macroCode HEAP_CHK args
+ = let [liveness,words,reenter] = map amodeToStix args
in
- doHeapCheck liveness words reenter
+ heapCheck liveness words reenter
\end{code}
The @STK_CHK@ macro checks for enough space on the stack between @SpA@
@@ -125,12 +113,12 @@ enough space to continue. Not that @_StackOverflow@ doesn't return,
so we don't have to @callWrapper@ it.
\begin{code}
-
- genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
+macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter]
+ =
{- Need to check to see if we are compiling with stack checks
- getUniqLabelNCG `thenUs` \ ulbl ->
+ getUniqLabelNCG `thenUs` \ ulbl ->
let words = StPrim IntNegOp
- [StPrim IntAddOp [a2stix aWords, a2stix bWords]]
+ [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]]
temp = StIndex PtrRep stgSpA words
test = StPrim AddrGtOp [temp, stgSpB]
cjmp = StCondJump ulbl test
@@ -139,16 +127,16 @@ so we don't have to @callWrapper@ it.
returnUs (\xs -> cjmp : stackOverflow : join : xs)
-}
returnUs id
-
\end{code}
-@UPD_CAF@ involves changing the info pointer of the closure, adding an indirection,
-and putting the new CAF on a linked list for the storage manager.
+@UPD_CAF@ involves changing the info pointer of the closure, adding an
+indirection, and putting the new CAF on a linked list for the storage
+manager.
\begin{code}
-
- genmacro UPD_CAF args =
- let [cafptr,bhptr] = map a2stix args
+macroCode UPD_CAF args
+ = let
+ [cafptr,bhptr] = map amodeToStix args
w0 = StInd PtrRep cafptr
w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
@@ -157,8 +145,7 @@ and putting the new CAF on a linked list for the storage manager.
a3 = StAssign PtrRep w2 bhptr
a4 = StAssign PtrRep smCAFlist cafptr
in
- returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
-
+ returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
\end{code}
@UPD_IND@ is complicated by the fact that we are supporting the
@@ -166,10 +153,10 @@ Appel-style garbage collector by default. This means some extra work
if we update an old generation object.
\begin{code}
-
- genmacro UPD_IND args =
- getUniqLabelNCG `thenUs` \ ulbl ->
- let [updptr, heapptr] = map a2stix args
+macroCode UPD_IND args
+ = getUniqLabelNCG `thenUs` \ ulbl ->
+ let
+ [updptr, heapptr] = map amodeToStix args
test = StPrim AddrGtOp [updptr, smOldLim]
cjmp = StCondJump ulbl test
updRoots = StAssign PtrRep smOldMutables updptr
@@ -180,26 +167,22 @@ if we update an old generation object.
upd2 = StAssign PtrRep (StInd PtrRep
(StIndex PtrRep updptr (StInt 2))) heapptr
in
- returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
-
+ returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
\end{code}
@UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
\begin{code}
-
- genmacro UPD_INPLACE_NOPTRS args = returnUs id
-
+macroCode UPD_INPLACE_NOPTRS args = returnUs id
\end{code}
@UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
-the Appel-style garbage collector by default. This means some extra work
-if we update an old generation object.
+the Appel-style garbage collector by default. This means some extra
+work if we update an old generation object.
\begin{code}
-
- genmacro UPD_INPLACE_PTRS [liveness] =
- getUniqLabelNCG `thenUs` \ ulbl ->
+macroCode UPD_INPLACE_PTRS [liveness]
+ = getUniqLabelNCG `thenUs` \ ulbl ->
let cjmp = StCondJump ulbl testOldLim
testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
join = StLabel ulbl
@@ -212,12 +195,11 @@ if we update an old generation object.
updOldMutables = StAssign PtrRep smOldMutables stgNode
updUpdReg = StAssign PtrRep stgNode hpBack2
in
- genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
- `thenUs` \ heap_chk ->
- returnUs (\xs -> (cjmp :
- heap_chk (updUpd0 : updUpd1 : updUpd2 :
- updOldMutables : updUpdReg : join : xs)))
-
+ macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
+ `thenUs` \ heap_chk ->
+ returnUs (\xs -> (cjmp :
+ heap_chk (updUpd0 : updUpd1 : updUpd2 :
+ updOldMutables : updUpdReg : join : xs)))
\end{code}
@UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
@@ -225,24 +207,22 @@ the sequential case, the GC takes care of this). However, we do need
to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
\begin{code}
+macroCode UPD_BH_UPDATABLE args = returnUs id
- genmacro UPD_BH_UPDATABLE args = returnUs id
-
- genmacro UPD_BH_SINGLE_ENTRY [arg] =
- let
- update = StAssign PtrRep (StInd PtrRep (a2stix arg)) bh_info
+macroCode UPD_BH_SINGLE_ENTRY [arg]
+ = let
+ update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
in
- returnUs (\xs -> update : xs)
-
+ returnUs (\xs -> update : xs)
\end{code}
Push a four word update frame on the stack and slide the Su[AB]
registers to the current Sp[AB] locations.
\begin{code}
-
- genmacro PUSH_STD_UPD_FRAME args =
- let [bhptr, aWords, bWords] = map a2stix args
+macroCode PUSH_STD_UPD_FRAME args
+ = let
+ [bhptr, aWords, bWords] = map amodeToStix args
frame n = StInd PtrRep
(StIndex PtrRep stgSpB (StPrim IntAddOp
[bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
@@ -258,16 +238,15 @@ registers to the current Sp[AB] locations.
updSuA = StAssign PtrRep
stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
in
- returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
-
+ returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
\end{code}
Pop a standard update frame.
\begin{code}
-
- genmacro POP_STD_UPD_FRAME args =
- let frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
+macroCode POP_STD_UPD_FRAME args
+ = let
+ frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
grabSuB = StAssign PtrRep stgSuB (frame uF_SUB)
@@ -276,41 +255,38 @@ Pop a standard update frame.
updSpB = StAssign PtrRep
stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
in
- returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
-
+ returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
\end{code}
The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal''
compilation.
\begin{code}
- genmacro SET_ARITY args = returnUs id
- genmacro CHK_ARITY args = returnUs id
+macroCode SET_ARITY args = returnUs id
+macroCode CHK_ARITY args = returnUs id
\end{code}
This one only applies if we have a machine register devoted to TagReg.
\begin{code}
- genmacro SET_TAG [tag] =
- let set_tag = StAssign IntRep stgTagReg (a2stix tag)
+macroCode SET_TAG [tag]
+ = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
in
- case stg_reg TagReg of
- Always _ -> returnUs id
- Save _ -> returnUs (\ xs -> set_tag : xs)
+ case stgReg TagReg of
+ Always _ -> returnUs id
+ Save _ -> returnUs (\ xs -> set_tag : xs)
\end{code}
Do the business for a @HEAP_CHK@, having converted the args to Trees
of StixOp.
\begin{code}
-
-doHeapCheck
- :: {- unused now: Target
- -> -}StixTree -- liveness
+heapCheck
+ :: StixTree -- liveness
-> StixTree -- words needed
-> StixTree -- always reenter node? (boolean)
-> UniqSM StixTreeList
-doHeapCheck {-target:unused now-} liveness words reenter =
- getUniqLabelNCG `thenUs` \ ulbl ->
+heapCheck liveness words reenter
+ = getUniqLabelNCG `thenUs` \ ulbl ->
let newHp = StIndex PtrRep stgHp words
assign = StAssign PtrRep stgHp newHp
test = StPrim AddrLeOp [stgHp, stgHpLim]
@@ -320,14 +296,12 @@ doHeapCheck {-target:unused now-} liveness words reenter =
gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
join = StLabel ulbl
in
- returnUs (\xs -> assign : cjmp : gc : join : xs)
-
+ returnUs (\xs -> assign : cjmp : gc : join : xs)
\end{code}
Let's make sure that these CAFs are lifted out, shall we?
\begin{code}
-
-- Some common labels
bh_info, caf_info, ind_info :: StixTree
@@ -342,34 +316,4 @@ updatePAP, stackOverflow :: StixTree
updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
stackOverflow = StCall SLIT("StackOverflow") VoidRep []
-
-\end{code}
-
-Storage manager nonsense. Note that the indices are dependent on
-the definition of the smInfo structure in SMinterface.lh
-
-\begin{code}
-
-#include "../../includes/platform.h"
-
-#if alpha_TARGET_ARCH
-#include "../../includes/alpha-dec-osf1.h"
-#else
-#if sunos4_TARGET_OS
-#include "../../includes/sparc-sun-sunos4.h"
-#else
-#include "../../includes/sparc-sun-solaris2.h"
-#endif
-#endif
-
-storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
-
-storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
-smCAFlist = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST))
-smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES))
-smOldLim = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM))
-
-smStablePtrTable = StInd PtrRep
- (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
-
\end{code}
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index e566c7b5e724f58d12bd674cecb70ce0427506e9..d8e1bf61540f775d6e293da5cc6a7c2a29ce3d98 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -1,190 +1,171 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\begin{code}
#include "HsVersions.h"
-module StixPrim (
- genPrimCode, amodeCode, amodeCode',
+module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
- Target, CAddrMode, StixTree, PrimOp, UniqSupply
- ) where
+import Ubiq{-uitous-}
+import NcgLoop -- paranoia checking only
-IMPORT_Trace -- ToDo: rm debugging
+import MachMisc
+import MachRegs
import AbsCSyn
-import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), TyCon,
- getPrimOpResultInfo, isCompareOp, showPrimOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
+import AbsCUtils ( getAmodeRep, mixedTypeLocn )
import CgCompInfo ( spARelToInt, spBRelToInt )
-import MachDesc
-import Pretty
-import PrimRep ( isFloatingRep )
-import CostCentre
-import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
+import CostCentre ( noCostCentreAttached )
+import HeapOffs ( hpRelToInt, subOff )
+import Literal ( Literal(..) )
+import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
+ getPrimOpResultInfo, PrimOpResultInfo(..)
+ )
+import PrimRep ( PrimRep(..), isFloatingRep )
+import OrdList ( OrdList )
+import PprStyle ( PprStyle(..) )
+import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
import Stix
-import StixMacro ( smStablePtrTable )
+import StixMacro ( heapCheck, smStablePtrTable )
import StixInteger {- everything -}
-import UniqSupply
-import Unpretty
-import Util
-
+import UniqSupply ( returnUs, thenUs, UniqSM(..) )
+import Unpretty ( uppBeside, uppPStr, uppInt )
+import Util ( panic )
\end{code}
-The main honcho here is genPrimCode, which handles the guts of COpStmts.
+The main honcho here is primCode, which handles the guts of COpStmts.
\begin{code}
arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
-genPrimCode
- :: Target
- -> [CAddrMode] -- results
+primCode
+ :: [CAddrMode] -- results
-> PrimOp -- op
-> [CAddrMode] -- args
-> UniqSM StixTreeList
-
\end{code}
First, the dreaded @ccall@. We can't handle @casm@s.
-Usually, this compiles to an assignment, but when the left-hand side is
-empty, we just perform the call and ignore the result.
+Usually, this compiles to an assignment, but when the left-hand side
+is empty, we just perform the call and ignore the result.
ToDo ADR: modify this to handle Malloc Ptrs.
btw Why not let programmer use casm to provide assembly code instead
of C code? ADR
-\begin{code}
--- hacking with Uncle Will:
-#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
-
-genPrimCode target_STRICT res op args
- = genprim res op args
- where
- a2stix = amodeToStix target
- a2stix' = amodeToStix' target
- mut_hs = mutHS target
- data_hs = dataHS target
- heap_chkr = heapCheck target
- size_of = sizeof target
- fixed_hs = fixedHeaderSize target
- var_hs = varHeaderSize target
-
- --- real code will follow... -------------
-\end{code}
-
-The (MP) integer operations are a true nightmare. Since we don't have a
-convenient abstract way of allocating temporary variables on the (C) stack,
-we use the space just below HpLim for the @MP_INT@ structures, and modify our
-heap check accordingly.
+The (MP) integer operations are a true nightmare. Since we don't have
+a convenient abstract way of allocating temporary variables on the (C)
+stack, we use the space just below HpLim for the @MP_INT@ structures,
+and modify our heap check accordingly.
\begin{code}
- -- NB: ordering of clauses somewhere driven by
- -- the desire to getting sane patt-matching behavior
-
- genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
- IntegerQuotRemOp
- args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
- genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
- IntegerDivModOp
- args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
- genprim res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
- genprim res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
- genprim res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
- gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
-
- genprim res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] =
- gmpTake1Return1 target (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
+-- NB: ordering of clauses somewhere driven by
+-- the desire to getting sane patt-matching behavior
+
+primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
+ IntegerQuotRemOp
+ args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
+ IntegerDivModOp
+ args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
+ = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
\end{code}
-Since we are using the heap for intermediate @MP_INT@ structs, integer comparison
-{\em does} require a heap check in the native code implementation.
+Since we are using the heap for intermediate @MP_INT@ structs, integer
+comparison {\em does} require a heap check in the native code
+implementation.
\begin{code}
- genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] =
- decodeFloatingKind FloatRep target (exponr,ar,sr,dr) (hp, arg)
-
- genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] =
- decodeFloatingKind DoubleRep target (exponr,ar,sr,dr) (hp, arg)
+primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
+ = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
- genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
- = gmpInt2Integer target (ar,sr,dr) (hp, n)
+primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
+ = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
- genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
- = gmpString2Integer target (ar,sr,dr) (liveness,str)
+primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
+ = gmpInt2Integer (ar,sr,dr) (hp, n)
- genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
- = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2)
+primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
+ = gmpString2Integer (ar,sr,dr) (liveness,str)
- genprim [res] Integer2IntOp arg@[hp, aa,sa,da]
- = gmpInteger2Int target res (hp, aa,sa,da)
+primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
- genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] =
- encodeFloatingKind FloatRep target res (hp, aa,sa,da, expon)
+primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
+ = gmpInteger2Int res (hp, aa,sa,da)
- genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] =
- encodeFloatingKind DoubleRep target res (hp, aa,sa,da, expon)
+primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
+ = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
- genprim [res] Int2AddrOp [arg] =
- simpleCoercion AddrRep res arg
+primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
+ = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
- genprim [res] Addr2IntOp [arg] =
- simpleCoercion IntRep res arg
+primCode [res] Int2AddrOp [arg]
+ = simpleCoercion AddrRep res arg
- genprim [res] Int2WordOp [arg] =
- simpleCoercion IntRep{-WordRep?-} res arg
+primCode [res] Addr2IntOp [arg]
+ = simpleCoercion IntRep res arg
- genprim [res] Word2IntOp [arg] =
- simpleCoercion IntRep res arg
+primCode [res] Int2WordOp [arg]
+ = simpleCoercion IntRep{-WordRep?-} res arg
+primCode [res] Word2IntOp [arg]
+ = simpleCoercion IntRep res arg
\end{code}
-The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root
-closure, flush stdout and stderr, and jump to the @ErrorIO_innards@.
+The @ErrorIO@ primitive is actually a bit weird...assign a new value
+to the root closure, flush stdout and stderr, and jump to the
+@ErrorIO_innards@.
\begin{code}
-
- genprim [] ErrorIOPrimOp [rhs] =
- let changeTop = StAssign PtrRep topClosure (a2stix rhs)
+primCode [] ErrorIOPrimOp [rhs]
+ = let
+ changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
in
- returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
-
+ returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
\end{code}
@newArray#@ ops allocate heap space.
\begin{code}
- genprim [res] NewArrayOp args =
- let [liveness, n, initial] = map a2stix args
- result = a2stix res
- space = StPrim IntAddOp [n, mut_hs]
+primCode [res] NewArrayOp args
+ = let
+ [liveness, n, initial] = map amodeToStix args
+ result = amodeToStix res
+ space = StPrim IntAddOp [n, mutHS]
loc = StIndex PtrRep stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
assign = StAssign PtrRep result loc
initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
in
- heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk ->
-
- returnUs (heap_chk . (\xs -> assign : initialise : xs))
-
- genprim [res] (NewByteArrayOp pk) args =
- let [liveness, count] = map a2stix args
- result = a2stix res
- n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))]
- slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntRep - 1))]
- words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntRep))]
- space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]]
+ heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
+
+ returnUs (heap_chk . (\xs -> assign : initialise : xs))
+
+primCode [res] (NewByteArrayOp pk) args
+ = let
+ [liveness, count] = map amodeToStix args
+ result = amodeToStix res
+ n = StPrim IntMulOp [count, StInt (sizeOf pk)]
+ slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
+ words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
+ space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
loc = StIndex PtrRep stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
assign = StAssign PtrRep result loc
@@ -192,117 +173,121 @@ closure, flush stdout and stderr, and jump to the @ErrorIO_innards@.
init2 = StAssign IntRep
(StInd IntRep
(StIndex IntRep loc
- (StInt (toInteger fixed_hs))))
+ (StInt (toInteger fixedHdrSizeInWords))))
(StPrim IntAddOp [words,
- StInt (toInteger (var_hs (DataRep 0)))])
+ StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
in
- heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk ->
+ heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
+ returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
- genprim [res] SameMutableArrayOp args =
- let compare = StPrim AddrEqOp (map a2stix args)
- assign = StAssign IntRep (a2stix res) compare
+primCode [res] SameMutableArrayOp args
+ = let
+ compare = StPrim AddrEqOp (map amodeToStix args)
+ assign = StAssign IntRep (amodeToStix res) compare
in
- returnUs (\xs -> assign : xs)
-
- genprim res@[_] SameMutableByteArrayOp args =
- genprim res SameMutableArrayOp args
+ returnUs (\xs -> assign : xs)
+primCode res@[_] SameMutableByteArrayOp args
+ = primCode res SameMutableArrayOp args
\end{code}
-Freezing an array of pointers is a double assignment. We fix the header of
-the ``new'' closure because the lhs is probably a better addressing mode for
-the indirection (most likely, it's a VanillaReg).
+Freezing an array of pointers is a double assignment. We fix the
+header of the ``new'' closure because the lhs is probably a better
+addressing mode for the indirection (most likely, it's a VanillaReg).
\begin{code}
- genprim [lhs] UnsafeFreezeArrayOp [rhs] =
- let lhs' = a2stix lhs
- rhs' = a2stix rhs
+primCode [lhs] UnsafeFreezeArrayOp [rhs]
+ = let
+ lhs' = amodeToStix lhs
+ rhs' = amodeToStix rhs
header = StInd PtrRep lhs'
assign = StAssign PtrRep lhs' rhs'
freeze = StAssign PtrRep header imMutArrayOfPtrs_info
in
- returnUs (\xs -> assign : freeze : xs)
-
- genprim [lhs] UnsafeFreezeByteArrayOp [rhs] =
- simpleCoercion PtrRep lhs rhs
+ returnUs (\xs -> assign : freeze : xs)
+primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
+ = simpleCoercion PtrRep lhs rhs
\end{code}
Most other array primitives translate to simple indexing.
\begin{code}
- genprim lhs@[_] IndexArrayOp args =
- genprim lhs ReadArrayOp args
+primCode lhs@[_] IndexArrayOp args
+ = primCode lhs ReadArrayOp args
- genprim [lhs] ReadArrayOp [obj, ix] =
- let lhs' = a2stix lhs
- obj' = a2stix obj
- ix' = a2stix ix
- base = StIndex IntRep obj' mut_hs
+primCode [lhs] ReadArrayOp [obj, ix]
+ = let
+ lhs' = amodeToStix lhs
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ base = StIndex IntRep obj' mutHS
assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
in
- returnUs (\xs -> assign : xs)
-
- genprim [lhs] WriteArrayOp [obj, ix, v] =
- let obj' = a2stix obj
- ix' = a2stix ix
- v' = a2stix v
- base = StIndex IntRep obj' mut_hs
+ returnUs (\xs -> assign : xs)
+
+primCode [lhs] WriteArrayOp [obj, ix, v]
+ = let
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ v' = amodeToStix v
+ base = StIndex IntRep obj' mutHS
assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
in
- returnUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
- genprim lhs@[_] (IndexByteArrayOp pk) args =
- genprim lhs (ReadByteArrayOp pk) args
+primCode lhs@[_] (IndexByteArrayOp pk) args
+ = primCode lhs (ReadByteArrayOp pk) args
-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
- genprim [lhs] (ReadByteArrayOp pk) [obj, ix] =
- let lhs' = a2stix lhs
- obj' = a2stix obj
- ix' = a2stix ix
- base = StIndex IntRep obj' data_hs
+primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
+ = let
+ lhs' = amodeToStix lhs
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ base = StIndex IntRep obj' dataHS
assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
in
- returnUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
- genprim [lhs] (IndexOffAddrOp pk) [obj, ix] =
- let lhs' = a2stix lhs
- obj' = a2stix obj
- ix' = a2stix ix
+primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
+ = let
+ lhs' = amodeToStix lhs
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
in
- returnUs (\xs -> assign : xs)
-
- genprim [] (WriteByteArrayOp pk) [obj, ix, v] =
- let obj' = a2stix obj
- ix' = a2stix ix
- v' = a2stix v
- base = StIndex IntRep obj' data_hs
+ returnUs (\xs -> assign : xs)
+
+primCode [] (WriteByteArrayOp pk) [obj, ix, v]
+ = let
+ obj' = amodeToStix obj
+ ix' = amodeToStix ix
+ v' = amodeToStix v
+ base = StIndex IntRep obj' dataHS
assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
in
- returnUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
\end{code}
Stable pointer operations.
First the easy one.
-
\begin{code}
- genprim [lhs] DeRefStablePtrOp [sp] =
- let lhs' = a2stix lhs
+primCode [lhs] DeRefStablePtrOp [sp]
+ = let
+ lhs' = amodeToStix lhs
pk = getAmodeRep lhs
- sp' = a2stix sp
+ sp' = amodeToStix sp
call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
assign = StAssign pk lhs' call
in
- returnUs (\xs -> assign : xs)
-
+ returnUs (\xs -> assign : xs)
\end{code}
Now the hard one. For comparison, here's the code from StgMacros:
@@ -349,8 +334,8 @@ Notes for ADR:
--JSM
\begin{pseudocode}
- genprim [lhs] MakeStablePtrOp args =
- let
+primCode [lhs] MakeStablePtrOp args
+ = let
-- some useful abbreviations (I'm sure these must exist already)
add = trPrim . IntAddOp
sub = trPrim . IntSubOp
@@ -359,7 +344,7 @@ Notes for ADR:
inc x = trAssign IntRep [x, add [x, one]]
-- tedious hardwiring in of closure layout offsets (from SMClosures)
- dynHS = 2 + fixedHeaderSize md sty + varHeaderSize md sty DynamicRep
+ dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
@@ -380,8 +365,8 @@ Notes for ADR:
]
-- now to get down to business
- lhs' = amodeCode sty md lhs
- [liveness, unstable] = map (amodeCode sty md) args
+ lhs' = amodeCode lhs
+ [liveness, unstable] = map amodeCode args
spt = smStablePtrTable
@@ -408,81 +393,81 @@ Notes for ADR:
\end{pseudocode}
\begin{code}
- genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
-
- genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
- | is_asm = error "ERROR: Native code generator can't handle casm"
- | otherwise =
- case lhs of
- [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
- [lhs] ->
- let lhs' = a2stix lhs
- pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
- call = StAssign pk lhs' (StCall fn pk args)
- in
- returnUs (\xs -> call : xs)
- where
- args = map amodeCodeForCCall rhs
- amodeCodeForCCall x =
- let base = a2stix' x
- in
- case getAmodeRep x of
- ArrayRep -> StIndex PtrRep base mut_hs
- ByteArrayRep -> StIndex IntRep base data_hs
- MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
- _ -> base
+primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
+
+primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
+ | is_asm = error "ERROR: Native code generator can't handle casm"
+ | otherwise
+ = case lhs of
+ [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
+ [lhs] ->
+ let lhs' = amodeToStix lhs
+ pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
+ call = StAssign pk lhs' (StCall fn pk args)
+ in
+ returnUs (\xs -> call : xs)
+ where
+ args = map amodeCodeForCCall rhs
+ amodeCodeForCCall x =
+ let base = amodeToStix' x
+ in
+ case getAmodeRep x of
+ ArrayRep -> StIndex PtrRep base mutHS
+ ByteArrayRep -> StIndex IntRep base dataHS
+ MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
+ _ -> base
\end{code}
Now the more mundane operations.
\begin{code}
- genprim lhs op rhs =
- let lhs' = map a2stix lhs
- rhs' = map a2stix' rhs
+primCode lhs op rhs
+ = let
+ lhs' = map amodeToStix lhs
+ rhs' = map amodeToStix' rhs
in
- returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
-
- {-
- simpleCoercion
- :: Target
- -> PrimRep
- -> [CAddrMode]
- -> [CAddrMode]
+ returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
+\end{code}
+
+\begin{code}
+simpleCoercion
+ :: PrimRep
+ -> CAddrMode
+ -> CAddrMode
-> UniqSM StixTreeList
- -}
- simpleCoercion pk lhs rhs =
- returnUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs)
+simpleCoercion pk lhs rhs
+ = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
\end{code}
-Here we try to rewrite primitives into a form the code generator
-can understand. Any primitives not handled here must be handled
-at the level of the specific code generator.
+Here we try to rewrite primitives into a form the code generator can
+understand. Any primitives not handled here must be handled at the
+level of the specific code generator.
\begin{code}
- {-
- simplePrim
- :: Target
- -> [StixTree]
+simplePrim
+ :: [StixTree]
-> PrimOp
-> [StixTree]
-> StixTree
- -}
\end{code}
Now look for something more conventional.
\begin{code}
-
- simplePrim [lhs] op rest = StAssign pk lhs (StPrim op rest)
- where pk = if isCompareOp op then IntRep
- else case getPrimOpResultInfo op of
- ReturnsPrim pk -> pk
- _ -> simplePrim_error op
-
- simplePrim _ op _ = simplePrim_error op
-
- simplePrim_error op
+simplePrim [lhs] op rest
+ = StAssign pk lhs (StPrim op rest)
+ where
+ pk = if isCompareOp op then
+ IntRep
+ else
+ case getPrimOpResultInfo op of
+ ReturnsPrim pk -> pk
+ _ -> simplePrim_error op
+
+simplePrim _ op _ = simplePrim_error op
+
+simplePrim_error op
= error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
\end{code}
@@ -490,120 +475,109 @@ Now look for something more conventional.
Here we generate the Stix code for CAddrModes.
-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
+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 -> StixTree
-amodeCode, amodeCode'
- :: Target
- -> CAddrMode
- -> StixTree
-
-amodeCode'{-'-} target_STRICT am@(CVal rr CharRep)
- | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am]
- | otherwise = amodeToStix target am
-
-amodeCode' target am = amodeToStix target am
+amodeToStix'{-'-} am@(CVal rr CharRep)
+ | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
+ | otherwise = amodeToStix am
-amodeCode target_STRICT am
- = acode am
- where
- -- grab "target" things:
- hp_rel = hpRel target
- char_like = charLikeClosureSize target
- int_like = intLikeClosureSize target
- a2stix = amodeToStix target
+amodeToStix' am = amodeToStix am
- -- real code: ----------------------------------
- acode am@(CVal rr CharRep) | mixedTypeLocn am =
- StInd IntRep (acode (CAddr rr))
+-----------
+amodeToStix am@(CVal rr CharRep)
+ | mixedTypeLocn am
+ = StInd IntRep (amodeToStix (CAddr rr))
- acode (CVal rr pk) = StInd pk (acode (CAddr rr))
+amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
- acode (CAddr (SpARel spA off)) =
- StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
+amodeToStix (CAddr (SpARel spA off))
+ = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
- acode (CAddr (SpBRel spB off)) =
- StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
+amodeToStix (CAddr (SpBRel spB off))
+ = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
- acode (CAddr (HpRel hp off)) =
- StIndex IntRep stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
+amodeToStix (CAddr (HpRel hp off))
+ = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
- acode (CAddr (NodeRel off)) =
- StIndex IntRep stgNode (StInt (toInteger (hp_rel off)))
+amodeToStix (CAddr (NodeRel off))
+ = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
- acode (CReg magic) = StReg (StixMagicId magic)
- acode (CTemp uniq pk) = StReg (StixTemp uniq pk)
+amodeToStix (CReg magic) = StReg (StixMagicId magic)
+amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
- acode (CLbl lbl _) = StCLbl lbl
+amodeToStix (CLbl lbl _) = StCLbl lbl
+amodeToStix (CUnVecLbl dir _) = StCLbl dir
- acode (CUnVecLbl dir _) = StCLbl dir
-
- acode (CTableEntry base off pk) =
- StInd pk (StIndex pk (acode base) (acode off))
+amodeToStix (CTableEntry base off pk)
+ = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
- acode (CCharLike (CLit (MachChar c))) =
- StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
- where off = char_like * ord c
+amodeToStix (CCharLike (CLit (MachChar c)))
+ = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
+ where
+ off = charLikeSize * ord c
- acode (CCharLike x) =
- StPrim IntAddOp [charLike, off]
- where off = StPrim IntMulOp [acode x,
- StInt (toInteger (char_like))]
+amodeToStix (CCharLike x)
+ = StPrim IntAddOp [charLike, off]
+ where
+ off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
- acode (CIntLike (CLit (MachInt i _))) =
- StPrim IntAddOp [intLikePtr, StInt off]
- where off = toInteger int_like * i
+amodeToStix (CIntLike (CLit (MachInt i _)))
+ = StPrim IntAddOp [intLikePtr, StInt off]
+ where
+ off = toInteger intLikeSize * i
- acode (CIntLike x) =
- StPrim IntAddOp [intLikePtr, off]
- where off = StPrim IntMulOp [acode x,
- StInt (toInteger int_like)]
+amodeToStix (CIntLike x)
+ = StPrim IntAddOp [intLikePtr, off]
+ where
+ off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
-- A CString is just a (CLit . MachStr)
- acode (CString s) = StString s
-
- acode (CLit core) = case core of
- (MachChar c) -> StInt (toInteger (ord c))
- (MachStr s) -> StString s
- (MachAddr a) -> StInt a
- (MachInt i _) -> StInt i
- (MachLitLit s _) -> StLitLit s
- (MachFloat d) -> StDouble d
- (MachDouble d) -> StDouble d
- _ -> panic "amodeCode:core literal"
+amodeToStix (CString s) = StString s
+
+amodeToStix (CLit core)
+ = case core of
+ MachChar c -> StInt (toInteger (ord c))
+ MachStr s -> StString s
+ MachAddr a -> StInt a
+ MachInt i _ -> StInt i
+ MachLitLit s _ -> StLitLit s
+ MachFloat d -> StDouble d
+ MachDouble d -> StDouble d
+ _ -> panic "amodeToStix:core literal"
-- A CLitLit is just a (CLit . MachLitLit)
- acode (CLitLit s _) = StLitLit s
+amodeToStix (CLitLit s _) = StLitLit s
-- COffsets are in words, not bytes!
- acode (COffset off) = StInt (toInteger (hp_rel off))
-
- acode (CMacroExpr _ macro [arg]) =
- case macro of
- INFO_PTR -> StInd PtrRep (a2stix arg)
- ENTRY_CODE -> a2stix arg
- INFO_TAG -> tag
- EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
+amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
+
+amodeToStix (CMacroExpr _ macro [arg])
+ = case macro of
+ INFO_PTR -> StInd PtrRep (amodeToStix arg)
+ ENTRY_CODE -> amodeToStix arg
+ INFO_TAG -> tag
+ EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
where
- tag = StInd IntRep (StIndex IntRep (a2stix arg) (StInt (-2)))
- -- That ``-2'' really bothers me. (JSM)
+ tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
+ -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
- acode (CCostCentre cc print_as_string)
- = if noCostCentreAttached cc
- then StComment SLIT("") -- sigh
- else panic "amodeCode:CCostCentre"
+amodeToStix (CCostCentre cc print_as_string)
+ = if noCostCentreAttached cc
+ then StComment SLIT("") -- sigh
+ else panic "amodeToStix:CCostCentre"
\end{code}
-Sizes of the CharLike and IntLike closures that are arranged as arrays in the
-data segment. (These are in bytes.)
+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
intLikePtr :: StixTree
@@ -624,6 +598,5 @@ topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
-
\end{code}
diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs
index 6a4066b412b31fa7ead799c61335c0bdfd928a2b..3600897768822afc2c6aedb337c9c9357327e8ae 100644
--- a/ghc/compiler/parser/UgenAll.lhs
+++ b/ghc/compiler/parser/UgenAll.lhs
@@ -13,7 +13,6 @@ module UgenAll (
U_constr.. ,
U_coresyn.. ,
U_entidt.. ,
- U_finfot.. ,
U_hpragma.. ,
U_list.. ,
U_literal.. ,
@@ -35,7 +34,6 @@ import U_binding
import U_constr
import U_coresyn
import U_entidt
-import U_finfot
import U_hpragma
import U_list
import U_literal
diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex
index 5cfe16d90c2d973234cdf5f12062e2ca7fcaec65..892d2f994e49d64d42d4c8ece2acdef206189429 100644
--- a/ghc/compiler/parser/hslexer.flex
+++ b/ghc/compiler/parser/hslexer.flex
@@ -50,13 +50,13 @@ static unsigned char CharTable[NCHARS] = {
/* dle */ 0, 0, 0, 0, 0, 0, 0, 0,
/* can */ 0, 0, 0, 0, 0, 0, 0, 0,
/* sp */ _S, 0, 0, 0, 0, 0, 0, 0,
-/* '(' */ _C, 0, 0, 0, 0, 0, 0, 0, /* ( */
+/* '(' */ _C, 0, 0, 0, 0, 0, 0, 0,
/* '0' */ _D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,
/* '8' */ _D|_H, _D|_H, _C, 0, 0, 0, 0, 0,
/* '@' */ 0, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _C,
/* 'H' */ _C, _C, _C, _C, _C, _C, _C, _C,
/* 'P' */ _C, _C, _C, _C, _C, _C, _C, _C,
-/* 'X' */ _C, _C, _C, _C, 0, 0, 0, 0, /* [ */
+/* 'X' */ _C, _C, _C, _C, 0, 0, 0, 0,
/* '`' */ 0, _H, _H, _H, _H, _H, _H, 0,
/* 'h' */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 'p' */ 0, 0, 0, 0, 0, 0, 0, 0,
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index a3e99174bca43c8aee93f3ae3252681563705b3f..0743c55b16fea7aed1b28cfa1b90d84ebc86a8bf 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -1662,6 +1662,7 @@ aexp : qvar { $$ = mkident($1); }
| gcon { $$ = mkident($1); }
| lit_constant { $$ = mklit($1); }
| OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */
+ | qcon OCURLY CCURLY { $$ = mkrecord($1,Lnil); }
| qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
| OBRACK list_exps CBRACK { $$ = mkllist($2); }
| OPAREN exp COMMA texps CPAREN { if (ttree($4) == tuple)
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 18d0e56dd0d1c20caf949b60abe5164b0e12a1d8..e60b8d6cc47296aff8450070a6f3dddd1d0a9136 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -101,7 +101,7 @@ import FiniteMap
import Id ( mkTupleCon, GenId{-instances-} )
import Name ( Name(..) )
import NameTypes ( mkPreludeCoreName, FullName, ShortName )
-import TyCon ( getTyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon{-instances-} )
+import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon{-instances-} )
import Type
import Unique -- *Key stuff
import Util ( nOfThem, panic )
@@ -401,5 +401,5 @@ pcTyConNameInfo tc = (getOccurrenceName tc, WiredInTyCon tc)
pcDataConNameInfo :: TyCon -> [(FAST_STRING, Name)]
pcDataConNameInfo tycon
= -- slurp out its data constructors...
- [ (getOccurrenceName con, WiredInVal con) | con <- getTyConDataCons tycon ]
+ [ (getOccurrenceName con, WiredInVal con) | con <- tyConDataCons tycon ]
\end{code}
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index 457d11b9ce456953c0051276400a34bbfa179c82..b4845f70bbca49fd8a2100f7972804b6867faa1b 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -10,6 +10,7 @@ module PrelVals where
import Ubiq
import IdLoop ( UnfoldingGuidance(..) )
+import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals )
import PrelLoop
-- friends:
@@ -29,13 +30,13 @@ import SpecEnv ( SpecEnv(..), nullSpecEnv )
import TyVar ( alphaTyVar, betaTyVar )
import Unique -- lots of *Keys
import Util ( panic )
+\end{code}
+
--- only used herein:
-mkPreludeId = panic "PrelVals:Id.mkPreludeId"
-mkSpecId = panic "PrelVals:Id.mkSpecId"
-mkTemplateLocals = panic "PrelVals:Id.mkTemplateLocals"
-specialiseTy = panic "PrelVals:specialiseTy"
+
+\begin{code}
+-- only used herein:
pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
pcMiscPrelId key mod name ty info
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 5dd0ccbb3f66a991d7f763f846b2031bcfbd46d2..0fd25b73a0eef3186b2785126a8adedb9bed5f25 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -11,22 +11,21 @@ module PrimOp (
tagOf_PrimOp, -- ToDo: rm
primOp_str, -- sigh
primOpType, isCompareOp,
+ commutableOp,
PrimOpResultInfo(..),
getPrimOpResultInfo,
---MOVE: primOpCanTriggerGC, primOpNeedsWrapper,
---MOVE: primOpOkForSpeculation, primOpIsCheap,
---MOVE: fragilePrimOp,
---MOVE: HeapRequirement(..), primOpHeapReq,
+ primOpCanTriggerGC, primOpNeedsWrapper,
+ primOpOkForSpeculation, primOpIsCheap,
+ fragilePrimOp,
+ HeapRequirement(..), primOpHeapReq,
-- export for the Native Code Generator
primOpInfo, -- needed for primOpNameInfo
PrimOpInfo(..),
pprPrimOp, showPrimOp
-
- -- and to make the interface self-sufficient....
) where
import Ubiq{-uitous-}
@@ -37,19 +36,19 @@ import TysWiredIn
import CStrings ( identToC )
import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
+import HeapOffs ( addOff, intOff, totHdrSize )
import NameTypes ( mkPreludeCoreName, FullName, ShortName )
import PprStyle ( codeStyle )
+import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import TyCon ( TyCon{-instances-} )
import Type ( getAppDataTyCon, maybeAppDataTyCon,
- mkForAllTys, mkFunTys, applyTyCon )
-import TyVar ( alphaTyVar, betaTyVar )
+ mkForAllTys, mkFunTys, applyTyCon, typePrimRep
+ )
+import TyVar ( alphaTyVar, betaTyVar, GenTyVar{-instance Eq-} )
+import Unique ( Unique{-instance Eq-} )
import Util ( panic#, assoc, panic{-ToDo:rm-} )
-
-glueTyArgs = panic "PrimOp:glueTyArgs"
-pprParendType = panic "PrimOp:pprParendType"
-primRepFromType = panic "PrimOp:primRepFromType"
\end{code}
%************************************************************************
@@ -1305,7 +1304,6 @@ unfortunate few, some unknown amount of heap is required (these are the
ops which can trigger GC).
\begin{code}
-{- MOVE:
data HeapRequirement
= NoHeapRequired
| FixedHeapRequired HeapOffset
@@ -1395,7 +1393,6 @@ primOpHeapReq ParLocalOp = trace "primOpHeapReq:ParLocalOp:verify!" (
#endif {-GRAN-}
primOpHeapReq other_op = NoHeapRequired
--}
\end{code}
Primops which can trigger GC have to be called carefully.
@@ -1403,9 +1400,8 @@ In particular, their arguments are guaranteed to be in registers,
and a liveness mask tells which regs are live.
\begin{code}
-{- MOVE:
-primOpCanTriggerGC op =
- case op of
+primOpCanTriggerGC op
+ = case op of
TakeMVarOp -> True
ReadIVarOp -> True
DelayOp -> True
@@ -1414,7 +1410,6 @@ primOpCanTriggerGC op =
case primOpHeapReq op of
VariableHeapRequired -> True
_ -> False
--}
\end{code}
Sometimes we may choose to execute a PrimOp even though it isn't
@@ -1429,7 +1424,6 @@ There should be no worries about side effects; that's all taken care
of by data dependencies.
\begin{code}
-{- MOVE:
primOpOkForSpeculation :: PrimOp -> Bool
-- Int.
@@ -1470,24 +1464,20 @@ primOpOkForSpeculation ParLocalOp = False -- Could be expensive!
-- The default is "yes it's ok for speculation"
primOpOkForSpeculation other_op = True
--}
\end{code}
@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK
WARNING), we just borrow some other predicates for a
what-should-be-good-enough test.
\begin{code}
-{-MOVE:
primOpIsCheap op
= primOpOkForSpeculation op && not (primOpCanTriggerGC op)
--}
\end{code}
And some primops have side-effects and so, for example, must not be
duplicated.
\begin{code}
-{- MOVE:
fragilePrimOp :: PrimOp -> Bool
fragilePrimOp ParOp = True
@@ -1504,14 +1494,12 @@ fragilePrimOp NoFollowOp = trace "fragilePrimOp:NoFollowOp" True -- Possibly no
#endif {-GRAN-}
fragilePrimOp other = False
--}
\end{code}
Primitive operations that perform calls need wrappers to save any live variables
that are stored in caller-saves registers
\begin{code}
-{- MOVE:
primOpNeedsWrapper :: PrimOp -> Bool
primOpNeedsWrapper (CCallOp _ _ _ _ _) = True
@@ -1574,7 +1562,6 @@ primOpNeedsWrapper DelayOp = True
primOpNeedsWrapper WaitOp = True
primOpNeedsWrapper other_op = False
--}
\end{code}
\begin{code}
@@ -1601,10 +1588,10 @@ primOpType op
Coerce str ty1 ty2 -> mkFunTys [ty1] ty2
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))
+ mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))
AlgResult str tyvars arg_tys tycon res_tys ->
- mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))
+ mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys))
\end{code}
\begin{code}
@@ -1619,10 +1606,10 @@ getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
getPrimOpResultInfo op
= case (primOpInfo op) of
- Dyadic _ ty -> ReturnsPrim (primRepFromType ty)
- Monadic _ ty -> ReturnsPrim (primRepFromType ty)
+ Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
+ Monadic _ ty -> ReturnsPrim (typePrimRep ty)
Compare _ ty -> ReturnsAlg boolTyCon
- Coerce _ _ ty -> ReturnsPrim (primRepFromType ty)
+ Coerce _ _ ty -> ReturnsPrim (typePrimRep ty)
PrimResult _ _ _ _ kind _ -> ReturnsPrim kind
AlgResult _ _ _ tycon _ -> ReturnsAlg tycon
@@ -1634,6 +1621,33 @@ isCompareOp op
_ -> False
\end{code}
+The commutable ops are those for which we will try to move constants
+to the right hand side for strength reduction.
+
+\begin{code}
+commutableOp :: PrimOp -> Bool
+
+commutableOp CharEqOp = True
+commutableOp CharNeOp = True
+commutableOp IntAddOp = True
+commutableOp IntMulOp = True
+commutableOp AndOp = True
+commutableOp OrOp = True
+commutableOp IntEqOp = True
+commutableOp IntNeOp = True
+commutableOp IntegerAddOp = True
+commutableOp IntegerMulOp = True
+commutableOp FloatAddOp = True
+commutableOp FloatMulOp = True
+commutableOp FloatEqOp = True
+commutableOp FloatNeOp = True
+commutableOp DoubleAddOp = True
+commutableOp DoubleMulOp = True
+commutableOp DoubleEqOp = True
+commutableOp DoubleNeOp = True
+commutableOp _ = False
+\end{code}
+
Utils:
\begin{code}
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
@@ -1662,8 +1676,8 @@ pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty)
pp_tys
= ppBesides [ppStr " { [",
- ppIntersperse pp'SP{-'-} (map (pprParendType sty) arg_tys),
- ppRbrack, ppSP, pprParendType sty res_ty, ppStr " })"]
+ ppIntersperse pp'SP{-'-} (map (pprParendGenType sty) arg_tys),
+ ppRbrack, ppSP, pprParendGenType sty res_ty, ppStr " })"]
in
ppBesides [ppStr before, ppPStr fun, after, pp_tys]
diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index c16c6b87b5f68195318e8ba82d8df3ec68bff42f..092a9f48daace44ce552195787b06b2169403dee 100644
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -17,8 +17,7 @@ import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind )
import NameTypes ( mkPreludeCoreName, FullName )
import PrelMods ( pRELUDE_BUILTIN )
import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
-import TyCon ( mkPrimTyCon, mkDataTyCon,
- ConsVisible(..), NewOrData(..) )
+import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) )
import TyVar ( GenTyVar(..), alphaTyVars )
import Type ( applyTyCon, mkTyVarTys )
import Usage ( usageOmega )
@@ -119,7 +118,6 @@ realWorldTyCon
[{-no context-}]
[{-no data cons!-}] -- we tell you *nothing* about this guy
[{-no derivings-}]
- ConsInvisible
DataType
where
full_name = mkPreludeCoreName pRELUDE_BUILTIN SLIT("_RealWorld")
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 514682d8645e9eab967499d99d89f53c7ec24377..977758fa8436a95ac7fc59bec8eed511b85be35d 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -100,7 +100,8 @@ import NameTypes ( mkPreludeCoreName, mkShortName )
import Kind ( mkBoxedTypeKind, mkArrowKind )
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
- ConsVisible(..), NewOrData(..), TyCon )
+ NewOrData(..), TyCon
+ )
import Type ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy,
mkFunTys, maybeAppDataTyCon,
GenType(..), ThetaType(..), TauType(..) )
@@ -117,7 +118,7 @@ pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> [I
pcDataTyCon key mod name tyvars cons
= mkDataTyCon key tycon_kind full_name tyvars
[{-no context-}] cons [{-no derivings-}]
- ConsVisible DataType
+ DataType
where
full_name = mkPreludeCoreName mod name
tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind tyvars
diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index 58ca3cbbd8d4999ec3f73f4440788bbd6cc16b50..970264567c2c7412fbc3c5b12f947bce24cb452a 100644
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[SCCfinal]{Modify and collect code generation for final STG program}
@@ -27,35 +27,35 @@ This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
module SCCfinal ( stgMassageForProfiling ) where
-import Pretty -- ToDo: rm (debugging only)
+import Ubiq{-uitous-}
-import Type ( isFunType, getTauType )
-import CmdLineOpts
-import CostCentre
-import Id ( mkSysLocal, idType )
-import SrcLoc ( mkUnknownSrcLoc )
import StgSyn
-import UniqSupply
-import UniqSet ( emptyUniqSet
- IF_ATTACK_PRAGMAS(COMMA emptyUFM)
+
+import CmdLineOpts ( opt_AutoSccsOnIndividualCafs,
+ opt_CompilingPrelude
)
-import Util
+import CostCentre -- lots of things
+import Id ( idType, mkSysLocal, emptyIdSet )
+import Maybes ( maybeToBool )
+import SrcLoc ( mkUnknownSrcLoc )
+import Type ( splitSigmaTy, getFunTy_maybe )
+import UniqSupply ( getUnique, splitUniqSupply )
+import Util ( removeDups, assertPanic )
infixr 9 `thenMM`, `thenMM_`
\end{code}
\begin{code}
-type CollectedCCs = ([CostCentre], -- locally defined ones
- [CostCentre]) -- ones needing "extern" decls
+type CollectedCCs = ([CostCentre], -- locally defined ones
+ [CostCentre]) -- ones needing "extern" decls
stgMassageForProfiling
- :: FAST_STRING -> FAST_STRING -- module name, group name
- -> UniqSupply -- unique supply
- -> (GlobalSwitch -> Bool) -- command-line opts checker
- -> [StgBinding] -- input
+ :: FAST_STRING -> FAST_STRING -- module name, group name
+ -> UniqSupply -- unique supply
+ -> [StgBinding] -- input
-> (CollectedCCs, [StgBinding])
-stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
+stgMassageForProfiling mod_name grp_name us stg_binds
= let
((local_ccs, extern_ccs),
stg_binds2)
@@ -71,8 +71,8 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
in
((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
where
- do_auto_sccs_on_cafs = sw_chkr AutoSccsOnIndividualCafs -- only use!
- doing_prelude = sw_chkr CompilingPrelude
+ do_auto_sccs_on_cafs = opt_AutoSccsOnIndividualCafs -- only use!
+ doing_prelude = opt_CompilingPrelude
all_cafs_cc = if doing_prelude
then preludeCafsCostCentre
@@ -298,7 +298,9 @@ boxHigherOrderArgs almost_expr args live_vars
in
returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
where
- is_fun_type ty = isFunType (getTauType ty)
+ is_fun_type ty
+ = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
+ maybeToBool (getFunTy_maybe tau_ty) }
---------------
mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr
@@ -313,7 +315,7 @@ boxHigherOrderArgs almost_expr args live_vars
in
StgLet (StgNonRec new_var rhs) body
where
- bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
+ bOGUS_LVs = emptyIdSet -- easier to print than: panic "mk_stg_let: LVs"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 6043f72c10c05420bec2b70b51512734c4429c30..733dd7f52dc4d934bb8fd540b63cbd4d81863595 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -31,7 +31,7 @@ import MainMonad ( thenMn, MainIO(..) )
import PprStyle ( PprStyle(..) )
import Pretty
import ProtoName ( isConopPN, ProtoName(..) )
-import Util ( nOfThem, panic )
+import Util ( nOfThem, pprError, panic )
\end{code}
%************************************************************************
@@ -327,7 +327,7 @@ wlkExpr expr
U_record con rbinds -> -- record construction
wlkQid con `thenUgn` \ rcon ->
wlkList rdRbind rbinds `thenUgn` \ recbinds ->
- returnUgn (RecordCon rcon recbinds)
+ returnUgn (RecordCon (HsVar rcon) recbinds)
U_rupdate updexp updbinds -> -- record update
wlkExpr updexp `thenUgn` \ aexp ->
@@ -352,7 +352,11 @@ rdRbind pt
= rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
wlkQid var `thenUgn` \ rvar ->
wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
- returnUgn (rvar, expr_maybe)
+ returnUgn (
+ case expr_maybe of
+ Nothing -> (rvar, HsVar rvar, True{-pun-})
+ Just re -> (rvar, re, False)
+ )
\end{code}
Patterns: just bear in mind that lists of patterns are represented as
@@ -406,9 +410,8 @@ wlkPat pat
ConPatIn x [] -> (x, lpats)
ConOpPatIn x op y -> (op, x:y:lpats)
_ -> -- sorry about the weedy msg; the parser missed this one
- error (ppShow 100 (ppCat [
- ppStr "ERROR: an illegal `application' of a pattern to another one:",
- ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats))]))
+ pprError "ERROR: an illegal `application' of a pattern to another one:"
+ (ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats)))
in
returnUgn (ConPatIn n arg_pats)
where
@@ -444,7 +447,11 @@ wlkPat pat
= rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
wlkQid var `thenUgn` \ rvar ->
wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
- returnUgn (rvar, pat_maybe)
+ returnUgn (
+ case pat_maybe of
+ Nothing -> (rvar, VarPatIn rvar, True{-pun-})
+ Just rp -> (rvar, rp, False)
+ )
\end{code}
\begin{code}
@@ -748,7 +755,7 @@ mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
mk_class_assertion other
- = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
+ = pprError "ERROR: malformed type context: " (ppr PprForUser other)
-- regrettably, the parser does let some junk past
-- e.g., f :: Num {-nothing-} => a -> ...
\end{code}
@@ -784,14 +791,14 @@ wlkConDecl (U_constrrec ccon cfields srcline)
= mkSrcLocUgn srcline `thenUgn` \ src_loc ->
wlkQid ccon `thenUgn` \ con ->
wlkList rd_field cfields `thenUgn` \ fields_lists ->
- returnUgn (RecConDecl con (concat fields_lists) src_loc)
+ returnUgn (RecConDecl con fields_lists src_loc)
where
- rd_field :: ParseTree -> UgnM [(ProtoName, BangType ProtoName)]
+ rd_field :: ParseTree -> UgnM ([ProtoName], BangType ProtoName)
rd_field pt
= rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
wlkList rdQid fvars `thenUgn` \ vars ->
wlkBangType fty `thenUgn` \ ty ->
- returnUgn [ (var, ty) | var <- vars ]
+ returnUgn (vars, ty)
-----------------
rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
diff --git a/ghc/compiler/rename/RnBinds4.lhs b/ghc/compiler/rename/RnBinds4.lhs
index 418c6269671a3ef83101b9aa92396254623d2973..57303d82b2bdf27166c5832be3d76d9a649c6e35 100644
--- a/ghc/compiler/rename/RnBinds4.lhs
+++ b/ghc/compiler/rename/RnBinds4.lhs
@@ -15,8 +15,6 @@ module RnBinds4 (
rnTopBinds, rnMethodBinds,
rnBinds,
FreeVars(..), DefinedVars(..)
-
- -- and to make the interface self-sufficient...
) where
import Ubiq{-uitous-}
@@ -37,9 +35,9 @@ import Name ( isUnboundName, Name{-instances-} )
import Pretty
import ProtoName ( elemByLocalNames, eqByLocalName, ProtoName{-instances-} )
import RnExpr4 -- OK to look here; but not the other way 'round
-import UniqSet ( emptyUniqSet, singletonUniqSet, mkUniqSet,
+import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
unionUniqSets, unionManyUniqSets,
- elementOfUniqSet,
+ elementOfUniqSet, addOneToUniqSet,
uniqSetToList,
UniqSet(..)
)
@@ -368,7 +366,7 @@ flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
returnRn4 (
uniq + 1,
[(uniq,
- singletonUniqSet name',
+ unitUniqSet name',
fvs `unionUniqSets` sigs_fvs,
FunMonoBind name' new_matches locn,
sigs_for_me
@@ -391,7 +389,7 @@ sig_for_here want_me acc other_wise = acc
-- acct in the dependency analysis (or we get an
-- unexpected out-of-scope error)! WDP 95/07
-sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` singletonUniqSet blah
+sig_fv (SpecSig _ _ (Just blah) _) acc = addOneToUniqSet acc blah
sig_fv _ acc = acc
\end{code}
diff --git a/ghc/compiler/rename/RnExpr4.lhs b/ghc/compiler/rename/RnExpr4.lhs
index 21f5346e22dfc80b58f1e72b7c1920bb38f9d905..99f0b7531d853deb46d366e5eb08d82949722f97 100644
--- a/ghc/compiler/rename/RnExpr4.lhs
+++ b/ghc/compiler/rename/RnExpr4.lhs
@@ -30,7 +30,7 @@ import RnMonad4
import Name ( Name(..) )
import NameTypes ( FullName{-instances-} )
import Outputable ( isConop )
-import UniqSet ( emptyUniqSet, singletonUniqSet,
+import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
UniqSet(..)
)
@@ -193,11 +193,11 @@ rnExpr (HsVar v)
= lookupValue v `thenRn4` \ vname ->
returnRn4 (HsVar vname, fv_set vname)
where
- fv_set n@(Short uniq sname) = singletonUniqSet n
+ fv_set n@(Short uniq sname) = unitUniqSet n
fv_set n@(ValName uniq fname)
| isLocallyDefined fname
&& not (isConop (getOccurrenceName fname))
- = singletonUniqSet n
+ = unitUniqSet n
fv_set other = emptyUniqSet
rnExpr (HsLit lit) = returnRn4 (HsLit lit, emptyUniqSet)
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index b141a302945ecb36c0b4fae0c7ed73ff95f0f0fc..278fc6589796e4535bd4843607bf195e6f75578a 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -32,6 +32,7 @@ type RenamedGenPragmas = GenPragmas Name
type RenamedHsBinds = HsBinds Fake Fake Name RenamedPat
type RenamedHsExpr = HsExpr Fake Fake Name RenamedPat
type RenamedHsModule = HsModule Fake Fake Name RenamedPat
+type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat
type RenamedImportedInterface = ImportedInterface Fake Fake Name RenamedPat
type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat
type RenamedInstancePragmas = InstancePragmas Name
diff --git a/ghc/compiler/rename/RnPass1.lhs b/ghc/compiler/rename/RnPass1.lhs
index 53f4bb607c4abd3ed7c2202735ec6ba2db821b0b..bd76c69c4859516f158cb2da5cdcb3481562840d 100644
--- a/ghc/compiler/rename/RnPass1.lhs
+++ b/ghc/compiler/rename/RnPass1.lhs
@@ -652,7 +652,7 @@ doIfaceTyDecls1 sifun full_tc_nf ty_decls
do_condecl cf_nf tc_nf (RecConDecl con fields src_loc)
= RecConDecl (cf_nf con) (map do_field fields) src_loc
where
- do_field (var, ty) = (cf_nf var, do_bang tc_nf ty)
+ do_field (vars, ty) = (map cf_nf vars, do_bang tc_nf ty)
--------------------------------------------
do_bang tc_nf (Banged ty) = Banged (doIfaceMonoType1 tc_nf ty)
diff --git a/ghc/compiler/rename/RnPass4.lhs b/ghc/compiler/rename/RnPass4.lhs
index 9aaa2e7802efc53991c4e18a2eb8ce2cbc0420ba..5006d17290d76c632c086ce2afbfa04aec990691 100644
--- a/ghc/compiler/rename/RnPass4.lhs
+++ b/ghc/compiler/rename/RnPass4.lhs
@@ -292,7 +292,12 @@ rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
in
mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
lookupClass cname `thenRn4` \ cname' ->
- rnPolyType False{-no invisibles-} tv_env ty
+
+ rnPolyType False{-no invisibles-} [] ty
+ -- The "[]" was tv_env, but that means the InstDecl's tyvars aren't
+ -- pinned on the HsForAllType, which they should be.
+ -- Urgh! Improve in the new renamer!
+
`thenRn4` \ ty' ->
rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
mapRn4 (rn_uprag cname') uprags `thenRn4` \ new_uprags ->
diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs
index 7e456079ccaeeee7ddf188f5d864815ed147aebf..8422c18695235137e9e2891b0ab9c10b0ef54d7d 100644
--- a/ghc/compiler/simplCore/AnalFBWW.lhs
+++ b/ghc/compiler/simplCore/AnalFBWW.lhs
@@ -8,29 +8,36 @@
module AnalFBWW ( analFBWW ) where
-import Util
-import Id ( addIdFBTypeInfo )
-import IdInfo
-import PrelInfo ( foldrId, buildId,
- nilDataCon, consDataCon, mkListTy, mkFunTy,
- unpackCStringAppendId
- )
-import BinderInfo
-import SimplEnv -- everything
-import OccurAnal -- OLD: was NewOccurAnal
-import Maybes
-
+import Ubiq{-uitous-}
+
+import CoreSyn ( CoreBinding(..) )
+import Util ( panic{-ToDo:rm-} )
+
+--import Util
+--import Id ( addIdFBTypeInfo )
+--import IdInfo
+--import PrelInfo ( foldrId, buildId,
+-- nilDataCon, consDataCon, mkListTy, mkFunTy,
+-- unpackCStringAppendId
+-- )
+--import BinderInfo
+--import SimplEnv -- everything
+--import OccurAnal -- OLD: was NewOccurAnal
+--import Maybes
\end{code}
\begin{code}
analFBWW
- :: (GlobalSwitch -> Bool)
- -> [CoreBinding]
+ :: [CoreBinding]
-> [CoreBinding]
-analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
+
+analFBWW = panic "analFBWW (ToDo)"
+
+{- LATER:
+analFBWW top_binds = trace "ANALFBWW" (snd anno)
where
anals :: [InBinding]
- anals = newOccurAnalyseBinds top_binds switch (const False)
+ anals = newOccurAnalyseBinds top_binds (const False)
anno = mapAccumL annotateBindingFBWW nullIdEnv anals
\end{code}
@@ -136,14 +143,14 @@ analExprFBWW (SCC lab e) env = analExprFBWW e env
analExprFBWW (Let binds e) env = analExprFBWW e (analBind binds env)
analExprFBWW (Case e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
-analAltsFBWW (AlgAlts alts deflt) env =
- case analDefFBWW deflt env of
+analAltsFBWW (AlgAlts alts deflt) env
+ = case analDefFBWW deflt env of
Just ty -> ty : tys
Nothing -> tys
where
tys = map (\(con,binders,e) -> analExprFBWW e (delManyFromIdEnv env (map fst binders))) alts
-analAltsFBWW (PrimAlts alts deflt) env =
- case analDefFBWW deflt env of
+analAltsFBWW (PrimAlts alts deflt) env
+ = case analDefFBWW deflt env of
Just ty -> ty : tys
Nothing -> tys
where
@@ -162,8 +169,8 @@ Only add a type info if:
\begin{code}
analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
-analBindExpr bnd expr env =
- case analExprFBWW expr env of
+analBindExpr bnd expr env
+ = case analExprFBWW expr env of
IsFB ty@(FBType [] _) ->
if oneSafeOcc False bnd
then IsFB ty
@@ -246,4 +253,5 @@ annotateBindingFBWW env bnds = (env',bnds')
| not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v)
(addIdFBTypeInfo v (mkFBTypeInfo ty))
_ -> v)
+-}
\end{code}
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 27b6c08f14ff0a4cfc265b4a7928be078d04b5a9..0eb15290b29caf58326c5630965fb6a04284966e 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -172,12 +172,11 @@ fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body)
where
whnf :: CoreExprWithFVs -> Bool
- whnf (_,AnnLit _) = True
- whnf (_,AnnCon _ _) = True
- whnf (_,AnnLam (ValBinder _) _) = True
- whnf (_,AnnLam _ e) = whnf e
- whnf (_,AnnSCC _ e) = whnf e
- whnf _ = False
+ whnf (_,AnnLit _) = True
+ whnf (_,AnnCon _ _) = True
+ whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
+ whnf (_,AnnSCC _ e) = whnf e
+ whnf _ = False
\end{code}
Applications: we could float inside applications, but it's probably
diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs
index 7c97d5415154d4467cc5ebe9c177cd67f2d66018..99fa850513912ec747071f88a218bf84ac9fa1f2 100644
--- a/ghc/compiler/simplCore/FoldrBuildWW.lhs
+++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs
@@ -8,38 +8,43 @@
module FoldrBuildWW ( mkFoldrBuildWW ) where
-IMPORT_Trace
-import Outputable
-import Pretty
-import Type ( cloneTyVarFromTemplate, mkTyVarTy,
- splitTypeWithDictsAsArgs, eqTyCon, mkForallTy )
-import TysPrim ( alphaTy )
-import TyVar ( alphaTyVar )
-
-import Type ( Type(..) ) -- **** CAN SEE THE CONSTRUCTORS ****
-import UniqSupply ( runBuiltinUs )
-import WwLib -- share the same monad (is this eticit ?)
-import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
- foldrId, buildId
- )
-import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
- replaceIdInfo, mkSysLocal, idType
- )
-import IdInfo
-import Maybes
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
+import Ubiq{-uitous-}
+
+import CoreSyn ( CoreBinding(..) )
+import Util ( panic{-ToDo:rm?-} )
+
+--import Type ( cloneTyVarFromTemplate, mkTyVarTy,
+-- splitTypeWithDictsAsArgs, eqTyCon, mkForallTy )
+--import TysPrim ( alphaTy )
+--import TyVar ( alphaTyVar )
+--
+--import Type ( Type(..) ) -- **** CAN SEE THE CONSTRUCTORS ****
+--import UniqSupply ( runBuiltinUs )
+--import WwLib -- share the same monad (is this eticit ?)
+--import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
+-- foldrId, buildId
+-- )
+--import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
+-- replaceIdInfo, mkSysLocal, idType
+-- )
+--import IdInfo
+--import Maybes
+--import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
+--import Util
\end{code}
\begin{code}
mkFoldrBuildWW
- :: (GlobalSwitch -> Bool)
- -> UniqSupply
+ :: UniqSupply
-> [CoreBinding]
-> [CoreBinding]
-mkFoldrBuildWW switch us top_binds =
+
+mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
+
+{- LATER:
+mkFoldrBuildWW us top_binds =
(mapWw wwBind top_binds `thenWw` \ top_binds2 ->
- returnWw (concat top_binds2)) us switch
+ returnWw (concat top_binds2)) us
\end{code}
\begin{code}
@@ -176,5 +181,5 @@ try_split_bind id expr =
else
returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
_ -> returnWw [(id,expr')]
+-}
\end{code}
-
diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs
index a56b4c9003aa823ea96245b0b4944836b458ea0d..47d0a27cf497bb301a1c071dc2098aa5f6d96ea9 100644
--- a/ghc/compiler/simplCore/MagicUFs.lhs
+++ b/ghc/compiler/simplCore/MagicUFs.lhs
@@ -14,6 +14,7 @@ module MagicUFs (
) where
import Ubiq{-uitous-}
+import IdLoop -- paranoia checking
import CoreSyn
import PrelInfo ( mkListTy )
@@ -317,8 +318,8 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
foldr_fun _ _ = returnSmpl Nothing
isConsFun :: SimplEnv -> CoreArg -> Bool
-isConsFun env (VarArg v) =
- case lookupUnfolding env v of
+isConsFun env (VarArg v)
+ = case lookupUnfolding env v of
GenForm _ _ (Lam (x,_) (Lam (y,_)
(Con con tys [VarArg x',VarArg y']))) _
| con == consDataCon && x==x' && y==y'
@@ -327,8 +328,8 @@ isConsFun env (VarArg v) =
isConsFun env _ = False
isNilForm :: SimplEnv -> CoreArg -> Bool
-isNilForm env (VarArg v) =
- case lookupUnfolding env v of
+isNilForm env (VarArg v)
+ = case lookupUnfolding env v of
GenForm _ _ (CoTyApp (Var id) _) _
| id == nilDataCon -> True
ConForm id _ _
@@ -338,8 +339,8 @@ isNilForm env (VarArg v) =
isNilForm env _ = False
getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
-getBuildForm env (VarArg v) =
- case lookupUnfolding env v of
+getBuildForm env (VarArg v)
+ = case lookupUnfolding env v of
GenForm False _ _ _ -> Nothing
-- not allowed to inline :-(
GenForm _ _ (App (CoTyApp (Var bld) _) (VarArg g)) _
@@ -353,8 +354,8 @@ getBuildForm env _ = Nothing
getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
-getAugmentForm env (VarArg v) =
- case lookupUnfolding env v of
+getAugmentForm env (VarArg v)
+ = case lookupUnfolding env v of
GenForm False _ _ _ -> Nothing
-- not allowed to inline :-(
GenForm _ _ (App (App (CoTyApp (Var bld) _)
@@ -387,8 +388,8 @@ getListForm
:: SimplEnv
-> CoreArg
-> Maybe ([CoreArg],CoreArg)
-getListForm env (VarArg v) =
- case lookupUnfolding env v of
+getListForm env (VarArg v)
+ = case lookupUnfolding env v of
ConForm id _ [head,tail]
| id == consDataCon ->
case getListForm env tail of
@@ -398,8 +399,8 @@ getListForm env (VarArg v) =
getListForm env _ = Nothing
isInterestingArg :: SimplEnv -> CoreArg -> Bool
-isInterestingArg env (VarArg v) =
- case lookupUnfolding env v of
+isInterestingArg env (VarArg v)
+ = case lookupUnfolding env v of
GenForm False _ _ UnfoldNever -> False
GenForm _ _ exp guide -> True
_ -> False
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index b04eb4b031c74d852e9624b4b28c70da4a5130ce..94e9fc6c0ae67a3756d3827fe87074ec5fbdf99b 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
@@ -15,19 +15,34 @@ core expression with (hopefully) improved usage information.
module OccurAnal (
occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
-
- -- and to make the interface self-sufficient...
) where
-import Type
+import Ubiq{-uitous-}
+
import BinderInfo
-import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) )
+import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
+import CoreSyn
import Digraph ( stronglyConnComp )
-import Id ( eqId, idWantsToBeINLINEd, isConstMethodId,
- isSpecPragmaId_maybe, SpecInfo )
-import Maybes
-import UniqSet
-import Util
+import Id ( idWantsToBeINLINEd, isConstMethodId,
+ emptyIdSet, unionIdSets, mkIdSet,
+ unitIdSet, elementOfIdSet,
+ addOneToIdSet, IdSet(..),
+ nullIdEnv, unitIdEnv, combineIdEnvs,
+ delOneFromIdEnv, delManyFromIdEnv,
+ mapIdEnv, lookupIdEnv, IdEnv(..),
+ GenId{-instance Eq-}
+ )
+import Maybes ( maybeToBool )
+import Outputable ( isExported, Outputable(..){-instance * (,) -} )
+import PprCore
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
+import Pretty ( ppAboves )
+import TyVar ( GenTyVar{-instance Eq-} )
+import Unique ( Unique{-instance Eq-} )
+import Util ( assoc, pprTrace, panic )
+
+isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
\end{code}
@@ -56,18 +71,18 @@ data OccEnv =
Bool -- IgnoreINLINEPragma flag
-- False <=> OK to use INLINEPragma information
-- True <=> ignore INLINEPragma information
- (UniqSet Id) -- Candidates
+ IdSet -- Candidates
addNewCands :: OccEnv -> [Id] -> OccEnv
addNewCands (OccEnv kd ks kc ip cands) ids
- = OccEnv kd ks kc ip (cands `unionUniqSets` mkUniqSet ids)
+ = OccEnv kd ks kc ip (cands `unionIdSets` mkIdSet ids)
addNewCand :: OccEnv -> Id -> OccEnv
addNewCand (OccEnv ks kd kc ip cands) id
- = OccEnv kd ks kc ip (cands `unionUniqSets` singletonUniqSet id)
+ = OccEnv kd ks kc ip (addOneToIdSet cands id)
isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
+isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfIdSet` cands
ignoreINLINEPragma :: OccEnv -> Bool
ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
@@ -86,37 +101,34 @@ combineUsageDetails, combineAltsUsageDetails
:: UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetails usage1 usage2
- = --BSCC("combineUsages")
- combineIdEnvs combineBinderInfo usage1 usage2
- --ESCC
+ = combineIdEnvs combineBinderInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
- = --BSCC("combineUsages")
- combineIdEnvs combineAltsBinderInfo usage1 usage2
- --ESCC
+ = combineIdEnvs combineAltsBinderInfo usage1 usage2
addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
-addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
+addOneOcc usage id info
+ = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
-- ToDo: make this more efficient
emptyDetails = (nullIdEnv :: UsageDetails)
unitDetails id info = (unitIdEnv id info :: UsageDetails)
-tagBinders :: UsageDetails -- Of scope
- -> [Id] -- Binders
- -> (UsageDetails, -- Details with binders removed
- [(Id,BinderInfo)]) -- Tagged binders
+tagBinders :: UsageDetails -- Of scope
+ -> [Id] -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ [(Id,BinderInfo)]) -- Tagged binders
tagBinders usage binders
= (usage `delManyFromIdEnv` binders,
- [(binder, usage_of usage binder) | binder <- binders]
+ [ (binder, usage_of usage binder) | binder <- binders ]
)
-tagBinder :: UsageDetails -- Of scope
- -> Id -- Binders
- -> (UsageDetails, -- Details with binders removed
- (Id,BinderInfo)) -- Tagged binders
+tagBinder :: UsageDetails -- Of scope
+ -> Id -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ (Id,BinderInfo)) -- Tagged binders
tagBinder usage binder
= (usage `delOneFromIdEnv` binder,
@@ -126,12 +138,12 @@ tagBinder usage binder
usage_of usage binder
| isExported binder = ManyOcc 0 -- Exported things count as many
| otherwise
- = case lookupIdEnv usage binder of
+ = case (lookupIdEnv usage binder) of
Nothing -> DeadCode
Just info -> info
isNeeded env usage binder
- = case usage_of usage binder of
+ = case (usage_of usage binder) of
DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
other -> True
\end{code}
@@ -148,13 +160,14 @@ Here's the externally-callable interface:
\begin{code}
occurAnalyseBinds
:: [CoreBinding] -- input
- -> (GlobalSwitch -> Bool)
-> (SimplifierSwitch -> Bool)
-> [SimplifiableCoreBinding] -- output
-occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
- | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
- | otherwise = binds'
+occurAnalyseBinds binds simplifier_sw_chkr
+ | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
+ (ppAboves (map (ppr PprDebug) binds'))
+ binds'
+ | otherwise = binds'
where
(_, binds') = do initial_env binds
@@ -162,7 +175,7 @@ occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
(simplifier_sw_chkr KeepSpecPragmaIds)
(not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
(simplifier_sw_chkr IgnoreINLINEPragma)
- emptyUniqSet
+ emptyIdSet
do env [] = (emptyDetails, [])
do env (bind:binds)
@@ -170,15 +183,13 @@ occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
where
new_env = env `addNewCands` (bindersOf bind)
(binds_usage, the_rest) = do new_env binds
- (final_usage, new_binds) = --BSCC("occAnalBind1")
- occAnalBind env bind binds_usage
- --ESCC
+ (final_usage, new_binds) = occAnalBind env bind binds_usage
\end{code}
\begin{code}
-occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars
+occurAnalyseExpr :: IdSet -- Set of interesting free vars
-> CoreExpr
- -> (IdEnv BinderInfo, -- Occ info for interesting free vars
+ -> (IdEnv BinderInfo, -- Occ info for interesting free vars
SimplifiableCoreExpr)
occurAnalyseExpr candidates expr
@@ -194,7 +205,7 @@ occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
- expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr
+ expr' where (_, expr') = occurAnalyseExpr emptyIdSet expr
\end{code}
%************************************************************************
@@ -291,7 +302,7 @@ occAnalBind env (Rec pairs) body_usage
sccs :: [[Id]]
sccs = case binders of
[_] -> [binders] -- Singleton; no need to analyse
- other -> stronglyConnComp eqId edges binders
+ other -> stronglyConnComp (==) edges binders
---- stuff to "re-constitute" bindings from dependency-analysis info ------
@@ -336,7 +347,7 @@ ToDo: try using the occurrence info for the inline'd binder.
\begin{code}
occAnalRhs :: OccEnv
- -> Id -- Binder
+ -> Id -- Binder
-> CoreExpr -- Rhs
-> (UsageDetails, SimplifiableCoreExpr)
@@ -356,7 +367,7 @@ Expressions
\begin{code}
occAnal :: OccEnv
-> CoreExpr
- -> (UsageDetails, -- Gives info only about the "interesting" Ids
+ -> (UsageDetails, -- Gives info only about the "interesting" Ids
SimplifiableCoreExpr)
occAnal env (Var v)
@@ -367,8 +378,8 @@ occAnal env (Var v)
= (emptyDetails, Var v)
occAnal env (Lit lit) = (emptyDetails, Lit lit)
-occAnal env (Con con tys args) = (occAnalAtoms env args, Con con tys args)
-occAnal env (Prim op tys args) = (occAnalAtoms env args, Prim op tys args)
+occAnal env (Con con args) = (occAnalArgs env args, Con con args)
+occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
occAnal env (SCC cc body)
= (mapIdEnv markInsideSCC usage, SCC cc body')
@@ -378,26 +389,25 @@ occAnal env (SCC cc body)
occAnal env (App fun arg)
= (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
where
- (fun_usage, fun') = occAnal env fun
- arg_usage = occAnalAtom env arg
+ (fun_usage, fun') = occAnal env fun
+ arg_usage = occAnalArg env arg
-occAnal env (CoTyApp fun ty)
- = (fun_usage, CoTyApp fun' ty)
+occAnal env (Lam (ValBinder binder) body)
+ = (mapIdEnv markDangerousToDup final_usage,
+ Lam (ValBinder tagged_binder) body')
where
- (fun_usage, fun') = occAnal env fun
-
-occAnal env (Lam binder body)
- = (mapIdEnv markDangerousToDup final_usage, Lam tagged_binder body')
- where
- (body_usage, body') = occAnal (env `addNewCand` binder) body
+ (body_usage, body') = occAnal (env `addNewCand` binder) body
(final_usage, tagged_binder) = tagBinder body_usage binder
-- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
-occAnal env (CoTyLam tyvar body)
- = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body')
+occAnal env (Lam (TyBinder tyvar) body)
+ = (mapIdEnv markDangerousToDup body_usage,
+ Lam (TyBinder tyvar) body')
where
(body_usage, body') = occAnal env body
+occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
+
occAnal env (Case scrut alts)
= (scrut_usage `combineUsageDetails` alts_usage,
Case scrut' alts')
@@ -410,9 +420,7 @@ occAnal env (Let bind body)
where
new_env = env `addNewCands` (bindersOf bind)
(body_usage, body') = occAnal new_env body
- (final_usage, new_binds) = --BSCC("occAnalBind2")
- occAnalBind env bind body_usage
- --ESCC
+ (final_usage, new_binds) = occAnalBind env bind body_usage
\end{code}
Case alternatives
@@ -460,21 +468,21 @@ occAnalDeflt env (BindDefault binder rhs)
Atoms
~~~~~
\begin{code}
-occAnalAtoms :: OccEnv -> [CoreArg] -> UsageDetails
+occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
-occAnalAtoms env atoms
+occAnalArgs env atoms
= foldr do_one_atom emptyDetails atoms
where
- do_one_atom (LitArg lit) usage = usage
do_one_atom (VarArg v) usage
| isCandidate env v = addOneOcc usage v (argOccurrence 0)
| otherwise = usage
+ do_one_atom other_arg usage = usage
-occAnalAtom :: OccEnv -> CoreArg -> UsageDetails
+occAnalArg :: OccEnv -> CoreArg -> UsageDetails
-occAnalAtom env (LitArg lit) = emptyDetails
-occAnalAtom env (VarArg v)
+occAnalArg env (VarArg v)
| isCandidate env v = unitDetails v (argOccurrence 0)
| otherwise = emptyDetails
+occAnalArg _ _ = emptyDetails
\end{code}
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 7c70bca19d7b622b55d99d5fc4db19bda8acc5a0..6783e1154d070c7fd90598bcc1d7e606b7bfa0a9 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -1,5 +1,5 @@
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[SimplCase]{Simplification of `case' expression}
@@ -10,33 +10,35 @@ Support code for @Simplify@.
module SimplCase ( simplCase, bindLargeRhs ) where
-import SimplMonad
-import SimplEnv
+import Ubiq{-uitous-}
+import SmplLoop ( simplBind, simplExpr, MagicUnfoldingFun )
-import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp,
- voidPrimTy, voidPrimId, mkFunTy, primOpOkForSpeculation
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import BinderInfo -- too boring to try to select things...
+import CmdLineOpts ( SimplifierSwitch(..) )
+import CoreSyn
+import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
+ FormSummary(..)
)
-import Type ( splitSigmaTy, splitTyArgs, glueTyArgs,
- getTyConFamilySize, isPrimType,
- maybeAppDataTyCon
+import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
+ unTagBindersAlts
)
-import Literal ( isNoRepLit, Literal )
-import CmdLineOpts ( SimplifierSwitch(..) )
-import Id
-import IdInfo
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Simplify
-import SimplUtils
-import SimplVar ( completeVar )
-import Util
+import Id ( idType, isDataCon, getIdDemandInfo,
+ DataCon(..), GenId{-instance Eq-}
+ )
+import IdInfo ( willBeDemanded, DemandInfo )
+import Literal ( isNoRepLit, Literal{-instance Eq-} )
+import Maybes ( maybeToBool )
+import PrelInfo ( voidPrimTy, voidPrimId )
+import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
+import SimplEnv
+import SimplMonad
+import SimplUtils ( mkValLamTryingEta )
+import Type ( isPrimType, maybeAppDataTyCon, mkFunTys, eqTy )
+import Unique ( Unique{-instance Eq-} )
+import Usage ( GenUsage{-instance Eq-} )
+import Util ( isIn, isSingleton, panic, assertPanic )
\end{code}
-
-
-
-
Float let out of case.
\begin{code}
@@ -44,7 +46,7 @@ simplCase :: SimplEnv
-> InExpr -- Scrutinee
-> InAlts -- Alternatives
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
- -> OutUniType -- Type of result expression
+ -> OutType -- Type of result expression
-> SmplM OutExpr
simplCase env (Let bind body) alts rhs_c result_ty
@@ -185,10 +187,10 @@ completeCase env (Lit lit) alts rhs_c
tick KnownBranch `thenSmpl_`
completePrimCaseWithKnownLit env lit alts rhs_c
-completeCase env expr@(Con con tys con_args) alts rhs_c
+completeCase env expr@(Con con con_args) alts rhs_c
= -- Ha! Staring us in the face -- select the appropriate alternative
tick KnownBranch `thenSmpl_`
- completeAlgCaseWithKnownCon env con tys con_args alts rhs_c
+ completeAlgCaseWithKnownCon env con con_args alts rhs_c
\end{code}
Case elimination
@@ -310,7 +312,7 @@ completeCase env scrut alts rhs_c
not (alt_con `is_elem` not_these)]
#ifdef DEBUG
--- ConForm c t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (ppr PprDebug alts))
+-- ConForm c v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppStr "<args>"]) (ppr PprDebug alts))
-- ConForm can't happen, since we'd have
-- inlined it, and be in completeCaseWithKnownCon by now
#endif
@@ -328,19 +330,19 @@ completeCase env scrut alts rhs_c
-- If the scrut is already eval'd then there's no worry about
-- eliminating the case
scrut_is_evald = case scrut_form of
- OtherLitForm _ -> True
- ConForm _ _ _ -> True
- OtherConForm _ -> True
- other -> False
+ OtherLitForm _ -> True
+ ConForm _ _ -> True
+ OtherConForm _ -> True
+ other -> False
scrut_is_eliminable_primitive
= case scrut of
- Prim op _ _ -> primOpOkForSpeculation op
- Var _ -> case alts of
- PrimAlts _ _ -> True -- Primitive, hence non-bottom
- AlgAlts _ _ -> False -- Not primitive
- other -> False
+ Prim op _ -> primOpOkForSpeculation op
+ Var _ -> case alts of
+ PrimAlts _ _ -> True -- Primitive, hence non-bottom
+ AlgAlts _ _ -> False -- Not primitive
+ other -> False
-- case v of w -> e{strict in w} ===> e[v/w]
scrut_is_var_and_single_strict_default
@@ -390,7 +392,7 @@ completeCase env scrut alts rhs_c
bindLargeAlts :: SimplEnv
-> InAlts
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
- -> OutUniType -- Result type
+ -> OutType -- Result type
-> SmplM ([OutBinding], -- Extra bindings
InAlts) -- Modified alts
@@ -427,7 +429,7 @@ bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
\begin{code}
bindLargeRhs :: SimplEnv
-> [InBinder] -- The args wrt which the rhs should be abstracted
- -> OutUniType
+ -> OutType
-> (SimplEnv -> SmplM OutExpr) -- Rhs handler
-> SmplM (OutBinding, -- New bindings (singleton or empty)
InExpr) -- Modified rhs
@@ -473,15 +475,15 @@ bindLargeRhs env args rhs_ty rhs_c
-- it's processed the OutId won't be found in the environment, so it
-- will be left unmodified.
where
- rhs_fun_ty :: OutUniType
- rhs_fun_ty = glueTyArgs [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
+ rhs_fun_ty :: OutType
+ rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
dead DeadCode = True
dead other = False
- prim_rhs_fun_ty = mkFunTy voidPrimTy rhs_ty
+ prim_rhs_fun_ty = mkFunTys [voidPrimTy] rhs_ty
\end{code}
Case alternatives when we don't know the scrutinee
@@ -517,8 +519,8 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c
let
env1 = extendIdEnvWithClones env con_args con_args'
new_env = case scrut of
- Var var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args')
- other -> env1
+ Var v -> extendUnfoldEnvGivenConstructor env1 v con con_args'
+ other -> env1
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (con, con_args', rhs')
@@ -532,8 +534,8 @@ simplAlts env scrut (PrimAlts alts deflt) rhs_c
do_alt (lit, rhs)
= let
new_env = case scrut of
- Var var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LitForm lit))
- other -> env
+ Var v -> extendUnfoldEnvGivenFormDetails env v (LitForm lit)
+ other -> env
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (lit, rhs')
@@ -588,12 +590,12 @@ simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rh
final_form
= case (form_from_this_case, scrut_form) of
(OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
- (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
+ (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
-- ConForm, LitForm impossible
-- (ASSERT? ASSERT? Hello? WDP 95/05)
- other -> form_from_this_case
+ other -> form_from_this_case
- env2 = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' final_form)
+ env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
-- Change unfold details for scrut var. We now want to unfold it
-- to binder'
@@ -609,7 +611,7 @@ simplDefault env scrut (BindDefault binder rhs) form rhs_c
= cloneId env binder `thenSmpl` \ binder' ->
let
env1 = extendIdEnvWithAtom env binder (VarArg binder')
- new_env = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' form)
+ new_env = extendUnfoldEnvGivenFormDetails env1 binder' form
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
@@ -663,13 +665,13 @@ var [substitute \tr{y} out of existence].
\begin{code}
completeAlgCaseWithKnownCon
:: SimplEnv
- -> DataCon -> [Type] -> [InAtom]
+ -> DataCon -> [InArg]
-- Scrutinee is (con, type, value arguments)
-> InAlts
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> SmplM OutExpr
-completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c
+completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
= ASSERT(isDataCon con)
search_alts alts
where
@@ -698,11 +700,11 @@ completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c
cloneId env binder `thenSmpl` \ id' ->
let
env1 = extendIdEnvWithClone env binder id'
- new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id'
- (ConForm con tys con_args))
+ new_env = extendUnfoldEnvGivenFormDetails env1 id'
+ (ConForm con con_args)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (Let (NonRec id' (Con con tys con_args)) rhs')
+ returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
\end{code}
Case absorption and identity-case elimination
@@ -787,7 +789,7 @@ mkCoCase scrut (AlgAlts outer_alts
munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
where
v | scrut_is_var = Var scrut_var
- | otherwise = Con con arg_tys (map VarArg args)
+ | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
arg_tys = case maybeAppDataTyCon (idType deflt_var) of
Just (_, arg_tys, _) -> arg_tys
@@ -856,7 +858,7 @@ mkCoCase scrut alts
identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
- identity_alg_alt (con, args, Con con' _ args')
+ identity_alg_alt (con, args, Con con' args')
= con == con'
&& and (zipWith eq_arg args args')
&& length args == length args'
@@ -913,26 +915,30 @@ munge_alg_deflt deflt_var (BindDefault d' rhs)
\end{code}
\begin{code}
- -- A cheap equality test which bales out fast!
cheap_eq :: InExpr -> InExpr -> Bool
+ -- A cheap equality test which bales out fast!
+
cheap_eq (Var v1) (Var v2) = v1==v2
cheap_eq (Lit l1) (Lit l2) = l1==l2
-cheap_eq (Con con1 tys1 args1) (Con con2 tys2 args2) = (con1==con2) &&
- (args1 `eq_args` args2)
- -- Types bound to be equal
-cheap_eq (Prim op1 tys1 args1) (Prim op2 tys2 args2) = (op1==op2) &&
- (args1 `eq_args` args2)
- -- Types bound to be equal
-cheap_eq (App f1 a1) (App f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2)
-cheap_eq (CoTyApp f1 t1) (CoTyApp f2 t2) = (f1 `cheap_eq` f2) && (t1 == t2)
+cheap_eq (Con con1 args1) (Con con2 args2)
+ = con1 == con2 && args1 `eq_args` args2
+
+cheap_eq (Prim op1 args1) (Prim op2 args2)
+ = op1 ==op2 && args1 `eq_args` args2
+
+cheap_eq (App f1 a1) (App f2 a2)
+ = f1 `cheap_eq` f2 && a1 `eq_arg` a2
+
cheap_eq _ _ = False
-- ToDo: make CoreArg an instance of Eq
-eq_args (arg1: args1) (arg2 : args2) = (arg1 `eq_atom` arg2) && (args1 `eq_args` args2)
-eq_args [] [] = True
-eq_args other1 other2 = False
-
-eq_atom (LitArg l1) (LitArg l2) = l1==l2
-eq_atom (VarArg v1) (VarArg v2) = v1==v2
-eq_atom other1 other2 = False
+eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
+eq_args [] [] = True
+eq_args _ _ = False
+
+eq_arg (LitArg l1) (LitArg l2) = l1 == l2
+eq_arg (VarArg v1) (VarArg v2) = v1 == v2
+eq_arg (TyArg t1) (TyArg t2) = t1 `eqTy` t2
+eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2
+eq_arg _ _ = False
\end{code}
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 2ada37315e570b49f2120efe3f038f70d280dac8..1c99c714a2016c3c2134fed9b3d86cd0bc7a1c77 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -1,61 +1,84 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[SimplCore]{Driver for simplifying @Core@ programs}
\begin{code}
#include "HsVersions.h"
-module SimplCore (
- core2core
- ) where
+module SimplCore ( core2core ) where
-import Type ( getTyConDataCons )
---SAVE:import ArityAnal ( arityAnalProgram )
-import Bag
-import BinderInfo ( BinderInfo) -- instances only
+import Ubiq{-uitous-}
+
+import AnalFBWW ( analFBWW )
+import Bag ( isEmptyBag, foldBag )
+import BinderInfo ( BinderInfo{-instance Outputable-} )
import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD,
uNFOLDING_USE_THRESHOLD,
uNFOLDING_OVERRIDE_THRESHOLD,
uNFOLDING_CON_DISCOUNT_WEIGHT
)
-import CmdLineOpts
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
+ opt_D_show_passes,
+ opt_D_simplifier_stats,
+ opt_D_verbose_core2core,
+ opt_DoCoreLinting,
+ opt_FoldrBuildOn,
+ opt_ReportWhyUnfoldingsDisallowed,
+ opt_ShowImportSpecs,
+ opt_UnfoldingCreationThreshold,
+ opt_UnfoldingOverrideThreshold,
+ opt_UnfoldingUseThreshold
+ )
import CoreLint ( lintCoreBindings )
+import CoreSyn
+import CoreUnfold
+import CoreUtils ( substCoreBindings, manifestlyWHNF )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( getIdUnfolding,
- idType, toplevelishId,
- idWantsToBeINLINEd,
- unfoldingUnfriendlyId, isWrapperId,
- mkTemplateLocals
+import FoldrBuildWW ( mkFoldrBuildWW )
+import Id ( idType, toplevelishId, idWantsToBeINLINEd,
+ unfoldingUnfriendlyId,
+ nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
+ lookupIdEnv, IdEnv(..),
+ GenId{-instance Outputable-}
)
-import IdInfo
+import IdInfo ( mkUnfolding )
import LiberateCase ( liberateCase )
-import MainMonad
-import Maybes
+import MagicUFs ( MagicUnfoldingFun )
+import MainMonad ( writeMn, exitMn, thenMn, thenMn_, returnMn,
+ MainIO(..)
+ )
+import Maybes ( maybeToBool )
+import Outputable ( Outputable(..){-instance * (,) -} )
+import PprCore ( pprCoreBinding, GenCoreExpr{-instance Outputable-} )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
+import Pretty ( ppShow, ppAboves, ppAbove, ppCat, ppStr )
import SAT ( doStaticArgs )
-import SCCauto
---ANDY:
---import SimplHaskell ( coreToHaskell )
-import SimplMonad ( zeroSimplCount, showSimplCount, TickType, SimplCount )
+import SCCauto ( addAutoCostCentres )
+import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
import SimplPgm ( simplifyPgm )
import SimplVar ( leastItCouldCost )
import Specialise
import SpecUtils ( pprSpecErrs )
import StrictAnal ( saWwTopBinds )
-import FoldrBuildWW
-import AnalFBWW
+import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} )
+import Unique ( Unique{-instance Eq-} )
+import UniqSupply ( splitUniqSupply )
+import Util ( panic{-ToDo:rm-} )
+
#if ! OMIT_DEFORESTER
import Deforest ( deforestProgram )
import DefUtils ( deforestable )
#endif
-import UniqSupply
-import Util
+
+isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
+isWrapperId = panic "SimplCore.isWrapperId (ToDo)"
\end{code}
\begin{code}
core2core :: [CoreToDo] -- spec of what core-to-core passes to do
- -> (GlobalSwitch->SwitchResult)-- "global" command-line info lookup fn
-> FAST_STRING -- module name (profiling only)
-> PprStyle -- printing style (for debugging only)
-> UniqSupply -- a name supply
@@ -67,12 +90,14 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do
IdEnv UnfoldingDetails, -- unfoldings to be exported from here
SpecialiseData) -- specialisation data
-core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs binds
+core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
= BSCC("Core2Core")
if null core_todos then -- very rare, I suspect...
-- well, we still must do some renumbering
returnMn (
- (snd (instCoreBindings (mkUniqueSupplyGrimily us) binds), nullIdEnv, init_specdata)
+ (substCoreBindings nullIdEnv nullTyVarEnv binds us,
+ nullIdEnv,
+ init_specdata)
)
else
(if do_verbose_core2core then
@@ -85,7 +110,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
core_todos
`thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
- (if switch_is_on D_simplifier_stats
+ (if opt_D_simplifier_stats
then writeMn stderr ("\nSimplifier Stats:\n")
`thenMn_`
writeMn stderr (showSimplCount simpl_stats)
@@ -99,18 +124,16 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
where
init_specdata = initSpecData local_tycons tycon_specs
- switch_is_on = switchIsOn sw_chkr
-
- do_verbose_core2core = switch_is_on D_verbose_core2core
+ do_verbose_core2core = opt_D_verbose_core2core
lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
-- Use 4x a known threshold
- = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
+ = case opt_UnfoldingOverrideThreshold of
Nothing -> 4 * uNFOLDING_USE_THRESHOLD
Just xx -> 4 * xx
-------------
- core_linter = if switch_is_on DoCoreLinting
+ core_linter = if opt_DoCoreLinting
then lintCoreBindings ppr_style
else ( \ whodunnit spec_done binds -> binds )
@@ -124,7 +147,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
-> BSCC("CoreSimplify")
begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
then " (foldr/build)" else "") `thenMn_`
- case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of
+ case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
(p, it_cnt, simpl_stats2)
-> end_pass False us2 p inline_env spec_data simpl_stats2
("Simplify (" ++ show it_cnt ++ ")"
@@ -135,14 +158,14 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
CoreDoFoldrBuildWorkerWrapper
-> BSCC("CoreDoFoldrBuildWorkerWrapper")
begin_pass "FBWW" `thenMn_`
- case (mkFoldrBuildWW switch_is_on us1 binds) of { binds2 ->
+ case (mkFoldrBuildWW us1 binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
} ESCC
CoreDoFoldrBuildWWAnal
-> BSCC("CoreDoFoldrBuildWWAnal")
begin_pass "AnalFBWW" `thenMn_`
- case (analFBWW switch_is_on binds) of { binds2 ->
+ case (analFBWW binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
} ESCC
@@ -156,14 +179,14 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
-> BSCC("CoreInlinings1")
begin_pass "CalcInlinings" `thenMn_`
- case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 ->
+ case (calcInlinings False inline_env binds) of { inline_env2 ->
end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
} ESCC
CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
-> BSCC("CoreInlinings2")
begin_pass "CalcInlinings" `thenMn_`
- case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 ->
+ case (calcInlinings True inline_env binds) of { inline_env2 ->
end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
} ESCC
@@ -177,7 +200,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
CoreDoFullLaziness
-> BSCC("CoreFloating")
begin_pass "FloatOut" `thenMn_`
- case (floatOutwards switch_is_on us1 binds) of { binds2 ->
+ case (floatOutwards us1 binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut"
} ESCC
@@ -194,20 +217,20 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
CoreDoStrictness
-> BSCC("CoreStranal")
begin_pass "StrAnal" `thenMn_`
- case (saWwTopBinds us1 switch_is_on binds) of { binds2 ->
+ case (saWwTopBinds us1 binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal"
} ESCC
CoreDoSpecialising
-> BSCC("Specialise")
begin_pass "Specialise" `thenMn_`
- case (specProgram switch_is_on us1 binds spec_data) of {
+ case (specProgram us1 binds spec_data) of {
(p, spec_data2@(SpecData _ spec_noerrs _ _ _
spec_errs spec_warn spec_tyerrs)) ->
-- if we got errors, we die straight away
(if not spec_noerrs ||
- (switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then
+ (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
writeMn stderr (ppShow 1000 {-pprCols-}
(pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
`thenMn_` writeMn stderr "\n"
@@ -229,7 +252,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
#else
-> BSCC("Deforestation")
begin_pass "Deforestation" `thenMn_`
- case (deforestProgram sw_chkr binds us1) of { binds2 ->
+ case (deforestProgram binds us1) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
}
ESCC
@@ -238,7 +261,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
CoreDoAutoCostCentres
-> BSCC("AutoSCCs")
begin_pass "AutoSCCs" `thenMn_`
- case (addAutoCostCentres sw_chkr module_name binds) of { binds2 ->
+ case (addAutoCostCentres module_name binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs"
}
ESCC
@@ -250,7 +273,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
-------------------------------------------------
begin_pass
- = if switch_is_on D_show_passes
+ = if opt_D_show_passes
then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n")
else \ what -> returnMn ()
@@ -264,7 +287,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b
writeMn stderr ("\n*** "++what++":\n")
`thenMn_`
writeMn stderr (ppShow 1000
- (ppAboves (map (pprPlainCoreBinding ppr_style) binds2)))
+ (ppAboves (map (pprCoreBinding ppr_style) binds2)))
`thenMn_`
writeMn stderr "\n"
else
@@ -307,12 +330,11 @@ will be visible on the other side of an interface, too.
\begin{code}
calcInlinings :: Bool -- True => inlinings with _scc_s are OK
- -> (GlobalSwitch -> SwitchResult)
-> IdEnv UnfoldingDetails
-> [CoreBinding]
-> IdEnv UnfoldingDetails
-calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
+calcInlinings scc_s_OK inline_env_so_far top_binds
= let
result = foldl calci inline_env_so_far top_binds
in
@@ -323,30 +345,28 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
= ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
where
pp_det NoUnfoldingDetails = ppStr "_N_"
- pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
+--LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
pp_det (GenForm _ _ expr guide)
= ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
pp_det other = ppStr "???"
------------
- switch_is_on = switchIsOn sw_chkr
-
- my_trace = if (switch_is_on ReportWhyUnfoldingsDisallowed)
+ my_trace = if opt_ReportWhyUnfoldingsDisallowed
then trace
else \ msg stuff -> stuff
(unfolding_creation_threshold, explicit_creation_threshold)
- = case (intSwitchSet sw_chkr UnfoldingCreationThreshold) of
+ = case opt_UnfoldingCreationThreshold of
Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
Just xx -> (xx, True)
unfold_use_threshold
- = case (intSwitchSet sw_chkr UnfoldingUseThreshold) of
+ = case opt_UnfoldingUseThreshold of
Nothing -> uNFOLDING_USE_THRESHOLD
Just xx -> xx
unfold_override_threshold
- = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of
+ = case opt_UnfoldingOverrideThreshold of
Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
Just xx -> xx
@@ -378,20 +398,15 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
which = if scc_s_OK then " (late):" else " (early):"
in
- --pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug
- -- [rhs_mentions_an_unmentionable, explicit_INLINE_requested,
- -- rhs_looks_like_a_caf, guidance_says_don't, guidance_size_too_big]]) (
my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
ignominious_defeat
)
- --)
| rhs `isWrapperFor` binder
-- Don't add an explicit "unfolding"; let the worker/wrapper
-- stuff do its thing. INLINE things don't get w/w'd, so
-- they will be OK.
- = --pprTrace "giving up on isWrapperFor:" (ppr PprDebug binder)
- ignominious_defeat
+ = ignominious_defeat
#if ! OMIT_DEFORESTER
-- For the deforester: bypass the barbed wire for recursive
@@ -474,8 +489,8 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
rhs_looks_like_a_data_val
= case (collectBinders rhs) of
- (_, _, [], Con _ _ _) -> True
- other -> False
+ (_, _, [], Con _ _) -> True
+ other -> False
rhs_arg_tys
= case (collectBinders rhs) of
@@ -485,13 +500,11 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
= mentionedInUnfolding (\x -> x) rhs
rhs_mentions_an_unmentionable
- = --pprTrace "mentions:" (ppCat [ppr PprDebug binder, ppr PprDebug [(i,unfoldingUnfriendlyId i) | i <- mentioned_ids ]]) (
- any unfoldingUnfriendlyId mentioned_ids
+ = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
|| mentions_litlit
- --)
-- ToDo: probably need to chk tycons/classes...
- mentions_no_other_ids = null mentioned_ids
+ mentions_no_other_ids = isEmptyBag mentioned_ids
explicit_INLINE_requested
-- did it come from a user {-# INLINE ... #-}?
@@ -530,7 +543,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
= let
new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
- foldr_building = switch_is_on FoldrBuildOn
+ foldr_building = opt_FoldrBuildOn
in
if (not have_inlining_already) then
-- Not in env: we take it no matter what
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 6712d6a55bed17d3ff67dca79ea7e0bddd5577e1..ee87e0ae919466000cb3a4d63487d5bd8c9266cb 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -58,6 +58,7 @@ import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
)
import FiniteMap -- lots of things
import Id ( idType, getIdUnfolding, getIdStrictness,
+ applyTypeEnvToId,
nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
addOneToIdEnv, modifyIdEnv,
IdEnv(..), IdSet(..), GenId )
@@ -68,19 +69,18 @@ import PprCore -- various instances
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar )
import Pretty
-import Type ( getAppDataTyCon )
+import Type ( getAppDataTyCon, applyTypeEnvToTy )
import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
growTyVarEnvList,
- TyVarEnv(..), GenTyVar )
-import Unique ( Unique )
+ TyVarEnv(..), GenTyVar{-instance Eq-}
+ )
+import Unique ( Unique{-instance Outputable-} )
import UniqSet -- lots of things
import Usage ( UVar(..), GenUsage{-instances-} )
import Util ( zipEqual, panic, assertPanic )
type TypeEnv = TyVarEnv Type
addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)"
-applyTypeEnvToId = panic "applyTypeEnvToId (SimplEnv)"
-applyTypeEnvToTy = panic "applyTypeEnvToTy (SimplEnv)"
bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)"
cmpType = panic "cmpType (SimplEnv)"
exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
@@ -303,7 +303,7 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id
-- Only interested in Ids which have a "dangerous" unfolding; that is
-- one that claims to have a single occurrence.
= UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- (interesting_ids `unionUniqSets` singletonUniqSet id)
+ (addOneToUniqSet interesting_ids id)
con_apps
grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
@@ -496,7 +496,6 @@ extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
new_ty_env = growTyVarEnvList ty_env pairs
simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
-
simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
\end{code}
@@ -768,7 +767,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
-- (This is brought to you by *ANDY* Magic Constants, Inc.)
is_really_small
= case collectArgs new_rhs of
- (Var _, xs) -> length xs < 10
+ (Var _, _, _, xs) -> length xs < 10
_ -> False
-}
\end{code}
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index bc8fac77a7aecc3f986b767a2776b28a1972e629..1569843dd8a2317dc94e0950c48ccccc0dc38586 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -26,18 +26,16 @@ import Ubiq{-uitous-}
import SmplLoop -- well, cheating sort of
-import Id ( mkSysLocal )
+import Id ( mkSysLocal, mkIdWithNewUniq )
import SimplEnv
import SrcLoc ( mkUnknownSrcLoc )
+import TyVar ( cloneTyVar )
import UniqSupply ( getUnique, getUniques, splitUniqSupply,
UniqSupply
)
import Util ( zipWithEqual, panic )
infixr 9 `thenSmpl`, `thenSmpl_`
-
-cloneTyVar = panic "cloneTyVar (SimplMonad)"
-mkIdWithNewUniq = panic "mkIdWithNewUniq (SimplMonad)"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index ee791a660600dc0c0745f66dd30855590e7a0624..dc9d1c4846bb9ee367a1aaa8535d3c2ea7c60d4c 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -1,47 +1,52 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
-\section[SimplPgm]{Interface to the ``new'' simplifier}
+\section[SimplPgm]{Interface to the simplifier}
\begin{code}
#include "HsVersions.h"
module SimplPgm ( simplifyPgm ) where
-import Type ( getTyVarMaybe )
-import CmdLineOpts ( switchIsOn, intSwitchSet,
- GlobalSwitch(..), SimplifierSwitch(..)
+import Ubiq{-uitous-}
+
+import CmdLineOpts ( opt_D_verbose_core2core,
+ switchIsOn, intSwitchSet, SimplifierSwitch(..)
+ )
+import CoreSyn
+import CoreUtils ( substCoreExpr )
+import Id ( externallyVisibleId,
+ mkIdEnv, lookupIdEnv, IdEnv(..),
+ GenId{-instance Ord3-}
)
-import Id ( externallyVisibleId )
-import IdInfo
-import Maybes ( catMaybes, Maybe(..) )
-import Outputable
+import Maybes ( catMaybes )
+import OccurAnal ( occurAnalyseBinds )
+import Outputable ( isExported )
+import Pretty ( ppAboves, ppBesides, ppInt, ppChar, ppStr )
import SimplEnv
import SimplMonad
import Simplify ( simplTopBinds )
-import OccurAnal -- occurAnalyseBinds
-import UniqSupply
-import Util
+import TyVar ( nullTyVarEnv, TyVarEnv(..) )
+import UniqSupply ( thenUs, returnUs, mapUs, splitUniqSupply, UniqSM(..) )
+import Util ( isIn, isn'tIn, removeDups, pprTrace )
\end{code}
\begin{code}
-simplifyPgm :: [CoreBinding] -- input
- -> (GlobalSwitch->SwitchResult) -- switch lookup fns (global
- -> (SimplifierSwitch->SwitchResult) -- and this-simplification-specific)
- -> SimplCount -- info about how many times
- -- each transformation has occurred
+simplifyPgm :: [CoreBinding] -- input
+ -> (SimplifierSwitch->SwitchResult)
+ -> SimplCount -- info about how many times
+ -- each transformation has occurred
-> UniqSupply
-> ([CoreBinding], -- output
- Int, -- info about how much happened
- SimplCount) -- accumulated simpl stats
+ Int, -- info about how much happened
+ SimplCount) -- accumulated simpl stats
-simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us
+simplifyPgm binds s_sw_chkr simpl_stats us
= case (splitUniqSupply us) of { (s1, s2) ->
case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) ->
case (tidy_top pgm2 s2) of { pgm3 ->
(pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}}
where
- global_switch_is_on = switchIsOn g_sw_chkr
simpl_switch_is_on = switchIsOn s_sw_chkr
occur_anal = occurAnalyseBinds
@@ -56,11 +61,8 @@ simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us
simpl_pgm n iterations pgm
= -- find out what top-level binders are used,
-- and prepare to unfold all the "simple" bindings
- -- pprTrace ("\niteration "++show iterations++":\n") (ppr PprDebug pgm) (
let
- tagged_pgm = BSCC("OccurBinds")
- occur_anal pgm global_switch_is_on simpl_switch_is_on
- ESCC
+ tagged_pgm = occur_anal pgm simpl_switch_is_on
in
-- do the business
simplTopBinds (nullSimplEnv s_sw_chkr) tagged_pgm `thenSmpl` \ new_pgm ->
@@ -74,11 +76,11 @@ simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us
show_status = pprTrace "NewSimpl: " (ppAboves [
ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations],
ppStr (showSimplCount dr)
---DEBUG: , ppAboves (map (pprPlainCoreBinding PprDebug) new_pgm)
+--DEBUG: , ppAboves (map (pprCoreBinding PprDebug) new_pgm)
])
in
- (if global_switch_is_on D_verbose_core2core
+ (if opt_D_verbose_core2core
|| simpl_switch_is_on ShowSimplifierProgress
then show_status
else id)
@@ -98,7 +100,6 @@ simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us
else
simpl_pgm r (iterations + 1) new_pgm
)
- -- )
\end{code}
In @tidy_top@, we look for things at the top-level of the form...
@@ -131,10 +132,8 @@ tidy_top binds_in
= if null blast_alist then
returnUs binds_in -- no joy there
else
- -- pprTrace "undup output length:" (ppInt (length blast_alist)) (
mapUs blast binds_in `thenUs` \ binds_maybe ->
returnUs (catMaybes binds_maybe)
- -- )
where
blast_alist = undup (foldl find_cand [] binds_in)
blast_id_env = mkIdEnv blast_alist
@@ -158,13 +157,11 @@ tidy_top binds_in
undup :: [(Id, Id)] -> [(Id, Id)]
undup blast_list
- = -- pprTrace "undup input length:" (ppInt (length blast_list)) (
- let
+ = let
(singles, dups) = removeDups compare blast_list
list_of_dups = concat dups
in
[ s | s <- singles, s `not_elem` list_of_dups ]
- -- )
where
compare (x,_) (y,_) = x `cmp` y
@@ -186,25 +183,23 @@ tidy_top binds_in
returnUs (Just (Rec blasted_pairs))
where
blast_pr (binder, rhs)
- = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs ->
+ = substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
returnUs (
- case lookupIdEnv blast_id_env binder of
- Just exportee -> (exportee, blasted_rhs)
- Nothing -> (binder, blasted_rhs)
+ case (lookupIdEnv blast_id_env binder) of
+ Just exportee -> (exportee, new_rhs)
+ Nothing -> (binder, new_rhs)
)
blast (NonRec binder rhs)
= if binder `is_elem` blast_all_exps then
returnUs Nothing -- this binding dies!
else
- subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs ->
+ substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
returnUs (Just (
- case lookupIdEnv blast_id_env binder of
- Just exportee -> NonRec exportee blasted_rhs
- Nothing -> NonRec binder blasted_rhs
+ case (lookupIdEnv blast_id_env binder) of
+ Just exportee -> NonRec exportee new_rhs
+ Nothing -> NonRec binder new_rhs
))
where
is_elem = isIn "blast"
-
-subst_CoreExprUS e1 e2 rhs us = snd (substCoreExprUS e1 e2 rhs (mkUniqueSupplyGrimily us))
\end{code}
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 3f5c1a5f2fa91213e30d67954b072c3298213dd1..f546fbc054ea11fd53b30188311893837f64ded5 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -24,18 +24,23 @@ module SimplUtils (
import Ubiq{-uitous-}
import BinderInfo
+import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
import CoreUtils ( manifestlyWHNF )
-import Id ( idType, isBottomingId, getIdArity )
+import Id ( idType, isBottomingId, idWantsToBeINLINEd,
+ getIdArity, GenId{-instance Eq-}
+ )
import IdInfo ( arityMaybe )
import Maybes ( maybeToBool )
import PrelInfo ( augmentId, buildId, realWorldStateTy )
+import PrimOp ( primOpIsCheap )
import SimplEnv
import SimplMonad
-import Type ( isPrimType, maybeAppDataTyCon, getTyVar_maybe )
+import Type ( eqTy, isPrimType, maybeAppDataTyCon, getTyVar_maybe )
+import TyVar ( GenTyVar{-instance Eq-} )
import Util ( isIn, panic )
-primOpIsCheap = panic "SimplUtils. (ToDo)"
+getInstantiatedDataConSig = panic "SimplUtils.getInstantiatedDataConSig (ToDo)"
\end{code}
@@ -50,13 +55,13 @@ floatExposesHNF
:: Bool -- Float let(rec)s out of rhs
-> Bool -- Float cheap primops out of rhs
-> Bool -- OK to duplicate code
- -> GenCoreExpr bdr Id
+ -> GenCoreExpr bdr Id tyvar uvar
-> Bool
floatExposesHNF float_lets float_primops ok_to_dup rhs
= try rhs
where
- try (Case (Prim _ _ _) (PrimAlts alts deflt) )
+ try (Case (Prim _ _) (PrimAlts alts deflt) )
| float_primops && (null alts || ok_to_dup)
= or (try_deflt deflt : map try_alt alts)
@@ -132,7 +137,7 @@ mkValLamTryingEta orig_ids body
reduce_it (id:ids) (App fun (VarArg arg))
| id == arg
- && idType id /= realWorldStateTy
+ && not (idType id `eqTy` realWorldStateTy)
-- *never* eta-reduce away a PrimIO state token! (WDP 94/11)
= reduce_it ids fun
@@ -171,7 +176,7 @@ arguments as you care to give it. For this special case we return
100, to represent "infinity", which is a bit of a hack.
\begin{code}
-etaExpandCount :: GenCoreExpr bdr Id
+etaExpandCount :: GenCoreExpr bdr Id tyvar uvar
-> Int -- Number of extra args you can safely abstract
etaExpandCount (Lam (ValBinder _) body)
@@ -200,8 +205,8 @@ etaExpandCount other = 0 -- Give up
-- Case with non-whnf scrutinee
-----------------------------
-eta_fun :: GenCoreExpr bdr Id -- The function
- -> Int -- How many args it can safely be applied to
+eta_fun :: GenCoreExpr bdr Id tv uv -- The function
+ -> Int -- How many args it can safely be applied to
eta_fun (App fun arg) | notValArg arg = eta_fun fun
@@ -240,17 +245,14 @@ which aren't WHNF but are ``cheap'' are:
where op is a cheap primitive operator
\begin{code}
-manifestlyCheap :: GenCoreExpr bndr Id -> Bool
+manifestlyCheap :: GenCoreExpr bndr Id tv uv -> Bool
-manifestlyCheap (Var _) = True
-manifestlyCheap (Lit _) = True
-manifestlyCheap (Con _ _ _) = True
-manifestlyCheap (SCC _ e) = manifestlyCheap e
-
-manifestlyCheap (Lam (ValBinder _) _) = True
-manifestlyCheap (Lam other_binder e) = manifestlyCheap e
-
-manifestlyCheap (Prim op _ _) = primOpIsCheap op
+manifestlyCheap (Var _) = True
+manifestlyCheap (Lit _) = True
+manifestlyCheap (Con _ _) = True
+manifestlyCheap (SCC _ e) = manifestlyCheap e
+manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
+manifestlyCheap (Prim op _) = primOpIsCheap op
manifestlyCheap (Let bind body)
= manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
@@ -259,7 +261,7 @@ manifestlyCheap (Case scrut alts)
= manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
manifestlyCheap other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, args) ->
+ = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
case fun of
Var f | isBottomingId f -> True -- Application of a function which
@@ -268,7 +270,7 @@ manifestlyCheap other_expr -- look for manifest partial application
-- need to be shared!
Var f -> let
- num_val_args = numValArgs args
+ num_val_args = length vargs
in
num_val_args == 0 || -- Just a type application of
-- a variable (f t1 t2 t3)
@@ -381,7 +383,7 @@ mkIdentityAlts rhs_ty
in
returnSmpl (
AlgAlts
- [(data_con, new_binders, Con data_con ty_args (map VarArg new_bindees))]
+ [(data_con, new_binders, mkCon data_con [] ty_args (map VarArg new_bindees))]
NoDefault
)
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index c0a91cddea13d6d7e5ab7d4f4e1f36cb56655d46..84555a7ef68d8a5724e766fc308a4ad60aaf4d31 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -11,26 +11,31 @@ module SimplVar (
leastItCouldCost
) where
-import SimplMonad
-import SimplEnv
-import Literal ( isNoRepLit )
+import Ubiq{-uitous-}
+import SmplLoop ( simplExpr )
-import Type ( getAppDataTyCon, maybeAppDataTyCon,
- getTyConFamilySize, isPrimType
- )
-import BinderInfo ( oneTextualOcc, oneSafeOcc )
import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
uNFOLDING_CON_DISCOUNT_WEIGHT
)
-import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) )
-import Id ( idType, getIdInfo )
-import IdInfo
-import Maybes ( maybeToBool, Maybe(..) )
-import Simplify ( simplExpr )
-import SimplUtils ( simplIdWantsToBeINLINEd )
-import MagicUFs
-import Pretty
-import Util
+import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) )
+import CoreSyn
+import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
+ FormSummary(..)
+ )
+import Id ( idType, getIdInfo,
+ GenId{-instance Outputable-}
+ )
+import IdInfo ( DeforestInfo(..) )
+import Literal ( isNoRepLit )
+import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( ppBesides, ppStr )
+import SimplEnv
+import SimplMonad
+import TyCon ( tyConFamilySize )
+import Type ( isPrimType, getAppDataTyCon, maybeAppDataTyCon )
+import Util ( pprTrace, assertPanic, panic )
\end{code}
%************************************************************************
@@ -56,11 +61,11 @@ completeVar env var args
-> ASSERT( null args )
returnSmpl (Lit lit)
- ConForm con ty_args val_args
+ ConForm con args
-- Always inline constructors.
-- See comments before completeLetBinding
-> ASSERT( null args )
- returnSmpl (Con con ty_args val_args)
+ returnSmpl (Con con args)
GenForm txt_occ form_summary template guidance
-> considerUnfolding env var args
@@ -82,7 +87,8 @@ completeVar env var args
tick MagicUnfold `thenSmpl_`
returnSmpl magic_result
- IWantToBeINLINEd _ -> returnSmpl boring_result
+-- LATER:
+-- IWantToBeINLINEd _ -> returnSmpl boring_result
other -> returnSmpl boring_result
\end{code}
@@ -135,7 +141,7 @@ considerUnfolding env var args txt_occ form_summary template guidance
= go_for_it
| (case form_summary of {BottomForm -> True; other -> False} &&
- not (any isPrimType [ ty | (TypeArg ty) <- args ]))
+ not (any isPrimType [ ty | (TyArg ty) <- args ]))
-- Always inline bottoming applications, unless
-- there's a primitive type lurking around...
= go_for_it
@@ -193,16 +199,19 @@ considerUnfolding env var args txt_occ form_summary template guidance
con_discount -- ToDo: ************ get from a switch *********
= uNFOLDING_CON_DISCOUNT_WEIGHT
- (tyargs, valargs, args_left) = decomposeArgs args
+ (_, _, tyargs, valargs) = collectArgs args_in_dummy_expr
no_tyargs = length tyargs
no_valargs = length valargs
+ args_in_dummy_expr = mkGenApp (Var (panic "SimplVar.dummy")) args
+ -- we concoct this dummy expr, just so we can use collectArgs
+ -- (rather than make up a special-purpose bit of code)
rhs_looks_like_a_Con
= let
(_,_,val_binders,body) = collectBinders template
in
case (val_binders, body) of
- ([], Con _ _ _) -> True
+ ([], Con _ _) -> True
other -> False
dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
@@ -229,7 +238,7 @@ discountedCost
-> Int -- the size/cost of the expr
-> Int -- the number of val args (== length args)
-> ArgInfoVector -- what we know about the *use* of the arguments
- -> [OutAtom] -- *an actual set of value arguments*!
+ -> [OutArg] -- *an actual set of value arguments*!
-> Int
-- If we apply an expression (usually a function) of given "costs"
@@ -249,8 +258,7 @@ discountedCost env con_discount_weight size no_args is_con_vec args
full_price = disc size
take_something_off v = let
(tycon, _, _) = getAppDataTyCon (idType v)
- no_cons = case (getTyConFamilySize tycon) of
- Just n -> n
+ no_cons = tyConFamilySize tycon
reduced_size
= size - (no_cons * con_discount_weight)
in
@@ -262,8 +270,8 @@ discountedCost env con_discount_weight size no_args is_con_vec args
case arg of
LitArg _ -> full_price
VarArg v -> case lookupUnfolding env v of
- ConForm _ _ _ -> take_something_off v
- other_form -> full_price
+ ConForm _ _ -> take_something_off v
+ other_form -> full_price
) want_cons rest_args
\end{code}
@@ -294,7 +302,7 @@ leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
= let
take_something_off tycon
= let
- no_cons = case (getTyConFamilySize tycon) of { Just n -> n }
+ no_cons = tyConFamilySize tycon
reduced_size
= size - (no_cons * con_discount_weight)
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 36591fc7de6cebe535598546a01c21047f8aa441..962b6d008929ce21df3284b588ad390a91b50cc7 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -8,34 +8,38 @@
module Simplify ( simplTopBinds, simplExpr, simplBind ) where
-import Pretty -- these are for debugging only
-import Outputable
+import Ubiq{-uitous-}
+import SmplLoop -- paranoia checking
-import SimplMonad
-import SimplEnv
-
-import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..),
- primOpOkForSpeculation, PrimOp(..), PrimRep,
- realWorldStateTy
- IF_ATTACK_PRAGMAS(COMMA realWorldTy)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Type ( maybeAppDataTyCon, mkTyVarTy, mkTyVarTys, applyTy,
- splitTyArgs, splitTypeWithDictsAsArgs,
- maybeUnpackFunTy, isPrimType
- )
-import Literal ( isNoRepLit, Literal(..) )
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
-import Id
-import IdInfo
-import Maybes ( Maybe(..), catMaybes, maybeToBool )
-import SimplCase
-import SimplUtils
+import CoreSyn
+import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
+ unTagBinders, squashableDictishCcExpr,
+ manifestlyWHNF
+ )
+import Id ( idType, idWantsToBeINLINEd,
+ getIdDemandInfo, addIdDemandInfo,
+ GenId{-instance NamedThing-}
+ )
+import IdInfo ( willBeDemanded, DemandInfo )
+import Literal ( isNoRepLit )
+import Maybes ( maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import PrelInfo ( realWorldStateTy )
+import Pretty ( ppAbove )
+import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
+import SimplCase ( simplCase, bindLargeRhs )
+import SimplEnv
+import SimplMonad
import SimplVar ( completeVar )
-import Util
+import SimplUtils
+import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
+ splitFunTy, getFunTy_maybe, eqTy
+ )
+import Util ( isSingleton, panic, pprPanic, assertPanic )
\end{code}
The controlling flags, and what they do
@@ -122,12 +126,12 @@ would occur]. But consider:
f = \y -> ...y...y...y...
in f x
@
-Now, it seems that @x@ appears only once, but even so it is NOT safe to put @x@
-in the UnfoldEnv, because @f@ will be inlined, and will duplicate the references to
-@x@.
+Now, it seems that @x@ appears only once, but even so it is NOT safe
+to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
+duplicate the references to @x@.
-Becuase of this, the "unconditional-inline" mechanism above is the only way
-in which non-HNFs can get inlined.
+Because of this, the "unconditional-inline" mechanism above is the
+only way in which non-HNFs can get inlined.
INLINE pragmas
~~~~~~~~~~~~~~
@@ -185,12 +189,10 @@ simplTopBinds env [] = returnSmpl []
simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
| inlineUnconditionally ok_to_dup_code occ_info
- = --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) (
- let
+ = let
new_env = extendIdEnvWithInlining env env binder rhs
in
simplTopBinds new_env binds
- --)
where
ok_to_dup_code = switchIsSet env SimplOkToDupCode
@@ -200,12 +202,10 @@ simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
let
new_env = case rhs' of
- Var var -> extendIdEnvWithAtom env binder (VarArg var)
- Lit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (LitArg lit)
- other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
+ Var v -> extendIdEnvWithAtom env binder (VarArg v)
+ Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
+ other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
in
- --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) (
-
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds' ->
@@ -214,19 +214,15 @@ simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
-- an unused atom binding. This localises the decision about
-- discarding top-level bindings.
returnSmpl (NonRec in_id rhs' : binds')
- --)
simplTopBinds env (Rec pairs : binds)
= simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
- --pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) (
-
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds' ->
-- Glue together and return
returnSmpl (bind' : binds')
- --)
where
triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
-- No cloning necessary at top level
@@ -251,15 +247,14 @@ applied to the specified arguments.
Variables
~~~~~~~~~
-Check if there's a macro-expansion, and if so rattle on. Otherwise
-do the more sophisticated stuff.
+Check if there's a macro-expansion, and if so rattle on. Otherwise do
+the more sophisticated stuff.
\begin{code}
simplExpr env (Var v) args
- = --pprTrace "simplExpr:Var:" (ppr PprDebug v) (
- case lookupId env v of
+ = case (lookupId env v) of
Nothing -> let
- new_v = simplTyInId env v
+ new_v = simplTyInId env v
in
completeVar env new_v args
@@ -278,15 +273,16 @@ simplExpr env (Var v) args
InlineIt id_env ty_env in_expr -- A macro-expansion
-> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
- --)
\end{code}
Literals
-~~~~~~~~~
+~~~~~~~~
\begin{code}
simplExpr env (Lit l) [] = returnSmpl (Lit l)
+#ifdef DEBUG
simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
+#endif
\end{code}
Primitive applications are simple.
@@ -296,14 +292,13 @@ NB: Prim expects an empty argument list! (Because it should be
saturated and not higher-order. ADR)
\begin{code}
-simplExpr env (Prim op tys prim_args) args
+simplExpr env (Prim op prim_args) args
= ASSERT (null args)
let
- tys' = [simplTy env ty | ty <- tys]
- prim_args' = [simplAtom env prim_arg | prim_arg <- prim_args]
+ prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]
op' = simpl_op op
in
- completePrim env op' tys' prim_args'
+ completePrim env op' prim_args'
where
-- PrimOps just need any types in them renamed.
@@ -323,12 +318,9 @@ Nothing to try here. We only reuse constructors when they appear as the
rhs of a let binding (see completeLetBinding).
\begin{code}
-simplExpr env (Con con tys con_args) args
+simplExpr env (Con con con_args) args
= ASSERT( null args )
- returnSmpl (Con con tys' con_args')
- where
- con_args' = [simplAtom env con_arg | con_arg <- con_args]
- tys' = [simplTy env ty | ty <- tys]
+ returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])
\end{code}
@@ -338,10 +330,7 @@ Just stuff 'em in the arg stack
\begin{code}
simplExpr env (App fun arg) args
- = simplExpr env fun (ValArg (simplAtom env arg) : args)
-
-simplExpr env (CoTyApp fun ty) args
- = simplExpr env fun (TypeArg (simplTy env ty) : args)
+ = simplExpr env fun (simplArg env arg : args)
\end{code}
Type lambdas
@@ -352,7 +341,7 @@ be eta-reduced. This requires us to collect up all tyvar parameters so
we can pass them all to @mkTyLamTryingEta@.
\begin{code}
-simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
+simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
= -- ASSERT(not (isPrimType ty))
let
new_env = extendTyEnv env tyvar ty
@@ -360,10 +349,10 @@ simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
tick TyBetaReduction `thenSmpl_`
simplExpr new_env body args
-simplExpr env tylam@(CoTyLam tyvar body) []
+simplExpr env tylam@(Lam (TyBinder tyvar) body) []
= do_tylambdas env [] tylam
where
- do_tylambdas env tyvars' (CoTyLam tyvar body)
+ do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)
= -- Clone the type variable
cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' ->
let
@@ -376,11 +365,13 @@ simplExpr env tylam@(CoTyLam tyvar body) []
returnSmpl (
(if switchIsSet env SimplDoEtaReduction
then mkTyLamTryingEta
- else mkCoTyLam) (reverse tyvars') body'
+ else mkTyLam) (reverse tyvars') body'
)
-simplExpr env (CoTyLam tyvar body) (ValArg _ : _)
- = panic "simplExpr:CoTyLam ValArg"
+#ifdef DEBUG
+simplExpr env (Lam (TyBinder _) _) (_ : _)
+ = panic "simplExpr:TyLam with non-TyArg"
+#endif
\end{code}
@@ -388,7 +379,7 @@ Ordinary lambdas
~~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env (Lam binder body) args
+simplExpr env (Lam (ValBinder binder) body) args
| null leftover_binders
= -- The lambda is saturated (or over-saturated)
tick BetaReduction `thenSmpl_`
@@ -407,7 +398,7 @@ simplExpr env (Lam binder body) args
0 {- Guaranteed applied to at least 0 args! -}
where
- (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args [binder] args
+ (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args
env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
@@ -427,24 +418,23 @@ simplExpr env (Lam binder body) args
zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
| ((id, occ_info), arg) <- binder_args_pairs ]
- collect_val_args :: [InBinder] -- Binders
- -> [OutArg] -- Arguments
- -> ([(InBinder,OutAtom)], -- Binder,arg pairs
- [InBinder], -- Leftover binders
- [OutArg]) -- Leftover args
+ collect_val_args :: InBinder -- Binder
+ -> [OutArg] -- Arguments
+ -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?)
+ [InBinder], -- Leftover binders (ToDo: a maybe)
+ [OutArg]) -- Leftover args
-- collect_val_args strips off the leading ValArgs from
-- the current arg list, returning them along with the
-- depleted list
- collect_val_args [] args = ([], [], args)
- collect_val_args binders [] = ([], binders, [])
- collect_val_args (binder:binders) (ValArg val_arg : args)
- = ((binder,val_arg):rest_pairs, leftover_binders, leftover_args)
- where
- (rest_pairs, leftover_binders, leftover_args) = collect_val_args binders args
-
- collect_val_args (binder:binders) (other_val_arg : args) = panic "collect_val_args"
- -- TypeArg should never meet a Lam
+ collect_val_args binder [] = ([], [binder], [])
+ collect_val_args binder (arg : args) | isValArg arg
+ = ([(binder,arg)], [], args)
+
+#ifdef DEBUG
+ collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
+ -- TyArg should never meet a Lam
+#endif
\end{code}
@@ -486,9 +476,6 @@ interfaces change less (arities).
\begin{code}
simplExpr env (SCC cc (Lam binder body)) args
= simplExpr env (Lam binder (SCC cc body)) args
-
-simplExpr env (SCC cc (CoTyLam tyvar body)) args
- = simplExpr env (CoTyLam tyvar (SCC cc body)) args
\end{code}
Some other slightly turgid SCC tidying-up cases:
@@ -559,7 +546,7 @@ simplRhsExpr env binder@(id,occ_info) rhs
returnSmpl (
(if switchIsSet env SimplDoEtaReduction
then mkTyLamTryingEta
- else mkCoTyLam) tyvars' lambda'
+ else mkTyLam) tyvars' lambda'
)
where
-- Note from ANDY:
@@ -590,10 +577,12 @@ simplRhsExpr env binder@(id,occ_info) rhs
-- non-trivial.
dont_eta_expand (Lit _) = True
dont_eta_expand (Var _) = True
- dont_eta_expand (CoTyApp f _) = dont_eta_expand f
- dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
- dont_eta_expand (Con _ _ _) = True
- dont_eta_expand _ = False
+ dont_eta_expand (Con _ _) = True
+ dont_eta_expand (App f a)
+ | notValArg a = dont_eta_expand f
+ dont_eta_expand (Lam x b)
+ | notValBinder x = dont_eta_expand b
+ dont_eta_expand _ = False
\end{code}
@@ -628,8 +617,8 @@ simplLam env binders body min_no_of_args
let
new_env = extendIdEnvWithClones env binders binders'
in
- newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
- simplExpr new_env body (map (ValArg.VarArg) extra_binders') `thenSmpl` \ body' ->
+ newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
+ simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
then mkValLamTryingEta
@@ -638,7 +627,7 @@ simplLam env binders body min_no_of_args
where
(potential_extra_binder_tys, res_ty)
- = splitTyArgs (simplTy env (coreExprType (unTagBinders body)))
+ = splitFunTy (simplTy env (coreExprType (unTagBinders body)))
-- Note: it's possible that simplLam will be applied to something
-- with a forall type. Eg when being applied to the rhs of
-- let x = wurble
@@ -661,8 +650,8 @@ simplLam env binders body min_no_of_args
-- but usually doesn't
`max`
case potential_extra_binder_tys of
- [ty] | ty == realWorldStateTy -> 1
- other -> 0
+ [ty] | ty `eqTy` realWorldStateTy -> 1
+ other -> 0
\end{code}
@@ -677,7 +666,7 @@ simplLam env binders body min_no_of_args
simplBind :: SimplEnv
-> InBinding
-> (SimplEnv -> SmplM OutExpr)
- -> OutUniType
+ -> OutType
-> SmplM OutExpr
\end{code}
@@ -1028,8 +1017,8 @@ simplRecursiveGroup env triples
(early_triples, late_triples)
= partition is_early_triple ordinary_triples
- is_early_triple (_, (_, Con _ _ _)) = True
- is_early_triple (i, _ ) = idWantsToBeINLINEd i
+ is_early_triple (_, (_, Con _ _)) = True
+ is_early_triple (i, _ ) = idWantsToBeINLINEd i
in
-- Process the early bindings first
mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
@@ -1102,7 +1091,7 @@ completeLet
-> InExpr -- Original RHS
-> OutExpr -- The simplified RHS
-> (SimplEnv -> SmplM OutExpr) -- Body handler
- -> OutUniType -- Type of body
+ -> OutType -- Type of body
-> SmplM OutExpr
completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
@@ -1126,7 +1115,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
= cloneId env binder `thenSmpl` \ id' ->
let
env1 = extendIdEnvWithClone env binder id'
- new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
+ new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs
in
body_c new_env `thenSmpl` \ body' ->
returnSmpl (Let (NonRec id' new_rhs) body')
@@ -1137,7 +1126,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
- maybe_atomic_rhs :: Maybe (OutAtom, TickType)
+ maybe_atomic_rhs :: Maybe (OutArg, TickType)
-- If the RHS is atomic, we return Just (atom, tick type)
-- otherwise Nothing
@@ -1148,7 +1137,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
Lit lit | not (isNoRepLit lit)
-> Just (LitArg lit, AtomicRhs)
- Con con tys con_args
+ Con con con_args
| try_to_reuse_constr
-- Look out for
-- let v = C args
@@ -1156,7 +1145,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
--- ...(let w = C same-args in ...)...
-- Then use v instead of w. This may save
-- re-constructing an existing constructor.
- -> case lookForConstructor env con tys con_args of
+ -> case (lookForConstructor env con con_args) of
Nothing -> Nothing
Just var -> Just (VarArg var, ConReused)
@@ -1173,15 +1162,16 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
%************************************************************************
\begin{code}
-simplAtom :: SimplEnv -> InAtom -> OutAtom
+simplArg :: SimplEnv -> InArg -> OutArg
-simplAtom env (LitArg lit) = LitArg lit
+simplArg env (LitArg lit) = LitArg lit
+simplArg env (TyArg ty) = TyArg (simplTy env ty)
-simplAtom env (VarArg id)
+simplArg env (VarArg id)
| isLocallyDefined id
= case lookupId env id of
Just (ItsAnAtom atom) -> atom
- Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
+ Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
Nothing -> VarArg id -- Must be an uncloned thing
| otherwise
@@ -1209,20 +1199,20 @@ fix_up_demandedness False {- May not be demanded -} (Rec pairs)
un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
-is_cheap_prim_app (Prim op tys args) = primOpOkForSpeculation op
-is_cheap_prim_app other = False
+is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
+is_cheap_prim_app other = False
-computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
+computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType
computeResultType env expr args
- = do expr_ty' args
+ = go expr_ty' args
where
expr_ty = coreExprType (unTagBinders expr)
expr_ty' = simplTy env expr_ty
- do ty [] = ty
- do ty (TypeArg ty_arg : args) = do (applyTy ty ty_arg) args
- do ty (ValArg a : args) = case maybeUnpackFunTy ty of
- Just (_, res_ty) -> do res_ty args
- Nothing -> panic "computeResultType"
+ go ty [] = ty
+ go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
+ go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
+ Just (_, res_ty) -> go res_ty args
+ Nothing -> panic "computeResultType"
\end{code}
diff --git a/ghc/compiler/simplCore/SmplLoop.lhi b/ghc/compiler/simplCore/SmplLoop.lhi
index 89de04b35cfeaef7841fefc6c29660e5835b2a1d..3a9e3493e87ea4269d970088c168544efb6600b5 100644
--- a/ghc/compiler/simplCore/SmplLoop.lhi
+++ b/ghc/compiler/simplCore/SmplLoop.lhi
@@ -1,10 +1,26 @@
Breaks the loop between SimplEnv and MagicUFs, by telling SimplEnv all
it needs to know about MagicUFs (not much).
+Also break the loop between SimplVar/SimplCase (which use
+Simplify.simplExpr) and SimplExpr (which uses whatever
+SimplVar/SimplCase cough up).
+
\begin{code}
interface SmplLoop where
-import MagicUFs (MagicUnfoldingFun )
+import MagicUFs ( MagicUnfoldingFun )
+import SimplEnv ( SimplEnv, InBinding(..), InExpr(..),
+ OutArg(..), OutExpr(..), OutType(..)
+ )
+import Simplify ( simplExpr, simplBind )
+import SimplMonad ( SmplM(..) )
data MagicUnfoldingFun
+
+simplExpr :: SimplEnv -> InExpr -> [OutArg] -> SmplM OutExpr
+simplBind :: SimplEnv
+ -> InBinding
+ -> (SimplEnv -> SmplM OutExpr)
+ -> OutType
+ -> SmplM OutExpr
\end{code}
diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs
index 40d180a318e52599f7033e99350258b7b5452ba8..b1c83ddba6c4d70b67d4abf1e978b53da82334d1 100644
--- a/ghc/compiler/simplStg/LambdaLift.lhs
+++ b/ghc/compiler/simplStg/LambdaLift.lhs
@@ -1,5 +1,5 @@
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[LambdaLift]{A STG-code lambda lifter}
@@ -8,18 +8,20 @@
module LambdaLift ( liftProgram ) where
+import Ubiq{-uitous-}
+
import StgSyn
-import Type ( mkForallTy, splitForalls, glueTyArgs,
- Type, RhoType(..), TauType(..)
+import Bag ( emptyBag, unionBags, unitBag, snocBag, bagToList )
+import Id ( idType, mkSysLocal, addIdArity,
+ mkIdSet, unitIdSet, minusIdSet,
+ unionManyIdSets, idSetToList, IdSet(..),
+ nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..)
)
-import Bag
-import Id ( mkSysLocal, idType, addIdArity, Id )
-import Maybes
-import UniqSupply
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import UniqSet
-import Util
+import SrcLoc ( mkUnknownSrcLoc )
+import Type ( splitForAllTy, mkForAllTys, mkFunTys )
+import UniqSupply ( getUnique, splitUniqSupply )
+import Util ( zipEqual, panic, assertPanic )
\end{code}
This is the lambda lifter. It turns lambda abstractions into
@@ -251,9 +253,9 @@ liftExpr (StgLet (StgRec pairs) body)
let
-- Find the free vars of all the rhss,
-- excluding the binders themselves.
- rhs_free_vars = unionManyUniqSets (map rhsFreeVars rhss)
- `minusUniqSet`
- mkUniqSet binders
+ rhs_free_vars = unionManyIdSets (map rhsFreeVars rhss)
+ `minusIdSet`
+ mkIdSet binders
rhs_info = unionLiftInfos rhs_infos
in
@@ -335,7 +337,7 @@ isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _
isLiftableRec other_rhs = False
rhsFreeVars :: StgRhs -> IdSet
-rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkUniqSet fvs
+rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkIdSet fvs
rhsFreeVars other = panic "rhsFreeVars"
\end{code}
@@ -364,22 +366,18 @@ mkScPieces :: IdSet -- Extra args for the supercombinator
mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body)
= ASSERT( n_args > 0 )
-- Construct the rhs of the supercombinator, and its Id
- -- this trace blackholes sometimes, don't use it
- -- trace ("LL " ++ show (length (uniqSetToList extra_arg_set))) (
newSupercombinator sc_ty arity `thenLM` \ sc_id ->
-
returnLM ((sc_id, extra_args), (sc_id, sc_rhs))
- --)
where
n_args = length args
- extra_args = uniqSetToList extra_arg_set
+ extra_args = idSetToList extra_arg_set
arity = n_args + length extra_args
-- Construct the supercombinator type
type_of_original_id = idType id
extra_arg_tys = map idType extra_args
- (tyvars, rest) = splitForalls type_of_original_id
- sc_ty = mkForallTy tyvars (glueTyArgs extra_arg_tys rest)
+ (tyvars, rest) = splitForAllTy type_of_original_id
+ sc_ty = mkForAllTys tyvars (mkFunTys extra_arg_tys rest)
sc_rhs = StgRhsClosure cc bi [] upd (extra_args ++ args) body
\end{code}
@@ -451,9 +449,9 @@ newSupercombinator ty arity ci us idenv
lookup :: Id -> LiftM (Id,[Id])
lookup v ci us idenv
- = case lookupIdEnv idenv v of
- Just result -> result
- Nothing -> (v, [])
+ = case (lookupIdEnv idenv v) of
+ Just result -> result
+ Nothing -> (v, [])
addScInlines :: [Id] -> [(Id,[Id])] -> LiftM a -> LiftM a
addScInlines ids values m ci us idenv
@@ -488,14 +486,13 @@ addScInlines ids values m ci us idenv
getFinalFreeVars :: IdSet -> LiftM IdSet
getFinalFreeVars free_vars ci us idenv
- = unionManyUniqSets (map munge_it (uniqSetToList free_vars))
+ = unionManyIdSets (map munge_it (idSetToList free_vars))
where
munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real"
-- free var
- munge_it id = case lookupIdEnv idenv id of
- Just (_, args) -> mkUniqSet args
- Nothing -> singletonUniqSet id
-
+ munge_it id = case (lookupIdEnv idenv id) of
+ Just (_, args) -> mkIdSet args
+ Nothing -> unitIdSet id
\end{code}
diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs
index 16c903e726a910584a438e8596b54c4c829e8b2b..2c9dcfc515e3474bb7b770516bd12d755e94e0f1 100644
--- a/ghc/compiler/simplStg/SatStgRhs.lhs
+++ b/ghc/compiler/simplStg/SatStgRhs.lhs
@@ -1,8 +1,10 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[SatStgRhs]{Saturates RHSs when they are partial applications}
+96/03: This is actually an essential module, as it sets arity info
+for the code generator.
\begin{display}
Subject: arg satis check
@@ -58,20 +60,22 @@ This is done for local definitions as well.
module SatStgRhs ( satStgRhs ) where
+import Ubiq{-uitous-}
+
import StgSyn
-import Type ( splitTypeWithDictsAsArgs, Class,
- TyVarTemplate, TauType(..)
+import CostCentre ( isCafCC, subsumedCosts, useCurrentCostCentre )
+import Id ( idType, getIdArity, addIdArity, mkSysLocal,
+ nullIdEnv, addOneToIdEnv, growIdEnvList,
+ lookupIdEnv, IdEnv(..)
)
-import CostCentre
-import Id ( mkSysLocal, idType, getIdArity, addIdArity )
-import IdInfo -- SIGH: ( arityMaybe, ArityInfo, OptIdInfo(..) )
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import UniqSupply
-import Util
-import Maybes
-
-type Arity = Int
+import IdInfo ( arityMaybe )
+import SrcLoc ( mkUnknownSrcLoc )
+import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) )
+import Util ( panic, assertPanic )
+
+splitTypeWithDictsAsArgs = panic "SatStgRhs.splitTypeWithDictsAsArgs (ToDo)"
+
type Count = Int
type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed
diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index be139b7a9b95fea17dfba928644f62c5eb1bee6f..7ecb01c779f5d6cd8421556a18433491df182c76 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -8,7 +8,7 @@
module SimplStg ( stg2stg ) where
-IMPORT_Trace
+import Ubiq{-uitous-}
import StgSyn
import StgUtils
@@ -16,36 +16,43 @@ import StgUtils
import LambdaLift ( liftProgram )
import SCCfinal ( stgMassageForProfiling )
import SatStgRhs ( satStgRhs )
+import StgLint ( lintStgBindings )
+import StgSAT ( doStaticArgs )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
import UpdAnal ( updateAnalyse )
-import CmdLineOpts
-import Id ( unlocaliseId )
-import MainMonad
-import Maybes ( maybeToBool, Maybe(..) )
-import Outputable
-import Pretty
-import StgLint ( lintStgBindings )
-import StgSAT ( doStaticArgs )
-import UniqSet
-import UniqSupply
-import Util
+import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup,
+ opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
+ StgToDo(..)
+ )
+import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
+ growIdEnvList, isNullIdEnv, IdEnv(..),
+ GenId{-instance Eq/Outputable -}
+ )
+import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
+import Maybes ( maybeToBool )
+import Outputable ( isExported )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( ppShow, ppAbove, ppAboves, ppStr )
+import UniqSupply ( splitUniqSupply )
+import Util ( mapAccumL, panic, assertPanic )
+
+unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
\end{code}
\begin{code}
-stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
- -> (GlobalSwitch -> SwitchResult)-- access to all global cmd-line opts
- -> FAST_STRING -- module name (profiling only)
- -> PprStyle -- printing style (for debugging only)
+stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
+ -> FAST_STRING -- module name (profiling only)
+ -> PprStyle -- printing style (for debugging only)
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
-> MainIO
- ([StgBinding], -- output program...
- ([CostCentre], -- local cost-centres that need to be decl'd
- [CostCentre])) -- "extern" cost-centres
+ ([StgBinding], -- output program...
+ ([CostCentre], -- local cost-centres that need to be decl'd
+ [CostCentre])) -- "extern" cost-centres
-stg2stg stg_todos sw_chkr module_name ppr_style us binds
+stg2stg stg_todos module_name ppr_style us binds
= BSCC("Stg2Stg")
case (splitUniqSupply us) of { (us4now, us4later) ->
@@ -98,18 +105,16 @@ stg2stg stg_todos sw_chkr module_name ppr_style us binds
}}
ESCC
where
- switch_is_on = switchIsOn sw_chkr
-
- do_let_no_escapes = switch_is_on StgDoLetNoEscapes
- do_verbose_stg2stg = switch_is_on D_verbose_stg2stg
+ do_let_no_escapes = opt_StgDoLetNoEscapes
+ do_verbose_stg2stg = opt_D_verbose_stg2stg
(do_unlocalising, unlocal_tag)
- = case (stringSwitchSet sw_chkr EnsureSplittableC) of
+ = case (opt_EnsureSplittableC) of
Nothing -> (False, panic "tag")
- Just tag -> (True, _PK_ tag)
+ Just tag -> (True, tag)
- grp_name = case (stringSwitchSet sw_chkr SccGroup) of
- Just xx -> _PK_ xx
+ grp_name = case (opt_SccGroup) of
+ Just xx -> xx
Nothing -> module_name -- default: module name
-------------
@@ -158,7 +163,7 @@ stg2stg stg_todos sw_chkr module_name ppr_style us binds
BSCC("ProfMassage")
let
(collected_CCs, binds3)
- = stgMassageForProfiling module_name grp_name us1 switch_is_on binds
+ = stgMassageForProfiling module_name grp_name us1 binds
in
end_pass us2 "ProfMassage" collected_CCs binds3
ESCC
diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs
index c8a5e35dfea7131d3dca7f5b2170474363614a76..a70205e11b7e57871751a474da78db94cf911aac 100644
--- a/ghc/compiler/simplStg/StgSAT.lhs
+++ b/ghc/compiler/simplStg/StgSAT.lhs
@@ -33,19 +33,19 @@ useless as map' will be transformed back to what map was.
module StgSAT ( doStaticArgs ) where
-import Maybes ( Maybe(..) )
+import Ubiq{-uitous-}
+
import StgSyn
-import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
- SatM(..), initSAT, thenSAT, thenSAT_,
- emptyEnvSAT, returnSAT, mapSAT )
-import StgSATMonad
-import UniqSupply
-import Util
+import UniqSupply ( UniqSM(..) )
+import Util ( panic )
\end{code}
\begin{code}
doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding]
+doStaticArgs = panic "StgSAT.doStaticArgs"
+
+{- LATER: to end of file:
doStaticArgs binds
= initSAT (mapSAT sat_bind binds)
where
@@ -174,5 +174,5 @@ satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs
satRhs (StgRhsClosure cc bi fvs upd args body)
= satExpr body `thenSAT` \ body' ->
returnSAT (StgRhsClosure cc bi fvs upd args body')
+-}
\end{code}
-
diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs
index 5996c18cb86d7e3e98227d93cd0da18fc5ceeb84..57fff4d56c9b878fbc815cc861088e3311d13966 100644
--- a/ghc/compiler/simplStg/StgSATMonad.lhs
+++ b/ghc/compiler/simplStg/StgSATMonad.lhs
@@ -10,28 +10,14 @@
\begin{code}
#include "HsVersions.h"
-module StgSATMonad (
- getArgLists, saTransform
- ) where
-
-import Type ( mkSigmaTy, TyVarTemplate,
- splitSigmaTy, splitTyArgs,
- glueTyArgs, instantiateTy, TauType(..),
- Class, ThetaType(..), SigmaType(..),
- InstTyEnv(..)
- )
-import Id ( mkSysLocal, idType, eqId )
-import Maybes ( Maybe(..) )
-import StgSyn
-import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
- SatM(..), initSAT, thenSAT, thenSAT_,
- emptyEnvSAT, returnSAT, mapSAT, isStatic, dropStatics,
- getSATInfo, newSATName )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
-import UniqSupply
-import UniqSet ( UniqSet(..), emptyUniqSet )
-import Util
+module StgSATMonad ( getArgLists, saTransform ) where
+import Ubiq{-uitous-}
+
+import Util ( panic )
+
+getArgLists = panic "StgSATMonad.getArgLists"
+saTransform = panic "StgSATMonad.saTransform"
\end{code}
%************************************************************************
@@ -41,6 +27,8 @@ import Util
%************************************************************************
\begin{code}
+{- LATER: to end of file:
+
newSATNames :: [Id] -> SatM [Id]
newSATNames [] = returnSAT []
newSATNames (id:ids) = newSATName id (idType id) `thenSAT` \ id' ->
@@ -175,4 +163,5 @@ doStgSubst binder orig_args subst_env body
= remove_static_args origs as
remove_static_args (NotStatic:origs) (a:as)
= substAtom a:remove_static_args origs as
+-}
\end{code}
diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs
index a513b50fa3f17b94d5e0f93899b7c4854878fcca..8fba50ebc2648d8520df58f6efa5b2eed39d8b4f 100644
--- a/ghc/compiler/simplStg/StgStats.lhs
+++ b/ghc/compiler/simplStg/StgStats.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[StgStats]{Gathers statistical information about programs}
@@ -25,11 +25,11 @@ The program gather statistics about
module StgStats ( showStgStats ) where
-import StgSyn
+import Ubiq{-uitous-}
-import FiniteMap
+import StgSyn
-import Util
+import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList )
\end{code}
\begin{code}
@@ -63,10 +63,10 @@ combineSEs :: [StatEnv] -> StatEnv
combineSEs = foldr combineSE emptySE
countOne :: CounterType -> StatEnv
-countOne c = singletonFM c 1
+countOne c = unitFM c 1
countN :: CounterType -> Int -> StatEnv
-countN = singletonFM
+countN = unitFM
\end{code}
%************************************************************************
diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs
index 258ab152192a95c92b8cc4de91a52a6ee20aeadf..c43d816601ec8fa664cc1679eb18d2e4b8a4f91f 100644
--- a/ghc/compiler/simplStg/StgVarInfo.lhs
+++ b/ghc/compiler/simplStg/StgVarInfo.lhs
@@ -11,18 +11,23 @@ let-no-escapes.
module StgVarInfo ( setStgVarInfo ) where
-IMPORT_Trace -- ToDo: rm (debugging only)
-import Pretty
-import Outputable
+import Ubiq{-uitous-}
import StgSyn
-import Id ( getIdArity, externallyVisibleId )
-import IdInfo -- ( arityMaybe, ArityInfo )
-
-import Maybes ( maybeToBool, Maybe(..) )
-import UniqSet
-import Util
+import Id ( emptyIdSet, mkIdSet, minusIdSet,
+ unionIdSets, unionManyIdSets, isEmptyIdSet,
+ unitIdSet, intersectIdSets,
+ addOneToIdSet, IdSet(..),
+ nullIdEnv, growIdEnvList, lookupIdEnv,
+ unitIdEnv, combineIdEnvs, delManyFromIdEnv,
+ rngIdEnv, IdEnv(..),
+ GenId{-instance Eq-}
+ )
+import Maybes ( maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import Util ( panic, pprPanic, assertPanic )
infixr 9 `thenLne`, `thenLne_`
\end{code}
@@ -116,7 +121,7 @@ varsTopBinds (bind:binds)
env_extension = [(b, LetrecBound
True {- top level -}
(rhsArity rhs)
- emptyUniqSet)
+ emptyIdSet)
| (b,rhs) <- pairs]
pairs = case bind of
@@ -164,9 +169,9 @@ varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body)
= extendVarEnv [ (a, LambdaBound) | a <- args ] (
do_body args body `thenLne` \ (body2, body_fvs, body_escs) ->
let
- set_of_args = mkUniqSet args
+ set_of_args = mkIdSet args
rhs_fvs = body_fvs `minusFVBinders` args
- rhs_escs = body_escs `minusUniqSet` set_of_args
+ rhs_escs = body_escs `minusIdSet` set_of_args
binder_info = lookupFVInfo scope_fv_info binder
in
returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2,
@@ -227,9 +232,7 @@ decisions. Hence no black holes.
\begin{code}
varsExpr (StgApp lit@(StgLitArg _) args _)
- = --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) (
- returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet)
- --)
+ = returnLne (StgApp lit [] emptyIdSet, emptyFVInfo, emptyIdSet)
varsExpr (StgApp fun@(StgVarArg f) args _) = varsApp Nothing f args
@@ -257,7 +260,7 @@ varsExpr (StgCase scrut _ _ uniq alts)
vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) ->
lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
let
- live_in_alts = live_in_cont `unionUniqSets` alts_lvs
+ live_in_alts = live_in_cont `unionIdSets` alts_lvs
in
-- we tell the scrutinee that everything live in the alts
-- is live in it, too.
@@ -266,12 +269,12 @@ varsExpr (StgCase scrut _ _ uniq alts)
) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
let
- live_in_whole_case = live_in_alts `unionUniqSets` scrut_lvs
+ live_in_whole_case = live_in_alts `unionIdSets` scrut_lvs
in
returnLne (
StgCase scrut2 live_in_whole_case live_in_alts uniq alts2,
scrut_fvs `unionFVInfo` alts_fvs,
- alts_escs `unionUniqSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape
+ alts_escs `unionIdSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape
)
where
vars_alts (StgAlgAlts ty alts deflt)
@@ -279,13 +282,13 @@ varsExpr (StgCase scrut _ _ uniq alts)
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
alts_fvs = unionFVInfos alts_fvs_list
- alts_escs = unionManyUniqSets alts_escs_list
+ alts_escs = unionManyIdSets alts_escs_list
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
StgAlgAlts ty alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionUniqSets` deflt_escs
+ alts_escs `unionIdSets` deflt_escs
)
where
vars_alg_alt (con, binders, worthless_use_mask, rhs)
@@ -298,7 +301,7 @@ varsExpr (StgCase scrut _ _ uniq alts)
returnLne (
(con, binders, good_use_mask, rhs2),
rhs_fvs `minusFVBinders` binders,
- rhs_escs `minusUniqSet` mkUniqSet binders -- ToDo: remove the minusUniqSet;
+ rhs_escs `minusIdSet` mkIdSet binders -- ToDo: remove the minusIdSet;
-- since escs won't include
-- any of these binders
))
@@ -308,13 +311,13 @@ varsExpr (StgCase scrut _ _ uniq alts)
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
alts_fvs = unionFVInfos alts_fvs_list
- alts_escs = unionManyUniqSets alts_escs_list
+ alts_escs = unionManyIdSets alts_escs_list
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
StgPrimAlts ty alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionUniqSets` deflt_escs
+ alts_escs `unionIdSets` deflt_escs
)
where
vars_prim_alt (lit, rhs)
@@ -322,7 +325,7 @@ varsExpr (StgCase scrut _ _ uniq alts)
returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
vars_deflt StgNoDefault
- = returnLne (StgNoDefault, emptyFVInfo, emptyUniqSet)
+ = returnLne (StgNoDefault, emptyFVInfo, emptyIdSet)
vars_deflt (StgBindDefault binder _ rhs)
= extendVarEnv [(binder, CaseBound)] (
@@ -333,7 +336,7 @@ varsExpr (StgCase scrut _ _ uniq alts)
returnLne (
StgBindDefault binder used_in_rhs rhs2,
rhs_fvs `minusFVBinders` [binder],
- rhs_escs `minusUniqSet` singletonUniqSet binder
+ rhs_escs `minusIdSet` unitIdSet binder
))
\end{code}
@@ -402,17 +405,17 @@ varsApp maybe_thunk_body f args
other -> NoStgBinderInfo
-- uninteresting variable
- myself = singletonUniqSet f
+ myself = unitIdSet f
fun_escs = case how_bound of
LetrecBound _ arity lvs ->
if arity == n_args then
- emptyUniqSet -- Function doesn't escape
+ emptyIdSet -- Function doesn't escape
else
myself -- Inexact application; it does escape
- other -> emptyUniqSet -- Only letrec-bound escapees
+ other -> emptyIdSet -- Only letrec-bound escapees
-- are interesting
-- At the moment of the call:
@@ -427,14 +430,14 @@ varsApp maybe_thunk_body f args
-- two regardless.
live_at_call
- = live_in_cont `unionUniqSets` case how_bound of
- LetrecBound _ _ lvs -> lvs `minusUniqSet` myself
- other -> emptyUniqSet
+ = live_in_cont `unionIdSets` case how_bound of
+ LetrecBound _ _ lvs -> lvs `minusIdSet` myself
+ other -> emptyIdSet
in
returnLne (
StgApp (StgVarArg f) args live_at_call,
fun_fvs `unionFVInfo` args_fvs,
- fun_escs `unionUniqSets` (getFVSet args_fvs)
+ fun_escs `unionIdSets` (getFVSet args_fvs)
-- All the free vars of the args are disqualified
-- from being let-no-escaped.
)
@@ -458,7 +461,7 @@ vars_let let_no_escape bind body
-- we ain't in a let-no-escape world
getVarsLiveInCont `thenLne` \ live_in_cont ->
setVarsLiveInCont
- (if let_no_escape then live_in_cont else emptyUniqSet)
+ (if let_no_escape then live_in_cont else emptyIdSet)
(vars_bind rec_bind_lvs rec_body_fvs bind)
`thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
@@ -467,7 +470,7 @@ vars_let let_no_escape bind body
-- together with the live_in_cont ones
lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs ->
let
- bind_lvs = lvs_from_fvs `unionUniqSets` live_in_cont
+ bind_lvs = lvs_from_fvs `unionIdSets` live_in_cont
in
-- bind_fvs and bind_escs still include the binders of the let(rec)
@@ -498,7 +501,7 @@ vars_let let_no_escape bind body
= (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
live_in_whole_let
- = bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` set_of_binders)
+ = bind_lvs `unionIdSets` (body_lvs `minusIdSet` set_of_binders)
real_bind_escs = if let_no_escape then
bind_escs
@@ -506,12 +509,12 @@ vars_let let_no_escape bind body
getFVSet bind_fvs
-- Everything escapes which is free in the bindings
- let_escs = (real_bind_escs `unionUniqSets` body_escs) `minusUniqSet` set_of_binders
+ let_escs = (real_bind_escs `unionIdSets` body_escs) `minusIdSet` set_of_binders
- all_escs = bind_escs `unionUniqSets` body_escs -- Still includes binders of
+ all_escs = bind_escs `unionIdSets` body_escs -- Still includes binders of
-- this let(rec)
- no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs)
+ no_binder_escapes = isEmptyIdSet (set_of_binders `intersectIdSets` all_escs)
-- Mustn't depend on the passed-in let_no_escape flag, since
-- no_binder_escapes is used by the caller to derive the flag!
in
@@ -525,7 +528,7 @@ vars_let let_no_escape bind body
binders = case bind of
StgNonRec binder rhs -> [binder]
StgRec pairs -> map fst pairs
- set_of_binders = mkUniqSet binders
+ set_of_binders = mkIdSet binders
mk_binding bind_lvs (binder,rhs)
= (binder,
@@ -535,9 +538,9 @@ vars_let let_no_escape bind body
)
where
live_vars = if let_no_escape then
- bind_lvs `unionUniqSets` singletonUniqSet binder
+ addOneToIdSet bind_lvs binder
else
- singletonUniqSet binder
+ unitIdSet binder
vars_bind :: StgLiveVars
-> FreeVarsInfo -- Free var info for body of binding
@@ -567,7 +570,7 @@ vars_let let_no_escape bind body
mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
let
fvs = unionFVInfos fvss
- escs = unionManyUniqSets escss
+ escs = unionManyIdSets escss
in
returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
))
@@ -588,15 +591,13 @@ type LneM a = Bool -- True <=> do let-no-escapes
-> StgLiveVars -- vars live in continuation
-> a
-type Arity = Int
-
data HowBound
= ImportBound
| CaseBound
| LambdaBound
| LetrecBound
- Bool -- True <=> bound at top level
- Arity -- Arity
+ Bool -- True <=> bound at top level
+ Arity -- Arity
StgLiveVars -- Live vars... see notes below
\end{code}
@@ -610,7 +611,7 @@ in the LetrecBound constructor; x itself *is* included.
The std monad functions:
\begin{code}
initLne :: Bool -> LneM a -> a
-initLne want_LNEs m = m want_LNEs nullIdEnv emptyUniqSet
+initLne want_LNEs m = m want_LNEs nullIdEnv emptyIdSet
{-# INLINE thenLne #-}
{-# INLINE thenLne_ #-}
@@ -692,17 +693,17 @@ lookupVarEnv v sw env lvs_cont
lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
lookupLiveVarsForSet fvs sw env lvs_cont
- = returnLne (unionManyUniqSets (map do_one (getFVs fvs)))
+ = returnLne (unionManyIdSets (map do_one (getFVs fvs)))
sw env lvs_cont
where
do_one v
= if isLocallyDefined v then
case (lookupIdEnv env v) of
- Just (LetrecBound _ _ lvs) -> lvs `unionUniqSets` singletonUniqSet v
- Just _ -> singletonUniqSet v
+ Just (LetrecBound _ _ lvs) -> addOneToIdSet lvs v
+ Just _ -> unitIdSet v
Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v)
else
- emptyUniqSet
+ emptyIdSet
\end{code}
@@ -724,7 +725,7 @@ type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
--
-- The Bool is True <=> the Id is top level letrec bound
-type EscVarsSet = UniqSet Id
+type EscVarsSet = IdSet
\end{code}
\begin{code}
@@ -756,8 +757,8 @@ lookupFVInfo fvs id = case lookupIdEnv fvs id of
getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
getFVs fvs = [id | (id,False,_) <- rngIdEnv fvs]
-getFVSet :: FreeVarsInfo -> UniqSet Id
-getFVSet fvs = mkUniqSet (getFVs fvs)
+getFVSet :: FreeVarsInfo -> IdSet
+getFVSet fvs = mkIdSet (getFVs fvs)
plusFVInfo (id1,top1,info1) (id2,top2,info2)
= ASSERT (id1 == id2 && top1 == top2)
diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs
index f4ac876495f1a7055d68c0fa1ef2c410cbb3b2b5..553acacee3796f2e9cc9eef25a9534b45272e757 100644
--- a/ghc/compiler/simplStg/UpdAnal.lhs
+++ b/ghc/compiler/simplStg/UpdAnal.lhs
@@ -1,7 +1,7 @@
\section{Update Avoidance Analyser} -*-haskell-literate-*-
(c) Simon Marlow, Andre Santos 1992-1993
-(c) The AQUA Project, Glasgow University, 1995
+(c) The AQUA Project, Glasgow University, 1995-1996
%-----------------------------------------------------------------------------
\subsection{Module Interface}
@@ -12,18 +12,27 @@
> module UpdAnal ( updateAnalyse ) where
>
-> import Type ( splitTyArgs, splitSigmaTy, Class, TyVarTemplate,
-> TauType(..)
-> )
-> import Id
-> import IdInfo
-> import Outputable ( isExported )
-> import Pretty
-> import SrcLoc ( mkUnknownSrcLoc )
+> import Ubiq{-uitous-}
+>
> import StgSyn
-> import UniqSet
-> import UniqSupply ( getBuiltinUniques )
-> import Util
+> import Util ( panic )
+>
+> updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -}
+> updateAnalyse = panic "UpdAnal.updateAnalyse"
+>
+> {- LATER: to end of file:
+> --import Type ( splitTyArgs, splitSigmaTy, Class, TyVarTemplate,
+> -- TauType(..)
+> -- )
+> --import Id
+> --import IdInfo
+> --import Outputable ( isExported )
+> --import Pretty
+> --import SrcLoc ( mkUnknownSrcLoc )
+> --import StgSyn
+> --import UniqSet
+> --import UniqSupply ( getBuiltinUniques )
+> --import Util
%-----------------------------------------------------------------------------
\subsection{Reverse application}
@@ -503,5 +512,6 @@ suffice for now.
> addIdUpdateInfo v
> (mkUpdateInfo (mkUpdateSpec v c))
> | otherwise = v
+> -}
%-----------------------------------------------------------------------------
diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs
index 374b4c0139da43486596c0e22fb4a3cd864ca198..64319b860e374c1819a36e98b318d407a60f27f1 100644
--- a/ghc/compiler/specialise/SpecEnv.lhs
+++ b/ghc/compiler/specialise/SpecEnv.lhs
@@ -115,7 +115,8 @@ lookupSpecId unspec_id ty_maybes
case (firstJust (map try spec_infos)) of
Just id -> id
- Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
+ Nothing -> pprError "ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"
+ (ppr PprDebug unspec_id)
}
where
try (SpecInfo template_maybes _ id)
@@ -188,7 +189,7 @@ lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
match [{-out of templates-}] [] = Just []
match (Nothing:ty_maybes) (spec_ty:spec_tys)
- = case (isUnboxedDataType spec_ty) of
+ = case (isUnboxedType spec_ty) of
True -> Nothing -- Can only match boxed type against
-- type argument which has not been
-- specialised on
@@ -248,6 +249,6 @@ pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
pp_maybe Nothing = ifPprInterface sty pp_NONE
- pp_maybe (Just t) = pprParendType sty t
+ pp_maybe (Just t) = pprParendGenType sty t
\end{pseudocode}
diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs
index 8a019922ab991f3f726d16812150ccb955c4b932..c360e6104cb170eb691be55c89543527d0a7b134 100644
--- a/ghc/compiler/specialise/SpecUtils.lhs
+++ b/ghc/compiler/specialise/SpecUtils.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
@@ -21,19 +21,39 @@ module SpecUtils (
pprSpecErrs
) where
-import Type
-import Bag ( Bag, isEmptyBag, bagToList )
-import FiniteMap ( FiniteMap, emptyFM, addListToFM_C,
- plusFM_C, keysFM, lookupWithDefaultFM
+import Ubiq{-uitous-}
+
+import Bag ( isEmptyBag, bagToList )
+import Class ( getClassOpString, GenClass{-instance NamedThing-} )
+import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM,
+ lookupWithDefaultFM
)
-import Id ( mkSameSpecCon, idType,
- isDictFunId, isConstMethodId_maybe,
+import Id ( idType, isDictFunId, isConstMethodId_maybe,
isDefaultMethodId_maybe,
- getInstIdModule, Id )
-import Maybes
-import Outputable
-import Pretty
-import Util
+ GenId {-instance NamedThing -}
+ )
+import Maybes ( maybeToBool, catMaybes, firstJust )
+import Outputable ( isAvarop, pprNonOp )
+import PprStyle ( PprStyle(..) )
+import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
+ TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
+ )
+import Pretty -- plenty of it
+import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} )
+import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys,
+ getTyVar_maybe, isUnboxedType
+ )
+import TyVar ( GenTyVar{-instance Eq-} )
+import Unique ( Unique{-instance Eq-} )
+import Util ( equivClasses, zipWithEqual, cmpPString,
+ assertPanic, panic{-ToDo:rm-}
+ )
+
+cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)"
+mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)"
+getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)"
+specialiseTy :: Type -> [Maybe Type] -> Int -> Type
+specialiseTy = panic "SpecUtils.specialiseTy (ToDo)"
\end{code}
@specialiseCallTys@ works out which type args don't need to be specialised on,
@@ -52,7 +72,7 @@ specialiseCallTys True _ _ cvec tys
specialiseCallTys False spec_unboxed spec_overloading cvec tys
= zipWithEqual spec_ty_other cvec tys
where
- spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
+ spec_ty_other c ty | (spec_unboxed && isUnboxedType ty)
|| (spec_overloading && c)
= Just ty
| otherwise
@@ -85,16 +105,16 @@ gained by specialising wrt them.
\begin{code}
getIdOverloading :: Id
- -> ([TyVarTemplate], [(Class,TyVarTemplate)])
+ -> ([TyVar], [(Class,TyVar)])
getIdOverloading id
= (tyvars, tyvar_part_of theta)
where
(tyvars, theta, _) = splitSigmaTy (idType id)
- tyvar_part_of [] = []
- tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
- Nothing -> []
- Just tyvar -> (clas, tyvar) : tyvar_part_of theta
+ tyvar_part_of [] = []
+ tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of
+ Nothing -> []
+ Just tv -> (c, tv) : tyvar_part_of theta
\end{code}
\begin{code}
@@ -115,7 +135,7 @@ isUnboxedSpecialisation :: [Maybe Type] -> Bool
isUnboxedSpecialisation tys
= any is_unboxed tys
where
- is_unboxed (Just ty) = isUnboxedDataType ty
+ is_unboxed (Just ty) = isUnboxedType ty
is_unboxed Nothing = False
\end{code}
@@ -129,7 +149,7 @@ specialiseConstrTys :: [Type]
specialiseConstrTys tys
= map maybe_unboxed_ty tys
where
- maybe_unboxed_ty ty = case isUnboxedDataType ty of
+ maybe_unboxed_ty ty = case isUnboxedType ty of
True -> Just ty
False -> Nothing
\end{code}
@@ -156,13 +176,13 @@ argTysMatchSpecTys_error spec_tys arg_tys
then Nothing
else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
- ppStr "argtys=", ppSep [pprParendType PprDebug ty | ty <- arg_tys]])
+ ppStr "argtys=", ppSep [pprParendGenType PprDebug ty | ty <- arg_tys]])
where
match (Nothing:spec_tys) (arg:arg_tys)
- = not (isUnboxedDataType arg) &&
+ = not (isUnboxedType arg) &&
match spec_tys arg_tys
match (Just spec:spec_tys) (arg:arg_tys)
- = case (cmpUniType True{-properly-} spec arg) of
+ = case (cmpType True{-properly-} spec arg) of
EQ_ -> match spec_tys arg_tys
other -> False
match [] [] = True
@@ -261,7 +281,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
have_specs = not (null mod_tyspecs && null mod_idspecs)
- ty_sty = PprInterface (error "SpecUtils:PprInterface:sw_chkr")
+ ty_sty = PprInterface
pp_module mod
= ppBesides [ppPStr mod, ppStr ":"]
@@ -271,15 +291,15 @@ pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
pp_tyspec sty pp_mod (_, tycon, tys)
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE", ppStr "data",
- pprNonOp PprForUser tycon, ppCat (map (pprParendType sty) spec_tys),
+ pprNonOp PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys),
ppStr "#-}", ppStr "{- Essential -}"
]
where
- tvs = getTyConTyVarTemplates tycon
+ tvs = tyConTyVars tycon
(spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
- spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args
+ spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args
- choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
+ choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
choose_ty (tv, Just ty) = (ty, Nothing)
pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
@@ -289,7 +309,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err)
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
ppStr "instance",
- pprType sty spec_ty,
+ pprGenType sty spec_ty,
ppStr "#-}", pp_essential ]
| is_const_method_id
@@ -301,9 +321,9 @@ pp_idspec sty pp_mod (_, id, tys, is_err)
ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
pp_clsop clsop_str, ppStr "::",
- pprType sty spec_ty,
+ pprGenType sty spec_ty,
ppStr "#-} {- IN instance",
- ppPStr cls_str, pprParendType sty clsty,
+ ppPStr cls_str, pprParendGenType sty clsty,
ppStr "-}", pp_essential ]
| is_default_method_id
@@ -317,14 +337,14 @@ pp_idspec sty pp_mod (_, id, tys, is_err)
ppPStr cls_str,
ppStr "EXPLICIT METHOD REQUIRED",
pp_clsop clsop_str, ppStr "::",
- pprType sty spec_ty,
+ pprGenType sty spec_ty,
ppStr "-}", pp_essential ]
| otherwise
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
pprNonOp PprForUser id, ppStr "::",
- pprType sty spec_ty,
+ pprGenType sty spec_ty,
ppStr "#-}", pp_essential ]
where
spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index e96941a549f9560ba109e53b7d5dd3118e53da81..42cd011a2f6d1d9929ea8a010ac3889e16fdf4cf 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -15,25 +15,84 @@ module Specialise (
) where
-import SpecUtils
+import Ubiq{-uitous-}
-import PrelInfo ( liftDataCon, PrimOp(..), PrimRep -- for CCallOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
+ partitionBag, listToBag, bagToList
+ )
+import Class ( GenClass{-instance Eq-} )
+import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
+ opt_CompilingPrelude, opt_SpecialiseTrace,
+ opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
+ opt_SpecialiseAll
)
-import Type
-import Bag
-import CmdLineOpts ( GlobalSwitch(..) )
import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
-import FiniteMap
-import Id
-import IdInfo -- All of it
-import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) )
-import UniqSet -- All of it
-import Util
-import UniqSupply
+import CoreSyn
+import CoreUtils ( coreExprType, squashableDictishCcExpr )
+import FiniteMap ( addListToFM_C )
+import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
+ isSuperDictSelId_maybe, isBottomingId,
+ isConstMethodId_maybe, isDataCon,
+ isImportedId, mkIdWithNewUniq,
+ dataConTyCon, applyTypeEnvToId,
+ nullIdEnv, addOneToIdEnv, growIdEnvList,
+ lookupIdEnv, IdEnv(..),
+ emptyIdSet, mkIdSet, unitIdSet,
+ elementOfIdSet, minusIdSet,
+ unionIdSets, unionManyIdSets, IdSet(..),
+ GenId{-instance Eq-}
+ )
+import Literal ( Literal{-instance Outputable-} )
+import Maybes ( catMaybes, firstJust, maybeToBool )
+import Outputable ( interppSP, Outputable(..){-instance * []-} )
+import PprStyle ( PprStyle(..) )
+import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
+ GenType{-instance Outputable-}, GenTyVar{-ditto-},
+ TyCon{-ditto-}
+ )
+import PrelInfo ( liftDataCon )
+import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
+ ppInt, ppSP, ppInterleave, ppNil, Pretty(..)
+ )
+import PrimOp ( PrimOp(..) )
+import SpecUtils
+import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyCon,
+ tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
+ )
+import TyCon ( TyCon{-instance Eq-} )
+import TyVar ( cloneTyVar,
+ elementOfTyVarSet, TyVarSet(..),
+ nullTyVarEnv, growTyVarEnvList, TyVarEnv(..),
+ GenTyVar{-instance Eq-}
+ )
+import Unique ( Unique{-instance Eq-} )
+import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
+import UniqSupply ( splitUniqSupply, getUniques, getUnique )
+import Util ( equivClasses, mapAccumL, assoc, zipWithEqual,
+ panic, pprTrace, pprPanic, assertPanic
+ )
infixr 9 `thenSM`
+
+--ToDo:kill
+data SpecInfo = SpecInfo [Maybe Type] Int Id
+
+addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
+cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
+getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
+isClassOpId = panic "Specialise.isClassOpId (ToDo)"
+isDictTy = panic "Specialise.isDictTy (ToDo)"
+isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
+isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
+isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
+isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
+lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
+lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
+mkPolySysTyVar = panic "Specialise.mkPolySysTyVar (ToDo)"
+mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
+mkSpecId = panic "Specialise.mkSpecId (ToDo)"
+selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
+specialiseTy = panic "Specialise.specialiseTy (ToDo)"
\end{code}
%************************************************************************
@@ -614,18 +673,18 @@ strictness analyser deems the lifted binding strict.
%************************************************************************
\begin{code}
-type FreeVarsSet = UniqSet Id
-type FreeTyVarsSet = UniqSet TyVar
+type FreeVarsSet = IdSet
+type FreeTyVarsSet = TyVarSet
data CallInstance
= CallInstance
- Id -- This Id; *new* ie *cloned* id
- [Maybe Type] -- Specialised at these types (*new*, cloned)
- -- Nothing => no specialisation on this type arg
- -- is required (flag dependent).
- [CoreArg] -- And these dictionaries; all ValArgs
- FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
- (Maybe SpecInfo) -- For specialisation with explicit SpecId
+ Id -- This Id; *new* ie *cloned* id
+ [Maybe Type] -- Specialised at these types (*new*, cloned)
+ -- Nothing => no specialisation on this type arg
+ -- is required (flag dependent).
+ [CoreArg] -- And these dictionaries; all ValArgs
+ FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
+ (Maybe SpecInfo) -- For specialisation with explicit SpecId
\end{code}
\begin{code}
@@ -634,14 +693,19 @@ pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
= ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id])
4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
case maybe_specinfo of
- Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts])
+ Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts])
Just (SpecInfo _ _ spec_id)
-> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
])
+-- ToDo: instance Outputable CoreArg?
+ppr_arg sty (TyArg t) = ppr sty t
+ppr_arg sty (LitArg i) = ppr sty i
+ppr_arg sty (VarArg v) = ppr sty v
+
isUnboxedCI :: CallInstance -> Bool
isUnboxedCI (CallInstance _ spec_tys _ _ _)
- = any isUnboxedDataType (catMaybes spec_tys)
+ = any isUnboxedType (catMaybes spec_tys)
isExplicitCI :: CallInstance -> Bool
isExplicitCI (CallInstance _ _ _ _ (Just _))
@@ -668,22 +732,22 @@ eqCI_tys c1 c2
isCIofTheseIds :: [Id] -> CallInstance -> Bool
isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
- = any (eqId ci_id) ids
+ = any ((==) ci_id) ids
singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
singleCI id tys dicts
= UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
- emptyBag [] emptyUniqSet 0 0
+ emptyBag [] emptyIdSet 0 0
where
- fv_set = mkUniqSet (id : [dict | ValArg (VarArg dict) <- dicts])
+ fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
explicitCI id tys specinfo
- = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0
+ = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
where
call_inst = CallInstance id tys dicts fv_set (Just specinfo)
dicts = panic "Specialise:explicitCI:dicts"
- fv_set = singletonUniqSet id
+ fv_set = unitIdSet id
-- We do not process the CIs for top-level dfuns or defms
-- Instead we require an explicit SPEC inst pragma for dfuns
@@ -703,7 +767,9 @@ getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
cis_here_list = bagToList cis_here
in
-- pprTrace "getCIs:"
- -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"])
+ -- (ppHang (ppBesides [ppStr "{",
+ -- interppSP PprDebug ids,
+ -- ppStr "}"])
-- 4 (ppAboves (map pprCI cis_here_list)))
(cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
@@ -730,7 +796,9 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids
then
pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
" (may be a non-HM recursive call)\n")
- (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"])
+ (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug bound_ids,
+ ppStr "}"])
4 (ppAboves [ppStr "Dumping CIs:",
ppAboves (map pprCI (bagToList cis_of_bound_id)),
ppStr "Instantiating CIs:",
@@ -741,7 +809,9 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids
else
(if not (isEmptyBag cis_dump_unboxed)
then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
- (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"])
+ (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug full_ids,
+ ppStr "}"])
4 (ppAboves (map pprCI (bagToList cis_dump))))
else id)
cis_keep_not_bound_id
@@ -754,7 +824,7 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids
= partitionBag ok_to_dump_ci cis_not_bound_id
ok_to_dump_ci (CallInstance _ _ _ fv_set _)
- = or [i `elementOfUniqSet` fv_set | i <- full_ids]
+ = any (\ i -> i `elementOfIdSet` fv_set) full_ids
(_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
have_inst_ci ci = any (eqCI_tys ci) inst_cis
@@ -803,10 +873,10 @@ cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
singleTyConI ty_con spec_tys
- = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0
+ = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
-isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con
+isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
@@ -869,22 +939,22 @@ tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
= UsageDetails cis ty_cis dbs fvs c (i+1)
-emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet 0 0
+emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
= UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
- (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2)
+ (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
-- The append here is really redundant, since the bindings don't
-- scope over each other. ToDo.
unionUDList = foldr unionUDs emptyUDs
singleFvUDs (VarArg v) | not (isImportedId v)
- = UsageDetails emptyBag emptyBag [] (singletonUniqSet v) 0 0
+ = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
singleFvUDs other
= emptyUDs
-singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) 0 0
+singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
dumpDBs :: [DictBindDetails]
-> Bool -- True <=> top level bound Ids
@@ -911,11 +981,11 @@ dumpDBs [] top_lev bound_tyvars bound_ids fvs
dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
top_lev bound_tyvars bound_ids fvs
| top_lev
- || or [i `elementOfUniqSet` db_fvs | i <- bound_ids]
- || or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars]
+ || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
+ || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
= let -- Ha! Dump it!
(dbinds_here, dbs_outer, full_bound_ids, full_fvs)
- = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` fvs)
+ = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
in
(dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
@@ -943,7 +1013,7 @@ dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound
(dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
= dumpDBs dbs top_lev tvs bound_ids fvs
cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
- fvs_outer = full_fvs `minusUniqSet` (mkUniqSet full_bound_ids)
+ fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
in
(dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
\end{code}
@@ -1057,23 +1127,22 @@ ToDo[sansom]: Transformation data to process specialisation requests.
%************************************************************************
\begin{code}
-specProgram :: (GlobalSwitch -> Bool)
- -> UniqSupply
+specProgram :: UniqSupply
-> [CoreBinding] -- input ...
-> SpecialiseData
-> ([CoreBinding], -- main result
SpecialiseData) -- result specialise data
-specProgram sw_chker uniqs binds
+specProgram uniqs binds
(SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
- = case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of
+ = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
(final_binds, tycon_specs_list,
UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
-> let
used_conids = filter isDataCon (uniqSetToList fvs)
- used_tycons = map getDataConTyCon used_conids
+ used_tycons = map dataConTyCon used_conids
used_gen = filter isLocalGenTyCon used_tycons
- gen_tycons = setToList (mkSet local_tycons `union` mkSet used_gen)
+ gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
result_specs = addListToFM_C (++) init_specs tycon_specs_list
@@ -1088,9 +1157,9 @@ specProgram sw_chker uniqs binds
tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
- && (not (sw_chker SpecialiseImports) || isEmptyBag cis_warn)
+ && (not opt_SpecialiseImports || isEmptyBag cis_warn)
in
- (if sw_chker D_simplifier_stats then
+ (if opt_D_simplifier_stats then
pprTrace "\nSpecialiser Stats:\n" (ppAboves [
ppBesides [ppStr "SpecCalls ", ppInt spec_calls],
ppBesides [ppStr "SpecInsts ", ppInt spec_insts],
@@ -1101,7 +1170,7 @@ specProgram sw_chker uniqs binds
SpecData True no_errs local_tycons gen_tycons result_specs
cis_errs cis_warn tycis_errs)
-specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _)
+specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
= panic "Specialise:specProgram: specialiser called more than once"
-- It may be possible safely to call the specialiser more than once,
@@ -1128,14 +1197,13 @@ specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
specTyConsAndScope scopeM
= scopeM `thenSM` \ (binds, scope_uds) ->
- getSwitchCheckerSM `thenSM` \ sw_chkr ->
let
(tycons_cis, gotci_scope_uds)
- = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
+ = getLocalSpecTyConIs opt_CompilingPrelude scope_uds
tycon_specs_list = collectTyConSpecs tycons_cis
in
- (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then
+ (if opt_SpecialiseTrace && not (null tycon_specs_list) then
pprTrace "Specialising TyCons:\n"
(ppAboves [ if not (null specs) then
ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
@@ -1180,8 +1248,8 @@ specTopBinds binds
(dbinders_s, dbinds, dfvs_s)
= unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
- full_fvs = fvs `unionUniqSets` unionManyUniqSets dfvs_s
- fvs_outer = full_fvs `minusUniqSet` (mkUniqSet (concat dbinders_s))
+ full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
+ fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
-- It is just to complex to try to sort out top-level dependencies
-- So we just place all the top-level binds in a *global* Rec and
@@ -1211,11 +1279,11 @@ specTopBinds binds
\begin{code}
specExpr :: CoreExpr
-> [CoreArg] -- The arguments:
- -- TypeArgs are speced
- -- ValArgs are unprocessed
+ -- TypeArgs are speced
+ -- ValArgs are unprocessed
-> SpecM (CoreExpr, -- Result expression with specialised versions installed
- UsageDetails) -- Details of usage of enclosing binders in the result
- -- expression.
+ UsageDetails)-- Details of usage of enclosing binders in the result
+ -- expression.
specExpr (Var v) args
= lookupId v `thenSM` \ vlookup ->
@@ -1228,7 +1296,7 @@ specExpr (Var v) args
returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
NoLift vatom@(VarArg new_v)
- -> mapSM specArg args `thenSM` \ arg_info ->
+ -> mapSM specOutArg args `thenSM` \ arg_info ->
mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
mkCall new_v arg_info `thenSM` \ ~(speced, call) ->
let
@@ -1243,29 +1311,38 @@ specExpr expr@(Lit _) null_args
= ASSERT (null null_args)
returnSM (expr, emptyUDs)
-specExpr (Con con tys args) null_args
+specExpr (Con con args) null_args
= ASSERT (null null_args)
- mapSM specTy tys `thenSM` \ tys ->
- mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
- mkTyConInstance con tys `thenSM` \ con_uds ->
- returnSM (applyBindUnlifts unlifts (Con con tys args),
+ let
+ (targs, vargs) = partition_args args
+ in
+ mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
+ mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
+ mkTyConInstance con tys `thenSM` \ con_uds ->
+ returnSM (applyBindUnlifts unlifts (Con con (targs ++ vargs)),
unionUDList args_uds_s `unionUDs` con_uds)
-specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
+specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
= ASSERT (null null_args)
- ASSERT (null tys)
- mapSM specTy arg_tys `thenSM` \ arg_tys ->
- specTy res_ty `thenSM` \ res_ty ->
- mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
- returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) tys args),
+ let
+ (targs, vargs) = partition_args args
+ in
+ ASSERT (null targs)
+ mapSM specTy arg_tys `thenSM` \ arg_tys ->
+ specTy res_ty `thenSM` \ res_ty ->
+ mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
+ returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) vargs),
unionUDList args_uds_s)
-specExpr (Prim prim tys args) null_args
+specExpr (Prim prim args) null_args
= ASSERT (null null_args)
- mapSM specTy tys `thenSM` \ tys ->
- mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
+ let
+ (targs, vargs) = partition_args args
+ in
+ mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
+ mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
-- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (applyBindUnlifts unlifts (Prim prim tys args),
+ returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)),
unionUDList args_uds_s {-`unionUDs` prim_uds-} )
{- ToDo: specPrimOp
@@ -1286,33 +1363,27 @@ specPrimOp :: PrimOp
specExpr (App fun arg) args
- = -- Arg is passed on unprocessed
- specExpr fun (ValArg arg : args) `thenSM` \ (expr,uds) ->
+ = -- If TyArg, arg will be processed; otherwise, left alone
+ preSpecArg arg `thenSM` \ new_arg ->
+ specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
returnSM (expr, uds)
-specExpr (CoTyApp fun ty) args
- = -- Spec the tyarg and pass it on
- specTy ty `thenSM` \ ty ->
- specExpr fun (TypeArg ty : args)
-
-specExpr (Lam binder body) (ValArg arg : args)
+specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
= lookup_arg arg `thenSM` \ arg ->
bindId binder arg (specExpr body args)
where
lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
lookup_arg (VarArg v) = lookupId v
-specExpr (Lam binder body) []
+specExpr (Lam (ValBinder binder) body) []
= specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
- returnSM (Lam binder body, uds)
+ returnSM (Lam (ValBinder binder) body, uds)
-specExpr (CoTyLam tyvar body) (TypeArg ty : args)
+specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
= -- Type lambda with argument; argument already spec'd
- bindTyVar tyvar ty (
- specExpr body args
- )
+ bindTyVar tyvar ty ( specExpr body args )
-specExpr (CoTyLam tyvar body) []
+specExpr (Lam (TyBinder tyvar) body) []
= -- No arguments
cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
bindTyVar tyvar (mkTyVarTy new_tyvar) (
@@ -1320,7 +1391,9 @@ specExpr (CoTyLam tyvar body) []
let
(binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
in
- returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds)
+ returnSM (Lam (TyBinder new_tyvar)
+ (mkCoLetsNoUnboxed binds_here body),
+ final_uds)
)
specExpr (Case scrutinee alts) args
@@ -1330,7 +1403,6 @@ specExpr (Case scrutinee alts) args
where
scrutinee_type = coreExprType scrutinee
-
specExpr (Let bind body) args
= specBindAndScope False bind (
specExpr body args `thenSM` \ (body, body_uds) ->
@@ -1339,8 +1411,8 @@ specExpr (Let bind body) args
returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
specExpr (SCC cc expr) args
- = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
- mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) ->
+ = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
+ mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
let
scc_expr
= if squashableDictishCcExpr cc expr -- can toss the _scc_
@@ -1420,7 +1492,6 @@ Now we must specialise op1 at {* Int#} which requires a version of
meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
not have access to its code to create the specialised version.
-
If we specialise on overloaded types as well we specialise op1 at
{Int Int#} d.Foo.Int:
@@ -1455,9 +1526,10 @@ specAlts (AlgAlts alts deflt) scrutinee_ty args
specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
returnSM (AlgAlts alts deflt,
unionUDList alts_uds_s `unionUDs` deflt_uds)
-
where
- -- We use ty_args of scrutinee type to identify specialisation of alternatives
+ -- We use ty_args of scrutinee type to identify specialisation of
+ -- alternatives:
+
(_, ty_args, _) = getAppDataTyCon scrutinee_ty
specAlgAlt ty_args (con,binders,rhs)
@@ -1489,13 +1561,30 @@ specDeflt (BindDefault binder rhs) args
%************************************************************************
\begin{code}
-specAtom :: CoreArg -> SpecM (CoreArg, UsageDetails,
- CoreExpr -> CoreExpr)
+partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
+partition_args args
+ = span is_ty_arg args
+ where
+ is_ty_arg (TyArg _) = True
+ is_ty_arg _ = False
+
+----------
+preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else
-specAtom (LitArg lit)
+preSpecArg (TyArg ty)
+ = specTy ty `thenSM` \ new_ty ->
+ returnSM (TyArg new_ty)
+
+preSpecArg other = returnSM other
+
+--------------------
+specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
+ CoreExpr -> CoreExpr)
+
+specValArg (LitArg lit)
= returnSM (LitArg lit, emptyUDs, id)
-specAtom (VarArg v)
+specValArg (VarArg v)
= lookupId v `thenSM` \ vlookup ->
case vlookup of
Lifted vl vu
@@ -1505,15 +1594,20 @@ specAtom (VarArg v)
-> returnSM (vatom, singleFvUDs vatom, id)
-specArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
+------------------
+specTyArg (TyArg ty)
+ = specTy ty `thenSM` \ new_ty ->
+ returnSM (TyArg new_ty, new_ty)
+
+--------------
+specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
CoreExpr -> CoreExpr)
-specArg (ValArg arg) -- unprocessed; spec the atom
- = specAtom arg `thenSM` \ (arg, uds, unlift) ->
- returnSM (ValArg arg, uds, unlift)
+specOutArg (TyArg ty) -- already speced; no action
+ = returnSM (TyArg ty, emptyUDs, id)
-specArg (TypeArg ty) -- already speced; no action
- = returnSM (TypeArg ty, emptyUDs, id)
+specOutArg other_arg -- unprocessed; spec the atom
+ = specValArg other_arg
\end{code}
@@ -1744,14 +1838,16 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
else if top_lev
then pprTrace "dumpCIs: not same overloading ... top level \n"
else (\ x y -> y)
- ) (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
- 4 (ppAboves [ppAboves (map (pprType PprDebug . idType) new_ids),
+ ) (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug new_ids,
+ ppStr "}"])
+ 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids),
ppAboves (map pprCI (concat equiv_ciss))]))
(returnSM ([], emptyUDs, []))
where
(tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
- tyvar_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls
+ tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
no_of_tyvars = length tyvar_tmpls
no_of_dicts = length class_tyvar_pairs
@@ -1841,8 +1937,7 @@ mkOneInst :: CallInstance
mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
- = getSwitchCheckerSM `thenSM` \ sw_chkr ->
- newSpecIds new_ids spec_tys no_of_dicts_to_specialise
+ = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
`thenSM` \ spec_ids ->
newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
let
@@ -1852,7 +1947,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
(_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
args :: [CoreArg]
- args = map TypeArg arg_tys ++ dict_args
+ args = map TyArg arg_tys ++ dict_args
(new_id:_) = new_ids
(spec_id:_) = spec_ids
@@ -1877,7 +1972,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
-- a specialised instance has been created but specialisation
-- "required" by one of the other Ids in the Rec
| top_lev && maybeToBool lookup_orig_spec
- = (if sw_chkr SpecialiseTrace
+ = (if opt_SpecialiseTrace
then trace_nospec " Exists: " exists_id
else id) (
@@ -1887,7 +1982,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
-- Check for a (single) explicit call instance for this id
| not (null explicit_cis_for_this_id)
= ASSERT (length explicit_cis_for_this_id == 1)
- (if sw_chkr SpecialiseTrace
+ (if opt_SpecialiseTrace
then trace_nospec " Explicit: " explicit_id
else id) (
@@ -1912,7 +2007,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
in
- if isUnboxedDataType (idType spec_id) then
+ if isUnboxedType (idType spec_id) then
ASSERT (null poly_tyvars)
liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
mkTyConInstance liftDataCon [idType unlift_spec_id]
@@ -1922,7 +2017,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
else
returnSM (Just (spec_id,
- mkCoLetsNoUnboxed local_dict_binds (mkCoTyLam poly_tyvars inst_rhs)),
+ mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
tickSpecInsts final_uds, spec_info)
where
lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
@@ -1932,14 +2027,17 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
[CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
SpecInfo _ _ explicit_id = explicit_spec_info
+ trace_nospec :: String -> Id -> a -> a
trace_nospec str spec_id
= pprTrace str
(ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys),
ppStr "==>", ppr PprDebug spec_id])
in
- (if sw_chkr SpecialiseTrace then
+ (if opt_SpecialiseTrace then
pprTrace "Specialising:"
- (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
+ (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug new_ids,
+ ppStr "}"])
4 (ppAboves [
ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
if isExplicitCI do_cis then ppNil else
@@ -1952,8 +2050,8 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
returnSM (maybe_inst_bind, inst_uds, spec_infos)
)
where
- pp_dict (ValArg d) = ppr PprDebug d
- pp_ty t = pprParendType PprDebug t
+ pp_dict d = ppr_arg PprDebug d
+ pp_ty t = pprParendGenType PprDebug t
do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
do_the_wotsit tyvars (Just ty) = (tyvars, ty)
@@ -1994,11 +2092,10 @@ mkCallInstance id new_id args
-- instances for a ConstMethodId extracted from its SpecEnv
| otherwise
- = getSwitchCheckerSM `thenSM` \ sw_chkr ->
- let
- spec_overloading = sw_chkr SpecialiseOverloaded
- spec_unboxed = sw_chkr SpecialiseUnboxed
- spec_all = sw_chkr SpecialiseAll
+ = let
+ spec_overloading = opt_SpecialiseOverloaded
+ spec_unboxed = opt_SpecialiseUnboxed
+ spec_all = opt_SpecialiseAll
(tyvars, class_tyvar_pairs) = getIdOverloading id
@@ -2019,7 +2116,7 @@ mkCallInstance id new_id args
in
if (not enough_args) then
pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
- (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
+ (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) [arg | (arg,_,_) <- args]))
else
case record_spec id tys of
(False, _, _)
@@ -2075,25 +2172,26 @@ mkCallInstance id new_id args
(returnSM emptyUDs)
-take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
- = case take_type_args tyvars class_tyvar_pairs args of
- Nothing -> Nothing
- Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
-take_type_args (_:tyvars) class_tyvar_pairs []
- = Nothing
+take_type_args (_:tyvars) class_tyvar_pairs ((TyArg ty,_,_):args)
+ = case (take_type_args tyvars class_tyvar_pairs args) of
+ Nothing -> Nothing
+ Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
+
+take_type_args (_:tyvars) class_tyvar_pairs [] = Nothing
+
take_type_args [] class_tyvar_pairs args
- = case take_dict_args class_tyvar_pairs args of
- Nothing -> Nothing
- Just (dicts, others) -> Just ([], dicts, others)
-
-take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
- = case take_dict_args class_tyvar_pairs args of
- Nothing -> Nothing
- Just (dicts, others) -> Just (dict:dicts, others)
-take_dict_args (_:class_tyvar_pairs) []
- = Nothing
-take_dict_args [] args
- = Just ([], args)
+ = case (take_dict_args class_tyvar_pairs args) of
+ Nothing -> Nothing
+ Just (dicts, others) -> Just ([], dicts, others)
+
+take_dict_args (_:class_tyvar_pairs) ((dict,_,_):args) | isValArg dict
+ = case (take_dict_args class_tyvar_pairs args) of
+ Nothing -> Nothing
+ Just (dicts, others) -> Just (dict:dicts, others)
+
+take_dict_args (_:class_tyvar_pairs) [] = Nothing
+
+take_dict_args [] args = Just ([], args)
\end{code}
\begin{code}
@@ -2103,7 +2201,7 @@ mkCall :: Id
mkCall new_id args
| maybeToBool (isSuperDictSelId_maybe new_id)
- && any isUnboxedDataType ty_args
+ && any isUnboxedType ty_args
-- No specialisations for super-dict selectors
-- Specialise unboxed calls to SuperDictSelIds by extracting
-- the super class dictionary directly form the super class
@@ -2149,7 +2247,7 @@ mkCall new_id args
-- These top level defns should have been lifted.
-- We must add code to unlift such a spec_id.
- if isUnboxedDataType (idType spec_id) then
+ if isUnboxedType (idType spec_id) then
ASSERT (null tys_left && null args_left)
if toplevelishId spec_id then
liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
@@ -2158,13 +2256,13 @@ mkCall new_id args
else
pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
(ppCat [ppr PprDebug new_id,
- ppInterleave ppNil (map (pprParendType PprDebug) ty_args),
+ ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args),
ppStr "==>",
ppr PprDebug spec_id])
else
let
(vals_left, _, unlifts_left) = unzip3 args_left
- applied_tys = mkCoTyApps (Var spec_id) tys_left
+ applied_tys = mkTyApp (Var spec_id) tys_left
applied_vals = mkGenApp applied_tys vals_left
in
returnSM (True, applyBindUnlifts unlifts_left applied_vals)
@@ -2179,33 +2277,34 @@ mkCall new_id args
(ty_args, val_args) = get args
where
- get ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
- get args = ([], args)
+ get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
+ get args = ([], args)
-- toss_dicts chucks away dict args, checking that they ain't types!
- toss_dicts 0 args = args
- toss_dicts n ((ValArg _,_,_) : args) = toss_dicts (n-1) args
+ toss_dicts 0 args = args
+ toss_dicts n ((a,_,_) : args)
+ | isValArg a = toss_dicts (n-1) args
\end{code}
\begin{code}
checkUnspecOK :: Id -> [Type] -> a -> a
checkUnspecOK check_id tys
- = if isLocallyDefined check_id && any isUnboxedDataType tys
+ = if isLocallyDefined check_id && any isUnboxedType tys
then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
(ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendType PprDebug) tys)])
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys)])
else id
checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
checkSpecOK check_id tys spec_id tys_left
- = if any isUnboxedDataType tys_left
+ = if any isUnboxedType tys_left
then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
(ppAboves [ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendType PprDebug) tys)],
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
ppCat [ppr PprDebug spec_id,
- ppInterleave ppNil (map (pprParendType PprDebug) tys_left)]])
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
else id
\end{code}
@@ -2231,7 +2330,7 @@ mkTyConInstance con tys
-- ppStr ")"]])
(returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
\end{code}
\begin{code}
@@ -2274,35 +2373,32 @@ Monad has:
threaded in and out: unique supply
\begin{code}
+type TypeEnv = TyVarEnv Type
+
type SpecM result
- = (GlobalSwitch -> Bool)
- -> TypeEnv
+ = TypeEnv
-> SpecIdEnv
-> UniqSupply
-> result
-initSM m sw_chker uniqs
- = m sw_chker nullTyVarEnv nullIdEnv uniqs
+initSM m uniqs
+ = m nullTyVarEnv nullIdEnv uniqs
returnSM :: a -> SpecM a
thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
fixSM :: (a -> SpecM a) -> SpecM a
-thenSM m k sw_chkr tvenv idenv us
+thenSM m k tvenv idenv us
= case splitUniqSupply us of { (s1, s2) ->
- case (m sw_chkr tvenv idenv s1) of { r ->
- k r sw_chkr tvenv idenv s2 }}
+ case (m tvenv idenv s1) of { r ->
+ k r tvenv idenv s2 }}
-returnSM r sw_chkr tvenv idenv us = r
+returnSM r tvenv idenv us = r
-fixSM k sw_chkr tvenv idenv us
+fixSM k tvenv idenv us
= r
where
- r = k r sw_chkr tvenv idenv us -- Recursive in r!
-\end{code}
-
-\begin{code}
-getSwitchCheckerSM sw_chkr tvenv idenv us = sw_chkr
+ r = k r tvenv idenv us -- Recursive in r!
\end{code}
The only interesting bit is figuring out the type of the SpecId!
@@ -2313,7 +2409,7 @@ newSpecIds :: [Id] -- The id of which to make a specialised version
-> Int -- No of dicts to specialise
-> SpecM [Id]
-newSpecIds new_ids maybe_tys dicts_to_ignore sw_chkr tvenv idenv us
+newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
= [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
| (id,uniq) <- new_ids `zip` uniqs ]
where
@@ -2321,7 +2417,7 @@ newSpecIds new_ids maybe_tys dicts_to_ignore sw_chkr tvenv idenv us
spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
newTyVars :: Int -> SpecM [TyVar]
-newTyVars n sw_chkr tvenv idenv us
+newTyVars n tvenv idenv us
= map mkPolySysTyVar uniqs
where
uniqs = getUniques n us
@@ -2343,7 +2439,7 @@ As well as returning the list of cloned @Id@s they also return a list of
cloneLambdaOrCaseBinders :: [Id] -- Old binders
-> SpecM ([Id], [CloneInfo]) -- New ones
-cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us
+cloneLambdaOrCaseBinders old_ids tvenv idenv us
= let
uniqs = getUniques (length old_ids) us
in
@@ -2359,7 +2455,7 @@ cloneLetBinders :: Bool -- Top level ?
-> [Id] -- Old binders
-> SpecM ([Id], [CloneInfo]) -- New ones
-cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us
+cloneLetBinders top_lev is_rec old_ids tvenv idenv us
= let
uniqs = getUniques (2 * length old_ids) us
in
@@ -2379,7 +2475,7 @@ cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us
-- (c) the thing is polymorphic so no need to subst
| otherwise
- = if (is_rec && isUnboxedDataType new_ty && not (isUnboxedDataType old_ty))
+ = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
then (lifted_id,
Lifted lifted_id unlifted_id) : clone_rest
else (new_id,
@@ -2397,7 +2493,7 @@ cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us
cloneTyVarSM :: TyVar -> SpecM TyVar
-cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
+cloneTyVarSM old_tyvar tvenv idenv us
= let
uniq = getUnique us
in
@@ -2405,13 +2501,13 @@ cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
-bindId id val specm sw_chkr tvenv idenv us
- = specm sw_chkr tvenv (addOneToIdEnv idenv id val) us
+bindId id val specm tvenv idenv us
+ = specm tvenv (addOneToIdEnv idenv id val) us
bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
-bindIds olds news specm sw_chkr tvenv idenv us
- = specm sw_chkr tvenv (growIdEnvList idenv (zip olds news)) us
+bindIds olds news specm tvenv idenv us
+ = specm tvenv (growIdEnvList idenv (zip olds news)) us
bindSpecIds :: [Id] -- Old
-> [(CloneInfo)] -- New
@@ -2421,8 +2517,8 @@ bindSpecIds :: [Id] -- Old
-> SpecM thing
-> SpecM thing
-bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
- = specm sw_chkr tvenv (growIdEnvList idenv old_to_clone) us
+bindSpecIds olds clones spec_infos specm tvenv idenv us
+ = specm tvenv (growIdEnvList idenv old_to_clone) us
where
old_to_clone = mk_old_to_clone olds clones spec_infos
@@ -2444,14 +2540,14 @@ bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
-bindTyVar tyvar ty specm sw_chkr tvenv idenv us
- = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
+bindTyVar tyvar ty specm tvenv idenv us
+ = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
\end{code}
\begin{code}
lookupId :: Id -> SpecM CloneInfo
-lookupId id sw_chkr tvenv idenv us
+lookupId id tvenv idenv us
= case lookupIdEnv idenv id of
Nothing -> NoLift (VarArg id)
Just info -> info
@@ -2460,13 +2556,13 @@ lookupId id sw_chkr tvenv idenv us
\begin{code}
specTy :: Type -> SpecM Type -- Apply the current type envt to the type
-specTy ty sw_chkr tvenv idenv us
+specTy ty tvenv idenv us
= applyTypeEnvToTy tvenv ty
\end{code}
\begin{code}
liftId :: Id -> SpecM (Id, Id)
-liftId id sw_chkr tvenv idenv us
+liftId id tvenv idenv us
= let
uniq = getUnique us
in
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 5afb086b0704fdba5aa118d13145d27a2f68206e..50a9bc07bd0ab35715a6884c1ff558f727e54888 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -13,39 +13,35 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program.
\begin{code}
#include "HsVersions.h"
-module CoreToStg (
- topCoreBindsToStg
+module CoreToStg ( topCoreBindsToStg ) where
- -- and to make the interface self-sufficient...
- ) where
+import Ubiq{-uitous-}
-import AnnCoreSyn -- intermediate form on which all work is done
+import CoreSyn -- input
import StgSyn -- output
-import UniqSupply
+import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
+import CoreUtils ( coreExprType )
+import CostCentre ( noCostCentre )
+import Id ( mkSysLocal, idType, isBottomingId,
+ nullIdEnv, addOneToIdEnv, lookupIdEnv,
+ IdEnv(..), GenId{-instance NamedThing-}
+ )
+import Literal ( mkMachInt, Literal(..) )
+import Outputable ( isExported )
import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy,
integerTy, rationalTy, ratioDataCon,
- PrimOp(..), -- For Int2IntegerOp etc
integerZeroId, integerPlusOneId,
integerPlusTwoId, integerMinusOneId
- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-
-import Type ( isPrimType, isLeakFreeType, getAppDataTyCon )
-import Bag -- Bag operations
-import Literal ( mkMachInt, Literal(..) ) -- ToDo: its use is ugly...
-import CostCentre ( noCostCentre, CostCentre )
-import Id ( mkSysLocal, idType, isBottomingId
- IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
)
-import Maybes ( Maybe(..), catMaybes )
-import Outputable ( isExported )
-import Pretty -- debugging only!
+import PrimOp ( PrimOp(..) )
import SpecUtils ( mkSpecialisedCon )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
-import Util
+import SrcLoc ( mkUnknownSrcLoc )
+import Type ( getAppDataTyCon )
+import UniqSupply -- all of it, really
+import Util ( panic )
+
+isLeakFreeType = panic "CoreToStg.isLeakFreeType (ToDo)"
\end{code}
@@ -360,10 +356,20 @@ litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
%************************************************************************
\begin{code}
-coreAtomToStg :: StgEnv -> CoreArg -> UniqSM (StgArg, Bag StgBinding)
+coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding)
-coreAtomToStg env (VarArg var) = returnUs (stgLookup env var, emptyBag)
-coreAtomToStg env (LitArg lit) = litToStgArg lit
+coreArgsToStg env [] = returnUs ([], [], emptyBag)
+coreArgsToStg env (a:as)
+ = coreArgsToStg env as `thenUs` \ (tys, args, binds) ->
+ do_arg a tys args binds
+ where
+ do_arg a trest vrest binds
+ = case a of
+ TyArg t -> returnUs (t:trest, vrest, binds)
+ UsageArg u -> returnUs (trest, vrest, binds)
+ VarArg v -> returnUs (trest, stgLookup env v : vrest, binds)
+ LitArg i -> litToStgArg i `thenUs` \ (v, bs) ->
+ returnUs (trest, v:vrest, bs `unionBags` binds)
\end{code}
There's not anything interesting we can ASSERT about \tr{var} if it
@@ -397,28 +403,16 @@ coreExprToStg env (Lit lit)
coreExprToStg env (Var var)
= returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
-coreExprToStg env (Con con types args)
- = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) ->
- returnUs (StgCon spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
- where
- spec_con = mkSpecialisedCon con types
-
-coreExprToStg env (Prim op tys args)
- = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) ->
- returnUs (StgPrim op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[coreToStg-type-stuff]{Type application and abstraction}
-%* *
-%************************************************************************
-
-This type information dies in this Core-to-STG translation.
+coreExprToStg env (Con con args)
+ = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) ->
+ let
+ spec_con = mkSpecialisedCon con types
+ in
+ returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds)
-\begin{code}
-coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr
-coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr
+coreExprToStg env (Prim op args)
+ = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) ->
+ returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds)
\end{code}
%************************************************************************
@@ -429,7 +423,10 @@ coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr
\begin{code}
coreExprToStg env expr@(Lam _ _)
- = coreExprToStg env body `thenUs` \ (stg_body, binds) ->
+ = let
+ (_,_, binders, body) = collectBinders expr
+ in
+ coreExprToStg env body `thenUs` \ (stg_body, binds) ->
newStgVar (coreExprType expr) `thenUs` \ var ->
returnUs
(StgLet (StgNonRec var (StgRhsClosure noCostCentre
@@ -440,14 +437,6 @@ coreExprToStg env expr@(Lam _ _)
stg_body))
(StgApp (StgVarArg var) [] bOGUS_LVs),
binds)
- where
- (binders,body) = collect expr
-
- -- Collect lambda-bindings, discarding type abstractions and applications
- collect (Lam x e) = (x:binders, body) where (binders,body) = collect e
- collect (CoTyLam _ e) = collect e
- collect (CoTyApp e _) = collect e
- collect body = ([], body)
\end{code}
%************************************************************************
@@ -458,13 +447,15 @@ coreExprToStg env expr@(Lam _ _)
\begin{code}
coreExprToStg env expr@(App _ _)
- = -- Deal with the arguments
- mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_args, arg_binds) ->
+ = let
+ (fun, _, _, args) = collectArgs expr
+ in
+ -- Deal with the arguments
+ coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
-- Now deal with the function
case fun of
- Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
- unionManyBags arg_binds)
+ Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
other -> -- A non-variable applied to things; better let-bind it.
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
@@ -479,16 +470,7 @@ coreExprToStg env expr@(App _ _)
in
returnUs (StgLet (StgNonRec fun_id fun_rhs)
(StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
- unionManyBags arg_binds `unionBags`
- fun_binds)
- where
- (fun,args) = collect_args expr []
-
- -- Collect arguments, discarding type abstractions and applications
- collect_args (App fun arg) args = collect_args fun (arg:args)
- collect_args (CoTyLam _ e) args = collect_args e args
- collect_args (CoTyApp e _) args = collect_args e args
- collect_args fun args = (fun, args)
+ arg_binds `unionBags` fun_binds)
\end{code}
%************************************************************************
@@ -517,9 +499,9 @@ to
\begin{code}
-coreExprToStg env (Case discrim@(Prim op tys args) alts)
- | funnyParallelOp op =
- getUnique `thenUs` \ uniq ->
+coreExprToStg env (Case discrim@(Prim op _) alts)
+ | funnyParallelOp op
+ = getUnique `thenUs` \ uniq ->
coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
returnUs (
diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index b97ef11d10d79f0822ec036596487138761ec088..74abea7f12a45059450797fc5c9518d2a80caea8 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[StgLint]{A ``lint'' pass to check for Stg correctness}
@@ -8,25 +8,34 @@
module StgLint ( lintStgBindings ) where
-import PrelInfo ( primOpType, mkFunTy, PrimOp(..), PrimRep
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Type
-import Bag
-import Literal ( literalType, Literal )
+import Ubiq{-uitous-}
+
+import StgSyn
+
+import Bag ( emptyBag, isEmptyBag, snocBag, foldBag )
import Id ( idType, isDataCon,
- getInstantiatedDataConSig
+ emptyIdSet, isEmptyIdSet, elementOfIdSet,
+ mkIdSet, intersectIdSets,
+ unionIdSets, idSetToList, IdSet(..),
+ GenId{-instanced NamedThing-}
)
-import Maybes
-import Outputable
-import Pretty
-import SrcLoc ( SrcLoc )
-import StgSyn
-import UniqSet
-import Util
+import Literal ( literalType, Literal{-instance Outputable-} )
+import Maybes ( catMaybes )
+import Outputable ( Outputable(..){-instance * []-} )
+import PprType ( GenType{-instance Outputable-}, TyCon )
+import Pretty -- quite a bit of it
+import PrimOp ( primOpType )
+import SrcLoc ( SrcLoc{-instance Outputable-} )
+import Type ( mkFunTys, splitFunTy, maybeAppDataTyCon,
+ isTyVarTy, eqTy
+ )
+import Util ( zipEqual, pprPanic, panic, panic# )
infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
+
+getInstantiatedDataConSig = panic "StgLint.getInstantiatedDataConSig (ToDo)"
+splitTypeWithDictsAsArgs = panic "StgLint.splitTypeWithDictsAsArgs (ToDo)"
+unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
\end{code}
Checks for
@@ -114,7 +123,7 @@ lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) (
addInScopeVars binders (
lintStgExpr expr `thenMaybeL` \ body_ty ->
- returnL (Just (foldr (mkFunTy . idType) body_ty binders))
+ returnL (Just (mkFunTys (map idType binders) body_ty))
))
lintStgRhs (StgRhsCon _ con args)
@@ -193,7 +202,6 @@ lintStgAlts :: StgCaseAlts
lintStgAlts alts scrut_ty case_tycon
= (case alts of
StgAlgAlts _ alg_alts deflt ->
- chk_non_abstract_type case_tycon `thenL_`
mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys ->
lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
returnL (maybe_deflt_ty : maybe_alt_tys)
@@ -211,11 +219,6 @@ lintStgAlts alts scrut_ty case_tycon
returnL (Just first_ty)
where
check ty = checkTys first_ty ty (mkCaseAltMsg alts)
- where
- chk_non_abstract_type tycon
- = case (getTyConFamilySize tycon) of
- Nothing -> addErrL (mkCaseAbstractMsg tycon)
- Just _ -> returnL () -- that's cool
lintAlgAlt scrut_ty (con, args, _, rhs)
= (case maybeAppDataTyCon scrut_ty of
@@ -264,7 +267,7 @@ lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
\begin{code}
type LintM a = [LintLocInfo] -- Locations
- -> UniqSet Id -- Local vars in scope
+ -> IdSet -- Local vars in scope
-> Bag ErrMsg -- Error messages so far
-> (a, Bag ErrMsg) -- Result and error messages (if any)
@@ -298,12 +301,12 @@ pp_binders sty bs
\begin{code}
initL :: LintM a -> Maybe ErrMsg
initL m
- = case (m [] emptyUniqSet emptyBag) of { (_, errs) ->
+ = case (m [] emptyIdSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
Just ( \ sty ->
- ppAboves [ msg sty | msg <- bagToList errs ]
+ foldBag ppAbove ( \ msg -> msg sty ) ppNil errs
)
}
@@ -374,17 +377,16 @@ addInScopeVars ids m loc scope errs
-- For now, it's just a "trace"; we may make
-- a real error out of it...
let
- new_set = mkUniqSet ids
+ new_set = mkIdSet ids
- shadowed = scope `intersectUniqSets` new_set
+ shadowed = scope `intersectIdSets` new_set
in
-- After adding -fliberate-case, Simon decided he likes shadowed
-- names after all. WDP 94/07
--- (if isEmptyUniqSet shadowed
+-- (if isEmptyIdSet shadowed
-- then id
--- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
- m loc (scope `unionUniqSets` new_set) errs
--- )
+-- else pprTrace "Shadowed vars:" (ppr PprDebug (idSetToList shadowed))) $
+ m loc (scope `unionIdSets` new_set) errs
\end{code}
\begin{code}
@@ -399,38 +401,38 @@ checkFunApp fun_ty arg_tys msg loc scope errs
(_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty
cfa res_ty expected [] -- Args have run out; that's fine
- = (Just (glueTyArgs expected res_ty), errs)
+ = (Just (mkFunTys expected res_ty), errs)
cfa res_ty [] arg_tys -- Expected arg tys ran out first;
-- first see if res_ty is a tyvar template;
-- otherwise, maybe res_ty is a
-- dictionary type which is actually a function?
- | isTyVarTemplateTy res_ty
+ | isTyVarTy res_ty
= (Just res_ty, errs)
| otherwise
- = case splitTyArgs (unDictifyTy res_ty) of
+ = case splitFunTy (unDictifyTy res_ty) of
([], _) -> (Nothing, addErr errs msg loc) -- Too many args
(new_expected, new_res) -> cfa new_res new_expected arg_tys
cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
- = case (sleazy_cmp_ty expected_arg_ty arg_ty) of
- EQ_ -> cfa res_ty expected_arg_tys arg_tys
- _ -> (Nothing, addErr errs msg loc) -- Arg mis-match
+ = if (sleazy_eq_ty expected_arg_ty arg_ty)
+ then cfa res_ty expected_arg_tys arg_tys
+ else (Nothing, addErr errs msg loc) -- Arg mis-match
\end{code}
\begin{code}
checkInScope :: Id -> LintM ()
checkInScope id loc scope errs
- = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfUniqSet` scope) then
+ = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfIdSet` scope) then
((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
else
((), errs)
checkTys :: Type -> Type -> ErrMsg -> LintM ()
checkTys ty1 ty2 msg loc scope errs
- = case (sleazy_cmp_ty ty1 ty2) of
- EQ_ -> ((), errs)
- other -> ((), addErr errs msg loc)
+ = if (sleazy_eq_ty ty1 ty2)
+ then ((), errs)
+ else ((), addErr errs msg loc)
\end{code}
\begin{code}
@@ -520,14 +522,15 @@ mkRhsMsg binder ty sty
pp_expr :: PprStyle -> StgExpr -> Pretty
pp_expr sty expr = ppr sty expr
-sleazy_cmp_ty ty1 ty2
+sleazy_eq_ty ty1 ty2
-- NB: probably severe overkill (WDP 95/04)
= case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) ->
case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) ->
let
- ty11 = glueTyArgs tyargs1 tyres1
- ty22 = glueTyArgs tyargs2 tyres2
+ ty11 = mkFunTys tyargs1 tyres1
+ ty22 = mkFunTys tyargs2 tyres2
in
- cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22
+ trace "StgLint.sleazy_cmp_ty" $
+ ty11 `eqTy` ty22
}}
\end{code}
diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 456a7f8e56e47d9deb239432eadb05b445bc0549..395eaa077edf483a6b7146cda888856c9ef4cea6 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -41,27 +41,20 @@ module StgSyn (
import Ubiq{-uitous-}
-{-
-import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..),
- PrimOp, PrimRep
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import CostCentre ( showCostCentre )
+import Id ( idPrimRep, GenId{-instance NamedThing-} )
+import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
+import Outputable ( isExported, isOpLexeme, ifPprDebug,
+ interppSP, interpp'SP,
+ Outputable(..){-instance * Bool-}
)
-import HsSyn ( HsBinds, HsExpr, GRHS, GRHSsAndBinds, InPat )
-import Type
-import Literal ( literalPrimRep, isLitLitLit,
- Literal(..) -- (..) for pragmas
- )
-import Id ( idType, getIdPrimRep, toplevelishId,
- isTopLevId, Id, IdInfo
- )
-import Maybes ( Maybe(..), catMaybes )
-import Outputable
-import Pretty
-import CostCentre ( showCostCentre, CostCentre )
-import UniqSet
-import Util
--}
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty -- all of it
+import PrimOp ( PrimOp{-instance Outputable-} )
+import Unique ( pprUnique )
+import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet(..) )
+import Util ( panic )
\end{code}
%************************************************************************
@@ -94,8 +87,8 @@ data GenStgArg occ
\end{code}
\begin{code}
-getArgPrimRep (StgVarArg local) = getIdPrimRep local
-getArgPrimRep (StgLitArg lit) = literalPrimRep lit
+getArgPrimRep (StgVarArg local) = idPrimRep local
+getArgPrimRep (StgLitArg lit) = literalPrimRep lit
isLitLitArg (StgLitArg x) = isLitLitLit x
isLitLitArg _ = False
diff --git a/ghc/compiler/stgSyn/StgUtils.lhs b/ghc/compiler/stgSyn/StgUtils.lhs
index 830a75233d5ea02b1feb7f1d0e38fafd15b20d21..7c89ac37616f957d3a99f6003555d0716ad3a66a 100644
--- a/ghc/compiler/stgSyn/StgUtils.lhs
+++ b/ghc/compiler/stgSyn/StgUtils.lhs
@@ -1,5 +1,5 @@
x%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[StgUtils]{Utility functions for @STG@ programs}
@@ -8,11 +8,11 @@ x%
module StgUtils ( mapStgBindeesRhs ) where
-import StgSyn
+import Ubiq{-uitous-}
+import Id ( GenId{-instanced NamedThing-} )
+import StgSyn
import UniqSet
-
-import Util
\end{code}
This utility function simply applies the given function to every
@@ -36,21 +36,21 @@ mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr)
(mapStgBindeesExpr fn expr)
mapStgBindeesRhs fn (StgRhsCon cc con atoms)
- = StgRhsCon cc con (map (mapStgBindeesAtom fn) atoms)
+ = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms)
------------------
mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr
mapStgBindeesExpr fn (StgApp f args lvs)
- = StgApp (mapStgBindeesAtom fn f)
- (map (mapStgBindeesAtom fn) args)
+ = StgApp (mapStgBindeesArg fn f)
+ (map (mapStgBindeesArg fn) args)
(mapUniqSet fn lvs)
mapStgBindeesExpr fn (StgCon con atoms lvs)
- = StgCon con (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
+ = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
mapStgBindeesExpr fn (StgPrim op atoms lvs)
- = StgPrim op (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
+ = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
mapStgBindeesExpr fn (StgLet bind expr)
= StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr)
@@ -83,8 +83,8 @@ mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts)
mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr)
------------------
-mapStgBindeesAtom :: (Id -> Id) -> StgArg -> StgArg
+mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg
-mapStgBindeesAtom fn a@(StgLitArg _) = a
-mapStgBindeesAtom fn a@(StgVarArg id) = StgVarArg (fn id)
+mapStgBindeesArg fn a@(StgLitArg _) = a
+mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id)
\end{code}
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 156f2ae1c170f0776c203261c1699d356cf75555..1020b6726b084d7068f81151ed9b3d3234977100 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -15,30 +15,37 @@ module SaAbsInt (
isBot
) where
-IMPORT_Trace -- ToDo: rm
-import Pretty
---import FiniteMap
-import Outputable
-
-import PrelInfo ( PrimOp(..),
- intTyCon, integerTyCon, doubleTyCon,
- floatTyCon, wordTyCon, addrTyCon,
- PrimRep
+import Ubiq{-uitous-}
+
+import CoreSyn
+import CoreUnfold ( UnfoldingDetails(..), FormSummary )
+import CoreUtils ( unTagBinders )
+import Id ( idType, getIdStrictness, getIdUnfolding,
+ dataConSig
)
-import Type ( isPrimType, maybeAppDataTyCon,
- maybeSingleConstructorTyCon,
- returnsRealWorld,
- isEnumerationTyCon, TyVarTemplate, TyCon
+import IdInfo ( StrictnessInfo(..), Demand(..),
+ wwPrim, wwStrict, wwEnum, wwUnpack
)
-import CoreUtils ( unTagBinders )
-import Id ( getIdStrictness, idType, getIdUnfolding,
- getDataConSig, getInstantiatedDataConSig,
- DataCon(..), isBottomingId
+import MagicUFs ( MagicUnfoldingFun )
+import Maybes ( maybeToBool )
+import Outputable ( Outputable(..){-instance * []-} )
+import PprStyle ( PprStyle(..) )
+import PrelInfo ( intTyCon, integerTyCon, doubleTyCon,
+ floatTyCon, wordTyCon, addrTyCon
)
-import IdInfo -- various bits
-import Maybes ( maybeToBool, Maybe(..) )
+import Pretty ( ppStr )
+import PrimOp ( PrimOp(..) )
import SaLib
-import Util
+import TyCon ( maybeTyConSingleCon, isEnumerationTyCon,
+ TyCon{-instance Eq-}
+ )
+import Type ( maybeAppDataTyCon, isPrimType )
+import Util ( isIn, isn'tIn, nOfThem, zipWithEqual,
+ pprTrace, panic, pprPanic, assertPanic
+ )
+
+getInstantiatedDataConSig = panic "SaAbsInt.getInstantiatedDataConSig (ToDo)"
+returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)"
\end{code}
%************************************************************************
@@ -390,7 +397,7 @@ absId anal var env
(Nothing, NoStrictnessInfo, LitForm _) ->
AbsTop -- Literals all terminate, and have no poison
- (Nothing, NoStrictnessInfo, ConForm _ _ _) ->
+ (Nothing, NoStrictnessInfo, ConForm _ _) ->
AbsTop -- An imported constructor won't have
-- bottom components, nor poison!
@@ -474,12 +481,13 @@ Things are a little different for absence analysis, because we want
to make sure that any poison (?????)
\begin{code}
-absEval StrAnal (Prim SeqOp [t] [e]) env
- = if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
+absEval StrAnal (Prim SeqOp [TyArg _, e]) env
+ = ASSERT(isValArg e)
+ if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
-- This is a special case to ensure that seq# is strict in its argument.
-- The comments below (for most normal PrimOps) do not apply.
-absEval StrAnal (Prim op ts es) env = AbsTop
+absEval StrAnal (Prim op es) env = AbsTop
-- The arguments are all of unboxed type, so they will already
-- have been eval'd. If the boxed version was bottom, we'll
-- already have returned bottom.
@@ -490,15 +498,15 @@ absEval StrAnal (Prim op ts es) env = AbsTop
-- uses boxed args and we don't know whether or not it's
-- strict, so we assume laziness. (JSM)
-absEval AbsAnal (Prim op ts as) env
- = if any anyBot [absEvalAtom AbsAnal a env | a <- as]
+absEval AbsAnal (Prim op as) env
+ = if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
then AbsBot
else AbsTop
-- For absence analysis, we want to see if the poison shows up...
-absEval anal (Con con ts as) env
+absEval anal (Con con as) env
| has_single_con
- = AbsProd [absEvalAtom anal a env | a <- as]
+ = AbsProd [absEvalAtom anal a env | a <- as, isValArg a]
| otherwise -- Not single-constructor
= case anal of
@@ -507,22 +515,22 @@ absEval anal (Con con ts as) env
AbsAnal -> -- In the absence case we need to be more
-- careful: look to see if there's any
-- poison in the components
- if any anyBot [absEvalAtom AbsAnal a env | a <- as]
+ if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
then AbsBot
else AbsTop
where
- (_,_,_, tycon) = getDataConSig con
- has_single_con = maybeToBool (maybeSingleConstructorTyCon tycon)
+ (_,_,_, tycon) = dataConSig con
+ has_single_con = maybeToBool (maybeTyConSingleCon tycon)
\end{code}
\begin{code}
-absEval anal (Lam binder body) env
+absEval anal (Lam (ValBinder binder) body) env
= AbsFun [binder] body env
-absEval anal (CoTyLam ty expr) env
+absEval anal (Lam other_binder expr) env
= absEval anal expr env
-absEval anal (App e1 e2) env
- = absApply anal (absEval anal e1 env) (absEvalAtom anal e2 env)
-absEval anal (CoTyApp expr ty) env
+absEval anal (App f a) env | isValArg a
+ = absApply anal (absEval anal f env) (absEvalAtom anal a env)
+absEval anal (App expr _) env
= absEval anal expr env
\end{code}
diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs
index c4b7797d26431a46b5127a31eb8a5bed93286f2f..ef42acde13faacc6853a333af0222a09a581961e 100644
--- a/ghc/compiler/stranal/SaLib.lhs
+++ b/ghc/compiler/stranal/SaLib.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[SaLib]{Basic datatypes, functions for the strictness analyser}
@@ -16,13 +16,19 @@ module SaLib (
nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
lookupAbsValEnv,
absValFromStrictness
-
- -- and to make the interface self-sufficient...
) where
-import IdInfo
-import Outputable
-import Pretty
+import Ubiq{-uitous-}
+
+import CoreSyn ( CoreExpr(..) )
+import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList,
+ lookupIdEnv, IdEnv(..),
+ GenId{-instance Outputable-}
+ )
+import IdInfo ( StrictnessInfo(..), Demand{-instance Outputable-} )
+import Outputable ( Outputable(..){-instance * []-} )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( ppStr, ppCat )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index 6605d26262675be6f8f2541dbe17b2fff8e55684..dc9926d8f0f5632b9e43ae296498a2dc1d1ff9d1 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -11,16 +11,31 @@ Semantique analyser) was written by Andy Gill.
module StrictAnal ( saWwTopBinds, saTopBinds ) where
-import Id ( addIdDemandInfo, isWrapperId, addIdStrictness,
- idType, getIdDemandInfo
+import Ubiq{-uitous-}
+
+import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict,
+ opt_D_dump_stranal, opt_D_simplifier_stats
+ )
+import CoreSyn
+import Id ( idType, addIdStrictness,
+ getIdDemandInfo, addIdDemandInfo,
+ GenId{-instance Outputable-}
+ )
+import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo,
+ mkDemandInfo, willBeDemanded, DemandInfo
)
-import IdInfo
+import PprCore ( pprCoreBinding, pprBigCoreBinder )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
+import Pretty ( ppBesides, ppStr, ppInt, ppChar, ppAboves )
import SaAbsInt
import SaLib
-import UniqSupply
-import Util
+import TyVar ( GenTyVar{-instance Eq-} )
import WorkWrap -- "back-end" of strictness analyser
-import WwLib ( WwM(..) )
+import Unique ( Unique{-instance Eq -} )
+import Util ( zipWith4Equal, pprTrace, panic{-ToDo:rm-} )
+
+isWrapperId = panic "StrictAnal.isWrapperId (ToDo)"
\end{code}
@@ -72,13 +87,12 @@ Alas and alack.
\begin{code}
saWwTopBinds :: UniqSupply
- -> (GlobalSwitch -> Bool)
-> [CoreBinding]
-> [CoreBinding]
-saWwTopBinds us switch_chker binds
+saWwTopBinds us binds
= let
- strflags = (switch_chker AllStrict, switch_chker NumbersStrict)
+ strflags = (opt_AllStrict, opt_NumbersStrict)
-- mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
@@ -90,13 +104,13 @@ saWwTopBinds us switch_chker binds
#endif
in
-- possibly show what we decided about strictness...
- (if switch_chker D_dump_stranal
+ (if opt_D_dump_stranal
then pprTrace "Strictness:\n" (ppAboves (
- map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness))
+ map (pprCoreBinding PprDebug) binds_w_strictness))
else id
)
-- possibly show how many things we marked as demanded...
- ((if switch_chker D_simplifier_stats
+ ((if opt_D_simplifier_stats
#ifndef OMIT_STRANAL_STATS
then pp_stats sa_stats
#else
@@ -107,7 +121,7 @@ saWwTopBinds us switch_chker binds
-- create worker/wrappers, and mark binders with their
-- "strictness info" [which encodes their
-- worker/wrapper-ness]
- (workersAndWrappers binds_w_strictness us switch_chker))
+ (workersAndWrappers binds_w_strictness us))
#ifndef OMIT_STRANAL_STATS
where
pp_stats (SaStats tlam dlam tc dc tlet dlet)
@@ -232,31 +246,27 @@ environment.
\begin{code}
saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
-saExpr _ _ e@(Var _) = returnSa e
-saExpr _ _ e@(Lit _) = returnSa e
-saExpr _ _ e@(Con _ _ _) = returnSa e
-saExpr _ _ e@(Prim _ _ _) = returnSa e
+saExpr _ _ e@(Var _) = returnSa e
+saExpr _ _ e@(Lit _) = returnSa e
+saExpr _ _ e@(Con _ _) = returnSa e
+saExpr _ _ e@(Prim _ _) = returnSa e
-saExpr str_env abs_env (Lam arg body)
+saExpr str_env abs_env (Lam (ValBinder arg) body)
= saExpr str_env abs_env body `thenSa` \ new_body ->
let
new_arg = addDemandInfoToId str_env abs_env body arg
in
tickLambda new_arg `thenSa_` -- stats
- returnSa (Lam new_arg new_body)
+ returnSa (Lam (ValBinder new_arg) new_body)
-saExpr str_env abs_env (CoTyLam ty expr)
+saExpr str_env abs_env (Lam other_binder expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoTyLam ty new_expr)
+ returnSa (Lam other_binder new_expr)
saExpr str_env abs_env (App fun arg)
= saExpr str_env abs_env fun `thenSa` \ new_fun ->
returnSa (App new_fun arg)
-saExpr str_env abs_env (CoTyApp expr ty)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoTyApp new_expr ty)
-
saExpr str_env abs_env (SCC cc expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
returnSa (SCC cc new_expr)
@@ -447,7 +457,7 @@ returnSa :: a -> SaM a
{-# INLINE thenSa_ #-}
{-# INLINE returnSa #-}
-tickLambda :: [Id] -> SaM ()
+tickLambda :: Id -> SaM ()
tickCases :: [Id] -> SaM ()
tickLet :: Id -> SaM ()
@@ -465,7 +475,7 @@ thenSa_ expr cont stats
returnSa x stats = (x, stats)
tickLambda var (SaStats tlam dlam tc dc tlet dlet)
- = case (tick_demanded (0,0) var) of { (IBOX(tot), IBOX(demanded)) ->
+ = case (tick_demanded var (0,0)) of { (IBOX(tot), IBOX(demanded)) ->
((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
tickCases vars (SaStats tlam dlam tc dc tlet dlet)
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index a82579db1de4e387d20c45901e7172640563abf4..4a7b076a46d36b2f822b17dfc7d46d3e51a9e1a3 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
@@ -8,20 +8,24 @@
module WorkWrap ( workersAndWrappers ) where
-IMPORT_Trace
-import Outputable
-import Pretty
+import Ubiq{-uitous-}
-import Id ( idType, addIdStrictness, getIdStrictness,
- getIdUnfolding, mkWorkerId,
- replaceIdInfo, getIdInfo, idWantsToBeINLINEd
+import CoreSyn
+import CoreUnfold ( UnfoldingGuidance(..) )
+import CoreUtils ( coreExprType )
+import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId,
+ getIdInfo
+ )
+import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker,
+ mkStrictnessInfo, StrictnessInfo(..)
)
-import IdInfo -- bits and pieces
-import Maybes ( maybeToBool, Maybe(..) )
import SaLib
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
+import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) )
import WwLib
+import Util ( panic{-ToDo:rm-} )
+
+replaceIdInfo = panic "WorkWrap.replaceIdInfo (ToDo)"
+iWantToBeINLINEd = panic "WorkWrap.iWantToBeINLINEd (ToDo)"
\end{code}
We take Core bindings whose binders have their strictness attached (by
@@ -37,14 +41,14 @@ info for exported values).
\end{enumerate}
\begin{code}
-workersAndWrappers :: [CoreBinding] -> WwM [CoreBinding]
+workersAndWrappers :: [CoreBinding] -> UniqSM [CoreBinding]
workersAndWrappers top_binds
- = mapWw (wwBind True{-top-level-}) top_binds `thenWw` \ top_binds2 ->
+ = mapUs (wwBind True{-top-level-}) top_binds `thenUs` \ top_binds2 ->
let
top_binds3 = map make_top_binding top_binds2
in
- returnWw (concat top_binds3)
+ returnUs (concat top_binds3)
where
make_top_binding :: WwBinding -> [CoreBinding]
@@ -63,24 +67,24 @@ turn. Non-recursive case first, then recursive...
\begin{code}
wwBind :: Bool -- True <=> top-level binding
-> CoreBinding
- -> WwM WwBinding -- returns a WwBinding intermediate form;
+ -> UniqSM WwBinding -- returns a WwBinding intermediate form;
-- the caller will convert to Expr/Binding,
-- as appropriate.
wwBind top_level (NonRec binder rhs)
- = wwExpr rhs `thenWw` \ new_rhs ->
- tryWW binder new_rhs `thenWw` \ new_pairs ->
- returnWw (WwLet [NonRec b e | (b,e) <- new_pairs])
+ = wwExpr rhs `thenUs` \ new_rhs ->
+ tryWW binder new_rhs `thenUs` \ new_pairs ->
+ returnUs (WwLet [NonRec b e | (b,e) <- new_pairs])
-- Generated bindings must be non-recursive
-- because the original binding was.
------------------------------
wwBind top_level (Rec pairs)
- = mapWw do_one pairs `thenWw` \ new_pairs ->
- returnWw (WwLet [Rec (concat new_pairs)])
+ = mapUs do_one pairs `thenUs` \ new_pairs ->
+ returnUs (WwLet [Rec (concat new_pairs)])
where
- do_one (binder, rhs) = wwExpr rhs `thenWw` \ new_rhs ->
+ do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs ->
tryWW binder new_rhs
\end{code}
@@ -91,70 +95,62 @@ matching by looking for strict arguments of the correct type.
???????????????? ToDo
\begin{code}
-wwExpr :: CoreExpr -> WwM CoreExpr
-
-wwExpr e@(Var _) = returnWw e
-wwExpr e@(Lit _) = returnWw e
-wwExpr e@(Con _ _ _) = returnWw e
-wwExpr e@(Prim _ _ _) = returnWw e
-
-wwExpr (Lam binders expr)
- = wwExpr expr `thenWw` \ new_expr ->
- returnWw (Lam binders new_expr)
+wwExpr :: CoreExpr -> UniqSM CoreExpr
-wwExpr (CoTyLam ty expr)
- = wwExpr expr `thenWw` \ new_expr ->
- returnWw (CoTyLam ty new_expr)
+wwExpr e@(Var _) = returnUs e
+wwExpr e@(Lit _) = returnUs e
+wwExpr e@(Con _ _) = returnUs e
+wwExpr e@(Prim _ _) = returnUs e
-wwExpr (App e1 e2)
- = wwExpr e1 `thenWw` \ new_e1 ->
- returnWw (App new_e1 e2)
+wwExpr (Lam binder expr)
+ = wwExpr expr `thenUs` \ new_expr ->
+ returnUs (Lam binder new_expr)
-wwExpr (CoTyApp expr ty)
- = wwExpr expr `thenWw` \ new_expr ->
- returnWw (CoTyApp new_expr ty)
+wwExpr (App f a)
+ = wwExpr f `thenUs` \ new_f ->
+ returnUs (App new_f a)
wwExpr (SCC cc expr)
- = wwExpr expr `thenWw` \ new_expr ->
- returnWw (SCC cc new_expr)
+ = wwExpr expr `thenUs` \ new_expr ->
+ returnUs (SCC cc new_expr)
wwExpr (Let bind expr)
- = wwBind False{-not top-level-} bind `thenWw` \ intermediate_bind ->
- wwExpr expr `thenWw` \ new_expr ->
- returnWw (mash_ww_bind intermediate_bind new_expr)
+ = wwBind False{-not top-level-} bind `thenUs` \ intermediate_bind ->
+ wwExpr expr `thenUs` \ new_expr ->
+ returnUs (mash_ww_bind intermediate_bind new_expr)
where
mash_ww_bind (WwLet binds) body = mkCoLetsNoUnboxed binds body
mash_ww_bind (WwCase case_fn) body = case_fn body
wwExpr (Case expr alts)
- = wwExpr expr `thenWw` \ new_expr ->
- ww_alts alts `thenWw` \ new_alts ->
- returnWw (Case new_expr new_alts)
+ = wwExpr expr `thenUs` \ new_expr ->
+ ww_alts alts `thenUs` \ new_alts ->
+ returnUs (Case new_expr new_alts)
where
ww_alts (AlgAlts alts deflt)
- = mapWw ww_alg_alt alts `thenWw` \ new_alts ->
- ww_deflt deflt `thenWw` \ new_deflt ->
- returnWw (AlgAlts new_alts new_deflt)
+ = mapUs ww_alg_alt alts `thenUs` \ new_alts ->
+ ww_deflt deflt `thenUs` \ new_deflt ->
+ returnUs (AlgAlts new_alts new_deflt)
ww_alts (PrimAlts alts deflt)
- = mapWw ww_prim_alt alts `thenWw` \ new_alts ->
- ww_deflt deflt `thenWw` \ new_deflt ->
- returnWw (PrimAlts new_alts new_deflt)
+ = mapUs ww_prim_alt alts `thenUs` \ new_alts ->
+ ww_deflt deflt `thenUs` \ new_deflt ->
+ returnUs (PrimAlts new_alts new_deflt)
ww_alg_alt (con, binders, rhs)
- = wwExpr rhs `thenWw` \ new_rhs ->
- returnWw (con, binders, new_rhs)
+ = wwExpr rhs `thenUs` \ new_rhs ->
+ returnUs (con, binders, new_rhs)
ww_prim_alt (lit, rhs)
- = wwExpr rhs `thenWw` \ new_rhs ->
- returnWw (lit, new_rhs)
+ = wwExpr rhs `thenUs` \ new_rhs ->
+ returnUs (lit, new_rhs)
ww_deflt NoDefault
- = returnWw NoDefault
+ = returnUs NoDefault
ww_deflt (BindDefault binder rhs)
- = wwExpr rhs `thenWw` \ new_rhs ->
- returnWw (BindDefault binder new_rhs)
+ = wwExpr rhs `thenUs` \ new_rhs ->
+ returnUs (BindDefault binder new_rhs)
\end{code}
%************************************************************************
@@ -179,7 +175,7 @@ The only reason this is monadised is for the unique supply.
tryWW :: Id -- the fn binder
-> CoreExpr -- the bound rhs; its innards
-- are already ww'd
- -> WwM [(Id, CoreExpr)] -- either *one* or *two* pairs;
+ -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
-- if one, then no worker (only
-- the orig "wrapper" lives on);
-- if two, then a worker and a
@@ -209,7 +205,7 @@ tryWW fn_id rhs
(uvars, tyvars, args, body) = collectBinders rhs
body_ty = coreExprType body
in
- uniqSMtoWwM (mkWwBodies body_ty tyvars args args_info) `thenWw` \ result ->
+ mkWwBodies body_ty tyvars args args_info `thenUs` \ result ->
case result of
Nothing -> -- Very peculiar. This can only happen if we hit an
@@ -223,7 +219,7 @@ tryWW fn_id rhs
Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
-- Terrific! It worked!
- getUniqueWw `thenWw` \ worker_uniq ->
+ getUnique `thenUs` \ worker_uniq ->
let
worker_ty = worker_ty_w_hole body_ty
@@ -246,8 +242,8 @@ tryWW fn_id rhs
-- NB! the "iWantToBeINLINEd" part adds an INLINE pragma to
-- the wrapper, which is of course what we want.
in
- returnWw [ (worker_id, worker_rhs), -- worker comes first
+ returnUs [ (worker_id, worker_rhs), -- worker comes first
(wrapper_id, wrapper_rhs) ] -- because wrapper mentions it
where
- do_nothing = returnWw [ (fn_id, rhs) ]
+ do_nothing = returnUs [ (fn_id, rhs) ]
\end{code}
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 4fa859a4e4c9cabe76f9930e8264e63087410d14..4d1fa7a576c4c6726ac8d9ddc9fb52c5557daef2 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -9,38 +9,24 @@
module WwLib (
WwBinding(..),
- mkWwBodies, mAX_WORKER_ARGS,
-
- -- our friendly worker/wrapper monad:
- WwM(..),
- returnWw, thenWw, mapWw,
- getUniqueWw, uniqSMtoWwM
-
- -- and to make the interface self-sufficient...
+ mkWwBodies, mAX_WORKER_ARGS
) where
import Ubiq{-uitous-}
+import CoreSyn
+import Id ( idType, mkSysLocal )
+import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
import PrelInfo ( aBSENT_ERROR_ID )
-{-
-import Id ( mkWorkerId, mkSysLocal, idType,
- getInstantiatedDataConSig, getIdInfo,
- replaceIdInfo, addIdStrictness, DataCon(..)
- )
-import IdInfo -- lots of things
-import Maybes ( maybeToBool, Maybe(..), MaybeErr )
-import SaLib
import SrcLoc ( mkUnknownSrcLoc )
-import Type ( mkTyVarTys, mkFunTys, isPrimType,
- maybeAppDataTyCon, quantifyTy
+import Type ( isPrimType, mkTyVarTys, mkFunTys, maybeAppDataTyCon )
+import UniqSupply ( returnUs, thenUs, thenMaybeUs,
+ getUniques, UniqSM(..)
)
-import UniqSupply
--}
-import Util ( panic )
-
-infixr 9 `thenWw`
+import Util ( zipWithEqual, assertPanic, panic )
quantifyTy = panic "WwLib.quantifyTy"
+getInstantiatedDataConSig = panic "WwLib.getInstantiatedDataConSig"
\end{code}
%************************************************************************
@@ -221,7 +207,7 @@ mkWwBodies body_ty tyvars args arg_infos
else -- the rest...
mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
- `thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) ->
+ `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
let
(work_args, wrkr_demands) = unzip work_args_info
@@ -230,7 +216,7 @@ mkWwBodies body_ty tyvars args arg_infos
wrapper_w_hole = \ worker_id ->
mkLam tyvars args (
wrap_frag (
- mkCoTyApps (Var worker_id) (mkTyVarTys tyvars)
+ mkTyApp (Var worker_id) (mkTyVarTys tyvars)
))
worker_w_hole = \ orig_body ->
@@ -302,7 +288,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
mk_ww_arg_processing args infos max_extra_args
-- we've already discounted for absent args,
-- so we don't change max_extra_args
- `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
+ `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
-- wrapper doesn't pass this arg to worker:
returnUs (Just (
@@ -317,7 +303,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
where
mk_absent_let arg arg_ty body
= if not (isPrimType arg_ty) then
- Let (NonRec arg (mkCoTyApp (Var aBSENT_ERROR_ID) arg_ty)) body
+ Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
else -- quite horrible
panic "WwLib: haven't done mk_absent_let for primitives yet"
@@ -354,7 +340,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
-- In processing the rest, push the sub-component args
-- and infos on the front of the current bunch
mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
- `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
+ `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
returnUs (Just (
-- wrapper: unpack the value
@@ -383,7 +369,8 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
)
mk_pk_let arg boxing_con con_tys unpk_args body
- = Let (NonRec arg (Con boxing_con con_tys [VarArg a | a <- unpk_args]))
+ = Let (NonRec arg (Con boxing_con
+ (map TyArg con_tys ++ map VarArg unpk_args)))
body
mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
@@ -394,7 +381,7 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
-- Finish args to the right...
mk_ww_arg_processing args infos max_extra_args
- `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
+ `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
returnUs (Just (
-- wrapper:
@@ -406,55 +393,3 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
))
--)
\end{code}
-
-%************************************************************************
-%* *
-\subsection[monad-WwLib]{Simple monad for worker/wrapper}
-%* *
-%************************************************************************
-
-In this monad, we thread a @UniqueSupply@, and we carry a
-@GlobalSwitch@-lookup function downwards.
-
-\begin{code}
-type WwM result
- = UniqSupply
- -> (GlobalSwitch -> Bool)
- -> result
-
-{-# INLINE thenWw #-}
-{-# INLINE returnWw #-}
-
-returnWw :: a -> WwM a
-thenWw :: WwM a -> (a -> WwM b) -> WwM b
-mapWw :: (a -> WwM b) -> [a] -> WwM [b]
-
-returnWw expr ns sw = expr
-
-thenWw m k us sw_chk
- = case splitUniqSupply us of { (s1, s2) ->
- case (m s1 sw_chk) of { m_res ->
- k m_res s2 sw_chk }}
-
-mapWw f [] = returnWw []
-mapWw f (x:xs)
- = f x `thenWw` \ x' ->
- mapWw f xs `thenWw` \ xs' ->
- returnWw (x':xs')
-\end{code}
-
-\begin{code}
-getUniqueWw :: WwM Unique
-uniqSMtoWwM :: UniqSM a -> WwM a
-
-getUniqueWw us sw_chk = getUnique us
-
-uniqSMtoWwM u_obj us sw_chk = u_obj us
-
-thenUsMaybe :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b)
-thenUsMaybe m k
- = m `thenUs` \ result ->
- case result of
- Nothing -> returnUs Nothing
- Just x -> k x
-\end{code}
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index 27e4a005503e78eff186900efa34ed7863270392..438e59a0d842aa7d86a689e6212457df2a477c8d 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -9,8 +9,7 @@
module GenSpecEtc (
TcSigInfo(..),
genBinds,
- checkSigTyVars, checkSigTyVarsGivenGlobals,
- specTy
+ checkSigTyVars, checkSigTyVarsGivenGlobals
) where
import Ubiq
@@ -26,7 +25,7 @@ import TcType ( TcType(..), TcThetaType(..), TcTauType(..),
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..),
Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake
)
-import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..) )
+import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..), tcIdType )
import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag )
import Class ( GenClass )
@@ -155,7 +154,7 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn
-- BUILD THE NEW LOCALS
let
tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order
- dict_tys = [idType d | TcId d <- dicts_bound] -- Slightly ugh-ish
+ dict_tys = map tcIdType dicts_bound
poly_tys = map (mkForAllTys tyvars . mkFunTys dict_tys) mono_id_types
poly_ids = zipWithEqual mk_poly binder_names poly_tys
mk_poly name ty = mkUserId name ty (prag_info_fn name)
@@ -282,12 +281,12 @@ The error message here is somewhat unsatisfactory, but it'll do for
now (ToDo).
\begin{code}
-checkSigMatch :: TcSigInfo s -> TcM s [TcTyVar s]
+checkSigMatch :: TcSigInfo s -> TcM s ()
checkSigMatch (TySigInfo id sig_tyvars _ tau_ty src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (sigCtxt id) $
- checkSigTyVars sig_tyvars tau_ty (idType id)
+ checkSigTyVars sig_tyvars tau_ty
\end{code}
@@ -337,6 +336,8 @@ are
eg matching signature [(a,b)] against inferred type [(p,p)]
[then a and b will be unified together]
+BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS
+
(c) not mentioned in the environment
eg the signature for f in this:
@@ -351,71 +352,30 @@ Before doing this, the substitution is applied to the signature type variable.
\begin{code}
checkSigTyVars :: [TcTyVar s] -- The original signature type variables
-> TcType s -- signature type (for err msg)
- -> TcType s -- inferred type (for err msg)
- -> TcM s [TcTyVar s] -- Post-substitution signature type variables
+ -> TcM s ()
-checkSigTyVars sig_tyvars sig_tau inferred_tau
+checkSigTyVars sig_tyvars sig_tau
= tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
- checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau inferred_tau
+ checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau
checkSigTyVarsGivenGlobals
:: TcTyVarSet s -- Consider these fully-zonked tyvars as global
-> [TcTyVar s] -- The original signature type variables
-> TcType s -- signature type (for err msg)
- -> TcType s -- inferred type (for err msg)
- -> TcM s [TcTyVar s] -- Post-substitution signature type variables
-
-checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau inferred_tau
- = -- Check point (a) above
- mapNF_Tc (zonkTcType.mkTyVarTy) sig_tyvars `thenNF_Tc` \ sig_tys ->
- checkMaybeTcM (allMaybes (map getTyVar_maybe sig_tys)) match_err `thenTc` \ sig_tyvars' ->
-
- -- Check point (b)
- checkTcM (hasNoDups sig_tyvars') match_err `thenTc_`
+ -> TcM s ()
- -- Check point (c)
+checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau
+ = -- Check point (c)
-- We want to report errors in terms of the original signature tyvars,
-- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond
-- 1-1 with sig_tyvars, so we can just map back.
- let
- mono_tyvars = [ sig_tyvar
- | (sig_tyvar,sig_tyvar') <- zipEqual sig_tyvars sig_tyvars',
- sig_tyvar' `elementOfTyVarSet` globals
- ]
- in
checkTc (null mono_tyvars)
- (notAsPolyAsSigErr sig_tau mono_tyvars) `thenTc_`
-
- returnTc sig_tyvars'
+ (notAsPolyAsSigErr sig_tau mono_tyvars)
where
- match_err = zonkTcType inferred_tau `thenNF_Tc` \ inferred_tau' ->
- failTc (badMatchErr sig_tau inferred_tau')
+ mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
\end{code}
-%************************************************************************
-%* *
-\subsection[GenEtc-SpecTy]{Instantiate a type and create new dicts for it}
-%* *
-%************************************************************************
-
-\begin{code}
-specTy :: InstOrigin s
- -> Type
- -> NF_TcM s ([TcTyVar s], LIE s, TcType s, [TcIdOcc s])
-
-specTy origin sigma_ty
- = tcInstType [] sigma_ty `thenNF_Tc` \ tc_sigma_ty ->
- let
- (tyvars, theta, tau) = splitSigmaTy tc_sigma_ty
- in
- -- Instantiate the dictionary types
- newDicts origin theta `thenNF_Tc` \ (dicts, dict_ids) ->
-
- -- Return the list of tyvars, the list of dicts and the tau type
- returnNF_Tc (tyvars, dicts, tau, dict_ids)
-\end{code}
-
Contexts and errors
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 7ad462e45cc6954c2b99cac883de2f12523451e0..e4a95844b28db6278d8ce2d359a3af471085e23b 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -10,7 +10,7 @@ module Inst (
Inst(..), -- Visible only to TcSimplify
InstOrigin(..), OverloadedLit(..),
- LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
+ LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
InstanceMapper(..),
@@ -41,7 +41,7 @@ import TcEnv ( tcLookupGlobalValueByKey )
import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
tcInstType, tcInstTcType, zonkTcType )
-import Bag ( Bag, emptyBag, unitBag, unionBags, listToBag, consBag )
+import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
import Id ( GenId, idType, mkInstId )
import MatchEnv ( lookupMEnv, insertMEnv )
@@ -78,6 +78,7 @@ emptyLIE = emptyBag
unitLIE inst = unitBag inst
plusLIE lie1 lie2 = lie1 `unionBags` lie2
consLIE inst lie = inst `consBag` lie
+plusLIEs lies = unionManyBags lies
zonkLIE :: LIE s -> NF_TcM s (LIE s)
zonkLIE lie = mapBagNF_Tc zonkInst lie
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 9ecbe7f330956cd047cf295f1c131f29c9a0608b..912a415554664e3b4082b221dd61085a5e599a46 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -182,7 +182,7 @@ tcBindAndSigs binder_names bind sigs prag_info_fn
-- If typechecking the binds fails, then return with each
-- binder given type (forall a.a), to minimise subsequent
-- error messages
- newTcTyVar Nothing mkBoxedTypeKind `thenNF_Tc` \ alpha_tv ->
+ newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv ->
let
forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
poly_ids = [ mkUserId name forall_a_a (prag_info_fn name)
@@ -271,13 +271,15 @@ tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s]
tcTySigs (Sig v ty _ src_loc : other_sigs)
= tcAddSrcLoc src_loc (
tcPolyType ty `thenTc` \ sigma_ty ->
- tcInstType [] sigma_ty `thenNF_Tc` \ tc_sigma_ty ->
+ tcInstType [] sigma_ty `thenNF_Tc` \ sigma_ty' ->
let
- (tyvars, theta, tau_ty) = splitSigmaTy tc_sigma_ty
+ (tyvars', theta', tau') = splitSigmaTy sigma_ty'
in
+
tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val ->
- unifyTauTy (idType val) tau_ty `thenTc_`
- returnTc (TySigInfo val tyvars theta tau_ty src_loc)
+ unifyTauTy (idType val) tau' `thenTc_`
+
+ returnTc (TySigInfo val tyvars' theta' tau' src_loc)
) `thenTc` \ sig_info1 ->
tcTySigs other_sigs `thenTc` \ sig_infos ->
@@ -386,7 +388,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
-- Get and instantiate its alleged specialised type
tcPolyType poly_ty `thenTc` \ sig_sigma ->
- tcInstType [] (idType sig_sigma) `thenNF_Tc` \ sig_ty ->
+ tcInstType [] sig_sigma `thenNF_Tc` \ sig_ty ->
let
(sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
origin = ValSpecOrigin name
@@ -407,8 +409,8 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
-- Check that the specialised type is indeed an instance of
-- the type of the main function.
- unifyTauTy sig_tau main_tau `thenTc_`
- checkSigTyVars sig_tyvars sig_tau main_tau `thenTc_`
+ unifyTauTy sig_tau main_tau `thenTc_`
+ checkSigTyVars sig_tyvars sig_tau `thenTc_`
-- Check that the type variables of the polymorphic function are
-- either left polymorphic, or instantiate to ground type.
@@ -447,8 +449,8 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
-- Check that it has the correct type, and doesn't constrain the
-- signature variables at all
- unifyTauTy sig_tau spec_tau `thenTc_`
- checkSigTyVars sig_tyvars sig_tau spec_tau `thenTc_`
+ unifyTauTy sig_tau spec_tau `thenTc_`
+ checkSigTyVars sig_tyvars sig_tau `thenTc_`
-- Make a local SpecId to bind to applied spec_id
newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 7bb5dc7678090f571aa8536695c7a8171bc8b733..e5cb1f3372044e599cbdc38040e9d525615fe1ba 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -24,13 +24,12 @@ import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
import TcMonad
-import GenSpecEtc ( specTy )
import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
import TcInstDcls ( processInstBinds )
import TcKind ( unifyKind )
import TcMonoType ( tcMonoType, tcContext )
-import TcType ( TcTyVar(..), tcInstType, tcInstTyVar )
+import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars )
import TcKind ( TcKind )
import Bag ( foldBag )
@@ -246,6 +245,11 @@ tcClassDecl2 :: RenamedClassDecl -- The class declaration
tcClassDecl2 (ClassDecl context class_name
tyvar_name class_sigs default_binds pragmas src_loc)
+
+ | not (isLocallyDefined class_name)
+ = returnNF_Tc (emptyLIE, EmptyBinds)
+
+ | otherwise -- It is locally defined
= recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
tcAddSrcLoc src_loc $
@@ -255,14 +259,14 @@ tcClassDecl2 (ClassDecl context class_name
(tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
= getClassBigSig clas
in
- tcInstTyVar tyvar `thenNF_Tc` \ clas_tyvar ->
+ tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
-- Generate bindings for the selector functions
- buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
- `thenNF_Tc` \ sel_binds ->
+ buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
+ `thenNF_Tc` \ sel_binds ->
-- Ditto for the methods
buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
- `thenTc` \ (const_insts, meth_binds) ->
+ `thenTc` \ (const_insts, meth_binds) ->
returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
\end{code}
@@ -275,29 +279,33 @@ tcClassDecl2 (ClassDecl context class_name
\begin{code}
buildSelectors :: Class -- The class object
- -> TcTyVar s -- Class type variable
+ -> TyVar -- Class type variable
+ -> TcTyVar s -- Instantiated class type variable (TyVarTy)
-> [Class] -> [Id] -- Superclasses and selectors
-> [ClassOp] -> [Id] -- Class ops and selectors
-> NF_TcM s (TcHsBinds s)
-buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
+buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
=
-- Make new Ids for the components of the dictionary
- mapNF_Tc (tcInstType [] . getClassOpLocalType) ops `thenNF_Tc` \ op_tys ->
-
+ let
+ clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
+ mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . getClassOpLocalType
+ in
+ mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys ->
newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids ->
newDicts ClassDeclOrigin
- [ (super_clas, mkTyVarTy clas_tyvar)
+ [ (super_clas, clas_tyvar_ty)
| super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
newDicts ClassDeclOrigin
- [ (clas, mkTyVarTy clas_tyvar) ] `thenNF_Tc` \ (_,[clas_dict]) ->
+ [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) ->
-- Make suitable bindings for the selectors
let
mk_sel sel_id method_or_dict
- = mkSelBind sel_id clas_tyvar clas_dict dict_ids method_ids method_or_dict
+ = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
in
listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
@@ -444,7 +452,7 @@ dfun.Foo.List
= /\ a -> \ dfoo_a ->
let rec
op1 = defm.Foo.op1 [a] dfoo_list
- op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
+ op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord
dfoo_list = (op1, op2)
in
dfoo_list
@@ -483,7 +491,11 @@ makeClassDeclDefaultMethodRhs
-> NF_TcM s (TcExpr s)
makeClassDeclDefaultMethodRhs clas method_ids tag
- = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) ->
+ = tcInstType [] (idType method_id) `thenNF_Tc` \ method_ty ->
+ let
+ (tyvars, theta, tau) = splitSigmaTy method_ty
+ in
+ newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) ->
returnNF_Tc (mkHsTyLam tyvars (
mkHsDictLam dict_ids (
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 891262613889d53f32eceb45c99f05a36ad5a15b..06e15fceabdc9ae59e3bc4aa7ced9641c45d76c4 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -35,8 +35,8 @@ import RnBinds4 ( rnMethodBinds, rnTopBinds )
import Bag ( Bag, isEmptyBag, unionBags, listToBag )
import Class ( GenClass, getClassKey )
-import ErrUtils ( pprBagOfErrors, addErrLoc, TcError(..) )
-import Id ( getDataConSig, getDataConArity )
+import ErrUtils ( pprBagOfErrors, addErrLoc )
+import Id ( dataConSig, dataConArity )
import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
import Name ( Name(..) )
import NameTypes ( mkPreludeCoreName, Provenance(..) )
@@ -46,7 +46,7 @@ import PprStyle
import Pretty
import ProtoName ( eqProtoName, ProtoName(..), Name )
import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TyCon ( getTyConTyVars, getTyConDataCons, getTyConDerivings,
+import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
maybeTyConSingleCon, isEnumerationTyCon, TyCon )
import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon,
mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
@@ -266,7 +266,7 @@ makeDerivEqns
need_deriving tycons_to_consider
= foldr ( \ tycon acc ->
- case (getTyConDerivings tycon) of
+ case (tyConDerivings tycon) of
[] -> acc
cs -> [ (clas,tycon) | clas <- cs ] ++ acc
)
@@ -303,9 +303,9 @@ makeDerivEqns
mk_eqn (clas, tycon)
= (clas, tycon, tyvars, constraints)
where
- tyvars = getTyConTyVars tycon -- ToDo: Do we need new tyvars ???
+ tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
tyvar_tys = mkTyVarTys tyvars
- data_cons = getTyConDataCons tycon
+ data_cons = tyConDataCons tycon
constraints = concat (map mk_constraints data_cons)
mk_constraints data_con
@@ -314,7 +314,7 @@ makeDerivEqns
not (isPrimType arg_ty) -- No constraints for primitive types
]
where
- (con_tyvars, _, arg_tys, _) = getDataConSig data_con
+ (con_tyvars, _, arg_tys, _) = dataConSig data_con
inst_env = con_tyvars `zipEqual` tyvar_tys
-- same number of tyvars in data constr and type constr!
\end{code}
@@ -638,7 +638,7 @@ gen_taggery_Names eqns
where
do_con2tag acc_Names tycon
= if (we_are_deriving eqClassKey tycon
- && any ( (== 0).getDataConArity ) (getTyConDataCons tycon))
+ && any ( (== 0).dataConArity ) (tyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
&& not (maybeToBool (maybeTyConSingleCon tycon)))
|| (we_are_deriving enumClassKey tycon)
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 42a6c9b3f98cb8dba1e874df4f4c551bb22374ef..8ca00347863390a8509709297fd7549f3818fd6e 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -13,7 +13,7 @@ module TcEnv(
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
- tcLookupGlobalValue, tcLookupGlobalValueByKey,
+ tcLookupGlobalValue, tcLookupGlobalValueByKey, tcGlobalOcc,
newMonoIds, newLocalIds, newLocalId,
tcGetGlobalTyVars
@@ -25,11 +25,13 @@ import TcMLoop -- for paranoia checking
import Id ( Id(..), GenId, idType, mkUserLocal )
import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) )
-import TcKind ( TcKind, newKindVars, tcKindToKind, kindToTcKind )
-import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, zonkTcTyVars )
+import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
+import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..),
+ newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars
+ )
import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet )
import Type ( tyVarsOfTypes )
-import TyCon ( TyCon, Arity(..), getTyConKind, getSynTyConArity )
+import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity )
import Class ( Class(..), GenClass, getClassSig )
import TcMonad
@@ -37,9 +39,10 @@ import TcMonad
import Name ( Name(..), getNameShortName )
import PprStyle
import Pretty
+import Type ( splitForAllTy )
import Unique ( Unique )
import UniqFM
-import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic )
+import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic )
\end{code}
Data type declarations
@@ -89,7 +92,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside
(thing_inside rec_tyvars) `thenTc` \ result ->
-- Get the tyvar's Kinds from their TcKinds
- mapNF_Tc tcKindToKind kinds `thenNF_Tc` \ kinds' ->
+ mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
-- Construct the real TyVars
let
@@ -123,7 +126,10 @@ tcExtendTyConEnv names_w_arities tycons scope
(kinds `zipLazy` tycons)
]
in
- tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope
+ tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope `thenTc` \ result ->
+ mapNF_Tc tcDefaultKind kinds `thenNF_Tc_`
+ returnTc result
+
tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r
tcExtendClassEnv names classes scope
@@ -132,7 +138,9 @@ tcExtendClassEnv names classes scope
let
ce' = addListToUFM ce (names `zip` (kinds `zipLazy` classes))
in
- tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope
+ tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope `thenTc` \ result ->
+ mapNF_Tc tcDefaultKind kinds `thenNF_Tc_`
+ returnTc result
\end{code}
@@ -145,7 +153,7 @@ tcLookupTyVar name
tcLookupTyCon (WiredInTyCon tc) -- wired in tycons
- = returnNF_Tc (kindToTcKind (getTyConKind tc), getSynTyConArity tc, tc)
+ = returnNF_Tc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
tcLookupTyCon name
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
@@ -154,7 +162,9 @@ tcLookupTyCon name
tcLookupTyConByKey uniq
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
- (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce (panic "tcLookupTyCon") uniq
+ (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce
+ (pprPanic "tcLookupTyCon:" (ppr PprDebug uniq))
+ uniq
in
returnNF_Tc tycon
@@ -165,7 +175,9 @@ tcLookupClass name
tcLookupClassByKey uniq
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
- (kind, clas) = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq
+ (kind, clas) = lookupWithDefaultUFM_Directly ce
+ (pprPanic "tcLookupClas:" (ppr PprDebug uniq))
+ uniq
in
returnNF_Tc clas
\end{code}
@@ -236,11 +248,27 @@ tcLookupGlobalValue name
returnNF_Tc (lookupWithDefaultUFM gve def name)
where
#ifdef DEBUG
- def = panic ("tcLookupGlobalValue:" ++ ppShow 1000 (ppr PprDebug name))
+ def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
#else
def = panic "tcLookupGlobalValue"
#endif
+-- A useful function that takes an occurrence of a global thing
+-- and instantiates its type with fresh type variables
+tcGlobalOcc :: Name
+ -> NF_TcM s (Id, -- The Id
+ [TcType s], -- Instance types
+ TcType s) -- Rest of its type
+
+tcGlobalOcc name
+ = tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ let
+ (tyvars, rho) = splitForAllTy (idType id)
+ in
+ tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
+ tcInstType tenv rho `thenNF_Tc` \ rho' ->
+ returnNF_Tc (id, arg_tys, rho')
+
tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
tcLookupGlobalValueByKey uniq
@@ -248,7 +276,7 @@ tcLookupGlobalValueByKey uniq
returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
where
#ifdef DEBUG
- def = panic ("tcLookupGlobalValueByKey:" ++ ppShow 1000 (ppr PprDebug uniq))
+ def = pprPanic "tcLookupGlobalValueByKey:" (ppr PprDebug uniq)
#else
def = panic "tcLookupGlobalValueByKey"
#endif
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 9f911d4b0064fb24adbca57c986ae2531efb8395..660c970b6f0e91fe9f74babeeb623a30821f07b9 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -15,45 +15,56 @@ import HsSyn ( HsExpr(..), Qual(..), Stmt(..),
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
Match, Fake, InPat, OutPat, PolyType,
irrefutablePat, collectPatBinders )
-import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), RenamedStmt(..) )
-import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..), TcIdOcc(..) )
+import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..),
+ RenamedStmt(..), RenamedRecordBinds(..)
+ )
+import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
+ TcIdOcc(..), TcRecordBinds(..),
+ mkHsTyApp
+ )
import TcMonad
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
- LIE(..), emptyLIE, plusLIE, newOverloadedLit,
+ LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
- tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars )
+ tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
+ tcGlobalOcc
+ )
import TcMatches ( tcMatchesCase, tcMatch )
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
-import TcType ( TcType(..), TcMaybe(..), tcReadTyVar,
- tcInstType, tcInstTcType,
- tcInstTyVar, newTyVarTy, zonkTcTyVars )
+import TcType ( TcType(..), TcMaybe(..),
+ tcInstType, tcInstTcType, tcInstTyVars,
+ newTyVarTy, zonkTcTyVars, zonkTcType )
import TcKind ( TcKind )
import Class ( Class(..), getClassSig )
-import Id ( Id(..), GenId, idType )
-import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals, specTy )
+import FieldLabel ( fieldLabelName )
+import Id ( Id(..), GenId, idType, dataConFieldLabels )
+import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
+import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy,
floatPrimTy, addrPrimTy, addrTy,
boolTy, charTy, stringTy, mkListTy,
mkTupleTy, mkPrimIoTy )
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
getTyVar_maybe, getFunTy_maybe,
- splitForAllTy, splitRhoTy, splitSigmaTy,
- isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe )
+ splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
+ isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
+ maybeAppDataTyCon
+ )
import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
-import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
+import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
monadClassKey, monadZeroClassKey )
import Name ( Name ) -- Instance
+import Outputable ( interpp'SP )
import PprType ( GenType, GenTyVar ) -- Instances
import Maybes ( maybeToBool )
import Pretty
@@ -302,24 +313,18 @@ tcExpr (HsDo stmts src_loc)
= -- get the Monad and MonadZero classes
-- create type consisting of a fresh monad tyvar
tcAddSrcLoc src_loc $
- tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass ->
- tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass ->
- let
- (tv,_,_) = getClassSig monadClass
- in
- tcInstTyVar tv `thenNF_Tc` \ m_tyvar ->
- let
- m = mkTyVarTy m_tyvar
- in
- tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
+ newTyVarTy monadKind `thenNF_Tc` \ m ->
+ tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
-- create dictionaries for monad and possibly monadzero
(if monad then
+ tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass ->
newDicts DoOrigin [(monadClass, m)]
else
returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
) `thenNF_Tc` \ (m_lie, [m_id]) ->
(if mzero then
+ tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass ->
newDicts DoOrigin [(monadZeroClass, m)]
else
returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
@@ -328,6 +333,8 @@ tcExpr (HsDo stmts src_loc)
returnTc (HsDoOut stmts' m_id mz_id src_loc,
lie `plusLIE` m_lie `plusLIE` mz_lie,
do_ty)
+ where
+ monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
\end{code}
\begin{code}
@@ -346,10 +353,41 @@ tcExpr (ExplicitTuple exprs)
= tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
-tcExpr (RecordCon con rbinds)
- = panic "tcExpr:RecordCon"
-tcExpr (RecordUpd exp rbinds)
- = panic "tcExpr:RecordUpd"
+tcExpr (RecordCon (HsVar con) rbinds)
+ = tcGlobalOcc con `thenNF_Tc` \ (con_id, arg_tys, con_rho) ->
+ let
+ (con_theta, con_tau) = splitRhoTy con_rho
+ (_, record_ty) = splitFunTy con_tau
+ con_expr = mkHsTyApp (HsVar (RealId con_id)) arg_tys
+ in
+ -- TEMPORARY ASSERT
+ ASSERT( null con_theta )
+
+ -- Con is syntactically constrained to be a data constructor
+ ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
+
+ tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+
+ checkTc (checkRecordFields rbinds con_id)
+ (badFieldsCon con rbinds) `thenTc_`
+
+ returnTc (RecordCon con_expr rbinds', panic "tcExpr:RecordCon:con_lie???" {-con_lie???-} `plusLIE` rbinds_lie, record_ty)
+
+tcExpr (RecordUpd record_expr rbinds)
+ = tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
+ tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+
+ -- Check that the field names are plausible
+ zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
+ let
+ maybe_tycon_stuff = maybeAppDataTyCon record_ty'
+ Just (tycon, args_tys, data_cons) = maybe_tycon_stuff
+ in
+ checkTc (maybeToBool maybe_tycon_stuff)
+ (panic "TcExpr:Records:mystery error message") `thenTc_`
+ checkTc (any (checkRecordFields rbinds) data_cons)
+ (badFieldsUpd rbinds) `thenTc_`
+ returnTc (RecordUpd record_expr' rbinds', record_lie `plusLIE` rbinds_lie, record_ty)
tcExpr (ArithSeqIn seq@(From expr))
= tcExpr expr `thenTc` \ (expr', lie1, ty) ->
@@ -425,13 +463,17 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty)
-- Check the tau-type part
tcSetErrCtxt (exprSigCtxt in_expr) $
- specTy SignatureOrigin sigma_sig `thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau, _) ->
- unifyTauTy tau_ty sig_tau `thenTc_`
+ tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' ->
+ let
+ (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
+ in
+ unifyTauTy tau_ty sig_tau' `thenTc_`
-- Check the type variables of the signature
- checkSigTyVars sig_tyvars sig_tau tau_ty `thenTc` \ sig_tyvars' ->
+ checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
-- Check overloading constraints
+ newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
tcSimplifyAndCheck
(mkTyVarSet sig_tyvars')
sig_dicts lie `thenTc_`
@@ -485,46 +527,23 @@ tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error m
tcApp_help orig_fun arg_no fun_ty []
= returnTc ([], emptyLIE, fun_ty)
-tcApp_help orig_fun arg_no fun_ty (arg:args)
- | maybeToBool maybe_arrow_ty
- = -- The function's type is A->B
+tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
+ = -- Expect the function to have type A->B
+ tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
+ unifyFunTy fun_ty
+ ) `thenTc` \ (expected_arg_ty, result_ty) ->
+
+ -- Type check the argument
tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
- tcArg expected_arg_ty arg
- ) `thenTc` \ (arg', lie_arg) ->
+ tcArg expected_arg_ty arg
+ ) `thenTc` \ (arg', lie_arg) ->
+ -- Do the other args
tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
- returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
-
- | maybeToBool maybe_tyvar_ty
- = -- The function's type is just a type variable
- tcReadTyVar fun_tyvar `thenNF_Tc` \ maybe_fun_ty ->
- case maybe_fun_ty of
-
- BoundTo new_fun_ty -> -- The tyvar in the corner of the function is bound
- -- to something ... so carry on ....
- tcApp_help orig_fun arg_no new_fun_ty (arg:args)
-
- UnBound -> -- Extra args match against an unbound type
- -- variable as the final result type, so unify the tyvar.
- newTyVarTy mkTypeKind `thenNF_Tc` \ result_ty ->
- tcExprs args `thenTc` \ (args', lie_args, arg_tys) ->
-
- -- Unification can't fail, since we're unifying against a tyvar
- unifyTauTy fun_ty (mkFunTys arg_tys result_ty) `thenTc_`
-
- returnTc (args', lie_args, result_ty)
-
- | otherwise
- = -- Must be an error: a lurking for-all, or (more commonly)
- -- a TyConTy... we've applied the function to too many args
- failTc (tooManyArgs orig_fun)
- where
- maybe_arrow_ty = getFunTy_maybe fun_ty
- Just (expected_arg_ty, result_ty) = maybe_arrow_ty
+ -- Done
+ returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
- maybe_tyvar_ty = getTyVar_maybe fun_ty
- Just fun_tyvar = maybe_tyvar_ty
\end{code}
\begin{code}
@@ -550,7 +569,7 @@ tcArg expected_arg_ty arg
let
(expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
in
- ASSERT( null expected_theta )
+ ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things
-- Type-check the arg and unify with expected type
tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
@@ -571,19 +590,19 @@ tcArg expected_arg_ty arg
zonkTcTyVars (tyVarsOfType expected_arg_ty) `thenNF_Tc` \ free_tyvars ->
checkSigTyVarsGivenGlobals
(env_tyvars `unionTyVarSets` free_tyvars)
- expected_tyvars expected_tau actual_arg_ty `thenTc` \ arg_tyvars' ->
+ expected_tyvars expected_tau `thenTc_`
-- Check that there's no overloading involved
- -- Even if there isn't, there may be some Insts which mention the arg_tyvars,
+ -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
-- but which, on simplification, don't actually need a dictionary involving
-- the tyvar. So we have to do a proper simplification right here.
- tcSimplifyRank2 (mkTyVarSet arg_tyvars')
+ tcSimplifyRank2 (mkTyVarSet expected_tyvars)
lie_arg `thenTc` \ (free_insts, inst_binds) ->
-- This HsLet binds any Insts which came out of the simplification.
-- It's a bit out of place here, but using AbsBind involves inventing
-- a couple of new names which seems worse.
- returnTc (TyLam arg_tyvars' (HsLet (mk_binds inst_binds) arg'), free_insts)
+ returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
)
where
@@ -605,29 +624,30 @@ tcArg expected_arg_ty arg
tcId :: Name -> TcM s (TcExpr s, LIE s, TcType s)
tcId name
= -- Look up the Id and instantiate its type
- (tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
- case maybe_local of
- Just tc_id -> tcInstTcType [] (idType tc_id) `thenNF_Tc` \ ty ->
- returnNF_Tc (TcId tc_id, ty)
-
- Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
- tcInstType [] (idType id) `thenNF_Tc` \ ty ->
- returnNF_Tc (RealId id, ty)
- ) `thenNF_Tc` \ (tc_id_occ, ty) ->
- let
- (tyvars, rho) = splitForAllTy ty
- (theta,tau) = splitRhoTy rho
- arg_tys = mkTyVarTys tyvars
- in
+ tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
+
+ (case maybe_local of
+ Just tc_id -> let
+ (tyvars, rho) = splitForAllTy (idType tc_id)
+ in
+ tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) ->
+ tcInstTcType tenv rho `thenNF_Tc` \ rho' ->
+ returnNF_Tc (TcId tc_id, arg_tys', rho')
+
+ Nothing -> tcGlobalOcc name `thenNF_Tc` \ (id, arg_tys, rho) ->
+ returnNF_Tc (RealId id, arg_tys, rho)
+
+ ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
+
-- Is it overloaded?
- case theta of
- [] -> -- Not overloaded, so just make a type application
- returnTc (TyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
-
- _ -> -- Overloaded, so make a Method inst
- newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) ->
- returnTc (HsVar meth_id, lie, tau)
+ case splitRhoTy rho of
+ ([], tau) -> -- Not overloaded, so just make a type application
+ returnTc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+
+ (theta, tau) -> -- Overloaded, so make a Method inst
+ newMethodWithGivenTy (OccurrenceOf tc_id_occ)
+ tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) ->
+ returnTc (HsVar meth_id, lie, tau)
\end{code}
@@ -752,6 +772,65 @@ tcDoStmts monad m (LetStmt binds : stmts)
\end{code}
+Game plan for record bindings
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For each binding
+ field = value
+1. look up "field", to find its selector Id, which must have type
+ forall a1..an. T a1 .. an -> tau
+ where tau is the type of the field.
+
+2. Instantiate this type
+
+3. Unify the (T a1 .. an) part with the "expected result type", which
+ is passed in. This checks that all the field labels come from the
+ same type.
+
+4. Type check the value using tcArg, passing tau as the expected
+ argument type.
+
+This extends OK when the field types are universally quantified.
+
+Actually, to save excessive creation of fresh type variables,
+we
+
+\begin{code}
+tcRecordBinds
+ :: TcType s -- Expected type of whole record
+ -> RenamedRecordBinds
+ -> TcM s (TcRecordBinds s, LIE s)
+
+tcRecordBinds expected_record_ty rbinds
+ = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
+ returnTc (rbinds', plusLIEs lies)
+ where
+ do_bind (field_label, rhs, pun_flag)
+ = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) ->
+
+ -- Record selectors all have type
+ -- forall a1..an. T a1 .. an -> tau
+ ASSERT( maybeToBool (getFunTy_maybe tau) )
+ let
+ -- Selector must have type RecordType -> FieldType
+ Just (record_ty, field_ty) = getFunTy_maybe tau
+ in
+ unifyTauTy expected_record_ty record_ty `thenTc_`
+ tcArg field_ty rhs `thenTc` \ (rhs', lie) ->
+ returnTc ((RealId sel_id, rhs', pun_flag), lie)
+
+checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in
+ -- RecordBinds are field of the
+ -- specified constructor
+checkRecordFields rbinds data_con
+ = all ok rbinds
+ where
+ data_con_fields = dataConFieldLabels data_con
+
+ ok (field_name, _, _) = any (match field_name) data_con_fields
+
+ match field_name field_label = field_name == fieldLabelName field_label
+\end{code}
+
%************************************************************************
%* *
\subsection{@tcExprs@ typechecks a {\em list} of expressions}
@@ -821,7 +900,7 @@ stmtCtxt stmt sty
= ppHang (ppStr "In a do statement:")
4 (ppr sty stmt)
-tooManyArgs f sty
+tooManyArgsCtxt f sty
= ppHang (ppStr "Too many arguments in an application of the function")
4 (ppr sty f)
@@ -834,5 +913,16 @@ rank2ArgCtxt arg expected_arg_ty sty
= ppHang (ppStr "In a polymorphic function argument:")
4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
ppr sty expected_arg_ty])
-\end{code}
+badFieldsUpd rbinds sty
+ = ppHang (ppStr "In a record update construct, no constructor has all these fields:")
+ 4 (interpp'SP sty fields)
+ where
+ fields = [field | (field, _, _) <- rbinds]
+
+badFieldsCon con rbinds sty
+ = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
+ 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
+ where
+ fields = [field | (field, _, _) <- rbinds]
+\end{code}
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 6a701272ef6a003fe1e2c1ea702ff3233cca8fd1..3dfcc031a89c5dc8eac3c395608773aedfcdb261 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -73,8 +73,8 @@ import RnHsSyn ( RenamedFixityDecl(..) )
import RnMonad4 -- initRn4, etc.
import RnUtils
-import Id ( GenId, getDataConArity, getDataConTag,
- getDataConSig, fIRST_TAG,
+import Id ( GenId, dataConArity, dataConTag,
+ dataConSig, fIRST_TAG,
isDataCon, DataCon(..), ConTag(..) )
import IdUtils ( primOpId )
import Maybes ( maybeToBool )
@@ -86,7 +86,7 @@ import PrelInfo
import Pretty
import ProtoName ( ProtoName(..) )
import SrcLoc ( mkGeneratedSrcLoc )
-import TyCon ( TyCon, getTyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
+import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
import Type ( eqTy, isPrimType )
import Unique
import Util
@@ -175,8 +175,8 @@ instance ... Eq (Foo ...) where
gen_Eq_binds :: TyCon -> ProtoNameMonoBinds
gen_Eq_binds tycon
- = case (partition (\ con -> getDataConArity con == 0)
- (getTyConDataCons tycon))
+ = case (partition (\ con -> dataConArity con == 0)
+ (tyConDataCons tycon))
of { (nullary_cons, nonnullary_cons) ->
let
rest
@@ -201,9 +201,9 @@ gen_Eq_binds tycon
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
data_con_PN = Prel (WiredInVal data_con)
- as_needed = take (getDataConArity data_con) as_PNs
- bs_needed = take (getDataConArity data_con) bs_PNs
- tys_needed = case (getDataConSig data_con) of
+ as_needed = take (dataConArity data_con) as_PNs
+ bs_needed = take (dataConArity data_con) bs_PNs
+ tys_needed = case (dataConSig data_con) of
(_,_, arg_tys, _) -> arg_tys
in
([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
@@ -342,7 +342,7 @@ gen_Ord_binds tycon
(cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
(nullary_cons, nonnullary_cons)
- = partition (\ con -> getDataConArity con == 0) (getTyConDataCons tycon)
+ = partition (\ con -> dataConArity con == 0) (tyConDataCons tycon)
cmp_eq
= mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
@@ -355,9 +355,9 @@ gen_Ord_binds tycon
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
data_con_PN = Prel (WiredInVal data_con)
- as_needed = take (getDataConArity data_con) as_PNs
- bs_needed = take (getDataConArity data_con) bs_PNs
- tys_needed = case (getDataConSig data_con) of
+ as_needed = take (dataConArity data_con) as_PNs
+ bs_needed = take (dataConArity data_con) bs_PNs
+ tys_needed = case (dataConSig data_con) of
(_,_, arg_tys, _) -> arg_tys
nested_compare_expr [ty] [a] [b]
@@ -570,21 +570,21 @@ gen_Ix_binds tycon
= case maybeTyConSingleCon tycon of -- just checking...
Nothing -> panic "get_Ix_binds"
Just dc -> let
- (_, _, arg_tys, _) = getDataConSig dc
+ (_, _, arg_tys, _) = dataConSig dc
in
if any isPrimType arg_tys then
error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
else
dc
- con_arity = getDataConArity data_con
+ con_arity = dataConArity data_con
data_con_PN = Prel (WiredInVal data_con)
con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs)
- as_needed = take (getDataConArity data_con) as_PNs
- bs_needed = take (getDataConArity data_con) bs_PNs
- cs_needed = take (getDataConArity data_con) cs_PNs
+ as_needed = take (dataConArity data_con) as_PNs
+ bs_needed = take (dataConArity data_con) bs_PNs
+ cs_needed = take (dataConArity data_con) cs_PNs
--------------------------------------------------------------
single_con_range
@@ -645,7 +645,7 @@ gen_Read_binds fixities tycon
reads_prec
= let
read_con_comprehensions
- = map read_con (getTyConDataCons tycon)
+ = map read_con (tyConDataCons tycon)
in
mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
foldl1 append_Expr read_con_comprehensions
@@ -655,10 +655,10 @@ gen_Read_binds fixities tycon
= let
data_con_PN = Prel (WiredInVal data_con)
data_con_str= snd (getOrigName data_con)
- as_needed = take (getDataConArity data_con) as_PNs
- bs_needed = take (getDataConArity data_con) bs_PNs
+ as_needed = take (dataConArity data_con) as_PNs
+ bs_needed = take (dataConArity data_con) bs_PNs
con_expr = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed)
- nullary_con = getDataConArity data_con == 0
+ nullary_con = dataConArity data_con == 0
con_qual
= GeneratorQual
@@ -696,14 +696,14 @@ gen_Show_binds fixities tycon
(HsApp (HsVar _showList_PN) (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0))))
-----------------------------------------------------------------------
shows_prec
- = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon))
+ = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
where
pats_etc data_con
= let
data_con_PN = Prel (WiredInVal data_con)
- bs_needed = take (getDataConArity data_con) bs_PNs
+ bs_needed = take (dataConArity data_con) bs_PNs
con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- nullary_con = getDataConArity data_con == 0
+ nullary_con = dataConArity data_con == 0
show_con
= let (mod, nm) = getOrigName data_con
@@ -773,19 +773,19 @@ gen_tag_n_con_monobind
-> ProtoNameMonoBinds
gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
- = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
+ = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
where
mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
mk_stuff var
= ASSERT(isDataCon var)
- ([pat], HsLit (HsIntPrim (toInteger ((getDataConTag var) - fIRST_TAG))))
+ ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
- pat = ConPatIn var_PN (nOfThem (getDataConArity var) WildPatIn)
+ pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
var_PN = Prel (WiredInVal var)
gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
- = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
+ = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
where
mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
@@ -793,13 +793,13 @@ gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
= ASSERT(isDataCon var)
([lit_pat], HsVar var_PN)
where
- lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((getDataConTag var) - fIRST_TAG)))]
+ lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
var_PN = Prel (WiredInVal var)
gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
= mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
where
- max_tag = case (getTyConDataCons tycon) of
+ max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
\end{code}
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 005fec5b706127e0256d88bc3458e27ce7f5ffd8..996658bc252f3ebcda3b55aa349685a909900c17 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -10,16 +10,21 @@ checker.
module TcHsSyn (
TcIdBndr(..), TcIdOcc(..),
- TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), TcExpr(..), TcGRHSsAndBinds(..),
- TcGRHS(..), TcMatch(..), TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcHsModule(..),
+ TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..),
+ TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..),
+ TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..),
+ TcHsModule(..),
- TypecheckedHsBinds(..), TypecheckedBind(..), TypecheckedMonoBinds(..),
- TypecheckedPat(..), TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
- TypecheckedQual(..), TypecheckedStmt(..), TypecheckedMatch(..),
- TypecheckedHsModule(..), TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
+ TypecheckedHsBinds(..), TypecheckedBind(..),
+ TypecheckedMonoBinds(..), TypecheckedPat(..),
+ TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
+ TypecheckedQual(..), TypecheckedStmt(..),
+ TypecheckedMatch(..), TypecheckedHsModule(..),
+ TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
mkHsTyApp, mkHsDictApp,
mkHsTyLam, mkHsDictLam,
+ tcIdType,
zonkBinds,
zonkInst,
@@ -32,7 +37,7 @@ import Ubiq{-uitous-}
-- friends:
import HsSyn -- oodles of it
import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
- DictVar(..)
+ DictVar(..), idType
)
-- others:
@@ -76,6 +81,7 @@ type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcQual s = Qual (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TypecheckedPat = OutPat TyVar UVar Id
@@ -104,6 +110,10 @@ mkHsTyLam tyvars expr = TyLam tyvars expr
mkHsDictLam [] expr = expr
mkHsDictLam dicts expr = DictLam dicts expr
+
+tcIdType :: TcIdOcc s -> TcType s
+tcIdType (TcId id) = idType id
+tcIdType other = panic "tcIdType"
\end{code}
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 6e3db5bc9d45720ce7ba62aff1d7383002ab3a9c..43d29fb61f9307528ba92c945cacef3dd937ca2a 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -25,13 +25,13 @@ import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..),
RenamedInstDecl(..), RenamedFixityDecl(..),
RenamedSig(..), RenamedSpecInstSig(..) )
import TcHsSyn ( TcIdOcc(..), TcHsBinds(..),
- TcMonoBinds(..), TcExpr(..),
+ TcMonoBinds(..), TcExpr(..), tcIdType,
mkHsTyLam, mkHsTyApp,
mkHsDictLam, mkHsDictApp )
import TcMonad
-import GenSpecEtc ( checkSigTyVars, specTy )
+import GenSpecEtc ( checkSigTyVars )
import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
import TcBinds ( tcPragmaSigs )
@@ -44,7 +44,8 @@ import TcMatches ( tcMatchesFun )
import TcMonoType ( tcContext, tcMonoTypeKind )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas )
import TcType ( TcType(..), TcTyVar(..),
- tcInstTyVar, tcInstType, tcInstTheta )
+ tcInstSigTyVars, tcInstType, tcInstTheta
+ )
import Unify ( unifyTauTy )
@@ -64,7 +65,7 @@ import Name ( Name, getTagFromClassOpName )
import Outputable
import PrelInfo ( pAT_ERROR_ID )
import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
- pprParendType )
+ pprParendGenType )
import PprStyle
import Pretty
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
@@ -346,10 +347,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
tcAddSrcLoc locn $
-- Get the class signature
- mapNF_Tc tcInstTyVar inst_tyvars `thenNF_Tc` \ inst_tyvars' ->
+ tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
let
- tenv = inst_tyvars `zip` (mkTyVarTys inst_tyvars')
-
(class_tyvar,
super_classes, sc_sel_ids,
class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
@@ -378,9 +377,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
mk_method_expr
= if opt_OmitDefaultInstanceMethods then
- makeInstanceDeclNoDefaultExpr origin clas meth_ids defm_ids inst_mod inst_ty'
+ makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod
else
- makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty'
+ makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
in
processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
`thenTc` \ (insts_needed, method_mbinds) ->
@@ -495,20 +494,18 @@ See the notes under default decls in TcClassDcl.lhs.
\begin{code}
makeInstanceDeclDefaultMethodExpr
:: InstOrigin s
- -> TcIdOcc s
- -> [ClassOp]
+ -> [TcIdOcc s]
-> [Id]
-> TcType s
+ -> TcIdOcc s
-> Int
-> NF_TcM s (TcExpr s)
-makeInstanceDeclDefaultMethodExpr origin this_dict class_ops defm_ids inst_ty tag
- = specTy origin (getClassOpLocalType class_op)
- `thenNF_Tc` \ (op_tyvars, op_lie, op_tau, op_dicts) ->
+makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
+ = newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) ->
-- def_op_id = /\ op_tyvars -> \ op_dicts ->
-- defm_id inst_ty op_tyvars this_dict op_dicts
-
returnNF_Tc (
mkHsTyLam op_tyvars (
mkHsDictLam op_dicts (
@@ -517,25 +514,23 @@ makeInstanceDeclDefaultMethodExpr origin this_dict class_ops defm_ids inst_ty ta
(this_dict : op_dicts)
)))
where
- idx = tag - 1
- class_op = class_ops !! idx
- defm_id = defm_ids !! idx
+ idx = tag - 1
+ meth_id = meth_ids !! idx
+ defm_id = defm_ids !! idx
+ (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id)
makeInstanceDeclNoDefaultExpr
:: InstOrigin s
- -> Class
-> [TcIdOcc s]
-> [Id]
- -> FAST_STRING
-> TcType s
+ -> Class
+ -> FAST_STRING
-> Int
-> NF_TcM s (TcExpr s)
-makeInstanceDeclNoDefaultExpr origin clas method_occs defm_ids inst_mod inst_ty tag
- = let
- (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType method_id)
- in
- newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) ->
+makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
+ = newDicts origin op_theta `thenNF_Tc` \ (op_lie, op_dicts) ->
-- Produce a warning if the default instance method
-- has been omitted when one exists in the class
@@ -547,12 +542,12 @@ makeInstanceDeclNoDefaultExpr origin clas method_occs defm_ids inst_mod inst_ty
HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))))
where
- idx = tag - 1
- method_occ = method_occs !! idx
- clas_op = (getClassOps clas) !! idx
- defm_id = defm_ids !! idx
+ idx = tag - 1
+ meth_id = meth_ids !! idx
+ clas_op = (getClassOps clas) !! idx
+ defm_id = defm_ids !! idx
+ (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id)
- TcId method_id = method_occ
Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
error_msg = "%E" -- => No explicit method for \"
@@ -673,12 +668,6 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
-- Type check the method itself
tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
-
- -- Make sure that the instance tyvars havn't been
- -- unified with each other or with the method tyvars.
- tcSetErrCtxt (methodSigCtxt op method_tau) (
- checkSigTyVars inst_tyvars method_tau method_tau
- ) `thenTc_`
returnTc ([tag], lieIop, mbind')
other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
@@ -696,12 +685,6 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
-- Typecheck the method
tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
- -- Make sure that the instance tyvars haven't been
- -- unified with each other or with the method tyvars.
- tcAddErrCtxt (methodSigCtxt op method_tau) (
- checkSigTyVars inst_method_tyvars method_tau method_tau
- ) `thenTc_`
-
-- Check the overloading part of the signature.
-- Simplify everything fully, even though some
-- constraints could "really" be left to the next
@@ -839,12 +822,12 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc
(ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
if null simpl_theta then ppNil else ppStr "=>",
ppr PprDebug clas,
- pprParendType PprDebug inst_ty],
+ pprParendGenType PprDebug inst_ty],
ppCat [ppStr " derived from:",
if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
if null unspec_theta then ppNil else ppStr "=>",
ppr PprDebug clas,
- pprParendType PprDebug unspec_inst_ty]])
+ pprParendGenType PprDebug unspec_inst_ty]])
else id) (
returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
@@ -962,7 +945,7 @@ nonBoxedPrimCCallErr clas inst_ty sty
omitDefaultMethodWarn clas_op clas_name inst_ty sty
= ppCat [ppStr "Warning: Omitted default method for",
ppr sty clas_op, ppStr "in instance",
- ppPStr clas_name, pprParendType sty inst_ty]
+ ppPStr clas_name, pprParendGenType sty inst_ty]
patMonoBindsCtxt pbind sty
diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs
index a23362306d2b5fbb8bead0d14f80c52095a401a9..05b4a03a41b8328c7efffd8b4a13e6eb80fc5f3c 100644
--- a/ghc/compiler/typecheck/TcKind.lhs
+++ b/ghc/compiler/typecheck/TcKind.lhs
@@ -11,7 +11,7 @@ module TcKind (
unifyKind, -- TcKind s -> TcKind s -> TcM s ()
kindToTcKind, -- Kind -> TcKind s
- tcKindToKind -- TcKind s -> NF_TcM s Kind
+ tcDefaultKind -- TcKind s -> NF_TcM s Kind
) where
import Kind
@@ -77,7 +77,7 @@ I'm not convinced it would save time, and it's a little tricky to get right.
unify_var uniq1 box1 kind2
= tcReadMutVar box1 `thenNF_Tc` \ maybe_kind1 ->
case maybe_kind1 of
- Just kind1 -> unify_kind kind1 kind1
+ Just kind1 -> unify_kind kind1 kind2
Nothing -> unify_unbound_var uniq1 box1 kind2
unify_unbound_var uniq1 box1 kind2@(TcVarKind uniq2 box2)
@@ -127,22 +127,27 @@ kindToTcKind UnboxedTypeKind = TcTypeKind
kindToTcKind (ArrowKind k1 k2) = TcArrowKind (kindToTcKind k1) (kindToTcKind k2)
-tcKindToKind :: TcKind s -> NF_TcM s Kind
+-- Default all unbound kinds to TcTypeKind, and return the
+-- corresponding Kind as well.
+tcDefaultKind :: TcKind s -> NF_TcM s Kind
-tcKindToKind TcTypeKind
- = returnNF_Tc TypeKind
+tcDefaultKind TcTypeKind
+ = returnNF_Tc BoxedTypeKind
-tcKindToKind (TcArrowKind kind1 kind2)
- = tcKindToKind kind1 `thenNF_Tc` \ k1 ->
- tcKindToKind kind2 `thenNF_Tc` \ k2 ->
+tcDefaultKind (TcArrowKind kind1 kind2)
+ = tcDefaultKind kind1 `thenNF_Tc` \ k1 ->
+ tcDefaultKind kind2 `thenNF_Tc` \ k2 ->
returnNF_Tc (ArrowKind k1 k2)
-- Here's where we "default" unbound kinds to BoxedTypeKind
-tcKindToKind (TcVarKind uniq box)
+tcDefaultKind (TcVarKind uniq box)
= tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
case maybe_kind of
- Nothing -> returnNF_Tc BoxedTypeKind -- Default is kind Type for unbound
- Just kind -> tcKindToKind kind
+ Just kind -> tcDefaultKind kind
+
+ Nothing -> -- Default unbound variables to kind Type
+ tcWriteMutVar box (Just TcTypeKind) `thenNF_Tc_`
+ returnNF_Tc BoxedTypeKind
zonkTcKind :: TcKind s -> NF_TcM s (TcKind s)
-- Removes variables that have now been bound.
@@ -200,6 +205,6 @@ kindMisMatchErr kind1 kind2 sty
= ppHang (ppStr "Couldn't match the kind") 4
(ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
ppStr "against",
- ppBesides [ppStr "`", ppr sty kind1, ppStr "'"]
+ ppBesides [ppStr "`", ppr sty kind2, ppStr "'"]
])
\end{code}
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 31a31501a0fb872b99216cbf3c991a621c1f3e6c..d5bae6830c95cdc889643a5f191d6b371c8fe40f 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -210,7 +210,7 @@ matchCtxt MCase match sty
matchCtxt (MFun fun) match sty
= ppHang (ppBesides [ppStr "In an equation for function ", ppr sty fun, ppChar ':'])
- 4 (ppBesides [ppr sty fun, pprMatch sty False{-not case-} match])
+ 4 (ppBesides [ppr sty fun, ppSP, pprMatch sty False{-not case-} match])
\end{code}
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 4daf3b4aa34c5ac54fea437b358bc591cd158b0a..de240682a5d0cd72eed4c7e3e981a14cdacf48c7 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -61,7 +61,8 @@ tycon_specs = emptyFM
\begin{code}
tcModule :: GlobalNameMappers -- final renamer info for derivings
-> RenamedHsModule -- input
- -> TcM s ((TypecheckedHsBinds, -- binds from class decls; does NOT
+ -> TcM s ((TypecheckedHsBinds, -- record selector binds
+ TypecheckedHsBinds, -- binds from class decls; does NOT
-- include default-methods bindings
TypecheckedHsBinds, -- binds from instance decls; INCLUDES
-- class default-methods binds
@@ -94,17 +95,17 @@ tcModule renamer_name_funs
-- pragmas, which is done lazily [ie failure just drops the pragma
-- without having any global-failure effect].
- fixTc (\ ~(_, _, _, _, _, sig_ids) ->
+ fixTc (\ ~(_, _, _, _, _, _, sig_ids) ->
tcExtendGlobalValEnv sig_ids (
-- The knot for instance information. This isn't used at all
-- till we type-check value declarations
- fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+ fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _) ->
-- Type-check the type and class decls
trace "tcTyAndClassDecls:" $
tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
- `thenTc` \ env ->
+ `thenTc` \ (env, record_binds) ->
-- Typecheck the instance decls, includes deriving
tcSetEnv env (
@@ -115,9 +116,9 @@ tcModule renamer_name_funs
buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
- returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+ returnTc (inst_mapper, env, record_binds, inst_info, deriv_binds, ddump_deriv)
- ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+ ) `thenTc` \ (_, env, record_binds, inst_info, deriv_binds, ddump_deriv) ->
tcSetEnv env (
-- Default declarations
@@ -132,9 +133,9 @@ tcModule renamer_name_funs
-- we silently discard the pragma
tcInterfaceSigs sigs `thenTc` \ sig_ids ->
- returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
+ returnTc (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
- )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) ->
+ )))) `thenTc` \ (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
tcSetEnv env ( -- to the end...
tcSetDefaultTys defaulting_tys ( -- ditto
@@ -181,6 +182,7 @@ tcModule renamer_name_funs
-- simplification step may have instantiated some
-- ambiguous types. So, sadly, we need to back-substitute
-- over the whole bunch of bindings.
+ zonkBinds record_binds `thenNF_Tc` \ record_binds' ->
zonkBinds val_binds `thenNF_Tc` \ val_binds' ->
zonkBinds inst_binds `thenNF_Tc` \ inst_binds' ->
zonkBinds cls_binds `thenNF_Tc` \ cls_binds' ->
@@ -189,7 +191,7 @@ tcModule renamer_name_funs
-- FINISHED AT LAST
returnTc (
- (cls_binds', inst_binds', val_binds', const_insts'),
+ (record_binds', cls_binds', inst_binds', val_binds', const_insts'),
-- the next collection is just for mkInterface
(fixities, exported_ids', tycons, classes, inst_info),
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 59b9967710fed66f3730c4086deec9f8e23b08f1..2ea7586b7272a954182d0759fa19574e67c71f88 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -26,6 +26,9 @@ module TcMonad(
rn4MtoTcM,
+ TcError(..), TcWarning(..), Message(..),
+ mkTcErr, arityErr,
+
-- For closure
MutableVar(..), _MutableArray
) where
@@ -36,8 +39,6 @@ import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an in
import Type ( Type(..), GenType )
import TyVar ( TyVar(..), GenTyVar )
import Usage ( Usage(..), GenUsage )
-import ErrUtils ( Error(..), Message(..), ErrCtxt(..),
- TcWarning(..), TcError(..), mkTcErr )
import SST
import RnMonad4
@@ -46,9 +47,8 @@ import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import FiniteMap ( FiniteMap, emptyFM )
-import Pretty ( Pretty(..), PrettyRep )
-import PprStyle ( PprStyle )
import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+import ErrUtils ( Error(..) )
import Maybes ( MaybeErr(..) )
import Name ( Name )
import ProtoName ( ProtoName )
@@ -57,6 +57,8 @@ import UniqFM ( UniqFM, emptyUFM )
import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
import Unique ( Unique )
import Util
+import Pretty
+import PprStyle ( PprStyle(..) )
infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
\end{code}
@@ -226,8 +228,8 @@ Error handling
\begin{code}
failTc :: Message -> TcM s a
failTc err_msg down env
- = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- foldr thenNF_Tc_ (returnNF_Tc []) ctxt down env `thenSST` \ ctxt_msgs ->
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
let
err = mkTcErr loc ctxt_msgs err_msg
in
@@ -442,3 +444,37 @@ rn4MtoTcM name_funs rn_action down env
where
u_var = getUniqSupplyVar down
\end{code}
+
+
+TypeChecking Errors
+~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+type Message = PprStyle -> Pretty
+type TcError = Message
+type TcWarning = Message
+
+
+mkTcErr :: SrcLoc -- Where
+ -> [Message] -- Context
+ -> Message -- What went wrong
+ -> TcError -- The complete error report
+
+mkTcErr locn ctxt msg sty
+ = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
+ 4 (ppAboves [msg sty | msg <- ctxt])
+
+
+arityErr kind name n m sty
+ = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
+ n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
+ where
+ errmsg = kind ++ " has too " ++ quantity ++ " arguments"
+ quantity | m < n = "few"
+ | otherwise = "many"
+ n_arguments | n == 0 = ppStr "no arguments"
+ | n == 1 = ppStr "1 argument"
+ | True = ppCat [ppInt n, ppStr "arguments"]
+\end{code}
+
+
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 91b1677a3b13d5bf059ded12bb48f07102f7bfe3..1825cdf2df9e8e53b58b80c62cded679b5399e4b 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -24,9 +24,8 @@ import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
mkTcArrowKind, unifyKind, newKindVar,
kindToTcKind
)
-import ErrUtils ( arityErr )
import Type ( GenType, Type(..), ThetaType(..),
- mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy,
+ mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
mkSigmaTy
)
import TyVar ( GenTyVar, TyVar(..), mkTyVar )
@@ -79,26 +78,18 @@ tcMonoTypeKind (MonoFunTy ty1 ty2)
tcMonoType ty2 `thenTc` \ tau_ty2 ->
returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
-tcMonoTypeKind (MonoTyApp name tys)
- = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
-
- tc_mono_name name `thenNF_Tc` \ (fun_kind, maybe_arity, fun_ty) ->
-
- newKindVar `thenNF_Tc` \ result_kind ->
- unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
-
- -- Check for saturated application in the special case of
- -- type synoyms.
- (case maybe_arity of
- Just arity | arity /= n_args -> failTc (err arity)
- other -> returnTc ()
- ) `thenTc_`
-
- returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
- where
- err arity = arityErr "Type synonym constructor" name arity n_args
- n_args = length tys
+tcMonoTypeKind (MonoTyApp name@(Short _ _) tys)
+ = -- Must be a type variable
+ tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ tcMonoTyApp kind (mkTyVarTy tyvar) tys
+tcMonoTypeKind (MonoTyApp name tys)
+ | isTyConName name -- Must be a type constructor
+ = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
+ case maybe_arity of
+ Just arity -> tcSynApp name kind arity tycon tys -- synonum
+ Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data
+
-- for unfoldings only:
tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
= tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
@@ -116,19 +107,28 @@ tcMonoTypeKind (MonoDictTy class_name ty)
tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
unifyKind class_kind arg_kind `thenTc_`
returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
+\end{code}
+Help functions for type applications
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcMonoTyApp fun_kind fun_ty tys
+ = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ newKindVar `thenNF_Tc` \ result_kind ->
+ unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
+ returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
-tc_mono_name :: Name -> NF_TcM s (TcKind s, Maybe Arity, Type)
-tc_mono_name name@(Short _ _) -- Must be a type variable
- = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
- returnNF_Tc (kind, Nothing, mkTyVarTy tyvar)
+tcSynApp name syn_kind arity tycon tys
+ = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ newKindVar `thenNF_Tc` \ result_kind ->
+ unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
-tc_mono_name name | isTyConName name -- Must be a type constructor
- = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
- returnNF_Tc (kind, maybe_arity, mkTyConTy tycon)
-
-tc_mono_name name -- Renamer should have got it right
- = panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name))
+ -- Check that it's applied to the right number of arguments
+ checkTc (arity == n_args) (err arity) `thenTc_`
+ returnTc (result_kind, mkSynTy tycon arg_tys)
+ where
+ err arity = arityErr "Type synonym constructor" name arity n_args
+ n_args = length tys
\end{code}
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 52e9f05e9426e46e10d077368ec714dfa3fe5aa9..dfd92d11060486ff05e6879393aacddd0de049b4 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -17,28 +17,33 @@ import RnHsSyn ( RenamedPat(..) )
import TcHsSyn ( TcPat(..), TcIdOcc(..) )
import TcMonad
-import Inst ( Inst, OverloadedLit(..), InstOrigin(..), LIE(..),
- emptyLIE, plusLIE, newMethod, newOverloadedLit )
+import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
+ emptyLIE, plusLIE, plusLIEs, LIE(..),
+ newMethod, newOverloadedLit
+ )
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
- tcLookupLocalValueOK )
+ tcLookupLocalValueOK, tcGlobalOcc )
import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
-import ErrUtils ( arityErr )
import Id ( GenId, idType )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
+import Maybes ( maybeToBool )
import Name ( Name )
import PprType ( GenType, GenTyVar )
import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, charTy, stringTy, mkListTy,
mkTupleTy, addrTy, addrPrimTy )
import Pretty
-import Type ( Type(..), GenType, splitFunTy, splitSigmaTy )
+import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
+ getFunTy_maybe, maybeAppDataTyCon,
+ Type(..), GenType
+ )
import TyVar ( GenTyVar )
import Unique ( Unique, eqClassOpKey )
-
+import Util ( assertPanic, panic{-ToDo:rm-} )
\end{code}
\begin{code}
@@ -147,31 +152,73 @@ efficient?
\begin{code}
tcPat pat_in@(ConPatIn name pats)
- = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
-
- tcPats pats `thenTc` \ (pats', lie, tys) ->
+ = tcPats pats `thenTc` \ (pats', lie, tys) ->
tcAddErrCtxt (patCtxt pat_in) $
- matchConArgTys con_id tys `thenTc` \ data_ty ->
+ matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
returnTc (ConPat con_id data_ty pats',
lie,
data_ty)
tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
- = tcLookupGlobalValue op `thenNF_Tc` \ con_id ->
-
- tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
+ = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
tcAddErrCtxt (patCtxt pat_in) $
- matchConArgTys con_id [ty1,ty2] `thenTc` \ data_ty ->
+ matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
returnTc (ConOpPat pat1' con_id pat2' data_ty,
lie1 `plusLIE` lie2,
data_ty)
\end{code}
+%************************************************************************
+%* *
+\subsection{Records}
+%* *
+%************************************************************************
+
+\begin{code}
+tcPat pat_in@(RecPatIn name rpats)
+ = tcGlobalOcc name `thenNF_Tc` \ (con_id, _, con_rho) ->
+ let
+ (_, con_tau) = splitRhoTy con_rho
+ -- Ignore the con_theta; overloaded constructors only
+ -- behave differently when called, not when used for
+ -- matching.
+ (_, record_ty) = splitFunTy con_tau
+ in
+ -- Con is syntactically constrained to be a data constructor
+ ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
+
+ mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
+
+ returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats',
+ plusLIEs lies,
+ record_ty-})
+
+ where
+ do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
+ = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) ->
+
+ -- Record selectors all have type
+ -- forall a1..an. T a1 .. an -> tau
+ ASSERT( maybeToBool (getFunTy_maybe tau) )
+ let
+ -- Selector must have type RecordType -> FieldType
+ Just (record_ty, field_ty) = getFunTy_maybe tau
+ in
+ tcAddErrCtxt (recordLabel field_label) (
+ unifyTauTy expected_record_ty record_ty
+ ) `thenTc_`
+ tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
+ tcAddErrCtxt (recordRhs field_label rhs_pat) (
+ unifyTauTy field_ty rhs_ty
+ ) `thenTc_`
+ returnTc ((sel_id, rhs_pat', pun_flag), lie)
+\end{code}
+
%************************************************************************
%* *
\subsection{Non-overloaded literals}
@@ -266,24 +313,25 @@ tcPats (pat:pats)
unifies the actual args against the expected ones.
\begin{code}
-matchConArgTys :: Id -> [TcType s] -> TcM s (TcType s)
+matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
-matchConArgTys con_id arg_tys
- = tcInstType [] (idType con_id) `thenNF_Tc` \ con_ty ->
+matchConArgTys con arg_tys
+ = tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) ->
let
- no_of_args = length arg_tys
- (con_tyvars, con_theta, con_tau) = splitSigmaTy con_ty
- -- Ignore the sig_theta; overloaded constructors only
+ (con_theta, con_tau) = splitRhoTy con_rho
+ -- Ignore the con_theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
+
(con_args, con_result) = splitFunTy con_tau
con_arity = length con_args
+ no_of_args = length arg_tys
in
checkTc (con_arity == no_of_args)
(arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
unifyTauTyLists arg_tys con_args `thenTc_`
- returnTc con_result
+ returnTc (con_id, con_result)
\end{code}
@@ -293,4 +341,12 @@ Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
+
+recordLabel field_label sty
+ = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
+ 4 (ppBesides [ppStr "with its immediately enclosing constructor"])
+
+recordRhs field_label pat sty
+ = ppHang (ppStr "In the record field pattern")
+ 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat])
\end{code}
diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs
index 12b7009214fc70919266f052e436bf818a31382f..59153c52f30c43fa2b22f036e5776ace0d714f18 100644
--- a/ghc/compiler/typecheck/TcPragmas.lhs
+++ b/ghc/compiler/typecheck/TcPragmas.lhs
@@ -665,7 +665,7 @@ tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
(length new_tyvars) maybe_tys locn)
`thenB_Tc_`
- checkB_Tc (not (all isUnboxedDataType (catMaybes maybe_tys)))
+ checkB_Tc (not (all isUnboxedType (catMaybes maybe_tys)))
(badSpecialisationErr "data" "not all unboxed types"
(length new_tyvars) maybe_tys locn)
`thenB_Tc_`
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 205c881f500e3af5153936588445d4ebfdbaae77..b2afd9f4b3f97502e65b827d0eb312b30b0fe068 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -14,8 +14,9 @@ import Ubiq{-uitous-}
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
ClassDecl(..), MonoType(..), PolyType(..),
- Sig(..), MonoBinds, Fake, InPat )
+ Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr )
import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..) )
+import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
import TcMonad
import Inst ( InstanceMapper(..) )
@@ -24,7 +25,7 @@ import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
tcExtendGlobalValEnv,
tcTyVarScope, tcGetEnv )
import TcKind ( TcKind, newKindVars )
-import TcTyDecls ( tcTyDecl )
+import TcTyDecls ( tcTyDecl, tcRecordSelectors )
import Bag
import Class ( Class(..), getClassSelIds )
@@ -33,10 +34,10 @@ import Name ( Name, isTyConName )
import PprStyle
import Pretty
import UniqSet ( UniqSet(..), emptyUniqSet,
- singletonUniqSet, unionUniqSets,
+ unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon, getTyConDataCons )
+import TyCon ( TyCon, tyConDataCons )
import Unique ( Unique )
import Util ( panic, pprTrace )
@@ -49,7 +50,7 @@ data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
tcTyAndClassDecls1 :: InstanceMapper
-> Bag RenamedTyDecl -> Bag RenamedClassDecl
- -> TcM s (TcEnv s)
+ -> TcM s (TcEnv s, TcHsBinds s)
tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
= sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
@@ -65,22 +66,24 @@ tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
tcGroups inst_mapper []
= tcGetEnv `thenNF_Tc` \ env ->
- returnTc env
+ returnTc (env, EmptyBinds)
tcGroups inst_mapper (group:groups)
- = tcGroup inst_mapper group `thenTc` \ new_env ->
+ = tcGroup inst_mapper group `thenTc` \ (new_env, binds1) ->
-- Extend the environment using the new tycons and classes
tcSetEnv new_env $
-- Do the remaining groups
- tcGroups inst_mapper groups
+ tcGroups inst_mapper groups `thenTc` \ (final_env, binds2) ->
+
+ returnTc (final_env, binds1 `ThenBinds` binds2)
\end{code}
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
+tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s, TcHsBinds s)
tcGroup inst_mapper decls
= pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
@@ -94,11 +97,6 @@ tcGroup inst_mapper decls
-- extend-env things work properly. A bit UGH-ish.
tcExtendTyConEnv tycon_names_w_arities tycons $
tcExtendClassEnv class_names classes $
- tcExtendGlobalValEnv (concat (map getTyConDataCons tycons)) $
- tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
-
- -- SNAFFLE ENV TO RETURN
- tcGetEnv `thenNF_Tc` \ final_env ->
-- DEAL WITH TYPE VARIABLES
tcTyVarScope tyvar_names ( \ tyvars ->
@@ -107,11 +105,34 @@ tcGroup inst_mapper decls
foldBag combine (tcDecl inst_mapper)
(returnTc (emptyBag, emptyBag))
decls
- ) `thenTc` \ (tycons,classes) ->
+ ) `thenTc` \ (tycon_bag,class_bag) ->
+ let
+ tycons = bagToList tycon_bag
+ classes = bagToList class_bag
+ in
- returnTc (bagToList tycons, bagToList classes, final_env)
- ) `thenTc` \ (_, _, final_env) ->
- returnTc final_env
+ -- SNAFFLE ENV TO RETURN
+ tcGetEnv `thenNF_Tc` \ final_env ->
+
+ returnTc (tycons, classes, final_env)
+ ) `thenTc` \ (tycons, classes, final_env) ->
+
+
+ -- Create any necessary record selector Ids and their bindings
+ mapAndUnzipTc tcRecordSelectors tycons `thenTc` \ (sel_ids_s, binds) ->
+
+ -- Extend the global value environment with
+ -- a) constructors
+ -- b) record selectors
+ -- c) class op selectors
+
+ tcSetEnv final_env $
+ tcExtendGlobalValEnv (concat (map tyConDataCons tycons)) $
+ tcExtendGlobalValEnv (concat sel_ids_s) $
+ tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
+ tcGetEnv `thenNF_Tc` \ really_final_env ->
+
+ returnTc (really_final_env, foldr ThenBinds EmptyBinds binds)
where
(tyvar_names, tycon_names_w_arities, class_names) = get_binders decls
@@ -170,8 +191,14 @@ sortByDependency syn_decls cls_decls decls
bag_acyclic (AcyclicSCC scc) = unitBag scc
bag_acyclic (CyclicSCC sccs) = sccs
-fmt_decl (TyD (TySynonym name _ _ _)) = (ppr PprForUser name, getSrcLoc name)
-fmt_decl (ClD (ClassDecl _ name _ _ _ _ _)) = (ppr PprForUser name, getSrcLoc name)
+fmt_decl decl
+ = (ppr PprForUser name, getSrcLoc name)
+ where
+ name = get_name decl
+ get_name (TyD (TyData _ name _ _ _ _ _)) = name
+ get_name (TyD (TyNew _ name _ _ _ _ _)) = name
+ get_name (TyD (TySynonym name _ _ _)) = name
+ get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
\end{code}
Edges in Type/Class decls
@@ -230,7 +257,7 @@ get_sigs sigs
get_sig (ClassOpSig _ ty _ _) = get_pty ty
get_sig other = panic "TcTyClsDecls:get_sig"
-set_name name = singletonUniqSet (getItsUnique name)
+set_name name = unitUniqSet (getItsUnique name)
set_to_bag set = listToBag (uniqSetToList set)
\end{code}
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 9d6c08fe8df42ef502142697dea9bd39fa7eddaa..8e379856d4ec00d4253e8f13c42b1e48845f331c 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -8,29 +8,42 @@
module TcTyDecls (
tcTyDecl,
- tcConDecl
+ tcConDecl,
+ tcRecordSelectors
) where
import Ubiq{-uitous-}
-import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), MonoType )
+import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
+ Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
+ HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType,
+ Bind(..), MonoBinds(..), Sig,
+ MonoType )
import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
+import TcHsSyn ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam )
import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
-import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass )
+import TcType ( tcInstTyVars, tcInstType )
+import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
+ newLocalId
+ )
import TcMonad
import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
-import Id ( mkDataCon, StrictnessMark(..) )
+import Id ( mkDataCon, dataConSig, mkRecordSelectorId,
+ dataConFieldLabels, StrictnessMark(..)
+ )
+import FieldLabel
import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
import SpecEnv ( SpecEnv(..), nullSpecEnv )
import Name ( getNameFullName, Name(..) )
import Pretty
-import TyCon ( TyCon, ConsVisible(..), NewOrData(..), mkSynTyCon, mkDataTyCon )
-import Type ( getTypeKind )
-import TyVar ( getTyVarKind )
-import Util ( panic )
-
+import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons )
+import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon,
+ mkForAllTys, mkFunTy )
+import TyVar ( getTyVarKind, elementOfTyVarSet )
+import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
+import Util ( panic, equivClasses )
\end{code}
\begin{code}
@@ -57,11 +70,16 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
(foldr mkTcArrowKind rhs_kind tyvar_kinds)
`thenTc_`
let
- -- Construct the tycon
+ -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
+ -- because that's a TcKind and may not yet be fully unified with other kinds.
+ -- We could have augmented the tycon environment with a knot-tied kind,
+ -- but the simplest thing to do seems to be to get the Kind by (lazily)
+ -- looking at the tyvars and rhs_ty.
result_kind, final_tycon_kind :: Kind -- NB not TcKind!
result_kind = getTypeKind rhs_ty
final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
+ -- Construct the tycon
tycon = mkSynTyCon (getItsUnique tycon_name)
(getNameFullName tycon_name)
final_tycon_kind
@@ -99,6 +117,7 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra
unifyKind tycon_kind
(foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
`thenTc_`
+
-- Walk the condecls
mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
`thenTc` \ con_ids ->
@@ -114,19 +133,109 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra
ctxt
con_ids
derived_classes
- ConsVisible -- For now; if constrs are from pragma we are *abstract*
data_or_new
in
returnTc tycon
- where
- tc_derivs Nothing = returnNF_Tc []
- tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
- tc_deriv name
- = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
- returnNF_Tc clas
+tc_derivs Nothing = returnNF_Tc []
+tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
+
+tc_deriv name
+ = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
+ returnNF_Tc clas
\end{code}
+Generating selector bindings for record delarations
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+tcRecordSelectors :: TyCon -> TcM s ([Id], TcHsBinds s)
+tcRecordSelectors tycon
+ = mapAndUnzipTc (tcRecordSelector tycon) groups `thenTc` \ (ids, binds) ->
+ returnTc (ids, SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds)))
+ where
+ data_cons = tyConDataCons tycon
+ fields = [ (con, field) | con <- data_cons,
+ field <- dataConFieldLabels con
+ ]
+
+ -- groups is list of fields that share a common name
+ groups = equivClasses cmp_name fields
+ cmp_name (_, field1) (_, field2)
+ = fieldLabelName field1 `cmp` fieldLabelName field2
+\end{code}
+
+We're going to build a record selector that looks like this:
+
+ data T a b c = T1 { op :: a, ...}
+ | T2 { op :: a, ...}
+ | T3
+
+ sel :: forall a b c. T a b c -> a
+ sel = /\ a b c -> \ T1 { sel = x } -> x
+ T2 { sel = 2 } -> x
+
+Note that the selector Id itself is used as the field
+label; it has to be an Id, you see!
+
+\begin{code}
+tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
+ = panic "tcRecordSelector: don't typecheck"
+{-
+ = let
+ field_ty = fieldLabelType first_field_label
+ field_name = fieldLabelName first_field_label
+ other_tys = [fieldLabelType fl | (_, fl) <- fields]
+ (tyvars, _, _, _) = dataConSig first_con
+ -- tyvars of first_con may be free in first_ty
+ in
+
+ -- Check that all the fields in the group have the same type
+ -- This check assumes that all the constructors of a given
+ -- data type use the same type variables
+ checkTc (all (eqTy field_ty) other_tys)
+ (fieldTypeMisMatch field_name) `thenTc_`
+
+ -- Create an Id for the field itself
+ tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
+ tcInstType tenv field_ty `thenNF_Tc` \ field_ty' ->
+ let
+ data_ty' = applyTyCon tycon tyvar_tys
+ in
+ newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id ->
+ newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id ->
+
+ -- Now build the selector
+ let
+ tycon_src_loc = getSrcLoc tycon
+
+ selector_ty = mkForAllTys tyvars' $
+ mkFunTy data_ty' $
+ field_ty'
+
+ selector_id = mkRecordSelectorId first_field_label selector_ty
+
+ -- HsSyn is dreadfully verbose for defining the selector!
+ selector_rhs = mkHsTyLam tyvars' $
+ HsLam $
+ PatMatch (VarPat record_id) $
+ GRHSMatch $
+ GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc]
+ EmptyBinds field_ty'
+
+ selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc
+
+ mk_match (con_id, field_label)
+ = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
+ GRHSMatch $
+ GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id)
+ (getSrcLoc (fieldLabelName field_label))]
+ EmptyBinds
+ field_ty'
+ in
+ returnTc (selector_id, VarMonoBind selector_id selector_rhs)
+-}
+\end{code}
Constructors
~~~~~~~~~~~~
@@ -134,65 +243,88 @@ Constructors
tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
+ = tcDataCon tycon tyvars ctxt name btys src_loc
+
+tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
+ = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
+
+tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
= tcAddSrcLoc src_loc $
- let
- (stricts, tys) = sep_bangs btys
- in
- mapTc tcMonoType tys `thenTc` \ arg_tys ->
+ tcMonoType ty `thenTc` \ arg_ty ->
let
data_con = mkDataCon (getItsUnique name)
(getNameFullName name)
- stricts
+ [NotMarkedStrict]
+ [{- No labelled fields -}]
tyvars
- [] -- ToDo: ctxt; limited to tyvars in arg_tys
- arg_tys
+ ctxt
+ [arg_ty]
tycon
-- nullSpecEnv
in
returnTc data_con
-tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
+tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
= tcAddSrcLoc src_loc $
+ mapTc tcField fields `thenTc` \ field_label_infos_s ->
let
- (stricts, tys) = sep_bangs [bty1, bty2]
- in
- mapTc tcMonoType tys `thenTc` \ arg_tys ->
- let
- data_con = mkDataCon (getItsUnique op)
- (getNameFullName op)
+ field_label_infos = concat field_label_infos_s
+ stricts = [strict | (_, _, strict) <- field_label_infos]
+ arg_tys = [ty | (_, ty, _) <- field_label_infos]
+
+ field_labels = [ mkFieldLabel name ty tag
+ | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags
+ ]
+
+ data_con = mkDataCon (getItsUnique name)
+ (getNameFullName name)
stricts
+ field_labels
tyvars
- [] -- ToDo: ctxt
+ (thinContext arg_tys ctxt)
arg_tys
tycon
-- nullSpecEnv
in
returnTc data_con
-tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
+tcField (field_label_names, bty)
+ = tcMonoType (get_ty bty) `thenTc` \ field_ty ->
+ returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
+
+tcDataCon tycon tyvars ctxt name btys src_loc
= tcAddSrcLoc src_loc $
- tcMonoType ty `thenTc` \ arg_ty ->
+ let
+ stricts = map get_strictness btys
+ tys = map get_ty btys
+ in
+ mapTc tcMonoType tys `thenTc` \ arg_tys ->
let
data_con = mkDataCon (getItsUnique name)
(getNameFullName name)
- [NotMarkedStrict]
+ stricts
+ [{- No field labels -}]
tyvars
- [] -- ToDo: ctxt
- [arg_ty]
+ (thinContext arg_tys ctxt)
+ arg_tys
tycon
-- nullSpecEnv
in
returnTc data_con
-tcConDecl tycon tyvars ctxt (RecConDecl con fields src_loc)
- = panic "tcConDecls:RecConDecl"
-
-
-sep_bangs btys
- = unzip (map sep_bang btys)
- where
- sep_bang (Banged ty) = (MarkedStrict, ty)
- sep_bang (Unbanged ty) = (NotMarkedStrict, ty)
+-- The context for a data constructor should be limited to
+-- the type variables mentioned in the arg_tys
+thinContext arg_tys ctxt
+ = filter in_arg_tys ctxt
+ where
+ arg_tyvars = tyVarsOfTypes arg_tys
+ in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
+
+get_strictness (Banged ty) = MarkedStrict
+get_strictness (Unbanged ty) = NotMarkedStrict
+
+get_ty (Banged ty) = ty
+get_ty (Unbanged ty) = ty
\end{code}
@@ -208,4 +340,7 @@ tyDataCtxt tycon_name sty
tyNewCtxt tycon_name sty
= ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
+
+fieldTypeMisMatch field_name sty
+ = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
\end{code}
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 1008e0cad8bb74316efe01dd30ae0448d76ce2f0..530e41a90f7fb9fece4b663978dd594cee08b72a 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -18,12 +18,10 @@ module TcType (
tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s)
- tcInstTyVar, -- TyVar -> NF_TcM s (TcTyVar s)
+ tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s)
+ tcInstSigTyVars,
tcInstType, tcInstTcType, tcInstTheta,
--- zonkTcType, -- TcType s -> NF_TcM s (TcType s)
--- zonkTcTheta, -- TcThetaType s -> NF_TcM s (TcThetaType s)
-
zonkTcTyVars, -- TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
zonkTcType, -- TcType s -> NF_TcM s (TcType s)
zonkTcTypeToType, -- TcType s -> NF_TcM s Type
@@ -51,7 +49,12 @@ import Unique ( Unique )
import UniqFM ( UniqFM )
import Name ( getNameShortName )
import Maybes ( assocMaybe )
-import Util ( panic )
+import Util ( panic, pprPanic )
+
+import Outputable ( Outputable(..) ) -- Debugging messages
+import PprType ( GenTyVar, GenType )
+import Pretty -- ditto
+import PprStyle ( PprStyle(..) ) -- ditto
\end{code}
@@ -74,6 +77,12 @@ type Box s = MutableVar s (TcMaybe s)
data TcMaybe s = UnBound
| BoundTo (TcType s)
+ | DontBind -- This variant is used for tyvars
+ -- arising from type signatures, or
+ -- existentially quantified tyvars;
+ -- The idea is that we must not unify
+ -- such tyvars with anything except
+ -- themselves.
-- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
-- because you get a synonym loop if you do!
@@ -91,23 +100,41 @@ Type instantiation
~~~~~~~~~~~~~~~~~~
\begin{code}
-newTcTyVar :: Maybe ShortName -> Kind -> NF_TcM s (TcTyVar s)
-newTcTyVar name kind
+newTcTyVar :: Kind -> NF_TcM s (TcTyVar s)
+newTcTyVar kind
= tcGetUnique `thenNF_Tc` \ uniq ->
tcNewMutVar UnBound `thenNF_Tc` \ box ->
- returnNF_Tc (TyVar uniq kind name box)
+ returnNF_Tc (TyVar uniq kind Nothing box)
newTyVarTy :: Kind -> NF_TcM s (TcType s)
newTyVarTy kind
- = newTcTyVar Nothing kind `thenNF_Tc` \ tc_tyvar ->
+ = newTcTyVar kind `thenNF_Tc` \ tc_tyvar ->
returnNF_Tc (TyVarTy tc_tyvar)
newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
newTyVarTys n kind = mapNF_Tc newTyVarTy (take n (repeat kind))
-tcInstTyVar :: TyVar -> NF_TcM s (TcTyVar s)
-tcInstTyVar tyvar@(TyVar uniq kind name _)
- = newTcTyVar name kind
+
+
+-- For signature type variables, mark them as "DontBind"
+tcInstTyVars, tcInstSigTyVars
+ :: [GenTyVar flexi]
+ -> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)])
+tcInstTyVars tyvars = inst_tyvars UnBound tyvars
+tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars
+
+
+inst_tyvars initial_cts tyvars
+ = mapNF_Tc (inst_tyvar initial_cts) tyvars `thenNF_Tc` \ tc_tyvars ->
+ let
+ tys = map TyVarTy tc_tyvars
+ in
+ returnNF_Tc (tc_tyvars, tys, tyvars `zip` tys)
+
+inst_tyvar initial_cts (TyVar _ kind name _)
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcNewMutVar initial_cts `thenNF_Tc` \ box ->
+ returnNF_Tc (TyVar uniq kind name box)
\end{code}
@tcInstType@ and @tcInstTcType@ both create a fresh instance of a
@@ -143,13 +170,14 @@ tcInstType tenv ty_to_inst
do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (DictTy clas ty' usage)
- do env (TyVarTy (TyVar uniq kind name _))
+ do env (TyVarTy tv@(TyVar uniq kind name _))
= case assocMaybe env uniq of
Just tc_ty -> returnNF_Tc tc_ty
- Nothing -> panic "tcInstType"
+ Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug tenv,
+ ppr PprDebug ty_to_inst, ppr PprDebug tv])
- do env (ForAllTy (TyVar uniq kind name _) ty)
- = newTcTyVar name kind `thenNF_Tc` \ tc_tyvar ->
+ do env (ForAllTy tyvar@(TyVar uniq kind name _) ty)
+ = inst_tyvar DontBind tyvar `thenNF_Tc` \ tc_tyvar ->
let
new_env = (uniq, TyVarTy tc_tyvar) : env
in
@@ -166,6 +194,8 @@ tcInstTheta tenv theta
go (clas,ty) = tcInstType tenv ty `thenNF_Tc` \ tc_ty ->
returnNF_Tc (clas, tc_ty)
+--???tcSpecTy :: Type -> NF_TcM s (
+
tcInstTcType :: [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s)
tcInstTcType tenv ty_to_inst
= do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst
@@ -193,15 +223,10 @@ tcInstTcType tenv ty_to_inst
Just tc_ty -> returnNF_Tc tc_ty
Nothing -> returnNF_Tc ty
- do env (ForAllTy (TyVar uniq kind name _) ty)
- = newTcTyVar name kind `thenNF_Tc` \ tc_tyvar ->
- let
- new_env = (uniq, TyVarTy tc_tyvar) : env
- in
- do new_env ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (ForAllTy tc_tyvar ty')
+ do env (ForAllTy (TyVar uniq kind name _) ty) = panic "tcInstTcType"
-- ForAllUsage impossible
+
\end{code}
Reading and writing TcTyVars
@@ -232,20 +257,22 @@ We return Nothing iff the original box was unbound.
tcReadTyVar (TyVar uniq kind name box)
= tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- UnBound -> returnNF_Tc UnBound
BoundTo ty -> short_out ty `thenNF_Tc` \ ty' ->
tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
returnNF_Tc (BoundTo ty')
+ other -> returnNF_Tc other
+
short_out :: TcType s -> NF_TcM s (TcType s)
short_out ty@(TyVarTy (TyVar uniq kind name box))
= tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- UnBound -> returnNF_Tc ty
BoundTo ty' -> short_out ty' `thenNF_Tc` \ ty' ->
tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
returnNF_Tc ty'
+ other -> returnNF_Tc ty
+
short_out other_ty = returnNF_Tc other_ty
\end{code}
@@ -310,8 +337,8 @@ zonk tyvar_fn (DictTy c ty u)
zonk_tv tyvar_fn tyvar
= tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- UnBound -> returnNF_Tc (TyVarTy (tyvar_fn tyvar))
BoundTo ty -> zonk tyvar_fn ty
+ other -> returnNF_Tc (TyVarTy (tyvar_fn tyvar))
zonk_tv_to_tv tyvar_fn tyvar
diff --git a/ghc/compiler/typecheck/Typecheck.lhs b/ghc/compiler/typecheck/Typecheck.lhs
index d1893e3c54ce186db294f53a58a62e5222d11bb5..64b33b7918e5a5488d020524f520994975835f7d 100644
--- a/ghc/compiler/typecheck/Typecheck.lhs
+++ b/ghc/compiler/typecheck/Typecheck.lhs
@@ -19,7 +19,6 @@ import HsSyn
import RnHsSyn
import TcHsSyn
-import ErrUtils ( TcWarning(..), TcError(..) )
import Pretty
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
import Maybes ( MaybeErr(..) )
@@ -41,7 +40,8 @@ typecheckModule
-> -- OUTPUTS ...
MaybeErr
-- SUCCESS ...
- (((TypecheckedHsBinds, -- binds from class decls; does NOT
+ (((TypecheckedHsBinds, -- record selector definitions
+ TypecheckedHsBinds, -- binds from class decls; does NOT
-- include default-methods bindings
TypecheckedHsBinds, -- binds from instance decls; INCLUDES
-- class default-methods binds
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index 74c2755854bf140ec2156cb1447b7e063a1be107..c8edce0c9df5f2ad09fd63b9cdaa6bb30dad351c 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -9,20 +9,21 @@ updatable substitution).
\begin{code}
#include "HsVersions.h"
-module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) where
+module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where
import Ubiq
-- friends:
import TcMonad
-import Type ( GenType(..), getTypeKind )
-import TyCon ( TyCon(..), ConsVisible, NewOrData )
-import TyVar ( GenTyVar(..), TyVar(..) )
+import Type ( GenType(..), getTypeKind, mkFunTy, getFunTy_maybe )
+import TyCon ( TyCon, mkFunTyCon )
+import TyVar ( GenTyVar(..), TyVar(..), getTyVarKind )
import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..),
- tcReadTyVar, tcWriteTyVar
+ newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
)
-- others:
-import Kind ( Kind, isSubKindOf )
+import Kind ( Kind, isSubKindOf, mkTypeKind )
+import Usage ( duffUsage )
import PprType ( GenTyVar, GenType ) -- instances
import Pretty
import Unique ( Unique ) -- instances
@@ -44,7 +45,7 @@ Unify two @TauType@s. Dead straightforward.
\begin{code}
unifyTauTy :: TcTauType s -> TcTauType s -> TcM s ()
unifyTauTy ty1 ty2
- = tcAddErrCtxt (unifyCtxt ty1 ty2) $
+ = tcAddErrCtxtM (unifyCtxt ty1 ty2) $
uTys ty1 ty1 ty2 ty2
\end{code}
@@ -99,8 +100,21 @@ uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar tyvar2 ps_ty1 ty1
-- Applications and functions; just check the two parts
uTys _ (FunTy fun1 arg1 _) _ (FunTy fun2 arg2 _)
= uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
-uTys _ (AppTy fun1 arg1) _ (AppTy fun2 arg2)
- = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
+uTys _ (AppTy s1 t1) _ (AppTy s2 t2)
+ = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
+
+ -- Special case: converts a -> b to (->) a b
+uTys _ (AppTy s1 t1) _ (FunTy fun2 arg2 _)
+ = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
+ where
+ s2 = AppTy (TyConTy mkFunTyCon duffUsage) fun2
+ t2 = arg2
+
+uTys _ (FunTy fun1 arg1 _) _ (AppTy s2 t2)
+ = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
+ where
+ s1 = AppTy (TyConTy mkFunTyCon duffUsage) fun1
+ t1 = arg1
-- Type constructors must match
uTys ps_ty1 (TyConTy con1 _) ps_ty2 (TyConTy con2 _)
@@ -110,16 +124,62 @@ uTys ps_ty1 (TyConTy con1 _) ps_ty2 (TyConTy con2 _)
uTys ps_ty1 (SynTy con1 args1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
uTys ps_ty1 ty1 ps_ty2 (SynTy con2 args2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
- -- Special case: converts (->) a b to a -> b
-uTys ps_ty1 (AppTy (AppTy (TyConTy FunTyCon u) fun) arg) ps_ty2 ty2
- = uTys ps_ty1 (FunTy fun arg u) ps_ty2 ty2
-uTys ps_ty1 ty1 ps_ty2 (AppTy (AppTy (TyConTy FunTyCon u) fun) arg)
- = uTys ps_ty1 ty1 ps_ty2 (FunTy fun arg u)
-
-- Anything else fails
uTys ps_ty1 ty1 ps_ty2 ty2 = failTc (unifyMisMatch ps_ty1 ps_ty2)
\end{code}
+Notes on synonyms
+~~~~~~~~~~~~~~~~~
+If you are tempted to make a short cut on synonyms, as in this
+pseudocode...
+
+\begin{verbatim}
+uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
+ = if (con1 == con2) then
+ -- Good news! Same synonym constructors, so we can shortcut
+ -- by unifying their arguments and ignoring their expansions.
+ unifyTauTypeLists args1 args2
+ else
+ -- Never mind. Just expand them and try again
+ uTys ty1 ty2
+\end{verbatim}
+
+then THINK AGAIN. Here is the whole story, as detected and reported
+by Chris Okasaki \tr{<Chris_Okasaki@loch.mess.cs.cmu.edu>}:
+\begin{quotation}
+Here's a test program that should detect the problem:
+
+\begin{verbatim}
+ type Bogus a = Int
+ x = (1 :: Bogus Char) :: Bogus Bool
+\end{verbatim}
+
+The problem with [the attempted shortcut code] is that
+\begin{verbatim}
+ con1 == con2
+\end{verbatim}
+is not a sufficient condition to be able to use the shortcut!
+You also need to know that the type synonym actually USES all
+its arguments. For example, consider the following type synonym
+which does not use all its arguments.
+\begin{verbatim}
+ type Bogus a = Int
+\end{verbatim}
+
+If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool},
+the unifier would blithely try to unify \tr{Char} with \tr{Bool} and
+would fail, even though the expanded forms (both \tr{Int}) should
+match.
+
+Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would
+unnecessarily bind \tr{t} to \tr{Char}.
+
+... You could explicitly test for the problem synonyms and mark them
+somehow as needing expansion, perhaps also issuing a warning to the
+user.
+\end{quotation}
+
+
%************************************************************************
%* *
\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
@@ -145,14 +205,16 @@ uVar tv1 ps_ty2 ty2
= tcReadTyVar tv1 `thenNF_Tc` \ maybe_ty1 ->
case maybe_ty1 of
BoundTo ty1 -> uTys ty1 ty1 ps_ty2 ty2
- UnBound -> uUnboundVar tv1 ps_ty2 ty2
+ other -> uUnboundVar tv1 maybe_ty1 ps_ty2 ty2
-- Expand synonyms
-uUnboundVar tv1 ps_ty2 (SynTy _ _ ty2) = uUnboundVar tv1 ps_ty2 ty2
+uUnboundVar tv1 maybe_ty1 ps_ty2 (SynTy _ _ ty2)
+ = uUnboundVar tv1 maybe_ty1 ps_ty2 ty2
-- The both-type-variable case
uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1)
+ maybe_ty1
ps_ty2
ty2@(TyVarTy tv2@(TyVar uniq2 kind2 name2 box2))
@@ -161,24 +223,34 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1)
= returnTc ()
-- Distinct type variables
+ -- ASSERT maybe_ty1 /= BoundTo
| otherwise
= tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
- case maybe_ty2 of
- BoundTo ty2' -> uUnboundVar tv1 ty2' ty2'
- UnBound -> if kind2 `isSubKindOf` kind1 then
- tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc ()
- else if kind1 `isSubKindOf` kind2 then
- tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
- else
- failTc (unifyKindErr tv1 ps_ty2)
+ case (maybe_ty1, maybe_ty2) of
+ (_, BoundTo ty2') -> uUnboundVar tv1 maybe_ty1 ty2' ty2'
+
+ (DontBind,DontBind)
+ -> failTc (unifyDontBindErr tv1 ps_ty2)
+
+ (UnBound, _) | kind2 `isSubKindOf` kind1
+ -> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc ()
+
+ (_, UnBound) | kind1 `isSubKindOf` kind2
+ -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
+
+ other -> failTc (unifyKindErr tv1 ps_ty2)
-- Second one isn't a type variable
-uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) ps_ty2 non_var_ty2
- = occur_check non_var_ty2 `thenTc_`
- checkTc (getTypeKind non_var_ty2 `isSubKindOf` kind1)
- (unifyKindErr tv1 ps_ty2) `thenTc_`
- tcWriteTyVar tv1 non_var_ty2 `thenNF_Tc_`
- returnTc ()
+uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) maybe_ty1 ps_ty2 non_var_ty2
+ = case maybe_ty1 of
+ DontBind -> failTc (unifyDontBindErr tv1 ps_ty2)
+
+ UnBound | getTypeKind non_var_ty2 `isSubKindOf` kind1
+ -> occur_check non_var_ty2 `thenTc_`
+ tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_`
+ returnTc ()
+
+ other -> failTc (unifyKindErr tv1 ps_ty2)
where
occur_check (TyVarTy tv2@(TyVar uniq2 _ _ box2))
| uniq1 == uniq2 -- Same tyvar; fail
@@ -188,7 +260,7 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) ps_ty2 non_var_ty2
= tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
case maybe_ty2 of
BoundTo ty2' -> occur_check ty2'
- UnBound -> returnTc ()
+ other -> returnTc ()
occur_check (AppTy fun arg) = occur_check fun `thenTc_` occur_check arg
occur_check (FunTy fun arg _) = occur_check fun `thenTc_` occur_check arg
@@ -197,78 +269,79 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) ps_ty2 non_var_ty2
occur_check other = panic "Unexpected Dict or ForAll in occurCheck"
\end{code}
-Notes on synonyms
-~~~~~~~~~~~~~~~~~
-If you are tempted to make a short cut on synonyms, as in this
-pseudocode...
+%************************************************************************
+%* *
+\subsection[Unify-fun]{@unifyFunTy@}
+%* *
+%************************************************************************
-\begin{verbatim}
-uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
- = if (con1 == con2) then
- -- Good news! Same synonym constructors, so we can shortcut
- -- by unifying their arguments and ignoring their expansions.
- unifyTauTypeLists args1 args2
- else
- -- Never mind. Just expand them and try again
- uTys ty1 ty2
-\end{verbatim}
+@unifyFunTy@ is used to avoid the fruitless creation of type variables.
-then THINK AGAIN. Here is the whole story, as detected and reported
-by Chris Okasaki \tr{<Chris_Okasaki@loch.mess.cs.cmu.edu>}:
-\begin{quotation}
-Here's a test program that should detect the problem:
+\begin{code}
+unifyFunTy :: TcType s -- Fail if ty isn't a function type
+ -> TcM s (TcType s, TcType s) -- otherwise return arg and result types
-\begin{verbatim}
- type Bogus a = Int
- x = (1 :: Bogus Char) :: Bogus Bool
-\end{verbatim}
+unifyFunTy ty@(TyVarTy tyvar)
+ = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ BoundTo ty' -> unifyFunTy ty'
-The problem with [the attempted shortcut code] is that
-\begin{verbatim}
- con1 == con2
-\end{verbatim}
-is not a sufficient condition to be able to use the shortcut!
-You also need to know that the type synonym actually USES all
-its arguments. For example, consider the following type synonym
-which does not use all its arguments.
-\begin{verbatim}
- type Bogus a = Int
-\end{verbatim}
+ UnBound -> newTyVarTy mkTypeKind `thenNF_Tc` \ arg ->
+ newTyVarTy mkTypeKind `thenNF_Tc` \ res ->
+ tcWriteTyVar tyvar (mkFunTy arg res) `thenNF_Tc_`
+ returnTc (arg,res)
-If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool},
-the unifier would blithely try to unify \tr{Char} with \tr{Bool} and
-would fail, even though the expanded forms (both \tr{Int}) should
-match.
+ DontBind -> failTc (expectedFunErr ty)
-Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would
-unnecessarily bind \tr{t} to \tr{Char}.
+unifyFunTy other_ty
+ = case getFunTy_maybe other_ty of
+ Just arg_and_res -> returnTc arg_and_res
+ Nothing -> failTc (expectedFunErr other_ty)
+\end{code}
-... You could explicitly test for the problem synonyms and mark them
-somehow as needing expansion, perhaps also issuing a warning to the
-user.
-\end{quotation}
+%************************************************************************
+%* *
+\subsection[Unify-context]{Errors and contexts}
+%* *
+%************************************************************************
Errors
~~~~~~
\begin{code}
-unifyCtxt ty1 ty2 sty
- = ppAboves [
- ppCat [ppStr "Expected:", ppr sty ty1],
- ppCat [ppStr " Actual:", ppr sty ty2]
- ]
+unifyCtxt ty1 ty2
+ = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
+ zonkTcType ty2 `thenNF_Tc` \ ty2' ->
+ returnNF_Tc (err ty1' ty2')
+ where
+ err ty1' ty2' sty = ppAboves [
+ ppCat [ppStr "When matching:", ppr sty ty1'],
+ ppCat [ppStr " against:", ppr sty ty2']
+ ]
unifyMisMatch ty1 ty2 sty
= ppHang (ppStr "Couldn't match the type")
4 (ppSep [ppr sty ty1, ppStr "against", ppr sty ty2])
+expectedFunErr ty sty
+ = ppHang (ppStr "Function type expected, but found the type")
+ 4 (ppr sty ty)
+
unifyKindErr tyvar ty sty
- = ppHang (ppStr "Kind mis-match between")
- 4 (ppSep [ppr sty tyvar, ppStr "and", ppr sty ty])
+ = ppHang (ppStr "Compiler bug: kind mis-match between")
+ 4 (ppSep [ppr sty tyvar, ppLparen, ppr sty (getTyVarKind tyvar), ppRparen,
+ ppStr "and",
+ ppr sty ty, ppLparen, ppr sty (getTypeKind ty), ppRparen])
+
+unifyDontBindErr tyvar ty sty
+ = ppHang (ppStr "Couldn't match the *signature/existential* type variable")
+ 4 (ppSep [ppr sty tyvar,
+ ppStr "with the type",
+ ppr sty ty])
unifyOccurCheck tyvar ty sty
- = ppHang (ppStr "Occur check: cannot construct the infinite type")
+ = ppHang (ppStr "Cannot construct the infinite type (occur check)")
4 (ppSep [ppr sty tyvar, ppStr "=", ppr sty ty])
\end{code}
diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index 0b247e4171e326a72f16efb4709643f6573d9cc3..945c66b3b7af1748c6c8705f0e31474cc2b44ddd 100644
--- a/ghc/compiler/types/Kind.lhs
+++ b/ghc/compiler/types/Kind.lhs
@@ -19,6 +19,8 @@ module Kind (
import Ubiq{-uitous-}
import Util ( panic )
+import Outputable ( Outputable(..) )
+import Pretty
\end{code}
\begin{code}
@@ -48,3 +50,18 @@ argKind :: Kind -> Kind -- Get argument from arrow kind
argKind (ArrowKind arg_kind _) = arg_kind
argKind other_kind = panic "argKind"
\end{code}
+
+Printing
+~~~~~~~~
+\begin{code}
+instance Outputable Kind where
+ ppr sty kind = pprKind kind
+
+pprKind TypeKind = ppStr "*"
+pprKind BoxedTypeKind = ppStr "*b"
+pprKind UnboxedTypeKind = ppStr "*u"
+pprKind (ArrowKind k1 k2) = ppSep [pprKind_parend k1, ppStr "->", pprKind k2]
+
+pprKind_parend k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen]
+pprKind_parend k = pprKind k
+\end{code}
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 1c2c08925bc5bd8d227b4f38fe6893fc9ff8f55f..be52e99e5ec7b73bfe5de239d790d528ab949d4a 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -7,15 +7,17 @@
#include "HsVersions.h"
module PprType(
- GenTyVar, pprTyVar,
- TyCon, pprTyCon,
- GenType, pprType, pprParendType,
- pprType_Internal,
+ GenTyVar, pprGenTyVar,
+ TyCon, pprTyCon, showTyCon,
+ GenType,
+ pprGenType, pprParendGenType,
+ pprType, pprParendType,
+ pprMaybeTy,
getTypeString,
typeMaybeString,
specMaybeTysSuffix,
GenClass,
- GenClassOp, pprClassOp
+ GenClassOp, pprGenClassOp
) where
import Ubiq
@@ -28,7 +30,7 @@ import NameLoop -- for paranoia checking
import Type ( GenType(..), maybeAppTyCon,
splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy )
import TyVar ( GenTyVar(..) )
-import TyCon ( TyCon(..), ConsVisible, NewOrData )
+import TyCon ( TyCon(..), NewOrData )
import Class ( Class(..), GenClass(..),
ClassOp(..), GenClassOp(..) )
import Kind ( Kind(..) )
@@ -39,7 +41,7 @@ import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( maybeToBool )
import NameTypes ( ShortName, FullName )
import Outputable ( ifPprShowAll, isAvarop, interpp'SP )
-import PprStyle ( PprStyle(..), codeStyle )
+import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
import Pretty
import TysWiredIn ( listTyCon )
import Unique ( pprUnique10, pprUnique )
@@ -50,7 +52,7 @@ import Util
\begin{code}
instance (Eq tyvar, Outputable tyvar,
Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
- ppr sty ty = pprType sty ty
+ ppr sty ty = pprGenType sty ty
instance Outputable TyCon where
ppr sty tycon = pprTyCon sty tycon
@@ -60,10 +62,17 @@ instance Outputable (GenClass tyvar uvar) where
ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
instance Outputable ty => Outputable (GenClassOp ty) where
- ppr sty clsop = pprClassOp sty clsop
+ ppr sty clsop = pprGenClassOp sty clsop
instance Outputable (GenTyVar flexi) where
- ppr sty tv = pprTyVar sty tv
+ ppr sty tv = pprGenTyVar sty tv
+
+-- and two SPECIALIZEd ones:
+instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where
+ ppr sty ty = pprGenType sty ty
+
+instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where
+ ppr sty ty = pprGenTyVar sty ty
\end{code}
%************************************************************************
@@ -72,29 +81,25 @@ instance Outputable (GenTyVar flexi) where
%* *
%************************************************************************
-@pprType@ is the std @Type@ printer; the overloaded @ppr@ function is
-defined to use this. @pprParendType@ is the same, except it puts
-parens around the type, except for the atomic cases. @pprParendType@
+@pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
+defined to use this. @pprParendGenType@ is the same, except it puts
+parens around the type, except for the atomic cases. @pprParendGenType@
works just by setting the initial context precedence very high.
\begin{code}
-pprType, pprParendType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> PprStyle -> GenType tyvar uvar -> Pretty
-pprType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC ty
-pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty
+pprGenType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC ty
+pprParendGenType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty
+
+pprType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC (ty :: Type)
+pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC (ty :: Type)
pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
pprMaybeTy sty Nothing = ppChar '*'
-pprMaybeTy sty (Just ty) = pprParendType sty ty
-\end{code}
-
-This somewhat sleazy interface is used when printing out Core syntax
-(see PprCore):
-\begin{code}
-pprType_Internal sty tvs ppr_tv uvs ppr_uv ty
- = ppr_ty sty (VE tvs ppr_tv uvs ppr_uv) tOP_PREC ty
+pprMaybeTy sty (Just ty) = pprParendGenType sty ty
\end{code}
\begin{code}
@@ -270,17 +275,8 @@ tYCON_PREC = (2 :: Int)
maybeParen ctxt_prec inner_prec pretty
| ctxt_prec < inner_prec = pretty
| otherwise = ppParens pretty
-
-
--- True means types like (Eq a, Text b) => a -> b
--- False means types like _forall_ a b => Eq a -> Text b -> a -> b
-showUserishTypes PprForUser = True
-showUserishTypes PprInterface = True
-showUserishTypes other = False
\end{code}
-
-
%************************************************************************
%* *
\subsection[TyVar]{@TyVar@}
@@ -288,7 +284,7 @@ showUserishTypes other = False
%************************************************************************
\begin{code}
-pprTyVar sty (TyVar uniq kind name usage)
+pprGenTyVar sty (TyVar uniq kind name usage)
= ppBesides [pp_name, pprUnique10 uniq]
where
pp_name = case name of
@@ -318,7 +314,7 @@ pprTyCon sty FunTyCon = ppStr "(->)"
pprTyCon sty (TupleTyCon arity) = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity)
pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
-pprTyCon sty tycon@(DataTyCon uniq kind name tyvars ctxt cons derivings cv nd)
+pprTyCon sty tycon@(DataTyCon uniq kind name tyvars ctxt cons derivings nd)
= case sty of
PprDebug -> pp_tycon_and_uniq
PprShowAll -> pp_tycon_and_uniq
@@ -341,7 +337,7 @@ pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
(ppCat [ ppStr " {-",
ppInt arity,
interpp'SP sty tyvars,
- pprParendType sty expansion,
+ pprParendGenType sty expansion,
ppStr "-}"]))
\end{code}
@@ -353,9 +349,9 @@ pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
%************************************************************************
\begin{code}
-pprClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
+pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
-pprClassOp sty op = ppr_class_op sty [] op
+pprGenClassOp sty op = ppr_class_op sty [] op
ppr_class_op sty tyvars (ClassOp op_name i ty)
= case sty of
@@ -388,7 +384,7 @@ getTypeString ty
| otherwise = [mod, string]
where
string = _PK_ (tidy (ppShow 1000 ppr_t))
- ppr_t = pprType PprForC ty
+ ppr_t = pprGenType PprForC ty
-- PprForC expands type synonyms as it goes
(is_prelude_ty, mod)
@@ -446,7 +442,7 @@ pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs
ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
-pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings unabstract data_or_new) specs
+pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings data_or_new) specs
= ppHang (ppCat [pp_data_or_new,
pprContext sty ctxt,
ppr sty n,
@@ -507,7 +503,7 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings una
where
ppr_con con
= let
- (_, _, con_arg_tys, _) = getDataConSig con
+ (_, _, con_arg_tys, _) = dataConSig con
in
ppCat [pprNonOp PprForUser con, -- the data con's name...
ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
@@ -523,7 +519,7 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings una
pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
pp_maybe Nothing = pp_NONE
- pp_maybe (Just ty) = pprParendType sty ty
+ pp_maybe (Just ty) = pprParendGenType sty ty
pp_NONE = ppPStr SLIT("_N_")
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 79dae8e00d782e6b0db7ff56a4fb460fccddff0f..36b70dc831240f33000a84930a5d3c0375af7175 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -9,9 +9,10 @@
module TyCon(
TyCon(..), -- NB: some pals need to see representation
- Arity(..), ConsVisible(..), NewOrData(..),
+ Arity(..), NewOrData(..),
- isFunTyCon, isPrimTyCon, isVisibleDataTyCon,
+ isFunTyCon, isPrimTyCon, isBoxedTyCon,
+ isDataTyCon, isSynTyCon,
mkDataTyCon,
mkFunTyCon,
@@ -21,12 +22,14 @@ module TyCon(
mkSynTyCon,
- getTyConKind,
- getTyConUnique,
- getTyConTyVars,
- getTyConDataCons,
- getTyConDerivings,
- getSynTyConArity,
+ tyConKind,
+ tyConUnique,
+ tyConTyVars,
+ tyConDataCons,
+ tyConFamilySize,
+ tyConDerivings,
+ tyConArity, synTyConArity,
+ getSynTyConDefn,
maybeTyConSingleCon,
isEnumerationTyCon,
@@ -39,7 +42,7 @@ import NameLoop -- for paranoia checking
import TyLoop ( Type(..), GenType,
Class(..), GenClass,
Id(..), GenId,
- mkTupleCon, getDataConSig,
+ mkTupleCon, dataConSig,
specMaybeTysSuffix
)
@@ -71,7 +74,6 @@ data TyCon
[(Class,Type)] -- Its context
[Id] -- Its data constructors, with fully polymorphic types
[Class] -- Classes which have derived instances
- ConsVisible
NewOrData
| TupleTyCon Arity -- just a special case of DataTyCon
@@ -106,10 +108,6 @@ data TyCon
-- Acts as a template for the expansion when
-- the tycon is applied to some types.
-data ConsVisible
- = ConsVisible -- whether or not data constructors are visible
- | ConsInvisible -- outside their TyCon's defining module.
-
data NewOrData
= NewType -- "newtype Blah ..."
| DataType -- "data Blah ..."
@@ -129,8 +127,17 @@ isFunTyCon _ = False
isPrimTyCon (PrimTyCon _ _ _) = True
isPrimTyCon _ = False
-isVisibleDataTyCon (DataTyCon _ _ _ _ _ _ _ ConsVisible _) = True
-isVisibleDataTyCon _ = False
+-- At present there are no unboxed non-primitive types, so
+-- isBoxedTyCon is just the negation of isPrimTyCon.
+isBoxedTyCon = not . isPrimTyCon
+
+-- isDataTyCon returns False for @newtype@.
+-- Not sure about this decision yet.
+isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True
+isDataTyCon other = False
+
+isSynTyCon (SynTyCon _ _ _ _ _ _) = True
+isSynTyCon _ = False
\end{code}
\begin{code}
@@ -138,20 +145,20 @@ isVisibleDataTyCon _ = False
kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind
kind2 = mkBoxedTypeKind `mkArrowKind` kind1
-getTyConKind :: TyCon -> Kind
-getTyConKind FunTyCon = kind2
-getTyConKind (DataTyCon _ kind _ _ _ _ _ _ _) = kind
-getTyConKind (PrimTyCon _ _ kind) = kind
+tyConKind :: TyCon -> Kind
+tyConKind FunTyCon = kind2
+tyConKind (DataTyCon _ kind _ _ _ _ _ _) = kind
+tyConKind (PrimTyCon _ _ kind) = kind
-getTyConKind (SpecTyCon tc tys)
- = spec (getTyConKind tc) tys
+tyConKind (SpecTyCon tc tys)
+ = spec (tyConKind tc) tys
where
spec kind [] = kind
spec kind (Just _ : tys) = spec (resultKind kind) tys
spec kind (Nothing : tys) =
argKind kind `mkArrowKind` spec (resultKind kind) tys
-getTyConKind (TupleTyCon n)
+tyConKind (TupleTyCon n)
= mkArrow n
where
mkArrow 0 = mkBoxedTypeKind
@@ -161,57 +168,78 @@ getTyConKind (TupleTyCon n)
\end{code}
\begin{code}
-getTyConUnique :: TyCon -> Unique
-getTyConUnique FunTyCon = funTyConKey
-getTyConUnique (DataTyCon uniq _ _ _ _ _ _ _ _) = uniq
-getTyConUnique (TupleTyCon a) = mkTupleTyConUnique a
-getTyConUnique (PrimTyCon uniq _ _) = uniq
-getTyConUnique (SynTyCon uniq _ _ _ _ _) = uniq
-getTyConUnique (SpecTyCon _ _ ) = panic "getTyConUnique:SpecTyCon"
+tyConUnique :: TyCon -> Unique
+tyConUnique FunTyCon = funTyConKey
+tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq
+tyConUnique (TupleTyCon a) = mkTupleTyConUnique a
+tyConUnique (PrimTyCon uniq _ _) = uniq
+tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq
+tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon"
+
+tyConArity :: TyCon -> Arity
+tyConArity FunTyCon = 2
+tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs
+tyConArity (TupleTyCon arity) = arity
+tyConArity (PrimTyCon _ _ _) = 0 -- ??
+tyConArity (SpecTyCon _ _) = 0
+tyConArity (SynTyCon _ _ _ arity _ _) = arity
+
+synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon
+synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
+synTyConArity _ = Nothing
\end{code}
\begin{code}
-getTyConTyVars :: TyCon -> [TyVar]
-getTyConTyVars FunTyCon = [alphaTyVar,betaTyVar]
-getTyConTyVars (DataTyCon _ _ _ tvs _ _ _ _ _) = tvs
-getTyConTyVars (TupleTyCon arity) = take arity alphaTyVars
-getTyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs
-getTyConTyVars (PrimTyCon _ _ _) = panic "getTyConTyVars:PrimTyCon"
-getTyConTyVars (SpecTyCon _ _ ) = panic "getTyConTyVars:SpecTyCon"
+tyConTyVars :: TyCon -> [TyVar]
+tyConTyVars FunTyCon = [alphaTyVar,betaTyVar]
+tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs
+tyConTyVars (TupleTyCon arity) = take arity alphaTyVars
+tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs
+tyConTyVars (PrimTyCon _ _ _) = panic "tyConTyVars:PrimTyCon"
+tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon"
\end{code}
\begin{code}
-getTyConDataCons :: TyCon -> [Id]
-getTyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _ _) = data_cons
-getTyConDataCons (TupleTyCon a) = [mkTupleCon a]
+tyConDataCons :: TyCon -> [Id]
+tyConFamilySize :: TyCon -> Int
+
+tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons
+tyConDataCons (TupleTyCon a) = [mkTupleCon a]
+tyConDataCons other = []
+ -- You may think this last equation should fail,
+ -- but it's quite convenient to return no constructors for
+ -- a synonym; see for example the call in TcTyClsDecls.
+
+tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
+tyConFamilySize (TupleTyCon a) = 1
\end{code}
\begin{code}
-getTyConDerivings :: TyCon -> [Class]
-getTyConDerivings (DataTyCon _ _ _ _ _ _ derivs _ _) = derivs
+tyConDerivings :: TyCon -> [Class]
+tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs
+tyConDerivings other = []
\end{code}
\begin{code}
-getSynTyConArity :: TyCon -> Maybe Arity
-getSynTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
-getSynTyConArity other = Nothing
+getSynTyConDefn :: TyCon -> ([TyVar], Type)
+getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
\end{code}
\begin{code}
maybeTyConSingleCon :: TyCon -> Maybe Id
-maybeTyConSingleCon (TupleTyCon arity) = Just (mkTupleCon arity)
-maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _ _) = Just c
-maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _ _) = Nothing
-maybeTyConSingleCon (PrimTyCon _ _ _) = Nothing
-maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon"
- -- requires DataCons of TyCon
+maybeTyConSingleCon (TupleTyCon arity) = Just (mkTupleCon arity)
+maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
+maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing
+maybeTyConSingleCon (PrimTyCon _ _ _) = Nothing
+maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon"
+ -- requires DataCons of TyCon
isEnumerationTyCon (TupleTyCon arity)
= arity == 0
-isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _ _)
+isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _)
= not (null data_cons) && all is_nullary data_cons
where
- is_nullary con = case (getDataConSig con) of { (_,_, arg_tys, _) ->
+ is_nullary con = case (dataConSig con) of { (_,_, arg_tys, _) ->
null arg_tys }
\end{code}
@@ -224,8 +252,8 @@ ToDo: what about derivings for specialised tycons !!!
\begin{code}
derivedFor :: Class -> TyCon -> Bool
-derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _ _) = isIn "derivedFor" clas derivs
-derivedFor clas something_weird = False
+derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _) = isIn "derivedFor" clas derivs
+derivedFor clas something_weird = False
\end{code}
%************************************************************************
@@ -241,12 +269,12 @@ the property @(a<=b) || (b<=a)@.
\begin{code}
instance Ord3 TyCon where
- cmp FunTyCon FunTyCon = EQ_
- cmp (DataTyCon a _ _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _ _) = a `cmp` b
- cmp (SynTyCon a _ _ _ _ _) (SynTyCon b _ _ _ _ _) = a `cmp` b
- cmp (TupleTyCon a) (TupleTyCon b) = a `cmp` b
- cmp (PrimTyCon a _ _) (PrimTyCon b _ _) = a `cmp` b
- cmp (SpecTyCon tc1 mtys1) (SpecTyCon tc2 mtys2)
+ cmp FunTyCon FunTyCon = EQ_
+ cmp (DataTyCon a _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _) = a `cmp` b
+ cmp (SynTyCon a _ _ _ _ _) (SynTyCon b _ _ _ _ _) = a `cmp` b
+ cmp (TupleTyCon a) (TupleTyCon b) = a `cmp` b
+ cmp (PrimTyCon a _ _) (PrimTyCon b _ _) = a `cmp` b
+ cmp (SpecTyCon tc1 mtys1) (SpecTyCon tc2 mtys2)
= panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx }
-- now we *know* the tags are different, so...
@@ -256,11 +284,11 @@ instance Ord3 TyCon where
where
tag1 = tag_TyCon other_1
tag2 = tag_TyCon other_2
- tag_TyCon FunTyCon = ILIT(1)
- tag_TyCon (DataTyCon _ _ _ _ _ _ _ _ _) = ILIT(2)
- tag_TyCon (TupleTyCon _) = ILIT(3)
- tag_TyCon (PrimTyCon _ _ _) = ILIT(4)
- tag_TyCon (SpecTyCon _ _) = ILIT(5)
+ tag_TyCon FunTyCon = ILIT(1)
+ tag_TyCon (DataTyCon _ _ _ _ _ _ _ _) = ILIT(2)
+ tag_TyCon (TupleTyCon _) = ILIT(3)
+ tag_TyCon (PrimTyCon _ _ _) = ILIT(4)
+ tag_TyCon (SpecTyCon _ _) = ILIT(5)
instance Eq TyCon where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
@@ -305,7 +333,7 @@ instance NamedThing TyCon where
Nothing -> mkBuiltinSrcLoc
Just name -> getSrcLoc name
- getItsUnique tycon = getTyConUnique tycon
+ getItsUnique tycon = tyConUnique tycon
fromPreludeCore tc = case get_name tc of
Nothing -> True
@@ -315,10 +343,9 @@ instance NamedThing TyCon where
Emphatically un-exported:
\begin{code}
-get_name (DataTyCon _ _ n _ _ _ _ _ _) = Just n
-get_name (PrimTyCon _ n _) = Just n
-get_name (SpecTyCon tc _) = get_name tc
-get_name (SynTyCon _ n _ _ _ _) = Just n
-get_name other = Nothing
+get_name (DataTyCon _ _ n _ _ _ _ _) = Just n
+get_name (PrimTyCon _ n _) = Just n
+get_name (SpecTyCon tc _) = get_name tc
+get_name (SynTyCon _ n _ _ _ _) = Just n
+get_name other = Nothing
\end{code}
-
diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi
index ac76205d1adc2fe634bee07b7f3cc0470674d450..a97c27d1a159a0bf08326339f79117a598603ed5 100644
--- a/ghc/compiler/types/TyLoop.lhi
+++ b/ghc/compiler/types/TyLoop.lhi
@@ -8,7 +8,7 @@ import PreludeStdIO ( Maybe )
import Unique ( Unique )
import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
- getDataConSig, getInstantiatedDataConSig )
+ dataConSig, getInstantiatedDataConSig )
import PprType ( specMaybeTysSuffix )
import NameTypes ( FullName )
import TyCon ( TyCon )
@@ -30,7 +30,7 @@ type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
-- Needed in TyCon
mkTupleCon :: Int -> Id
-getDataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon)
+dataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon)
specMaybeTysSuffix :: [Maybe Type] -> _PackedString
instance Eq (GenClass a b)
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index c963c1df4ef92da2d06d3ee1e134ab3d783d8fb9..f59382ab11842804f03d4158a74fe438dba8653e 100644
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -5,6 +5,7 @@ module TyVar (
GenTyVar(..), TyVar(..),
mkTyVar,
getTyVarKind, -- TyVar -> Kind
+ cloneTyVar,
alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
@@ -15,7 +16,7 @@ module TyVar (
growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv,
GenTyVarSet(..), TyVarSet(..),
- emptyTyVarSet, singletonTyVarSet, unionTyVarSets,
+ emptyTyVarSet, unitTyVarSet, unionTyVarSets,
unionManyTyVarSets, intersectTyVarSets, mkTyVarSet,
tyVarSetToList, elementOfTyVarSet, minusTyVarSet,
isEmptyTyVarSet
@@ -67,6 +68,9 @@ mkTyVar name uniq kind = TyVar uniq
getTyVarKind :: GenTyVar flexi -> Kind
getTyVarKind (TyVar _ kind _ _) = kind
+
+cloneTyVar :: GenTyVar flexi -> Unique -> GenTyVar flexi
+cloneTyVar (TyVar _ k n x) u = TyVar u k n x
\end{code}
@@ -112,14 +116,14 @@ intersectTyVarSets:: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
unionTyVarSets :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
unionManyTyVarSets:: [GenTyVarSet flexi] -> GenTyVarSet flexi
tyVarSetToList :: GenTyVarSet flexi -> [GenTyVar flexi]
-singletonTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi
+unitTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi
elementOfTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi -> Bool
minusTyVarSet :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
isEmptyTyVarSet :: GenTyVarSet flexi -> Bool
mkTyVarSet :: [GenTyVar flexi] -> GenTyVarSet flexi
emptyTyVarSet = emptyUniqSet
-singletonTyVarSet = singletonUniqSet
+unitTyVarSet = unitUniqSet
intersectTyVarSets= intersectUniqSets
unionTyVarSets = unionUniqSets
unionManyTyVarSets= unionManyUniqSets
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index a635130c124cbd2906274365cd49f55c20dd0c74..d84a1da679727b7c8088ff42307a995a0c6343f8 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -13,7 +13,7 @@ module Type (
mkForAllUsageTy, getForAllUsageTy,
applyTy,
- isPrimType,
+ isPrimType, isUnboxedType, typePrimRep,
RhoType(..), SigmaType(..), ThetaType(..),
mkDictTy,
@@ -26,7 +26,8 @@ module Type (
matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
- instantiateTy,instantiateUsage,
+ instantiateTy, instantiateTauTy, instantiateUsage,
+ applyTypeEnvToTy,
isTauTy,
@@ -43,17 +44,18 @@ import PrelLoop -- for paranoia checking
-- friends:
import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} )
import Kind ( mkBoxedTypeKind, resultKind )
-import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon,
- getTyConKind, getTyConDataCons, TyCon )
+import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, tyConArity,
+ tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( getTyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
- singletonTyVarSet, nullTyVarEnv, lookupTyVarEnv,
+ unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
addOneToTyVarEnv, TyVarEnv(..) )
import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..),
nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
eqUsage )
-- others
+import PrimRep ( PrimRep(..) )
import Util ( thenCmp, zipEqual, panic, panic#, assertPanic,
Ord3(..){-instances-}
)
@@ -233,7 +235,9 @@ getTyCon_maybe other_ty = Nothing
\begin{code}
mkSynTy syn_tycon tys
- = SynTy syn_tycon tys (panic "Type.mkSynTy:expansion")
+ = SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body)
+ where
+ (tyvars, body) = getSynTyConDefn syn_tycon
\end{code}
Tau stuff
@@ -344,11 +348,12 @@ maybeAppDataTyCon
maybeAppDataTyCon ty
= case (getTyCon_maybe app_ty) of
- Nothing -> Nothing
- Just tycon | isFunTyCon tycon
- -> Nothing
- | otherwise
- -> Just (tycon, arg_tys, getTyConDataCons tycon)
+ Just tycon | isDataTyCon tycon &&
+ tyConArity tycon == length arg_tys
+ -- Must be saturated for ty to be a data type
+ -> Just (tycon, arg_tys, tyConDataCons tycon)
+
+ other -> Nothing
where
(app_ty, arg_tys) = splitAppTy ty
@@ -397,7 +402,7 @@ Finding the kind of a type
\begin{code}
getTypeKind :: GenType (GenTyVar any) u -> Kind
getTypeKind (TyVarTy tyvar) = getTyVarKind tyvar
-getTypeKind (TyConTy tycon usage) = getTyConKind tycon
+getTypeKind (TyConTy tycon usage) = tyConKind tycon
getTypeKind (SynTy _ _ ty) = getTypeKind ty
getTypeKind (FunTy fun arg _) = mkBoxedTypeKind
getTypeKind (DictTy clas arg _) = mkBoxedTypeKind
@@ -412,13 +417,13 @@ Free variables of a type
\begin{code}
tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
-tyVarsOfType (TyVarTy tv) = singletonTyVarSet tv
+tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet
tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys
tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty
-tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` singletonTyVarSet tyvar
+tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty
tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
@@ -453,17 +458,84 @@ instantiateTy tenv ty
go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty)
+
+-- instantiateTauTy works only (a) on types with no ForAlls,
+-- and when (b) all the type variables are being instantiated
+-- In return it is more polymorphic than instantiateTy
+
+instantiateTauTy :: Eq t => [(t, GenType t' u)] -> GenType t u -> GenType t' u
+instantiateTauTy tenv ty
+ = go ty
+ where
+ go (TyVarTy tv) = case [ty | (tv',ty) <- tenv, tv==tv'] of
+ (ty:_) -> ty
+ [] -> panic "instantiateTauTy"
+ go (TyConTy tycon usage) = TyConTy tycon usage
+ go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
+ go (FunTy arg res usage) = FunTy (go arg) (go res) usage
+ go (AppTy fun arg) = AppTy (go fun) (go arg)
+ go (DictTy clas ty usage) = DictTy clas (go ty) usage
+
instantiateUsage
:: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
instantiateUsage = error "instantiateUsage: not implemented"
\end{code}
\begin{code}
-isPrimType :: GenType tyvar uvar -> Bool
+type TypeEnv = TyVarEnv Type
+
+applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType
+applyTypeEnvToTy tenv ty
+ = mapOverTyVars v_fn ty
+ where
+ v_fn v = case (lookupTyVarEnv tenv v) of
+ Just ty -> ty
+ Nothing -> TyVarTy v
+\end{code}
+
+@mapOverTyVars@ is a local function which actually does the work. It
+does no cloning or other checks for shadowing, so be careful when
+calling this on types with Foralls in them.
+
+\begin{code}
+mapOverTyVars :: (TyVar -> Type) -> Type -> Type
+
+mapOverTyVars v_fn ty
+ = let
+ mapper = mapOverTyVars v_fn
+ in
+ case ty of
+ TyVarTy v -> v_fn v
+ SynTy c as e -> SynTy c (map mapper as) (mapper e)
+ FunTy a r u -> FunTy (mapper a) (mapper r) u
+ AppTy f a -> AppTy (mapper f) (mapper a)
+ DictTy c t u -> DictTy c (mapper t) u
+ ForAllTy v t -> ForAllTy v (mapper t)
+ tc@(TyConTy _ _) -> tc
+\end{code}
+
+At present there are no unboxed non-primitive types, so
+isUnboxedType is the same as isPrimType.
+
+\begin{code}
+isPrimType, isUnboxedType :: GenType tyvar uvar -> Bool
+
isPrimType (AppTy ty _) = isPrimType ty
isPrimType (SynTy _ _ ty) = isPrimType ty
isPrimType (TyConTy tycon _) = isPrimTyCon tycon
isPrimType _ = False
+
+isUnboxedType = isPrimType
+\end{code}
+
+This is *not* right: it is a placeholder (ToDo 96/03 WDP):
+\begin{code}
+typePrimRep :: GenType tyvar uvar -> PrimRep
+
+typePrimRep (SynTy _ _ ty) = typePrimRep ty
+typePrimRep (TyConTy tc _) = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep
+typePrimRep (AppTy ty _) = typePrimRep ty
+typePrimRep _ = PtrRep -- the "default"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/utils/BitSet.lhs b/ghc/compiler/utils/BitSet.lhs
index fcd837d2d442d1e33490c4faf93261ed8181de89..e7f1ec664b78f18e23e00051a0f4127f24c2b1fe 100644
--- a/ghc/compiler/utils/BitSet.lhs
+++ b/ghc/compiler/utils/BitSet.lhs
@@ -18,7 +18,7 @@ Integer and get virtually unlimited sets.
module BitSet (
BitSet, -- abstract type
- mkBS, listBS, emptyBS, singletonBS,
+ mkBS, listBS, emptyBS, unitBS,
unionBS, minusBS
#if ! defined(COMPILING_GHC)
, elementBS, intersectBS, isEmptyBS
@@ -45,10 +45,10 @@ emptyBS :: BitSet
emptyBS = MkBS (int2Word# 0#)
mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
+mkBS xs = foldr (unionBS . unitBS) emptyBS xs
-singletonBS :: Int -> BitSet
-singletonBS x = case x of
+unitBS :: Int -> BitSet
+unitBS x = case x of
I# i# -> MkBS ((int2Word# 1#) `shiftL#` i#)
unionBS :: BitSet -> BitSet -> BitSet
@@ -60,8 +60,8 @@ minusBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` (not# y#))
#if ! defined(COMPILING_GHC)
-- not used in GHC
isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s#) =
- case word2Int# s# of
+isEmptyBS (MkBS s#)
+ = case word2Int# s# of
0# -> True
_ -> False
@@ -95,10 +95,10 @@ emptyBS :: BitSet
emptyBS = MkBS 0
mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
+mkBS xs = foldr (unionBS . unitBS) emptyBS xs
-singletonBS :: Int -> BitSet
-singletonBS x = MkBS (1 `ashInt` x)
+unitBS :: Int -> BitSet
+unitBS x = MkBS (1 `ashInt` x)
unionBS :: BitSet -> BitSet -> BitSet
unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y)
@@ -106,8 +106,8 @@ unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y)
#if ! defined(COMPILING_GHC)
-- not used in GHC
isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) =
- case s of
+isEmptyBS (MkBS s)
+ = case s of
0 -> True
_ -> False
@@ -115,8 +115,8 @@ intersectBS :: BitSet -> BitSet -> BitSet
intersectBS (MkBS x) (MkBS y) = MkBS (x `logandInt` y)
elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) =
- case logbitpInt x s of
+elementBS x (MkBS s)
+ = case logbitpInt x s of
0 -> False
_ -> True
#endif
@@ -144,10 +144,10 @@ emptyBS :: BitSet
emptyBS = MkBS 0
mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
+mkBS xs = foldr (unionBS . unitBS) emptyBS xs
-singletonBS :: Int -> BitSet
-singletonBS x = MkBS (1 `bitLsh` x)
+unitBS :: Int -> BitSet
+unitBS x = MkBS (1 `bitLsh` x)
unionBS :: BitSet -> BitSet -> BitSet
unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y)
@@ -155,8 +155,8 @@ unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y)
#if ! defined(COMPILING_GHC)
-- not used in GHC
isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) =
- case s of
+isEmptyBS (MkBS s)
+ = case s of
0 -> True
_ -> False
@@ -164,8 +164,8 @@ intersectBS :: BitSet -> BitSet -> BitSet
intersectBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` y)
elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) =
- case (1 `bitLsh` x) `bitAnd` s of
+elementBS x (MkBS s)
+ = case (1 `bitLsh` x) `bitAnd` s of
0 -> False
_ -> True
#endif
diff --git a/ghc/compiler/utils/CharSeq.lhs b/ghc/compiler/utils/CharSeq.lhs
index daa865ae4de7b4179e1d778cbc061d2954396a1e..68948f4c6678934e89b32067237db546551aa9ed 100644
--- a/ghc/compiler/utils/CharSeq.lhs
+++ b/ghc/compiler/utils/CharSeq.lhs
@@ -65,7 +65,7 @@ cCh :: Char -> CSeq
cInt :: Int -> CSeq
#if defined(COMPILING_GHC)
-cAppendFile :: _FILE -> CSeq -> PrimIO ()
+cAppendFile :: _FILE -> CSeq -> IO ()
#endif
\end{code}
@@ -128,7 +128,7 @@ cLength seq = length (cShow seq) -- *not* the best way to do this!
#if defined(COMPILING_GHC)
cAppendFile file_star seq
- = flattenIO file_star seq
+ = flattenIO file_star seq `seqPrimIO` return ()
#endif
\end{code}
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index 0308820f63eff71dda5a121d8bbc332c3cf80cf1..87da3e0c46a74881ddfb41bcaf44fabd3e15a8c9 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -36,7 +36,7 @@ near the end (only \tr{#ifdef COMPILING_GHC}).
module FiniteMap (
FiniteMap, -- abstract type
- emptyFM, singletonFM, listToFM,
+ emptyFM, unitFM, listToFM,
addToFM, addListToFM,
IF_NOT_GHC(addToFM_C COMMA)
@@ -98,7 +98,7 @@ import Pretty
\begin{code}
-- BUILDING
emptyFM :: FiniteMap key elt
-singletonFM :: key -> elt -> FiniteMap key elt
+unitFM :: key -> elt -> FiniteMap key elt
listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt
-- In the case of duplicates, the last is taken
@@ -201,7 +201,7 @@ emptyFM
-- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)
-singletonFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM
+unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM
listToFM key_elt_pairs = addListToFM emptyFM key_elt_pairs
\end{code}
@@ -215,7 +215,7 @@ listToFM key_elt_pairs = addListToFM emptyFM key_elt_pairs
\begin{code}
addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt
-addToFM_C combiner EmptyFM key elt = singletonFM key elt
+addToFM_C combiner EmptyFM key elt = unitFM key elt
addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
#ifdef __GLASGOW_HASKELL__
= case _tagCmp new_key key of
@@ -404,7 +404,7 @@ eltsFM fm = foldFM (\ key elt rest -> elt : rest) [] fm
@mkBranch@ simply gets the size component right. This is the ONLY
(non-trivial) place the Branch object is built, so the ASSERTion
recursively checks consistency. (The trivial use of Branch is in
-@singletonFM@.)
+@unitFM@.)
\begin{code}
sIZE_RATIO :: Int
diff --git a/ghc/compiler/utils/MatchEnv.lhs b/ghc/compiler/utils/MatchEnv.lhs
index 28b8ad2e3d5066dfafdd614f0c74a8a25c581539..81271a298262931bc3c3bd2f850dff1c3f690b3e 100644
--- a/ghc/compiler/utils/MatchEnv.lhs
+++ b/ghc/compiler/utils/MatchEnv.lhs
@@ -9,7 +9,7 @@
module MatchEnv (
MatchEnv, nullMEnv, mkMEnv,
- lookupMEnv, insertMEnv,
+ isEmptyMEnv, lookupMEnv, insertMEnv,
mEnvToList
) where
@@ -36,11 +36,15 @@ match will be the most specific.
nullMEnv :: MatchEnv a b
nullMEnv = EmptyME
+isEmptyMEnv EmptyME = True
+isEmptyMEnv _ = False
+
mkMEnv :: [(key, value)] -> MatchEnv key value
+mkMEnv [] = EmptyME
mkMEnv stuff = ME stuff
mEnvToList :: MatchEnv key value -> [(key, value)]
-mEnvToList EmptyME = []
+mEnvToList EmptyME = []
mEnvToList (ME stuff) = stuff
\end{code}
diff --git a/ghc/compiler/utils/PprStyle.lhs b/ghc/compiler/utils/PprStyle.lhs
index 5c3e339b68d7a56ea209b888e14386d71d10c634..b8ee2ed8ea30eca4ccc75754e249202bff7bd8c8 100644
--- a/ghc/compiler/utils/PprStyle.lhs
+++ b/ghc/compiler/utils/PprStyle.lhs
@@ -8,7 +8,8 @@
module PprStyle (
PprStyle(..),
- codeStyle
+ codeStyle,
+ showUserishTypes
) where
CHK_Ubiq() -- debugging consistency check
@@ -47,3 +48,10 @@ codeStyle (PprForAsm _ _) = True
codeStyle _ = False
\end{code}
+\begin{code}
+-- True means types like (Eq a, Text b) => a -> b
+-- False means types like _forall_ a b => Eq a -> Text b -> a -> b
+showUserishTypes PprForUser = True
+showUserishTypes PprInterface = True
+showUserishTypes other = False
+\end{code}
diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index 5875f039cbfce1f9ddda457d7d8e108e978693b6..31bad8120608818d25b31c4c9cf24167d5cf7ba4 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -94,7 +94,7 @@ ppNest :: Int -> Pretty -> Pretty
ppShow :: Int -> Pretty -> [Char]
#if defined(COMPILING_GHC)
-ppAppendFile :: _FILE -> Int -> Pretty -> PrimIO ()
+ppAppendFile :: _FILE -> Int -> Pretty -> IO ()
#endif
\end{code}
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
index b5783eebe36e607511d21377a1bf2b7dc9bd7338..a4168519910db049dabc546e853a0d392287eb87 100644
--- a/ghc/compiler/utils/Ubiq.lhi
+++ b/ghc/compiler/utils/Ubiq.lhi
@@ -7,14 +7,20 @@ import PreludePS(_PackedString)
import Bag ( Bag )
import BinderInfo ( BinderInfo )
+import CgBindery ( CgIdInfo )
+import CharSeq ( CSeq )
+import CLabel ( CLabel )
import Class ( GenClass, GenClassOp, Class(..), ClassOp )
+import ClosureInfo ( ClosureInfo, LambdaFormInfo )
import CmdLineOpts ( SimplifierSwitch, SwitchResult )
import CoreSyn ( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr,
GenCoreCaseAlts, GenCoreCaseDefault
)
import CoreUnfold ( UnfoldingDetails, UnfoldingGuidance )
import CostCentre ( CostCentre )
+import FieldLabel ( FieldLabel )
import FiniteMap ( FiniteMap )
+import HeapOffs ( HeapOffset )
import HsCore ( UnfoldingCoreExpr )
import HsPat ( OutPat )
import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas,
@@ -35,6 +41,7 @@ import Pretty ( PrettyRep )
import PrimOp ( PrimOp )
import PrimRep ( PrimRep )
import ProtoName ( ProtoName )
+import SMRep ( SMRep )
import SrcLoc ( SrcLoc )
import TcType ( TcMaybe )
import TyCon ( TyCon, Arity(..) )
@@ -75,13 +82,18 @@ class Outputable a where
data ArityInfo
data Bag a
data BinderInfo
+data CgIdInfo
+data CLabel
data ClassOpPragmas a
data ClassPragmas a
+data ClosureInfo
data CostCentre
+data CSeq
data DataPragmas a
data DeforestInfo
data Demand
data ExportFlag
+data FieldLabel
data FiniteMap a b
data FullName -- NB: fails the optimisation criterion
data GenClass a b
@@ -97,9 +109,11 @@ data GenPragmas a
data GenTyVar a -- NB: fails the optimisation criterion
data GenType a b
data GenUsage a
+data HeapOffset
data IdInfo
data InstancePragmas a
data Kind
+data LambdaFormInfo
data Literal
data MaybeErr a b
data MatchEnv a b
@@ -113,6 +127,7 @@ data PrimRep -- NB: an enumeration
data ProtoName
data ShortName -- NB: fails the optimisation criterion
data SimplifierSwitch
+data SMRep
data SrcLoc
data StrictnessInfo
data StrictnessMark
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index b9fc0dd74aec041c9296120d60532022a0c8e728..73b325c25c9ef73f8b69fce6afd4e7bed4f42c84 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -23,8 +23,8 @@ module UniqFM (
UniqFM, -- abstract type
emptyUFM,
- singletonUFM,
- singletonDirectlyUFM,
+ unitUFM,
+ unitDirectlyUFM,
listToUFM,
listToUFM_Directly,
addToUFM,
@@ -82,8 +82,8 @@ We use @FiniteMaps@, with a (@getItsUnique@-able) @Unique@ as ``key''.
\begin{code}
emptyUFM :: UniqFM elt
isNullUFM :: UniqFM elt -> Bool
-singletonUFM :: NamedThing key => key -> elt -> UniqFM elt
-singletonDirectlyUFM -- got the Unique already
+unitUFM :: NamedThing key => key -> elt -> UniqFM elt
+unitDirectlyUFM -- got the Unique already
:: Unique -> elt -> UniqFM elt
listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt
listToUFM_Directly
@@ -149,7 +149,7 @@ type RegFinMap elt = UniqFM elt
-- I don't think HBC was too happy about this (WDP 94/10)
{-# SPECIALIZE
- singletonUFM :: Id -> elt -> IdFinMap elt,
+ unitUFM :: Id -> elt -> IdFinMap elt,
TyVar -> elt -> TyVarFinMap elt,
Name -> elt -> NameFinMap elt
IF_NCG(COMMA Reg -> elt -> RegFinMap elt)
@@ -285,8 +285,8 @@ First the ways of building a UniqFM.
\begin{code}
emptyUFM = EmptyUFM
-singletonUFM key elt = mkLeafUFM (u2i (getItsUnique key)) elt
-singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt
+unitUFM key elt = mkLeafUFM (u2i (getItsUnique key)) elt
+unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
listToUFM key_elt_pairs
= addListToUFM_C use_snd EmptyUFM key_elt_pairs
diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs
index 6882e683e2e6f701b8514aff7fe424c9994a3384..eb9511c442e0ae297b3aa4a1b8fc0a09a55e05ed 100644
--- a/ghc/compiler/utils/UniqSet.lhs
+++ b/ghc/compiler/utils/UniqSet.lhs
@@ -13,7 +13,8 @@ Basically, the things need to be in class @NamedThing@.
module UniqSet (
UniqSet(..), -- abstract type: NOT
- mkUniqSet, uniqSetToList, emptyUniqSet, singletonUniqSet,
+ mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet,
+ addOneToUniqSet,
unionUniqSets, unionManyUniqSets, minusUniqSet,
elementOfUniqSet, mapUniqSet, intersectUniqSets,
isEmptyUniqSet
@@ -55,8 +56,8 @@ type UniqSet a = UniqFM a
emptyUniqSet :: UniqSet a
emptyUniqSet = MkUniqSet emptyUFM
-singletonUniqSet :: NamedThing a => a -> UniqSet a
-singletonUniqSet x = MkUniqSet (singletonUFM x x)
+unitUniqSet :: NamedThing a => a -> UniqSet a
+unitUniqSet x = MkUniqSet (unitUFM x x)
uniqSetToList :: UniqSet a -> [a]
uniqSetToList (MkUniqSet set) = eltsUFM set
@@ -64,6 +65,9 @@ uniqSetToList (MkUniqSet set) = eltsUFM set
mkUniqSet :: NamedThing a => [a] -> UniqSet a
mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
+addOneToUniqSet :: NamedThing a => UniqSet a -> a -> UniqSet a
+addOneToUniqSet set x = set `unionUniqSets` unitUniqSet x
+
unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (plusUFM set1 set2)
@@ -114,7 +118,7 @@ mapUniqSet f (MkUniqSet set)
#if 0
#if __GLASGOW_HASKELL__
{-# SPECIALIZE
- singletonUniqSet :: GenId ty -> GenIdSet ty,
+ unitUniqSet :: GenId ty -> GenIdSet ty,
GenTyVar flexi -> GenTyVarSet flexi,
Name -> NameSet
IF_NCG(COMMA Reg -> RegSet)
diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs
index 6b27379818236e9cd0dcb203bb9a6457acc6652c..822a7a900d11b301471c945038da2b822b53f0d2 100644
--- a/ghc/compiler/utils/Unpretty.lhs
+++ b/ghc/compiler/utils/Unpretty.lhs
@@ -13,6 +13,7 @@ module Unpretty (
uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen,
uppSemi, uppComma, uppEquals,
+ uppBracket, uppParens,
uppCat, uppBeside, uppBesides, uppAbove, uppAboves,
uppNest, uppSep, uppInterleave, uppIntersperse,
uppShow,
@@ -50,6 +51,9 @@ uppChar :: Char -> Unpretty
uppInt :: Int -> Unpretty
uppInteger :: Integer -> Unpretty
+uppBracket :: Unpretty -> Unpretty -- put brackets around it
+uppParens :: Unpretty -> Unpretty -- put parens around it
+
uppBeside :: Unpretty -> Unpretty -> Unpretty
uppBesides :: [Unpretty] -> Unpretty
ppBesideSP :: Unpretty -> Unpretty -> Unpretty
@@ -65,7 +69,7 @@ uppNest :: Int -> Unpretty -> Unpretty
uppShow :: Int -> Unpretty -> [Char]
-uppAppendFile :: _FILE -> Int -> Unpretty -> PrimIO ()
+uppAppendFile :: _FILE -> Int -> Unpretty -> IO ()
\end{code}
%************************************************
@@ -96,6 +100,9 @@ uppSemi = cCh ';'
uppComma = cCh ','
uppEquals = cCh '='
+uppBracket p = uppBeside uppLbrack (uppBeside p uppRbrack)
+uppParens p = uppBeside uppLparen (uppBeside p uppRparen)
+
uppInterleave sep ps = uppSep (pi ps)
where
pi [] = []
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index e59113e38576cc635c26586c7ccff096a76270c3..68fdb493fb0e7b9e1878c7fe135b693ad2c0f073 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -77,7 +77,7 @@ module Util (
-- error handling
#if defined(COMPILING_GHC)
- , panic, panic#, pprPanic, pprPanic#, pprTrace
+ , panic, panic#, pprPanic, pprPanic#, pprError, pprTrace
# ifdef DEBUG
, assertPanic
# endif
@@ -807,6 +807,7 @@ panic x = error ("panic! (the `impossible' happened):\n\t"
++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" )
pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
+pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg))
pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
-- #-versions because panic can't return an unboxed int, and that's