From e7498a3ee1d0484d02a9e86633cc179c76ebf36e Mon Sep 17 00:00:00 2001
From: partain <unknown>
Date: Wed, 5 Jun 1996 06:51:39 +0000
Subject: [PATCH] [project @ 1996-06-05 06:44:31 by partain] SLPJ changes
through 960604
---
ghc/compiler/HsVersions.h | 27 +-
ghc/compiler/Jmakefile | 89 +++--
ghc/compiler/absCSyn/AbsCSyn.lhs | 2 +-
ghc/compiler/absCSyn/AbsCUtils.lhs | 2 +-
ghc/compiler/absCSyn/CLabel.lhs | 83 ++--
ghc/compiler/absCSyn/CStrings.lhs | 6 +
ghc/compiler/absCSyn/Costs.lhs | 2 +-
ghc/compiler/absCSyn/HeapOffs.lhs | 4 +-
ghc/compiler/absCSyn/PprAbsC.lhs | 10 +-
ghc/compiler/basicTypes/FieldLabel.lhs | 2 +-
ghc/compiler/basicTypes/Id.lhs | 40 +-
ghc/compiler/basicTypes/IdInfo.lhs | 31 +-
ghc/compiler/basicTypes/IdLoop.lhi | 4 +-
ghc/compiler/basicTypes/IdUtils.lhs | 21 +-
ghc/compiler/basicTypes/Literal.lhs | 78 +++-
ghc/compiler/basicTypes/Name.lhs | 6 +-
ghc/compiler/basicTypes/PprEnv.lhs | 2 +-
ghc/compiler/basicTypes/PragmaInfo.lhs | 2 +-
ghc/compiler/basicTypes/SrcLoc.lhs | 2 +-
ghc/compiler/basicTypes/UniqSupply.lhs | 2 +-
ghc/compiler/basicTypes/Unique.lhs | 175 +++++----
ghc/compiler/codeGen/CgBindery.lhs | 4 +-
ghc/compiler/codeGen/CgCase.lhs | 7 +-
ghc/compiler/codeGen/CgClosure.lhs | 13 +-
ghc/compiler/codeGen/CgCompInfo.lhs | 3 -
ghc/compiler/codeGen/CgCon.lhs | 21 +-
ghc/compiler/codeGen/CgConTbls.lhs | 16 +-
ghc/compiler/codeGen/CgExpr.lhs | 4 +-
ghc/compiler/codeGen/CgHeapery.lhs | 2 +-
ghc/compiler/codeGen/CgLetNoEscape.lhs | 12 +-
ghc/compiler/codeGen/CgMonad.lhs | 4 +-
ghc/compiler/codeGen/CgRetConv.lhs | 10 +-
ghc/compiler/codeGen/CgStackery.lhs | 2 +-
ghc/compiler/codeGen/CgTailCall.lhs | 2 +-
ghc/compiler/codeGen/CgUpdate.lhs | 2 +-
ghc/compiler/codeGen/CgUsages.lhs | 6 +-
ghc/compiler/codeGen/ClosureInfo.lhs | 58 ++-
ghc/compiler/codeGen/CodeGen.lhs | 2 +-
ghc/compiler/codeGen/SMRep.lhs | 2 +-
ghc/compiler/coreSyn/AnnCoreSyn.lhs | 2 +-
ghc/compiler/coreSyn/CoreLift.lhs | 2 +-
ghc/compiler/coreSyn/CoreLint.lhs | 5 +-
ghc/compiler/coreSyn/CoreSyn.lhs | 5 +-
ghc/compiler/coreSyn/CoreUnfold.lhs | 62 +--
ghc/compiler/coreSyn/CoreUtils.lhs | 49 ++-
ghc/compiler/coreSyn/FreeVars.lhs | 2 +-
ghc/compiler/coreSyn/PprCore.lhs | 2 +-
ghc/compiler/deSugar/Desugar.lhs | 2 +-
ghc/compiler/deSugar/DsBinds.lhs | 4 +-
ghc/compiler/deSugar/DsCCall.lhs | 6 +-
ghc/compiler/deSugar/DsExpr.lhs | 89 ++++-
ghc/compiler/deSugar/DsGRHSs.lhs | 4 +-
ghc/compiler/deSugar/DsHsSyn.lhs | 2 +-
ghc/compiler/deSugar/DsListComp.lhs | 6 +-
ghc/compiler/deSugar/DsMonad.lhs | 7 +-
ghc/compiler/deSugar/DsUtils.lhs | 26 +-
ghc/compiler/deSugar/Match.lhs | 18 +-
ghc/compiler/deSugar/MatchCon.lhs | 4 +-
ghc/compiler/deSugar/MatchLit.lhs | 4 +-
ghc/compiler/deforest/DefExpr.lhs | 2 +-
ghc/compiler/hsSyn/HsBinds.lhs | 4 +-
ghc/compiler/hsSyn/HsCore.lhs | 2 +-
ghc/compiler/hsSyn/HsDecls.lhs | 4 +-
ghc/compiler/hsSyn/HsExpr.lhs | 25 +-
ghc/compiler/hsSyn/HsImpExp.lhs | 23 +-
ghc/compiler/hsSyn/HsLit.lhs | 3 +-
ghc/compiler/hsSyn/HsMatches.lhs | 4 +-
ghc/compiler/hsSyn/HsPat.lhs | 69 ++--
ghc/compiler/hsSyn/HsPragmas.lhs | 2 +-
ghc/compiler/hsSyn/HsSyn.lhs | 2 +-
ghc/compiler/hsSyn/HsTypes.lhs | 2 +-
ghc/compiler/main/ErrUtils.lhs | 2 +-
ghc/compiler/main/Main.lhs | 28 +-
ghc/compiler/main/MkIface.lhs | 43 +--
ghc/compiler/nativeGen/AbsCStixGen.lhs | 6 +-
ghc/compiler/nativeGen/AsmCodeGen.lhs | 10 +-
ghc/compiler/nativeGen/AsmRegAlloc.lhs | 3 +-
ghc/compiler/nativeGen/MachCode.lhs | 2 +-
ghc/compiler/nativeGen/MachMisc.lhs | 6 +-
ghc/compiler/nativeGen/MachRegs.lhs | 19 +-
ghc/compiler/nativeGen/PprMach.lhs | 5 +-
ghc/compiler/nativeGen/RegAllocInfo.lhs | 3 +-
ghc/compiler/nativeGen/Stix.lhs | 2 +-
ghc/compiler/nativeGen/StixInfo.lhs | 2 +-
ghc/compiler/nativeGen/StixInteger.lhs | 4 +-
ghc/compiler/nativeGen/StixMacro.lhs | 4 +-
ghc/compiler/nativeGen/StixPrim.lhs | 8 +-
ghc/compiler/parser/UgenAll.lhs | 4 +-
ghc/compiler/parser/UgenUtil.lhs | 2 +-
ghc/compiler/parser/binding.ugn | 4 +-
ghc/compiler/parser/constr.ugn | 4 +-
ghc/compiler/parser/either.ugn | 4 +-
ghc/compiler/parser/entidt.ugn | 4 +-
ghc/compiler/parser/hslexer.flex | 13 +-
ghc/compiler/parser/hsparser.y | 16 +-
ghc/compiler/parser/list.ugn | 4 +-
ghc/compiler/parser/literal.ugn | 4 +-
ghc/compiler/parser/maybe.ugn | 4 +-
ghc/compiler/parser/pbinding.ugn | 4 +-
ghc/compiler/parser/qid.ugn | 4 +-
ghc/compiler/parser/tree.ugn | 4 +-
ghc/compiler/parser/ttype.ugn | 4 +-
ghc/compiler/parser/util.c | 28 +-
ghc/compiler/parser/utils.h | 1 -
ghc/compiler/prelude/PrelInfo.lhs | 52 +--
ghc/compiler/prelude/PrelMods.lhs | 3 +
ghc/compiler/prelude/PrelVals.lhs | 18 +-
ghc/compiler/prelude/PrimOp.lhs | 16 +-
ghc/compiler/prelude/PrimRep.lhs | 3 +-
ghc/compiler/prelude/TysPrim.lhs | 75 ++--
ghc/compiler/prelude/TysWiredIn.lhs | 216 ++++-------
ghc/compiler/profiling/CostCentre.lhs | 2 +-
ghc/compiler/profiling/SCCauto.lhs | 2 +-
ghc/compiler/profiling/SCCfinal.lhs | 2 +-
ghc/compiler/reader/PrefixSyn.lhs | 6 +-
ghc/compiler/reader/PrefixToHs.lhs | 2 +-
ghc/compiler/reader/RdrHsSyn.lhs | 2 +-
ghc/compiler/reader/ReadPrefix.lhs | 27 +-
ghc/compiler/rename/ParseIface.y | 3 +-
ghc/compiler/rename/ParseUtils.lhs | 40 +-
ghc/compiler/rename/Rename.lhs | 30 +-
ghc/compiler/rename/RnBinds.lhs | 4 +-
ghc/compiler/rename/RnExpr.lhs | 4 +-
ghc/compiler/rename/RnHsSyn.lhs | 4 +-
ghc/compiler/rename/RnIfaces.lhs | 101 +++--
ghc/compiler/rename/RnMonad.lhs | 49 ++-
ghc/compiler/rename/RnNames.lhs | 133 ++++---
ghc/compiler/rename/RnSource.lhs | 147 ++++---
ghc/compiler/rename/RnUtils.lhs | 29 +-
ghc/compiler/simplCore/AnalFBWW.lhs | 2 +-
ghc/compiler/simplCore/BinderInfo.lhs | 50 ++-
ghc/compiler/simplCore/ConFold.lhs | 24 +-
ghc/compiler/simplCore/FloatIn.lhs | 2 +-
ghc/compiler/simplCore/FloatOut.lhs | 2 +-
ghc/compiler/simplCore/FoldrBuildWW.lhs | 2 +-
ghc/compiler/simplCore/LiberateCase.lhs | 2 +-
ghc/compiler/simplCore/MagicUFs.lhs | 30 +-
ghc/compiler/simplCore/OccurAnal.lhs | 10 +-
ghc/compiler/simplCore/SAT.lhs | 2 +-
ghc/compiler/simplCore/SATMonad.lhs | 2 +-
ghc/compiler/simplCore/SetLevels.lhs | 2 +-
ghc/compiler/simplCore/SimplCase.lhs | 41 +-
ghc/compiler/simplCore/SimplCore.lhs | 4 +-
ghc/compiler/simplCore/SimplEnv.lhs | 189 +++++----
ghc/compiler/simplCore/SimplMonad.lhs | 6 +-
ghc/compiler/simplCore/SimplPgm.lhs | 2 +-
ghc/compiler/simplCore/SimplUtils.lhs | 3 +-
ghc/compiler/simplCore/SimplVar.lhs | 31 +-
ghc/compiler/simplCore/Simplify.lhs | 4 +-
ghc/compiler/simplCore/SmplLoop.lhi | 5 +
ghc/compiler/simplStg/LambdaLift.lhs | 2 +-
ghc/compiler/simplStg/SatStgRhs.lhs | 2 +-
ghc/compiler/simplStg/SimplStg.lhs | 2 +-
ghc/compiler/simplStg/StgSAT.lhs | 2 +-
ghc/compiler/simplStg/StgSATMonad.lhs | 2 +-
ghc/compiler/simplStg/StgStats.lhs | 2 +-
ghc/compiler/simplStg/StgVarInfo.lhs | 2 +-
ghc/compiler/simplStg/UpdAnal.lhs | 2 +-
ghc/compiler/specialise/SpecEnv.lhs | 2 +-
ghc/compiler/specialise/SpecUtils.lhs | 2 +-
ghc/compiler/specialise/Specialise.lhs | 2 +-
ghc/compiler/stgSyn/CoreToStg.lhs | 58 ++-
ghc/compiler/stgSyn/StgLint.lhs | 2 +-
ghc/compiler/stgSyn/StgSyn.lhs | 4 +-
ghc/compiler/stgSyn/StgUtils.lhs | 2 +-
ghc/compiler/stranal/SaAbsInt.lhs | 23 +-
ghc/compiler/stranal/SaLib.lhs | 2 +-
ghc/compiler/stranal/StrictAnal.lhs | 2 +-
ghc/compiler/stranal/WorkWrap.lhs | 2 +-
ghc/compiler/stranal/WwLib.lhs | 2 +-
ghc/compiler/typecheck/GenSpecEtc.lhs | 42 +-
ghc/compiler/typecheck/Inst.lhs | 186 ++++-----
ghc/compiler/typecheck/TcBinds.lhs | 16 +-
ghc/compiler/typecheck/TcClassDcl.lhs | 205 +++++++---
ghc/compiler/typecheck/TcDefaults.lhs | 2 +-
ghc/compiler/typecheck/TcDeriv.lhs | 413 ++++++++++++--------
ghc/compiler/typecheck/TcEnv.lhs | 10 +-
ghc/compiler/typecheck/TcExpr.lhs | 248 ++++++------
ghc/compiler/typecheck/TcGRHSs.lhs | 6 +-
ghc/compiler/typecheck/TcGenDeriv.lhs | 490 +++++++++++++-----------
ghc/compiler/typecheck/TcHsSyn.lhs | 64 ++--
ghc/compiler/typecheck/TcIfaceSig.lhs | 20 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 86 +++--
ghc/compiler/typecheck/TcInstUtil.lhs | 4 +-
ghc/compiler/typecheck/TcKind.lhs | 4 +-
ghc/compiler/typecheck/TcMatches.lhs | 4 +-
ghc/compiler/typecheck/TcModule.lhs | 33 +-
ghc/compiler/typecheck/TcMonad.lhs | 25 +-
ghc/compiler/typecheck/TcMonoType.lhs | 4 +-
ghc/compiler/typecheck/TcPat.lhs | 4 +-
ghc/compiler/typecheck/TcSimplify.lhs | 35 +-
ghc/compiler/typecheck/TcTyClsDecls.lhs | 6 +-
ghc/compiler/typecheck/TcTyDecls.lhs | 3 +-
ghc/compiler/typecheck/TcType.lhs | 76 +++-
ghc/compiler/typecheck/Unify.lhs | 17 +-
ghc/compiler/types/Class.lhs | 51 ++-
ghc/compiler/types/Kind.lhs | 6 +-
ghc/compiler/types/PprType.lhs | 28 +-
ghc/compiler/types/TyCon.lhs | 73 ++--
ghc/compiler/types/TyLoop.lhi | 6 +-
ghc/compiler/types/TyVar.lhs | 13 +-
ghc/compiler/types/Type.lhs | 88 +++--
ghc/compiler/types/Usage.lhs | 2 +-
ghc/compiler/utils/Bag.lhs | 5 +-
ghc/compiler/utils/CharSeq.lhs | 77 +---
ghc/compiler/utils/FiniteMap.lhs | 107 ++----
ghc/compiler/utils/ListSetOps.lhs | 4 +-
ghc/compiler/utils/Maybes.lhs | 10 +-
ghc/compiler/utils/Outputable.lhs | 2 +-
ghc/compiler/utils/Pretty.lhs | 19 +-
ghc/compiler/utils/Ubiq.lhi | 12 +
ghc/compiler/utils/UniqFM.lhs | 7 +-
ghc/compiler/utils/UniqSet.lhs | 2 +-
ghc/compiler/utils/Unpretty.lhs | 9 +-
ghc/compiler/utils/Util.lhs | 8 +-
215 files changed, 3048 insertions(+), 2446 deletions(-)
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index 6a01f6858d8a..23d67ebe503d 100644
--- a/ghc/compiler/HsVersions.h
+++ b/ghc/compiler/HsVersions.h
@@ -25,7 +25,30 @@ you will screw up the layout where they are used in case expressions!
#else
#define ASSERT(e)
#endif
-#define CHK_Ubiq() import Ubiq
+
+#if __STDC__
+#define CAT2(a,b)a##b
+#else
+#define CAT2(a,b)a/**/b
+#endif
+
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 200
+# define REALLY_HASKELL_1_3
+# define SYN_IE(a) a
+# define IMPORT_DELOOPER(mod) import CAT2(mod,_1_3)
+# define IMPORT_1_3(mod) import mod
+# define _tagCmp compare
+# define _LT LT
+# define _EQ EQ
+# define _GT GT
+# define Text Show
+#else
+# define SYN_IE(a) a(..)
+# define IMPORT_DELOOPER(mod) import mod
+# define IMPORT_1_3(mod) {--}
+#endif
+#define IMP_Ubiq() IMPORT_DELOOPER(Ubiq)
+#define CHK_Ubiq() IMPORT_DELOOPER(Ubiq)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26
#define trace _trace
@@ -76,7 +99,7 @@ you will screw up the layout where they are used in case expressions!
#endif {- ! __GLASGOW_HASKELL__ -}
-#if __GLASGOW_HASKELL__ >= 23
+#if __GLASGOW_HASKELL__ >= 23 && __GLASGOW_HASKELL__ < 200
#define USE_FAST_STRINGS 1
#define FAST_STRING _PackedString
#define SLIT(x) (_packCString (A# x#))
diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index 58072a107563..a47b639c5fc5 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -27,6 +27,12 @@ SuffixRules_flexish()
SuffixRule_c_o()
LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */
+.SUFFIXES: .lhi
+.lhi.hi:
+ $(RM) $@
+ $(GHC_UNLIT) $< $@
+ @chmod 444 $@
+
/* assume ALL source is in subdirectories one level below
they don't have Jmakefiles; this Jmakefile controls everything
*/
@@ -356,6 +362,28 @@ SIMPL_SRCS_LHS \
STG_SRCS_LHS \
BACKSRCS_LHS NATIVEGEN_SRCS_LHS
+#if GhcBuilderVersion >= 200
+# define loop_hi(f) CAT3(f,_1_3,.hi)
+#else
+# define loop_hi(f) CAT2(f,.hi)
+#endif
+
+DELOOP_HIs = \
+utils/Ubiq.hi \
+absCSyn/AbsCLoop.hi \
+basicTypes/IdLoop.hi \
+codeGen/CgLoop1.hi \
+codeGen/CgLoop2.hi \
+deSugar/DsLoop.hi \
+hsSyn/HsLoop.hi \
+nativeGen/NcgLoop.hi \
+prelude/PrelLoop.hi \
+rename/RnLoop.hi \
+simplCore/SmplLoop.hi \
+typecheck/TcMLoop.hi \
+typecheck/TcLoop.hi \
+types/TyLoop.hi
+
/*
\
*/
@@ -471,36 +499,6 @@ HaskellCompileWithExtraFlags_Recursive(module,isuf,o,-c,extra_flags)
/* OK, here we go: */
-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
-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
-rename/RnLoop.hi : rename/RnLoop.lhi
- $(GHC_UNLIT) rename/RnLoop.lhi rename/RnLoop.hi
-simplCore/SmplLoop.hi : simplCore/SmplLoop.lhi
- $(GHC_UNLIT) simplCore/SmplLoop.lhi simplCore/SmplLoop.hi
-typecheck/TcMLoop.hi : typecheck/TcMLoop.lhi
- $(GHC_UNLIT) typecheck/TcMLoop.lhi typecheck/TcMLoop.hi
-typecheck/TcLoop.hi : typecheck/TcLoop.lhi
- $(GHC_UNLIT) typecheck/TcLoop.lhi typecheck/TcLoop.hi
-types/TyLoop.hi : types/TyLoop.lhi
- $(GHC_UNLIT) types/TyLoop.lhi types/TyLoop.hi
-
rename/ParseIface.hs : rename/ParseIface.y
$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
happy -g -i rename/ParseIface.hinfo rename/ParseIface.y
@@ -620,7 +618,7 @@ compile(reader/RdrHsSyn,lhs,)
compile(rename/ParseIface,hs,)
compile(rename/ParseUtils,lhs,)
compile(rename/RnHsSyn,lhs,)
-compile(rename/RnMonad,lhs,)
+compile(rename/RnMonad,lhs,if_ghc(-fvia-C))
compile(rename/Rename,lhs,)
compile(rename/RnNames,lhs,)
compile(rename/RnSource,lhs,)
@@ -672,7 +670,7 @@ compile(deforest/Deforest,lhs,)
compile(deforest/TreelessForm,lhs,)
#endif
-compile(specialise/Specialise,lhs,)
+compile(specialise/Specialise,lhs,-H12m if_ghc(-Onot)) /* -Onot for compile-space reasons */
compile(specialise/SpecEnv,lhs,)
compile(specialise/SpecUtils,lhs,)
@@ -702,7 +700,7 @@ compile(typecheck/TcInstDcls,lhs,)
compile(typecheck/TcInstUtil,lhs,)
compile(typecheck/TcMatches,lhs,)
compile(typecheck/TcModule,lhs,)
-compile(typecheck/TcMonad,lhs,)
+compile(typecheck/TcMonad,lhs,if_ghc(-fvia-C))
compile(typecheck/TcKind,lhs,)
compile(typecheck/TcType,lhs,)
compile(typecheck/TcEnv,lhs,)
@@ -716,7 +714,7 @@ compile(typecheck/Unify,lhs,)
compile(types/Class,lhs,)
compile(types/Kind,lhs,)
-compile(types/PprType,lhs,)
+compile(types/PprType,lhs,if_ghc26(-Onot)) /* avoid a 0.26 bug */
compile(types/TyCon,lhs,)
compile(types/TyVar,lhs,)
compile(types/Usage,lhs,)
@@ -822,17 +820,17 @@ InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC))
YaccRunWithExpectMsg(parser/hsparser,12,0)
-UgenTarget(parser/constr)
-UgenTarget(parser/binding)
-UgenTarget(parser/pbinding)
-UgenTarget(parser/entidt)
-UgenTarget(parser/list)
-UgenTarget(parser/literal)
-UgenTarget(parser/maybe)
-UgenTarget(parser/either)
-UgenTarget(parser/qid)
-UgenTarget(parser/tree)
-UgenTarget(parser/ttype)
+UgenTarget(parser,constr)
+UgenTarget(parser,binding)
+UgenTarget(parser,pbinding)
+UgenTarget(parser,entidt)
+UgenTarget(parser,list)
+UgenTarget(parser,literal)
+UgenTarget(parser,maybe)
+UgenTarget(parser,either)
+UgenTarget(parser,qid)
+UgenTarget(parser,tree)
+UgenTarget(parser,ttype)
UGENS_C = parser/constr.c \
parser/binding.c \
@@ -884,6 +882,7 @@ MKDEPENDHS_OPTS= -o .hc -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
#if HaskellCompilerType != HC_USE_HC_FILES
/* otherwise, the dependencies jeopardize our .hc files --
which are all we have! */
+depend :: $(DELOOP_HIs)
HaskellDependTarget( $(DEPSRCS) )
#endif
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index e518dcd6d620..41ee1f391bf3 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -35,7 +35,7 @@ module AbsCSyn {- (
CostRes(Cost)
)-} where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index a074524793a7..af1f7af9c7cd 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -19,7 +19,7 @@ module AbsCUtils (
-- printing/forcing stuff comes from PprAbsC
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index f35342ca4b6c..c4f8ae6e6166 100644
--- a/ghc/compiler/absCSyn/CLabel.lhs
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -16,7 +16,9 @@ module CLabel (
mkConEntryLabel,
mkStaticConEntryLabel,
mkRednCountsLabel,
+ mkConInfoTableLabel,
mkPhantomInfoTableLabel,
+ mkStaticClosureLabel,
mkStaticInfoTableLabel,
mkVapEntryLabel,
mkVapInfoTableLabel,
@@ -45,12 +47,12 @@ module CLabel (
#endif
) where
-import Ubiq{-uitous-}
-import AbsCLoop ( CtrlReturnConvention(..),
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..),
ctrlReturnConvAlg
)
#if ! OMIT_NATIVE_CODEGEN
-import NcgLoop ( underscorePrefix, fmtAsmLbl )
+IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
#endif
import CStrings ( pp_cSEP )
@@ -110,26 +112,25 @@ unspecialised constructors are compared.
\begin{code}
data CLabelId = CLabelId Id
+instance Ord3 CLabelId where
+ cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
+
instance Eq CLabelId where
- CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False }
- CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True }
+ CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord CLabelId where
- CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> True; EQ_ -> True; GT__ -> False }
- CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> True; EQ_ -> False; GT__ -> False }
- CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> False; EQ_ -> True; GT__ -> True }
- CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
- of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
\begin{code}
data IdLabelInfo
= Closure -- Label for (static???) closure
+ | StaticClosure -- Static closure -- e.g., nullary constructor
| InfoTbl -- Info table for a closure; always read-only
@@ -139,14 +140,15 @@ data IdLabelInfo
-- encoded into the name)
| ConEntry -- the only kind of entry pt for constructors
- | StaticConEntry -- static constructor entry point
+ | ConInfoTbl -- corresponding info table
+ | StaticConEntry -- static constructor entry point
| StaticInfoTbl -- corresponding info table
| PhantomInfoTbl -- for phantom constructors that only exist in regs
| VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
- | VapEntry Bool
+ | VapEntry Bool
-- Ticky-ticky counting
| RednCounts -- Label of place to keep reduction-count info for this Id
@@ -195,18 +197,28 @@ data RtsLabelInfo
\end{code}
\begin{code}
-mkClosureLabel id = IdLabel (CLabelId id) Closure
-mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
-mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
+mkClosureLabel id = IdLabel (CLabelId id) Closure
+mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
+mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
mkFastEntryLabel id arity = ASSERT(arity > 0)
- IdLabel (CLabelId id) (EntryFast arity)
-mkConEntryLabel id = IdLabel (CLabelId id) ConEntry
-mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry
-mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
-mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl
-mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl
-mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
-mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
+ IdLabel (CLabelId id) (EntryFast arity)
+
+mkStaticClosureLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) StaticClosure
+mkStaticInfoTableLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) StaticInfoTbl
+mkConInfoTableLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) ConInfoTbl
+mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) PhantomInfoTbl
+mkConEntryLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) ConEntry
+mkStaticConEntryLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) StaticConEntry
+
+mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
+mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
+mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
@@ -258,11 +270,12 @@ needsCDecl other = True
Whether the labelled thing can be put in C "text space":
\begin{code}
-isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
-isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other
-isReadOnly (IdLabel _ PhantomInfoTbl) = True
-isReadOnly (IdLabel _ (VapInfoTbl _)) = True
-isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
+isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
+isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
+isReadOnly (IdLabel _ StaticInfoTbl) = True
+isReadOnly (IdLabel _ PhantomInfoTbl) = True
+isReadOnly (IdLabel _ (VapInfoTbl _)) = True
+isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
isReadOnly (TyConLabel _ _) = True
isReadOnly (CaseLabel _ _) = True
@@ -378,7 +391,9 @@ ppFlavor x = uppBeside pp_cSEP
EntryStd -> uppPStr SLIT("entry")
EntryFast arity -> --false:ASSERT (arity > 0)
uppBeside (uppPStr SLIT("fast")) (uppInt arity)
- ConEntry -> uppPStr SLIT("entry")
+ StaticClosure -> uppPStr SLIT("static_closure")
+ ConEntry -> uppPStr SLIT("con_entry")
+ ConInfoTbl -> uppPStr SLIT("con_info")
StaticConEntry -> uppPStr SLIT("static_entry")
StaticInfoTbl -> uppPStr SLIT("static_info")
PhantomInfoTbl -> uppPStr SLIT("inregs_info")
diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs
index aaf04bcfdc79..4697911f8926 100644
--- a/ghc/compiler/absCSyn/CStrings.lhs
+++ b/ghc/compiler/absCSyn/CStrings.lhs
@@ -18,6 +18,12 @@ CHK_Ubiq() -- debugging consistency check
import Pretty
import Unpretty( uppChar )
+
+IMPORT_1_3(Char (isAlphanum))
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+chr = toEnum :: Int -> Char
+#endif
\end{code}
diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs
index 8f5e4d72dbbe..bf681148820a 100644
--- a/ghc/compiler/absCSyn/Costs.lhs
+++ b/ghc/compiler/absCSyn/Costs.lhs
@@ -57,7 +57,7 @@ module Costs( costs,
addrModeCosts, CostRes(Cost), nullCosts, Side(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs
index e37b4b2e3cf7..0ce2a41725ed 100644
--- a/ghc/compiler/absCSyn/HeapOffs.lhs
+++ b/ghc/compiler/absCSyn/HeapOffs.lhs
@@ -31,9 +31,9 @@ module HeapOffs (
SpARelOffset(..), SpBRelOffset(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
#if ! OMIT_NATIVE_CODEGEN
-import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords )
+IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords )
#endif
import Maybes ( catMaybes )
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 18053a7e9176..75cbf2b16cf6 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -18,8 +18,8 @@ module PprAbsC (
#endif
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- break its dependence on ClosureInfo
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
import AbsCSyn
@@ -62,10 +62,10 @@ call to a cost evaluation function @GRAN_EXEC@. For that,
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-writeRealC :: _FILE -> AbstractC -> IO ()
+writeRealC :: Handle -> AbstractC -> IO ()
-writeRealC file absC
- = uppAppendFile file 80 (
+writeRealC handle absC
+ = uppPutStr handle 80 (
uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
)
diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs
index d8f61d33933b..53a1b5758c2b 100644
--- a/ghc/compiler/basicTypes/FieldLabel.lhs
+++ b/ghc/compiler/basicTypes/FieldLabel.lhs
@@ -8,7 +8,7 @@
module FieldLabel where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Name ( Name{-instance Eq/Outputable-} )
import Type ( Type(..) )
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index d302df49ae46..570402726065 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -36,7 +36,7 @@ module Id {- (
getMentionedTyConsAndClassesFromId,
dataConTag, dataConStrictMarks,
- dataConSig, dataConArgTys,
+ dataConSig, dataConRawArgTys, dataConArgTys,
dataConTyCon, dataConArity,
dataConFieldLabels,
@@ -44,6 +44,7 @@ module Id {- (
-- PREDICATES
isDataCon, isTupleCon,
+ isNullaryDataCon,
isSpecId_maybe, isSpecPragmaId_maybe,
toplevelishId, externallyVisibleId,
isTopLevId, isWorkerId, isWrapperId,
@@ -94,9 +95,9 @@ module Id {- (
GenIdSet(..), IdSet(..)
)-} where
-import Ubiq
-import IdLoop -- for paranoia checking
-import TyLoop -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
import Bag
import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
@@ -1043,17 +1044,17 @@ mkSuperDictSelId u c sc ty info
n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname
-mkMethodSelId u c op ty info
- = Id u n ty (MethodSelId c op) NoPragmaInfo info
+mkMethodSelId u rec_c op ty info
+ = Id u n ty (MethodSelId rec_c op) NoPragmaInfo info
where
- cname = getName c -- we get other info out of here
+ cname = getName rec_c -- we get other info out of here
n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname
-mkDefaultMethodId u c op gen ty info
- = Id u n ty (DefaultMethodId c op gen) NoPragmaInfo info
+mkDefaultMethodId u rec_c op gen ty info
+ = Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info
where
- cname = getName c -- we get other info out of here
+ cname = getName rec_c -- we get other info out of here
n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname
@@ -1227,6 +1228,8 @@ dataConArity id@(Id _ _ _ _ _ id_info)
Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
Just i -> i
+isNullaryDataCon con = dataConArity con == 0 -- function of convenience
+
addIdArity :: Id -> Int -> Id
addIdArity (Id u n ty details pinfo info) arity
= Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
@@ -1405,6 +1408,9 @@ dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
= nOfThem arity NotMarkedStrict
+dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
+dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
+
dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
-> [Type] -- Needs arguments of these types
@@ -1583,15 +1589,15 @@ instance Ord3 (GenId ty) where
cmp = cmpId
instance Eq (GenId ty) where
- a == b = case cmpId a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord (GenId ty) where
- a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
@cmpId_withSpecDataCon@ ensures that any spectys are taken into
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 4d2a2a138c90..6946df3883c0 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -67,9 +67,9 @@ module IdInfo (
) where
-import Ubiq
+IMP_Ubiq()
-import IdLoop -- IdInfo is a dependency-loop ranch, and
+IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
-- we break those loops by using IdLoop and
-- *not* importing much of anything else,
-- except from the very general "utils".
@@ -77,6 +77,7 @@ import IdLoop -- IdInfo is a dependency-loop ranch, and
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList )
+import OccurAnal ( occurAnalyseGlobalExpr )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
@@ -84,10 +85,13 @@ import SrcLoc ( mkUnknownSrcLoc )
import Type ( eqSimpleTy, splitFunTyExpandingDicts )
import Util ( mapAccumL, panic, assertPanic, pprPanic )
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
+
applySubstToTy = panic "IdInfo.applySubstToTy"
showTypeCategory = panic "IdInfo.showTypeCategory"
mkFormSummary = panic "IdInfo.mkFormSummary"
-occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
isWrapperFor = panic "IdInfo.isWrapperFor"
pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
\end{code}
@@ -607,7 +611,11 @@ as the worker requires. Hence we have to give up altogether, and call
the wrapper only; so under these circumstances we return \tr{False}.
\begin{code}
+#ifdef REALLY_HASKELL_1_3
+instance Read Demand where
+#else
instance Text Demand where
+#endif
readList str = read_em [{-acc-}] str
where
read_em acc [] = [(reverse acc, "")]
@@ -626,6 +634,9 @@ instance Text Demand where
read_em acc other = panic ("IdInfo.readem:"++other)
+#ifdef REALLY_HASKELL_1_3
+instance Show Demand where
+#endif
showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
where
show1 (WwLazy False) = "L"
@@ -725,7 +736,7 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
\begin{code}
mkUnfolding guide expr
- = GenForm False (mkFormSummary NoStrictnessInfo expr)
+ = GenForm (mkFormSummary NoStrictnessInfo expr)
(occurAnalyseGlobalExpr expr)
guide
\end{code}
@@ -735,8 +746,8 @@ noInfo_UF = NoUnfoldingDetails
getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
= case unfolding of
- GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails
- unfolding_as_was -> unfolding_as_was
+ GenForm _ _ BadUnfolding -> NoUnfoldingDetails
+ unfolding_as_was -> unfolding_as_was
-- getInfo_UF ensures that any BadUnfoldings are never returned
-- We had to delay the test required in TcPragmas until now due
@@ -757,9 +768,9 @@ pp_unfolding sty for_this_id inline_env uf_details
pp (MagicForm tag _)
= ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
- pp (GenForm _ _ _ BadUnfolding) = pp_NONE
+ pp (GenForm _ _ BadUnfolding) = pp_NONE
- pp (GenForm _ _ template guide)
+ pp (GenForm _ template guide)
= let
untagged = unTagBinders template
in
@@ -798,7 +809,11 @@ updateInfoMaybe (SomeUpdateInfo u) = Just u
Text instance so that the update annotations can be read in.
\begin{code}
+#ifdef REALLY_HASKELL_1_3
+instance Read UpdateInfo where
+#else
instance Text UpdateInfo where
+#endif
readsPrec p s | null s = panic "IdInfo: empty update pragma?!"
| otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
where
diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi
index abd59f35667a..deeae88b42a0 100644
--- a/ghc/compiler/basicTypes/IdLoop.lhi
+++ b/ghc/compiler/basicTypes/IdLoop.lhi
@@ -65,11 +65,9 @@ data MagicUnfoldingFun
data FormSummary = WhnfForm | BottomForm | OtherForm
data UnfoldingDetails
= NoUnfoldingDetails
- | LitForm Literal
| OtherLitForm [Literal]
- | ConForm (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique]
| OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
- | GenForm Bool FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
+ | GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
| MagicForm _PackedString MagicUnfoldingFun
data UnfoldingGuidance
diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs
index 043b37dea4b8..afdc973f4848 100644
--- a/ghc/compiler/basicTypes/IdUtils.lhs
+++ b/ghc/compiler/basicTypes/IdUtils.lhs
@@ -8,19 +8,19 @@
module IdUtils ( primOpNameInfo, primOpId ) where
-import Ubiq
-import PrelLoop -- here for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking
import CoreSyn
import CoreUnfold ( UnfoldingGuidance(..) )
-import Id ( mkPreludeId )
+import Id ( mkPreludeId, mkTemplateLocals )
import IdInfo -- quite a few things
import Name ( mkBuiltinName )
import PrelMods ( pRELUDE_BUILTIN )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
PrimOpInfo(..), PrimOpResultInfo(..) )
import RnHsSyn ( RnName(..) )
-import Type ( mkForAllTys, mkFunTys, applyTyCon )
+import Type ( mkForAllTys, mkFunTys, mkTyVarTy, applyTyCon )
import TysWiredIn ( boolTy )
import Unique ( mkPrimOpIdUnique )
import Util ( panic )
@@ -81,15 +81,12 @@ The functions to make common unfoldings are tedious.
\begin{code}
mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
-mk_prim_unfold prim_op tvs arg_tys
- = panic "IdUtils.mk_prim_unfold"
-{-
+mk_prim_unfold prim_op tyvars arg_tys
= let
- (inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map uniqueOf tvs)
- inst_arg_tys = map (instantiateTauTy inst_env) arg_tys
- vars = mkTemplateLocals inst_arg_tys
+ vars = mkTemplateLocals arg_tys
in
- mkLam tyvars vars (Prim prim_op tyvar_tys [VarArg v | v <- vars])
--}
+ mkLam tyvars vars $
+ Prim prim_op
+ ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])
\end{code}
diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs
index 8fb477ee0bc5..1330a3d328f6 100644
--- a/ghc/compiler/basicTypes/Literal.lhs
+++ b/ghc/compiler/basicTypes/Literal.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
@@ -13,11 +13,9 @@ module Literal (
literalType, literalPrimRep,
showLiteral,
isNoRepLit, isLitLitLit
-
- -- and to make the interface self-sufficient....
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- friends:
import PrimRep ( PrimRep(..) ) -- non-abstract
@@ -27,10 +25,10 @@ import TysPrim ( getPrimRepInfo,
-- others:
import CStrings ( stringToC, charToC, charToEasyHaskell )
-import TysWiredIn ( integerTy, rationalTy, stringTy )
+import TysWiredIn ( stringTy )
import Pretty -- pretty-printing stuff
import PprStyle ( PprStyle(..), codeStyle )
-import Util ( panic )
+import Util ( thenCmp, panic )
\end{code}
So-called @Literals@ are {\em either}:
@@ -58,10 +56,10 @@ data Literal
PrimRep
| NoRepStr FAST_STRING -- the uncommitted ones
- | NoRepInteger Integer
- | NoRepRational Rational
+ | NoRepInteger Integer Type{-save what we learned in the typechecker-}
+ | NoRepRational Rational Type{-ditto-}
- deriving (Eq, Ord)
+ -- deriving (Eq, Ord): no, don't want to compare Types
-- The Ord is needed for the FiniteMap used in the lookForConstructor
-- in SimplEnv. If you declared that lookForConstructor *ignores*
-- constructor-applications with LitArg args, then you could get
@@ -71,12 +69,56 @@ mkMachInt, mkMachWord :: Integer -> Literal
mkMachInt x = MachInt x True{-signed-}
mkMachWord x = MachInt x False{-unsigned-}
+
+instance Ord3 Literal where
+ cmp (MachChar a) (MachChar b) = a `tcmp` b
+ cmp (MachStr a) (MachStr b) = a `tcmp` b
+ cmp (MachAddr a) (MachAddr b) = a `tcmp` b
+ cmp (MachInt a b) (MachInt c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
+ cmp (MachFloat a) (MachFloat b) = a `tcmp` b
+ cmp (MachDouble a) (MachDouble b) = a `tcmp` b
+ cmp (MachLitLit a b) (MachLitLit c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
+ cmp (NoRepStr a) (NoRepStr b) = a `tcmp` b
+ cmp (NoRepInteger a _) (NoRepInteger b _) = a `tcmp` b
+ cmp (NoRepRational a _) (NoRepRational b _) = a `tcmp` b
+
+ -- now we *know* the tags are different, so...
+ cmp other_1 other_2
+ | tag1 _LT_ tag2 = LT_
+ | otherwise = GT_
+ where
+ tag1 = tagof other_1
+ tag2 = tagof other_2
+
+ tagof (MachChar _) = ILIT(1)
+ tagof (MachStr _) = ILIT(2)
+ tagof (MachAddr _) = ILIT(3)
+ tagof (MachInt _ _) = ILIT(4)
+ tagof (MachFloat _) = ILIT(5)
+ tagof (MachDouble _) = ILIT(6)
+ tagof (MachLitLit _ _) = ILIT(7)
+ tagof (NoRepStr _) = ILIT(8)
+ tagof (NoRepInteger _ _) = ILIT(9)
+ tagof (NoRepRational _ _) = ILIT(10)
+
+tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
+
+instance Eq Literal where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord Literal where
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
\begin{code}
isNoRepLit (NoRepStr _) = True -- these are not primitive typed!
-isNoRepLit (NoRepInteger _) = True
-isNoRepLit (NoRepRational _) = True
+isNoRepLit (NoRepInteger _ _) = True
+isNoRepLit (NoRepRational _ _) = True
isNoRepLit _ = False
isLitLitLit (MachLitLit _ _) = True
@@ -93,8 +135,8 @@ literalType (MachInt _ signed) = if signed then intPrimTy else wordPrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLitLit _ k) = case (getPrimRepInfo k) of { (_,t,_) -> t }
-literalType (NoRepInteger _) = integerTy
-literalType (NoRepRational _)= rationalTy
+literalType (NoRepInteger _ t) = t
+literalType (NoRepRational _ t) = t
literalType (NoRepStr _) = stringTy
\end{code}
@@ -109,9 +151,9 @@ literalPrimRep (MachFloat _) = FloatRep
literalPrimRep (MachDouble _) = DoubleRep
literalPrimRep (MachLitLit _ k) = k
#ifdef DEBUG
-literalPrimRep (NoRepInteger _) = panic "literalPrimRep:NoRepInteger"
-literalPrimRep (NoRepRational _)= panic "literalPrimRep:NoRepRational"
-literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
+literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger"
+literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
+literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
#endif
\end{code}
@@ -160,12 +202,12 @@ instance Outputable Literal where
ppr sty (MachFloat f) = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty]
ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty]
- ppr sty (NoRepInteger i)
+ ppr sty (NoRepInteger i _)
| codeStyle sty = ppInteger i
| ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i]
| otherwise = ppBesides [ppInteger i, ppChar 'I']
- ppr sty (NoRepRational r)
+ ppr sty (NoRepRational r _)
| ufStyle sty = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)]
| codeStyle sty = panic "ppr.ForC.NoRepRational"
| otherwise = ppBesides [ppRational r, ppChar 'R']
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 905c4bcbe165..b6b07af74b78 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -52,7 +52,7 @@ module Name (
isLexConId, isLexConSym, isLexVarId, isLexVarSym
) where
-import Ubiq
+IMP_Ubiq()
import CStrings ( identToC, cSEP )
import Outputable ( Outputable(..) )
@@ -64,6 +64,10 @@ import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
pprUnique, Unique
)
import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
\end{code}
%************************************************************************
diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs
index d29b8755b30d..07dd8ec37234 100644
--- a/ghc/compiler/basicTypes/PprEnv.lhs
+++ b/ghc/compiler/basicTypes/PprEnv.lhs
@@ -23,7 +23,7 @@ module PprEnv (
-- lookupValVar, lookupTyVar, lookupUVar
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty ( Pretty(..) )
import Unique ( initRenumberingUniques )
diff --git a/ghc/compiler/basicTypes/PragmaInfo.lhs b/ghc/compiler/basicTypes/PragmaInfo.lhs
index fb02b0adb263..b1bf499774ea 100644
--- a/ghc/compiler/basicTypes/PragmaInfo.lhs
+++ b/ghc/compiler/basicTypes/PragmaInfo.lhs
@@ -8,7 +8,7 @@
module PragmaInfo where
-import Ubiq
+IMP_Ubiq()
\end{code}
\begin{code}
diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs
index 650de416a40f..03fb6c236431 100644
--- a/ghc/compiler/basicTypes/SrcLoc.lhs
+++ b/ghc/compiler/basicTypes/SrcLoc.lhs
@@ -22,7 +22,7 @@ module SrcLoc (
unpackSrcLoc
) where
-import Ubiq
+IMP_Ubiq()
import PprStyle ( PprStyle(..) )
import Pretty
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
index bc6da1645fd6..1f451550204d 100644
--- a/ghc/compiler/basicTypes/UniqSupply.lhs
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -21,7 +21,7 @@ module UniqSupply (
splitUniqSupply
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Unique
import Util
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 7e7b7193bdf9..34172e678d5f 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -46,6 +46,7 @@ module Unique (
addrDataConKey,
addrPrimTyConKey,
addrTyConKey,
+ andandIdKey,
appendIdKey,
arrayPrimTyConKey,
augmentIdKey,
@@ -56,12 +57,11 @@ module Unique (
byteArrayPrimTyConKey,
cCallableClassKey,
cReturnableClassKey,
- voidTyConKey,
charDataConKey,
charPrimTyConKey,
charTyConKey,
+ composeIdKey,
consDataConKey,
- evalClassKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
@@ -74,6 +74,7 @@ module Unique (
eqClassOpKey,
eqDataConKey,
errorIdKey,
+ evalClassKey,
falseDataConKey,
floatDataConKey,
floatPrimTyConKey,
@@ -81,12 +82,16 @@ module Unique (
floatingClassKey,
foldlIdKey,
foldrIdKey,
+ foreignObjDataConKey,
+ foreignObjPrimTyConKey,
+ foreignObjTyConKey,
forkIdKey,
fractionalClassKey,
fromIntClassOpKey,
fromIntegerClassOpKey,
fromRationalClassOpKey,
funTyConKey,
+ functorClassKey,
geClassOpKey,
gtDataConKey,
iOTyConKey,
@@ -100,23 +105,25 @@ module Unique (
integerTyConKey,
integerZeroIdKey,
integralClassKey,
+ irrefutPatErrorIdKey,
ixClassKey,
+ lexIdKey,
liftDataConKey,
liftTyConKey,
listTyConKey,
ltDataConKey,
mainIdKey,
mainPrimIOIdKey,
- foreignObjDataConKey,
- foreignObjPrimTyConKey,
- foreignObjTyConKey,
monadClassKey,
- monadZeroClassKey,
monadPlusClassKey,
- functorClassKey,
+ monadZeroClassKey,
mutableArrayPrimTyConKey,
mutableByteArrayPrimTyConKey,
nilDataConKey,
+ noDefaultMethodErrorIdKey,
+ nonExhaustiveGuardsErrorIdKey,
+ nonExplicitMethodErrorIdKey,
+ notIdKey,
numClassKey,
ordClassKey,
orderingTyConKey,
@@ -124,22 +131,20 @@ module Unique (
parErrorIdKey,
parIdKey,
patErrorIdKey,
- recConErrorIdKey,
- recUpdErrorIdKey,
- irrefutPatErrorIdKey,
- nonExhaustiveGuardsErrorIdKey,
- noDefaultMethodErrorIdKey,
- nonExplicitMethodErrorIdKey,
primIoTyConKey,
+ primIoDataConKey,
ratioDataConKey,
ratioTyConKey,
rationalTyConKey,
readClassKey,
+ readParenIdKey,
realClassKey,
realFloatClassKey,
realFracClassKey,
realWorldPrimIdKey,
realWorldTyConKey,
+ recConErrorIdKey,
+ recUpdErrorIdKey,
return2GMPsDataConKey,
return2GMPsTyConKey,
returnIntAndGMPDataConKey,
@@ -147,7 +152,11 @@ module Unique (
runSTIdKey,
seqIdKey,
showClassKey,
+ showParenIdKey,
+ showSpaceIdKey,
+ showStringIdKey,
stTyConKey,
+ stDataConKey,
stablePtrDataConKey,
stablePtrPrimTyConKey,
stablePtrTyConKey,
@@ -163,10 +172,10 @@ module Unique (
stateAndDoublePrimTyConKey,
stateAndFloatPrimDataConKey,
stateAndFloatPrimTyConKey,
- stateAndIntPrimDataConKey,
- stateAndIntPrimTyConKey,
stateAndForeignObjPrimDataConKey,
stateAndForeignObjPrimTyConKey,
+ stateAndIntPrimDataConKey,
+ stateAndIntPrimTyConKey,
stateAndMutableArrayPrimDataConKey,
stateAndMutableArrayPrimTyConKey,
stateAndMutableByteArrayPrimDataConKey,
@@ -182,19 +191,22 @@ module Unique (
stateDataConKey,
statePrimTyConKey,
stateTyConKey,
- stringTyConKey,
synchVarPrimTyConKey,
+ thenMClassOpKey,
traceIdKey,
trueDataConKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
unpackCStringFoldrIdKey,
unpackCStringIdKey,
- voidPrimIdKey,
- voidPrimTyConKey,
+ ureadListIdKey,
+ ushowListIdKey,
+ voidIdKey,
+ voidTyConKey,
wordDataConKey,
wordPrimTyConKey,
- wordTyConKey
+ wordTyConKey,
+ zeroClassOpKey
, copyableIdKey
, noFollowIdKey
, parAtAbsIdKey
@@ -207,7 +219,7 @@ module Unique (
import PreludeGlaST
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty
import Util
@@ -325,7 +337,6 @@ instance Outputable Unique where
instance Text Unique where
showsPrec p uniq rest = _UNPK_ (showUnique uniq)
- readsPrec p = panic "no readsPrec for Unique"
\end{code}
%************************************************************************
@@ -498,10 +509,10 @@ stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 45
stateAndWordPrimTyConKey = mkPreludeTyConUnique 46
statePrimTyConKey = mkPreludeTyConUnique 47
stateTyConKey = mkPreludeTyConUnique 48
-stringTyConKey = mkPreludeTyConUnique 49
+ -- 49 is spare
stTyConKey = mkPreludeTyConUnique 50
primIoTyConKey = mkPreludeTyConUnique 51
-voidPrimTyConKey = mkPreludeTyConUnique 52
+ -- 52 is spare
wordPrimTyConKey = mkPreludeTyConUnique 53
wordTyConKey = mkPreludeTyConUnique 54
voidTyConKey = mkPreludeTyConUnique 55
@@ -540,7 +551,7 @@ stateAndCharPrimDataConKey = mkPreludeDataConUnique 28
stateAndDoublePrimDataConKey = mkPreludeDataConUnique 29
stateAndFloatPrimDataConKey = mkPreludeDataConUnique 30
stateAndIntPrimDataConKey = mkPreludeDataConUnique 31
-stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 32
+stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 32
stateAndMutableArrayPrimDataConKey = mkPreludeDataConUnique 33
stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34
stateAndSynchVarPrimDataConKey = mkPreludeDataConUnique 35
@@ -550,6 +561,8 @@ stateAndWordPrimDataConKey = mkPreludeDataConUnique 38
stateDataConKey = mkPreludeDataConUnique 39
trueDataConKey = mkPreludeDataConUnique 40
wordDataConKey = mkPreludeDataConUnique 41
+stDataConKey = mkPreludeDataConUnique 42
+primIoDataConKey = mkPreludeDataConUnique 43
\end{code}
%************************************************************************
@@ -560,61 +573,73 @@ wordDataConKey = mkPreludeDataConUnique 41
\begin{code}
absentErrorIdKey = mkPreludeMiscIdUnique 1
-appendIdKey = mkPreludeMiscIdUnique 2
-augmentIdKey = mkPreludeMiscIdUnique 3
-buildIdKey = mkPreludeMiscIdUnique 4
-errorIdKey = mkPreludeMiscIdUnique 5
-foldlIdKey = mkPreludeMiscIdUnique 6
-foldrIdKey = mkPreludeMiscIdUnique 7
-forkIdKey = mkPreludeMiscIdUnique 8
-int2IntegerIdKey = mkPreludeMiscIdUnique 9
-integerMinusOneIdKey = mkPreludeMiscIdUnique 10
-integerPlusOneIdKey = mkPreludeMiscIdUnique 11
-integerPlusTwoIdKey = mkPreludeMiscIdUnique 12
-integerZeroIdKey = mkPreludeMiscIdUnique 13
-packCStringIdKey = mkPreludeMiscIdUnique 14
-parErrorIdKey = mkPreludeMiscIdUnique 15
-parIdKey = mkPreludeMiscIdUnique 16
-patErrorIdKey = mkPreludeMiscIdUnique 17
-realWorldPrimIdKey = mkPreludeMiscIdUnique 18
-runSTIdKey = mkPreludeMiscIdUnique 19
-seqIdKey = mkPreludeMiscIdUnique 20
-traceIdKey = mkPreludeMiscIdUnique 21
-unpackCString2IdKey = mkPreludeMiscIdUnique 22
-unpackCStringAppendIdKey = mkPreludeMiscIdUnique 23
-unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
-unpackCStringIdKey = mkPreludeMiscIdUnique 25
-voidPrimIdKey = mkPreludeMiscIdUnique 26
-mainIdKey = mkPreludeMiscIdUnique 27
-mainPrimIOIdKey = mkPreludeMiscIdUnique 28
-recConErrorIdKey = mkPreludeMiscIdUnique 29
-recUpdErrorIdKey = mkPreludeMiscIdUnique 30
-irrefutPatErrorIdKey = mkPreludeMiscIdUnique 31
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
-noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 33
-nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 34
-
-copyableIdKey = mkPreludeMiscIdUnique 35
-noFollowIdKey = mkPreludeMiscIdUnique 36
-parAtAbsIdKey = mkPreludeMiscIdUnique 37
-parAtForNowIdKey = mkPreludeMiscIdUnique 38
-parAtIdKey = mkPreludeMiscIdUnique 39
-parAtRelIdKey = mkPreludeMiscIdUnique 40
-parGlobalIdKey = mkPreludeMiscIdUnique 41
-parLocalIdKey = mkPreludeMiscIdUnique 42
+andandIdKey = mkPreludeMiscIdUnique 2
+appendIdKey = mkPreludeMiscIdUnique 3
+augmentIdKey = mkPreludeMiscIdUnique 4
+buildIdKey = mkPreludeMiscIdUnique 5
+composeIdKey = mkPreludeMiscIdUnique 6
+errorIdKey = mkPreludeMiscIdUnique 7
+foldlIdKey = mkPreludeMiscIdUnique 8
+foldrIdKey = mkPreludeMiscIdUnique 9
+forkIdKey = mkPreludeMiscIdUnique 10
+int2IntegerIdKey = mkPreludeMiscIdUnique 11
+integerMinusOneIdKey = mkPreludeMiscIdUnique 12
+integerPlusOneIdKey = mkPreludeMiscIdUnique 13
+integerPlusTwoIdKey = mkPreludeMiscIdUnique 14
+integerZeroIdKey = mkPreludeMiscIdUnique 15
+irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16
+lexIdKey = mkPreludeMiscIdUnique 17
+mainIdKey = mkPreludeMiscIdUnique 18
+mainPrimIOIdKey = mkPreludeMiscIdUnique 19
+noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20
+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21
+nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22
+notIdKey = mkPreludeMiscIdUnique 23
+packCStringIdKey = mkPreludeMiscIdUnique 24
+parErrorIdKey = mkPreludeMiscIdUnique 25
+parIdKey = mkPreludeMiscIdUnique 26
+patErrorIdKey = mkPreludeMiscIdUnique 27
+readParenIdKey = mkPreludeMiscIdUnique 28
+realWorldPrimIdKey = mkPreludeMiscIdUnique 29
+recConErrorIdKey = mkPreludeMiscIdUnique 30
+recUpdErrorIdKey = mkPreludeMiscIdUnique 31
+runSTIdKey = mkPreludeMiscIdUnique 32
+seqIdKey = mkPreludeMiscIdUnique 33
+showParenIdKey = mkPreludeMiscIdUnique 34
+showSpaceIdKey = mkPreludeMiscIdUnique 35
+showStringIdKey = mkPreludeMiscIdUnique 36
+traceIdKey = mkPreludeMiscIdUnique 37
+unpackCString2IdKey = mkPreludeMiscIdUnique 38
+unpackCStringAppendIdKey = mkPreludeMiscIdUnique 39
+unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 40
+unpackCStringIdKey = mkPreludeMiscIdUnique 41
+voidIdKey = mkPreludeMiscIdUnique 42
+ushowListIdKey = mkPreludeMiscIdUnique 43
+ureadListIdKey = mkPreludeMiscIdUnique 44
+
+copyableIdKey = mkPreludeMiscIdUnique 45
+noFollowIdKey = mkPreludeMiscIdUnique 46
+parAtAbsIdKey = mkPreludeMiscIdUnique 47
+parAtForNowIdKey = mkPreludeMiscIdUnique 48
+parAtIdKey = mkPreludeMiscIdUnique 49
+parAtRelIdKey = mkPreludeMiscIdUnique 50
+parGlobalIdKey = mkPreludeMiscIdUnique 51
+parLocalIdKey = mkPreludeMiscIdUnique 52
\end{code}
Certain class operations from Prelude classes. They get
their own uniques so we can look them up easily when we want
to conjure them up during type checking.
\begin{code}
-fromIntClassOpKey = mkPreludeMiscIdUnique 37
-fromIntegerClassOpKey = mkPreludeMiscIdUnique 38
-fromRationalClassOpKey = mkPreludeMiscIdUnique 39
-enumFromClassOpKey = mkPreludeMiscIdUnique 40
-enumFromThenClassOpKey = mkPreludeMiscIdUnique 41
-enumFromToClassOpKey = mkPreludeMiscIdUnique 42
-enumFromThenToClassOpKey= mkPreludeMiscIdUnique 43
-eqClassOpKey = mkPreludeMiscIdUnique 44
-geClassOpKey = mkPreludeMiscIdUnique 45
+fromIntClassOpKey = mkPreludeMiscIdUnique 53
+fromIntegerClassOpKey = mkPreludeMiscIdUnique 54
+fromRationalClassOpKey = mkPreludeMiscIdUnique 55
+enumFromClassOpKey = mkPreludeMiscIdUnique 56
+enumFromThenClassOpKey = mkPreludeMiscIdUnique 57
+enumFromToClassOpKey = mkPreludeMiscIdUnique 58
+enumFromThenToClassOpKey= mkPreludeMiscIdUnique 59
+eqClassOpKey = mkPreludeMiscIdUnique 60
+geClassOpKey = mkPreludeMiscIdUnique 61
+zeroClassOpKey = mkPreludeMiscIdUnique 62
+thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=)
\end{code}
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index b00aca77fa93..8edd5bd9dc78 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -26,8 +26,8 @@ module CgBindery (
rebindToAStack, rebindToBStack
) where
-import Ubiq{-uitous-}
-import CgLoop1 -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking
import AbsCSyn
import CgMonad
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 2d0f3aebd1d3..17d61261c1c1 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -12,8 +12,8 @@
module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
-import Ubiq{-uitous-}
-import CgLoop2 ( cgExpr, getPrimOpArgAmodes )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop2) ( cgExpr, getPrimOpArgAmodes )
import CgMonad
import StgSyn
@@ -41,7 +41,7 @@ import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
import CgTailCall ( tailCallBusiness, performReturn )
import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
- mkAltLabel, mkClosureLabel
+ mkAltLabel
)
import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
@@ -645,7 +645,6 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
where
lf_info = mkConLFInfo con
tag = dataConTag con
- closure_lbl = mkClosureLabel con
-- alloc_code generates code to allocate constructor con, whose args are
-- in the arguments to alloc_code, assigning the result to Node.
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 81ff55f65ce8..cfd5ceade1a2 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -12,8 +12,8 @@ with {\em closures} on the RHSs of let(rec)s. See also
module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
-import Ubiq{-uitous-}
-import CgLoop2 ( cgExpr, cgSccExpr )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop2) ( cgExpr, cgSccExpr )
import CgMonad
import AbsCSyn
@@ -451,7 +451,10 @@ closureCodeBody binder_info closure_info cc all_args body
ViaNode | is_concurrent -> []
other -> panic "closureCodeBody:arg_regs"
- stk_args = drop (length arg_regs) all_args
+ num_arg_regs = length arg_regs
+
+ (reg_args, stk_args) = splitAt num_arg_regs all_args
+
(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
= mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
@@ -509,7 +512,7 @@ closureCodeBody binder_info closure_info cc all_args body
-- Bind args to regs/stack as appropriate, and
-- record expected position of sps
- bindArgsToRegs all_args arg_regs `thenC`
+ bindArgsToRegs reg_args arg_regs `thenC`
mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
@@ -863,8 +866,6 @@ setupUpdate closure_info code
`thenC`
returnFC amode
- closure_label = mkClosureLabel (closureId closure_info)
-
vector
= case (closureType closure_info) of
Nothing -> CReg StdUpdRetVecReg
diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs
index 9b14dcdaf99d..561f8bf47709 100644
--- a/ghc/compiler/codeGen/CgCompInfo.lhs
+++ b/ghc/compiler/codeGen/CgCompInfo.lhs
@@ -63,9 +63,6 @@ module CgCompInfo (
spARelToInt,
spBRelToInt
-
- -- and to make the interface self-sufficient...
--- RegRelative
) where
-- This magical #include brings in all the everybody-knows-these magic
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 0d0e620cf625..cb5337be61eb 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -16,7 +16,7 @@ module CgCon (
cgReturnDataCon
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgMonad
import AbsCSyn
@@ -33,9 +33,8 @@ import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE )
import CgHeapery ( allocDynClosure )
import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CLabel ( mkClosureLabel, mkInfoTableLabel,
- mkPhantomInfoTableLabel,
- mkConEntryLabel, mkStdEntryLabel
+import CLabel ( mkClosureLabel, mkStaticClosureLabel,
+ mkConInfoTableLabel, mkPhantomInfoTableLabel
)
import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
layOutDynCon, layOutDynClosure,
@@ -157,13 +156,9 @@ cgTopRhsCon name con args all_zero_size_args
-- RETURN
returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
where
- con_tycon = dataConTyCon con
- lf_info = mkConLFInfo con
-
- closure_label = mkClosureLabel name
- info_label = mkInfoTableLabel con
- con_entry_label = mkConEntryLabel con
- entry_label = mkStdEntryLabel name
+ con_tycon = dataConTyCon con
+ lf_info = mkConLFInfo con
+ closure_label = mkClosureLabel name
\end{code}
The general case is:
@@ -277,7 +272,7 @@ at all.
buildDynCon binder cc con args all_zero_size_args@True
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel con) PtrRep)
+ (CLbl (mkStaticClosureLabel con) PtrRep)
(mkConLFInfo con))
\end{code}
@@ -427,7 +422,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
-- MAKE NODE POINT TO IT
let reg_assts = move_to_reg amode node
- info_lbl = mkInfoTableLabel con
+ info_lbl = mkConInfoTableLabel con
in
-- RETURN
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 98c5a1deed70..774546670693 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -8,7 +8,7 @@
module CgConTbls ( genStaticConBits ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
import CgMonad
@@ -23,7 +23,7 @@ import CgRetConv ( mkLiveRegsMask,
)
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import CgUsages ( getHpRelOffset )
-import CLabel ( mkConEntryLabel, mkClosureLabel,
+import CLabel ( mkConEntryLabel, mkStaticClosureLabel,
mkConUpdCodePtrVecLabel,
mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel
)
@@ -35,7 +35,7 @@ import ClosureInfo ( layOutStaticClosure, layOutDynCon,
import CostCentre ( dontCareCostCentre )
import FiniteMap ( fmToList )
import HeapOffs ( zeroOff, VirtualHeapOffset(..) )
-import Id ( dataConTag, dataConSig,
+import Id ( dataConTag, dataConRawArgTys,
dataConArity, fIRST_TAG,
emptyIdSet,
GenId{-instance NamedThing-}
@@ -240,10 +240,10 @@ genConInfo comp_info tycon data_con
zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0
- (_,_,arg_tys,_) = dataConSig data_con
- con_arity = dataConArity data_con
- entry_label = mkConEntryLabel data_con
- closure_label = mkClosureLabel data_con
+ arg_tys = dataConRawArgTys data_con
+ con_arity = dataConArity data_con
+ entry_label = mkConEntryLabel data_con
+ closure_label = mkStaticClosureLabel data_con
\end{code}
The entry code for a constructor now loads the info ptr by indirecting
@@ -288,7 +288,7 @@ mkConCodeAndInfo con
ReturnInHeap ->
let
- (_, _, arg_tys, _) = dataConSig con
+ arg_tys = dataConRawArgTys con
(closure_info, arg_things)
= layOutDynCon con typePrimRep arg_tys
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index dd0b7f4d4fca..a4a0746d3da9 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -12,8 +12,8 @@
module CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) where
-import Ubiq{-uitous-}
-import CgLoop2 -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking
import StgSyn
import CgMonad
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index fa8f1e0bdbbf..888908f612df 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -14,7 +14,7 @@ module CgHeapery (
, heapCheckOnly, fetchAndReschedule, yield
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
import CgMonad
diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index f59ef4eb7cff..3748ddd65756 100644
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -12,8 +12,8 @@
module CgLetNoEscape ( cgLetNoEscapeClosure ) where
-import Ubiq{-uitious-}
-import CgLoop2 ( cgExpr )
+IMP_Ubiq(){-uitious-}
+IMPORT_DELOOPER(CgLoop2) ( cgExpr )
import StgSyn
import CgMonad
@@ -169,9 +169,9 @@ cgLetNoEscapeBody :: [Id] -- Args
cgLetNoEscapeBody all_args rhs
= getVirtSps `thenFC` \ (vA, vB) ->
let
- arg_kinds = map idPrimRep all_args
- (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
- stk_args = drop (length arg_regs) all_args
+ arg_kinds = map idPrimRep all_args
+ (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
+ (reg_args, stk_args) = splitAt (length arg_regs) all_args
-- stk_args is the args which are passed on the stack at the fast-entry point
-- Using them, we define the stack layout
@@ -183,7 +183,7 @@ cgLetNoEscapeBody all_args rhs
in
-- Bind args to appropriate regs/stk locns
- bindArgsToRegs all_args arg_regs `thenC`
+ bindArgsToRegs reg_args arg_regs `thenC`
mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index 428d6f6881ab..ab22daeb2422 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -47,8 +47,8 @@ module CgMonad (
CompilationInfo(..)
) where
-import Ubiq{-uitous-}
-import CgLoop1 -- stuff from CgBindery and CgUsages
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages
import AbsCSyn
import AbsCUtils ( mkAbsCStmts )
diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index 14e59f4526aa..fa3644038b42 100644
--- a/ghc/compiler/codeGen/CgRetConv.lhs
+++ b/ghc/compiler/codeGen/CgRetConv.lhs
@@ -20,12 +20,10 @@ module CgRetConv (
assignPrimOpResultRegs,
makePrimOpArgsRobust,
assignRegs
-
- -- and to make the interface self-sufficient...
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) -- paranoia checking
import AbsCSyn -- quite a few things
import AbsCUtils ( mkAbstractCs, getAmodeRep,
@@ -36,7 +34,7 @@ import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
mAX_Double_REG
)
import CmdLineOpts ( opt_ReturnInRegsThreshold )
-import Id ( isDataCon, dataConSig,
+import Id ( isDataCon, dataConRawArgTys,
DataCon(..), GenId{-instance Eq-}
)
import Maybes ( catMaybes )
@@ -123,7 +121,7 @@ dataReturnConvAlg data_con
[] -> ReturnInRegs reg_assignment
other -> ReturnInHeap -- Didn't fit in registers
where
- (_, _, arg_tys, _) = dataConSig data_con
+ arg_tys = dataConRawArgTys data_con
(reg_assignment, leftover_kinds)
= assignRegs [node, infoptr] -- taken...
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index 8e1c90a58e1b..caf38104dd59 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -16,7 +16,7 @@ module CgStackery (
mkVirtStkOffsets, mkStkAmodes
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgMonad
import AbsCSyn
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 15b2ae249b36..770c4b52df7e 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -19,7 +19,7 @@ module CgTailCall (
tailCallBusiness
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgMonad
import AbsCSyn
diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs
index ff1a5546b9bd..70e344b7d99e 100644
--- a/ghc/compiler/codeGen/CgUpdate.lhs
+++ b/ghc/compiler/codeGen/CgUpdate.lhs
@@ -8,7 +8,7 @@
module CgUpdate ( pushUpdateFrame ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgMonad
import AbsCSyn
diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs
index eec6be60672f..e7e7b962cbcd 100644
--- a/ghc/compiler/codeGen/CgUsages.lhs
+++ b/ghc/compiler/codeGen/CgUsages.lhs
@@ -7,6 +7,8 @@ This module provides the functions to access (\tr{get*} functions) and
modify (\tr{set*} functions) the stacks and heap usage information.
\begin{code}
+#include "HsVersions.h"
+
module CgUsages (
initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp,
setRealAndVirtualSps,
@@ -18,8 +20,8 @@ module CgUsages (
freeBStkSlot
) where
-import Ubiq{-uitous-}
-import CgLoop1 -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking
import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode )
import CgMonad
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index e45fdeccf6c6..960e6a980302 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -50,8 +50,8 @@ module ClosureInfo (
dataConLiveness -- concurrency
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) -- here for paranoia-checking
import AbsCSyn
import StgSyn
@@ -68,6 +68,7 @@ import CgRetConv ( assignRegs, dataReturnConvAlg,
)
import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
mkPhantomInfoTableLabel, mkInfoTableLabel,
+ mkConInfoTableLabel,
mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
@@ -78,9 +79,9 @@ import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
VirtualHeapOffset(..)
)
import Id ( idType, idPrimRep, getIdArity,
- externallyVisibleId, dataConSig,
+ externallyVisibleId,
dataConTag, fIRST_TAG,
- isDataCon, dataConArity, dataConTyCon,
+ isDataCon, isNullaryDataCon, dataConTyCon,
isTupleCon, DataCon(..),
GenId{-instance Eq-}
)
@@ -425,7 +426,7 @@ mkClosureLFInfo False -- don't bother if at top-level
offset_into_int_maybe = intOffsetIntoGoods the_offset
Just offset_into_int = offset_into_int_maybe
is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
- (_,_,_, tycon) = dataConSig con
+ tycon = dataConTyCon con
\end{code}
Same kind of thing, looking for vector-apply thunks, of the form:
@@ -477,14 +478,8 @@ isUpdatable Updatable = True
mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo con
- = ASSERT(isDataCon con)
- let
- arity = dataConArity con
- in
- if isTupleCon con then
- LFTuple con (arity == 0)
- else
- LFCon con (arity == 0)
+ = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
+ (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
\end{code}
@@ -865,8 +860,8 @@ data EntryConvention
Int -- Its arity
[MagicId] -- Its register assignments (possibly empty)
-getEntryConvention :: Id -- Function being applied
- -> LambdaFormInfo -- Its info
+getEntryConvention :: Id -- Function being applied
+ -> LambdaFormInfo -- Its info
-> [PrimRep] -- Available arguments
-> FCode EntryConvention
@@ -894,13 +889,14 @@ getEntryConvention id lf_info arg_kinds
-> let itbl = if zero_arity then
mkPhantomInfoTableLabel con
else
- mkInfoTableLabel con
- in StdEntry (mkStdEntryLabel con) (Just itbl)
- -- Should have no args
+ mkConInfoTableLabel con
+ in
+ --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel con) (Just itbl)
+
LFTuple tup zero_arity
- -> StdEntry (mkStdEntryLabel tup)
- (Just (mkInfoTableLabel tup))
- -- Should have no args
+ -> --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup))
LFThunk _ _ updatable std_form_info
-> if updatable
@@ -1213,17 +1209,19 @@ infoTableLabelFromCI (MkClosureInfo id lf_info rep)
else -} mkInfoTableLabel id
mkConInfoPtr :: Id -> SMRep -> CLabel
-mkConInfoPtr id rep =
- case rep of
- PhantomRep -> mkPhantomInfoTableLabel id
- StaticRep _ _ -> mkStaticInfoTableLabel id
- _ -> mkInfoTableLabel id
+mkConInfoPtr con rep
+ = ASSERT(isDataCon con)
+ case rep of
+ PhantomRep -> mkPhantomInfoTableLabel con
+ StaticRep _ _ -> mkStaticInfoTableLabel con
+ _ -> mkConInfoTableLabel con
mkConEntryPtr :: Id -> SMRep -> CLabel
-mkConEntryPtr id rep =
- case rep of
- StaticRep _ _ -> mkStaticConEntryLabel id
- _ -> mkConEntryLabel id
+mkConEntryPtr con rep
+ = ASSERT(isDataCon con)
+ case rep of
+ StaticRep _ _ -> mkStaticConEntryLabel con
+ _ -> mkConEntryLabel con
closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 016bd99ec3ce..590aa9f65ea2 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -19,7 +19,7 @@ functions drive the mangling of top-level bindings.
module CodeGen ( codeGen ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
import CgMonad
diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs
index 99432c764314..7c46adff06c5 100644
--- a/ghc/compiler/codeGen/SMRep.lhs
+++ b/ghc/compiler/codeGen/SMRep.lhs
@@ -17,7 +17,7 @@ module SMRep (
isIntLikeRep
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty ( ppStr )
import Util ( panic )
diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs
index f1095d8cdd09..4e0a6a035574 100644
--- a/ghc/compiler/coreSyn/AnnCoreSyn.lhs
+++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs
@@ -18,7 +18,7 @@ module AnnCoreSyn (
deAnnotate -- we may eventually export some of the other deAnners
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
\end{code}
diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index 664231e37835..a14bf3d557bb 100644
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -17,7 +17,7 @@ module CoreLift (
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CoreUtils ( coreExprType )
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 304b30ecd7e9..31e8ea588ed5 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -11,7 +11,7 @@ module CoreLint (
lintUnfolding
) where
-import Ubiq
+IMP_Ubiq()
import CoreSyn
@@ -33,6 +33,7 @@ import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc )
import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe,
getFunTyExpandingDicts_maybe,
+ getForAllTyExpandingDicts_maybe,
isPrimType,typeKind,instantiateTy,splitSigmaTy,
mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
maybeAppDataTyConExpandingDicts, eqTy
@@ -285,7 +286,7 @@ lintCoreArg e ty a@(TyArg arg_ty)
= -- ToDo: Check that ty is well-kinded and has no unbound tyvars
checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
`seqL`
- case (getForAllTy_maybe ty) of
+ case (getForAllTyExpandingDicts_maybe ty) of
Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
Just (tyvar,body) ->
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 49e66879a54f..d66f7b6561e5 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -50,12 +50,9 @@ module CoreSyn (
SimplifiableCoreArg(..),
SimplifiableCoreCaseAlts(..),
SimplifiableCoreCaseDefault(..)
-
- -- and to make the interface self-sufficient ...
-
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- ToDo:rm:
--import PprCore ( GenCoreExpr{-instance-} )
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index fe034d6bea53..c0f61a31abc0 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -20,17 +20,17 @@ module CoreUnfold (
FormSummary(..),
mkFormSummary,
- mkGenForm,
+ mkGenForm, mkLitForm, mkConForm,
+ whnfDetails,
mkMagicUnfolding,
- modifyUnfoldingDetails,
calcUnfoldingGuidance,
mentionedInUnfolding
) where
-import Ubiq
-import IdLoop -- for paranoia checking;
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking;
-- and also to get mkMagicUnfoldingFun
-import PrelLoop -- for paranoia checking
+IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
import Bag ( emptyBag, unitBag, unionBags, Bag )
import BinderInfo ( oneTextualOcc, oneSafeOcc )
@@ -70,16 +70,9 @@ getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromTy
data UnfoldingDetails
= NoUnfoldingDetails
- | LitForm
- Literal
-
| OtherLitForm
[Literal] -- It is a literal, but definitely not one of these
- | ConForm
- Id -- The constructor
- [CoreArg] -- Type/value arguments; NB OutArgs, already cloned
-
| OtherConForm
[Id] -- It definitely isn't one of these constructors
-- This captures the situation in the default branch of
@@ -97,10 +90,6 @@ data UnfoldingDetails
| GenForm
- Bool -- True <=> At most one textual occurrence of the
- -- binder in its scope, *or*
- -- if we are happy to duplicate this
- -- binding.
FormSummary -- Tells whether the template is a WHNF or bottom
TemplateOutExpr -- The template
UnfoldingGuidance -- Tells about the *size* of the template.
@@ -140,6 +129,12 @@ mkFormSummary si expr
-- | manifestlyBottom expr = BottomForm
| otherwise = OtherForm
+
+whnfDetails :: UnfoldingDetails -> Bool -- True => thing is evaluated
+whnfDetails (GenForm WhnfForm _ _) = True
+whnfDetails (OtherLitForm _) = True
+whnfDetails (OtherConForm _) = True
+whnfDetails other = False
\end{code}
\begin{code}
@@ -191,46 +186,25 @@ instance Outputable UnfoldingGuidance where
%************************************************************************
%* *
-\subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
+\subsection{@mkGenForm@ and friends}
%* *
%************************************************************************
\begin{code}
-mkGenForm :: Bool -- Ok to Dup code down different case branches,
- -- because of either a flag saying so,
- -- or alternatively the object is *SMALL*
- -> BinderInfo --
- -> FormSummary
+mkGenForm :: FormSummary
-> TemplateOutExpr -- Template
-> UnfoldingGuidance -- Tells about the *size* of the template.
-> UnfoldingDetails
-mkGenForm safe_to_dup occ_info WhnfForm template guidance
- = GenForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance
-
-mkGenForm safe_to_dup occ_info form_summary template guidance
- | oneSafeOcc safe_to_dup occ_info -- Non-WHNF with only safe occurrences
- = GenForm True form_summary template guidance
-
- | otherwise -- Not a WHNF, many occurrences
- = NoUnfoldingDetails
-\end{code}
+mkGenForm = GenForm
-\begin{code}
-modifyUnfoldingDetails
- :: Bool -- OK to dup
- -> BinderInfo -- New occurrence info for the thing
- -> UnfoldingDetails
- -> UnfoldingDetails
+-- two shorthand variants:
+mkLitForm lit = mk_go_for_it (Lit lit)
+mkConForm con args = mk_go_for_it (Con con args)
-modifyUnfoldingDetails ok_to_dup occ_info
- (GenForm only_one form_summary template guidance)
- | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance
-
-modifyUnfoldingDetails ok_to_dup occ_info other = other
+mk_go_for_it expr = mkGenForm WhnfForm expr UnfoldAlways
\end{code}
-
%************************************************************************
%* *
\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 6e6d7baf30dc..bb73e018646e 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -25,13 +25,14 @@ module CoreUtils (
-} ) where
-import Ubiq
-import IdLoop -- for pananoia-checking purposes
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
import CoreSyn
import CostCentre ( isDictCC )
import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
+ toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
isNullIdEnv, IdEnv(..),
GenId{-instances-}
@@ -46,7 +47,9 @@ import Pretty ( ppAboves )
import PrelVals ( augmentId, buildId )
import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
-import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
+import TyVar ( cloneTyVar,
+ isNullTyVarEnv, addOneToTyVarEnv, TyVarEnv(..)
+ )
import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
getFunTy_maybe, applyTy, isPrimType,
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
@@ -61,7 +64,6 @@ import Util ( zipEqual, panic, pprPanic, assertPanic )
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
-dup_binder = panic "CoreUtils.dup_binder"
\end{code}
%************************************************************************
@@ -728,11 +730,21 @@ do_CoreExpr venv tenv (Prim op as)
do_PrimOp other_op = returnUs other_op
-do_CoreExpr venv tenv (Lam binder expr)
+do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
= dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
let new_venv = addOneToIdEnv venv old new in
do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (Lam new_binder new_expr)
+ returnUs (Lam (ValBinder new_binder) new_expr)
+
+do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
+ = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
+ let
+ new_tenv = addOneToTyVarEnv tenv old new
+ in
+ do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
+ returnUs (Lam (TyBinder new_tyvar) new_expr)
+
+do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
do_CoreExpr venv tenv (App expr arg)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
@@ -787,3 +799,28 @@ do_CoreExpr venv tenv (Coerce c ty expr)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
\end{code}
+
+\begin{code}
+dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
+dup_tyvar tyvar
+ = getUnique `thenUs` \ uniq ->
+ let new_tyvar = cloneTyVar tyvar uniq in
+ returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
+
+-- same thing all over again --------------------
+
+dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
+dup_binder tenv b
+ = if (toplevelishId b) then
+ -- binder is "top-level-ish"; -- it should *NOT* be renamed
+ -- ToDo: it's unsavoury that we return something to heave in env
+ returnUs (b, (b, Var b))
+
+ else -- otherwise, the full business
+ getUnique `thenUs` \ uniq ->
+ let
+ new_b1 = mkIdWithNewUniq b uniq
+ new_b2 = applyTypeEnvToId tenv new_b1
+ in
+ returnUs (new_b2, (b, Var new_b2))
+\end{code}
diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs
index e6987a826f0f..38de36c814cd 100644
--- a/ghc/compiler/coreSyn/FreeVars.lhs
+++ b/ghc/compiler/coreSyn/FreeVars.lhs
@@ -20,7 +20,7 @@ module FreeVars (
FVInfo(..), LeakInfo(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AnnCoreSyn -- output
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 8fa61e5e7ad9..fd2e03d31f25 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -23,7 +23,7 @@ module PprCore (
#endif
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CostCentre ( showCostCentre )
diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 1e2907570656..a1be8b473b01 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -8,7 +8,7 @@
module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( HsBinds, HsExpr )
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index bc5bc9ac76ba..82380970e7fa 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -12,8 +12,8 @@ lower levels it is preserved with @let@/@letrec@s).
module DsBinds ( dsBinds, dsInstBinds ) where
-import Ubiq
-import DsLoop -- break dsExpr-ish loop
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn -- lots of things
hiding ( collectBinders{-also in CoreSyn-} )
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index fbae35c89b63..47eb7c1b56b9 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -8,7 +8,7 @@
module DsCCall ( dsCCall ) where
-import Ubiq
+IMP_Ubiq()
import CoreSyn
@@ -23,15 +23,13 @@ import PprType ( GenType{-instances-} )
import Pretty
import PrelVals ( packStringForCId )
import PrimOp ( PrimOp(..) )
-import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy )
+import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy, maybeBoxedPrimType )
import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy )
import TysWiredIn ( getStatePairingConInfo,
realWorldStateTy, stateDataCon,
stringTy
)
import Util ( pprPanic, pprError, panic )
-
-maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
\end{code}
Desugaring of @ccall@s consists of adding some state manipulation,
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 8d059a2671c8..f679a7809c1a 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -8,18 +8,23 @@
module DsExpr ( dsExpr ) where
-import Ubiq
-import DsLoop -- partly to get dsBinds, partly to chk dsExpr
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr
-import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- Match, Qual, HsBinds, Stmt, PolyType )
+import HsSyn ( failureFreePat,
+ HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
+ Stmt(..), Match(..), Qual, HsBinds, PolyType,
+ GRHSsAndBinds
+ )
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
- TypecheckedRecordBinds(..), TypecheckedPat(..)
+ TypecheckedRecordBinds(..), TypecheckedPat(..),
+ TypecheckedStmt(..)
)
import CoreSyn
import DsMonad
import DsCCall ( dsCCall )
+import DsHsSyn ( outPatType )
import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
mkErrorAppDs, showForErr, EquationInfo,
@@ -42,21 +47,20 @@ import MagicUFs ( MagicUnfoldingFun )
import Name ( Name{--O only-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType )
-import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID )
+import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId )
import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
import TyCon ( isDataTyCon, isNewTyCon )
import Type ( splitSigmaTy, splitFunTy, typePrimRep,
- getAppDataTyConExpandingDicts, getAppTyCon, applyTy
+ getAppDataTyConExpandingDicts, getAppTyCon, applyTy,
+ maybeBoxedPrimType
)
-import TysWiredIn ( mkTupleTy, unitTy, nilDataCon, consDataCon,
+import TysWiredIn ( mkTupleTy, voidTy, nilDataCon, consDataCon,
charDataCon, charTy
)
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
import Usage ( UVar(..) )
import Util ( zipEqual, pprError, panic, assertPanic )
-maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
-
mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility...
\end{code}
@@ -149,11 +153,11 @@ dsExpr (HsLitOut (HsLitLit s) ty)
-> 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))
+dsExpr (HsLitOut (HsInt i) ty)
+ = returnDs (Lit (NoRepInteger i ty))
-dsExpr (HsLitOut (HsFrac r) _)
- = returnDs (Lit (NoRepRational r))
+dsExpr (HsLitOut (HsFrac r) ty)
+ = returnDs (Lit (NoRepRational r ty))
-- others where we know what to do:
@@ -268,9 +272,9 @@ dsExpr (HsLet binds expr)
dsExpr expr `thenDs` \ core_expr ->
returnDs ( mkCoLetsAny core_binds core_expr )
-dsExpr (HsDoOut stmts m_id mz_id src_loc)
+dsExpr (HsDoOut stmts then_id zero_id src_loc)
= putSrcLocDs src_loc $
- panic "dsExpr:HsDoOut"
+ dsDo then_id zero_id stmts
dsExpr (HsIf guard_expr then_expr else_expr src_loc)
= putSrcLocDs src_loc $
@@ -278,7 +282,6 @@ dsExpr (HsIf guard_expr then_expr else_expr src_loc)
dsExpr then_expr `thenDs` \ core_then ->
dsExpr else_expr `thenDs` \ core_else ->
returnDs (mkCoreIfThenElse core_guard core_then core_else)
-
\end{code}
@@ -498,7 +501,7 @@ dsExpr (Dictionary dicts methods)
`thenDs` \ core_d_and_ms ->
(case num_of_d_and_ms of
- 0 -> returnDs cocon_unit -- unit
+ 0 -> returnDs (Var voidId)
1 -> returnDs (head core_d_and_ms) -- just a single Id
@@ -515,7 +518,7 @@ dsExpr (Dictionary dicts methods)
dsExpr (ClassDictLam dicts methods expr)
= dsExpr expr `thenDs` \ core_expr ->
case num_of_d_and_ms of
- 0 -> newSysLocalDs unitTy `thenDs` \ new_x ->
+ 0 -> newSysLocalDs voidTy `thenDs` \ new_x ->
returnDs (mkValLam [new_x] core_expr)
1 -> -- no untupling
@@ -543,7 +546,6 @@ dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
#endif
-cocon_unit = mkCon (mkTupleCon 0) [] [] [] -- out here to avoid CAF (sigh)
out_of_range_msg -- ditto
= " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
\end{code}
@@ -593,7 +595,7 @@ dsApp (HsVar v) args
Nothing -> -- we're only saturating constructors and PrimOps
case getIdUnfolding v of
- GenForm _ _ the_unfolding EssentialUnfolding
+ GenForm _ the_unfolding EssentialUnfolding
-> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
_ -> apply_to_args (Var v) args
@@ -653,3 +655,48 @@ do_unfold ty_env val_env body args
-- Apply result to remaining arguments
apply_to_args body' args
\end{code}
+
+Basically does the translation given in the Haskell~1.3 report:
+\begin{code}
+dsDo :: Id -- id for: (>>=) m
+ -> Id -- id for: zero m
+ -> [TypecheckedStmt]
+ -> DsM CoreExpr
+
+dsDo then_id zero_id (stmt:stmts)
+ = case stmt of
+ ExprStmt expr locn -> ASSERT( null stmts ) do_expr expr locn
+
+ ExprStmtOut expr locn a b ->
+ do_expr expr locn `thenDs` \ expr2 ->
+ ds_rest `thenDs` \ rest ->
+ dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, VarArg rest]
+
+ LetStmt binds ->
+ dsBinds binds `thenDs` \ binds2 ->
+ ds_rest `thenDs` \ rest ->
+ returnDs (mkCoLetsAny binds2 rest)
+
+ BindStmtOut pat expr locn a b ->
+ do_expr expr locn `thenDs` \ expr2 ->
+ let
+ zero_expr = TyApp (HsVar zero_id) [b]
+ main_match
+ = PatMatch pat (SimpleMatch (HsDoOut stmts then_id zero_id locn))
+ the_matches
+ = if failureFreePat pat
+ then [main_match]
+ else [main_match, PatMatch (WildPat a) (SimpleMatch zero_expr)]
+ in
+ matchWrapper DoBindMatch the_matches "`do' statement"
+ `thenDs` \ (binders, matching_code) ->
+ dsApp (HsVar then_id) [TyArg a, TyArg b,
+ VarArg expr2, VarArg (mkValLam binders matching_code)]
+ where
+ ds_rest = dsDo then_id zero_id stmts
+ do_expr expr locn = putSrcLocDs locn (dsExpr expr)
+
+#ifdef DEBUG
+dsDo then_expr zero_expr [] = panic "dsDo:[]"
+#endif
+\end{code}
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index a1a41b4fdb52..fd8bec3b108d 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -8,8 +8,8 @@
module DsGRHSs ( dsGuarded, dsGRHSs ) where
-import Ubiq
-import DsLoop -- break dsExpr/dsBinds-ish loop
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr, HsBinds )
diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs
index b54d8a269879..fa3f0fe6f690 100644
--- a/ghc/compiler/deSugar/DsHsSyn.lhs
+++ b/ghc/compiler/deSugar/DsHsSyn.lhs
@@ -8,7 +8,7 @@
module DsHsSyn where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..),
Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 5508cb1b40fe..ac712c70abaf 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -4,10 +4,12 @@
\section[DsListComp]{Desugaring list comprehensions}
\begin{code}
+#include "HsVersions.h"
+
module DsListComp ( dsListComp ) where
-import Ubiq
-import DsLoop -- break dsExpr-ish loop
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn ( Qual(..), HsExpr, HsBinds )
import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 6236b69f4e28..618f8c910fc1 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -24,7 +24,7 @@ module DsMonad (
DsMatchContext(..), DsMatchKind(..), pprDsWarnings
) where
-import Ubiq
+IMP_Ubiq()
import Bag ( emptyBag, snocBag, bagToList )
import CmdLineOpts ( opt_SccGroup )
@@ -247,6 +247,7 @@ data DsMatchKind
| CaseMatch
| LambdaMatch
| PatBindMatch
+ | DoBindMatch
pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
pprDsWarnings sty warns
@@ -274,5 +275,9 @@ pprDsWarnings sty warns
= ppHang (ppPStr SLIT("in a lambda abstraction:"))
4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+ pp_match DoBindMatch pats
+ = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
+ 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+
pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
\end{code}
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 579062820dbd..528607cf8191 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -27,8 +27,8 @@ module DsUtils (
showForErr
) where
-import Ubiq
-import DsLoop ( match, matchSimply )
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
@@ -40,7 +40,7 @@ import DsMonad
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PprStyle ( PprStyle(..) )
-import PrelVals ( iRREFUT_PAT_ERROR_ID )
+import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
pprId{-ToDo:rm-},
@@ -50,6 +50,7 @@ import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon
)
+import TysWiredIn ( voidTy )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
import PprCore{-ToDo:rm-}
@@ -551,13 +552,13 @@ which is of course utterly wrong. Rather than drop the condition that
only boxed types can be let-bound, we just turn the fail into a function
for the primitive case:
\begin{verbatim}
- let fail.33 :: () -> Int#
+ let fail.33 :: Void -> Int#
fail.33 = \_ -> error "Help"
in
case x of
p1 -> ...
- p2 -> fail.33 ()
- p3 -> fail.33 ()
+ p2 -> fail.33 void
+ p3 -> fail.33 void
p4 -> ...
\end{verbatim}
@@ -572,19 +573,16 @@ mkFailurePair :: Type -- Result type of the whole case expression
-- applied to unit tuple
mkFailurePair ty
| isUnboxedType ty
- = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
- newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
+ = newFailLocalDs (mkFunTys [voidTy] ty) `thenDs` \ fail_fun_var ->
+ newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
returnDs (\ body ->
NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
- App (Var fail_fun_var) (VarArg unit_id))
+ App (Var fail_fun_var) (VarArg voidId))
| otherwise
= newFailLocalDs ty `thenDs` \ fail_var ->
returnDs (\ body -> NonRec fail_var body, Var fail_var)
+\end{code}
+
-unit_id :: Id -- out here to avoid CAF (sigh)
-unit_id = mkTupleCon 0
-unit_ty :: Type
-unit_ty = idType unit_id
-\end{code}
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 82c5a8ea8f46..a1d8fc750289 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -8,8 +8,8 @@
module Match ( match, matchWrapper, matchSimply ) where
-import Ubiq
-import DsLoop -- here for paranoia-checking reasons
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
-- and to break dsExpr/dsBinds-ish loop
import HsSyn hiding ( collectBinders{-also from CoreSyn-} )
@@ -26,7 +26,7 @@ import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
import FieldLabel ( allFieldLabelTags, fieldLabelTag )
-import Id ( idType, mkTupleCon, dataConSig,
+import Id ( idType, mkTupleCon,
dataConArgTys, recordSelectorFieldLabel,
GenId{-instance-}
)
@@ -43,7 +43,7 @@ import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
charTy, charDataCon, intTy, intDataCon,
floatTy, floatDataCon, doubleTy,
- doubleDataCon, integerTy, stringTy, addrTy,
+ doubleDataCon, stringTy, addrTy,
addrDataCon, wordTy, wordDataCon
)
import Unique ( Unique{-instance Eq-} )
@@ -209,9 +209,9 @@ match vars@(v:vs) eqns_info shadows
unmix_eqns [] = []
unmix_eqns [eqn] = [ [eqn] ]
unmix_eqns (eq1@(EqnInfo (p1:p1s) _) : eq2@(EqnInfo (p2:p2s) _) : eqs)
- = if ( (unfailablePat p1 && unfailablePat p2)
- || (isConPat p1 && isConPat p2)
- || (isLitPat p1 && isLitPat p2) ) then
+ = if ( (irrefutablePat p1 && irrefutablePat p2)
+ || (isConPat p1 && isConPat p2)
+ || (isLitPat p1 && isLitPat p2) ) then
eq1 `tack_onto` unmixed_rest
else
[ eq1 ] : unmixed_rest
@@ -514,8 +514,8 @@ matchUnmixedEqns :: [Id]
matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
- | unfailablePat first_pat
- = ASSERT( unfailablePats column_1_pats ) -- Sanity check
+ | irrefutablePat first_pat
+ = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
-- Real true variables, just like in matchVar, SLPJ p 94
match vars remaining_eqns_info remaining_shadows
diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs
index 11dbd1d99af5..c94ce52d45eb 100644
--- a/ghc/compiler/deSugar/MatchCon.lhs
+++ b/ghc/compiler/deSugar/MatchCon.lhs
@@ -8,8 +8,8 @@
module MatchCon ( matchConFamily ) where
-import Ubiq
-import DsLoop ( match ) -- break match-ish loop
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) ( match ) -- break match-ish loop
import HsSyn ( OutPat(..), HsLit, HsExpr )
import DsHsSyn ( outPatType )
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index da0392e5c203..010d471bbe98 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -8,8 +8,8 @@
module MatchLit ( matchLiterals ) where
-import Ubiq
-import DsLoop -- break match-ish and dsExpr-ish loops
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs
index cda10ffd639f..bae88366ec96 100644
--- a/ghc/compiler/deforest/DefExpr.lhs
+++ b/ghc/compiler/deforest/DefExpr.lhs
@@ -293,7 +293,7 @@ should an unfolding be required.
> then no_unfold
>
> else case (getIdUnfolding id) of
-> GenForm _ _ expr guidance ->
+> GenForm _ expr guidance ->
> panic "DefExpr:GenForm has changed a little; needs mod here"
> -- SLPJ March 95
>
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index a725c1d6fdbc..5d6667ccae6b 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -10,10 +10,10 @@ Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
module HsBinds where
-import Ubiq
+IMP_Ubiq()
-- friends:
-import HsLoop
+IMPORT_DELOOPER(HsLoop)
import HsMatches ( pprMatches, pprGRHSsAndBinds,
Match, GRHSsAndBinds )
import HsPat ( collectPatBinders, InPat )
diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index aac5fd6136b6..6dd80c18f25d 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -20,7 +20,7 @@ module HsCore (
UnfoldingPrimOp(..), UfCostCentre(..)
) where
-import Ubiq
+IMP_Ubiq()
-- friends:
import HsTypes ( MonoType, PolyType )
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 3bc2b5f9dbec..b4356c7e819b 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -11,10 +11,10 @@ Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
module HsDecls where
-import Ubiq
+IMP_Ubiq()
-- friends:
-import HsLoop ( nullMonoBinds, MonoBinds, Sig )
+IMPORT_DELOOPER(HsLoop) ( nullMonoBinds, MonoBinds, Sig )
import HsPragmas ( DataPragmas, ClassPragmas,
InstancePragmas, ClassOpPragmas
)
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 55709cabdd1d..53bd6720c49d 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -8,8 +8,8 @@
module HsExpr where
-import Ubiq{-uitous-}
-import HsLoop -- for paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(HsLoop) -- for paranoia checking
-- friends:
import HsBinds ( HsBinds )
@@ -84,8 +84,9 @@ data HsExpr tyvar uvar id pat
| HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts
SrcLoc
- | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts
- id id -- Monad and MonadZero dicts
+ | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts
+ id -- id for >>=, types applied
+ id -- id for zero, typed applied
SrcLoc
| ListComp (HsExpr tyvar uvar id pat) -- list comprehension
@@ -278,9 +279,9 @@ pprExpr sty (HsLet binds expr)
ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)]
pprExpr sty (HsDo stmts _)
- = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
+ = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
pprExpr sty (HsDoOut stmts _ _ _)
- = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
+ = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
pprExpr sty (ListComp expr quals)
= ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
@@ -304,8 +305,8 @@ pprExpr sty (RecordUpdOut aexp _ rbinds)
= pp_rbinds sty (pprParendExpr sty aexp) rbinds
pprExpr sty (ExprWithTySig expr sig)
- = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")])
- 4 (ppBeside (ppr sty sig) ppRparen)
+ = ppHang (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::")))
+ 4 (ppr sty sig)
pprExpr sty (ArithSeqIn info)
= ppBracket (ppr sty info)
@@ -421,6 +422,10 @@ data Stmt tyvar uvar id pat
| ExprStmt (HsExpr tyvar uvar id pat)
SrcLoc
| LetStmt (HsBinds tyvar uvar id pat)
+
+ -- Translations; the types are the "a" and "b" types of the monad.
+ | BindStmtOut pat (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar)
+ | ExprStmtOut (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar)
\end{code}
\begin{code}
@@ -433,6 +438,10 @@ instance (NamedThing id, Outputable id, Outputable pat,
= ppCat [ppPStr SLIT("let"), ppr sty binds]
ppr sty (ExprStmt expr _)
= ppr sty expr
+ ppr sty (BindStmtOut pat expr _ _ _)
+ = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
+ ppr sty (ExprStmtOut expr _ _ _)
+ = ppr sty expr
\end{code}
%************************************************************************
diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs
index b1d462da8689..7bdf830d7476 100644
--- a/ghc/compiler/hsSyn/HsImpExp.lhs
+++ b/ghc/compiler/hsSyn/HsImpExp.lhs
@@ -8,8 +8,9 @@
module HsImpExp where
-import Ubiq
+IMP_Ubiq()
+import Name ( pprNonSym )
import Outputable
import PprStyle ( PprStyle(..) )
import Pretty
@@ -33,23 +34,22 @@ data ImportDecl name
\end{code}
\begin{code}
-instance (Outputable name) => Outputable (ImportDecl name) where
+instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) where
ppr sty (ImportDecl mod qual as spec _)
- = ppHang (ppCat [ppStr "import", pp_qual qual, ppPStr mod, pp_as as])
+ = ppHang (ppCat [ppPStr SLIT("import"), pp_qual qual, ppPStr mod, pp_as as])
4 (pp_spec spec)
where
pp_qual False = ppNil
- pp_qual True = ppStr "qualified"
+ pp_qual True = ppPStr SLIT("qualified")
pp_as Nothing = ppNil
- pp_as (Just a) = ppCat [ppStr "as", ppPStr a]
+ pp_as (Just a) = ppBeside (ppPStr SLIT("as ")) (ppPStr a)
pp_spec Nothing = ppNil
pp_spec (Just (False, spec))
- = ppBesides [ppStr "(", interpp'SP sty spec, ppStr ")"]
+ = ppParens (interpp'SP sty spec)
pp_spec (Just (True, spec))
- = ppBesides [ppStr "hiding (", interpp'SP sty spec, ppStr ")"]
-
+ = ppBeside (ppPStr SLIT("hiding ")) (ppParens (interpp'SP sty spec))
\end{code}
%************************************************************************
@@ -67,13 +67,14 @@ data IE name
\end{code}
\begin{code}
-instance (Outputable name) => Outputable (IE name) where
- ppr sty (IEVar var) = ppr sty var
+instance (NamedThing name, Outputable name) => Outputable (IE name) where
+ ppr sty (IEVar var) = pprNonSym sty var
ppr sty (IEThingAbs thing) = ppr sty thing
ppr sty (IEThingAll thing)
= ppBesides [ppr sty thing, ppStr "(..)"]
ppr sty (IEThingWith thing withs)
- = ppBesides [ppr sty thing, ppLparen, ppInterleave ppComma (map (ppr sty) withs), ppRparen]
+ = ppBeside (ppr sty thing)
+ (ppParens (ppInterleave ppComma (map (pprNonSym sty) withs)))
ppr sty (IEModuleContents mod)
= ppBeside (ppPStr SLIT("module ")) (ppPStr mod)
\end{code}
diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs
index f18cde5a67d6..e0f736433a37 100644
--- a/ghc/compiler/hsSyn/HsLit.lhs
+++ b/ghc/compiler/hsSyn/HsLit.lhs
@@ -8,7 +8,8 @@
module HsLit where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ratio(Rational))
import Pretty
\end{code}
diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
index 7c7db36de986..5800e5e62f96 100644
--- a/ghc/compiler/hsSyn/HsMatches.lhs
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -10,9 +10,9 @@ The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
module HsMatches where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-import HsLoop ( HsExpr, nullBinds, HsBinds )
+IMPORT_DELOOPER(HsLoop) ( HsExpr, nullBinds, HsBinds )
import Outputable ( ifPprShowAll )
import PprType ( GenType{-instance Outputable-} )
import Pretty
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 96d308229dc4..5cb26fac2b3f 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -10,21 +10,21 @@ module HsPat (
InPat(..),
OutPat(..),
- unfailablePats, unfailablePat,
+ irrefutablePat, irrefutablePats,
+ failureFreePat,
patsAreAllCons, isConPat,
patsAreAllLits, isLitPat,
- irrefutablePat,
collectPatBinders
) where
-import Ubiq
+IMP_Ubiq()
-- friends:
import HsLit ( HsLit )
-import HsLoop ( HsExpr )
+IMPORT_DELOOPER(HsLoop) ( HsExpr )
-- others:
-import Id ( GenId, dataConSig )
+import Id ( dataConTyCon, GenId )
import Maybes ( maybeToBool )
import Name ( pprSym, pprNonSym )
import Outputable ( interppSP, interpp'SP, ifPprShowAll )
@@ -234,17 +234,36 @@ At least the numeric ones may be overloaded.
A pattern is in {\em exactly one} of the above three categories; `as'
patterns are treated specially, of course.
+The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
\begin{code}
-unfailablePats :: [OutPat a b c] -> Bool
-unfailablePats pat_list = all unfailablePat pat_list
-
-unfailablePat (AsPat _ pat) = unfailablePat pat
-unfailablePat (WildPat _) = True
-unfailablePat (VarPat _) = True
-unfailablePat (LazyPat _) = True
-unfailablePat (DictPat ds ms) = (length ds + length ms) <= 1
-unfailablePat other = False
+irrefutablePats :: [OutPat a b c] -> Bool
+irrefutablePats pat_list = all irrefutablePat pat_list
+
+irrefutablePat (AsPat _ pat) = irrefutablePat pat
+irrefutablePat (WildPat _) = True
+irrefutablePat (VarPat _) = True
+irrefutablePat (LazyPat _) = True
+irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1
+irrefutablePat other = False
+
+failureFreePat :: OutPat a b c -> Bool
+
+failureFreePat (WildPat _) = True
+failureFreePat (VarPat _) = True
+failureFreePat (LazyPat _) = True
+failureFreePat (AsPat _ pat) = failureFreePat pat
+failureFreePat (ConPat con tys pats) = only_con con && all failureFreePat pats
+failureFreePat (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1
+failureFreePat (RecPat con _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
+failureFreePat (ListPat _ _) = False
+failureFreePat (TuplePat pats) = all failureFreePat pats
+failureFreePat (DictPat _ _) = True
+failureFreePat other_pat = False -- Literals, NPat
+
+only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
+\end{code}
+\begin{code}
patsAreAllCons :: [OutPat a b c] -> Bool
patsAreAllCons pat_list = all isConPat pat_list
@@ -266,28 +285,6 @@ isLitPat (NPat _ _ _) = True
isLitPat other = False
\end{code}
-A pattern is irrefutable if a match on it cannot fail
-(at any depth).
-\begin{code}
-irrefutablePat :: OutPat a b c -> Bool
-
-irrefutablePat (WildPat _) = True
-irrefutablePat (VarPat _) = True
-irrefutablePat (LazyPat _) = True
-irrefutablePat (AsPat _ pat) = irrefutablePat pat
-irrefutablePat (ConPat con tys pats) = only_con con && all irrefutablePat pats
-irrefutablePat (ConOpPat pat1 con pat2 _) = only_con con && irrefutablePat pat1 && irrefutablePat pat1
-irrefutablePat (RecPat con _ fields) = only_con con && and [ irrefutablePat pat | (_,pat,_) <- fields ]
-irrefutablePat (ListPat _ _) = False
-irrefutablePat (TuplePat pats) = all irrefutablePat pats
-irrefutablePat (DictPat _ _) = True
-irrefutablePat other_pat = False -- Literals, NPat
-
-only_con con = maybeToBool (maybeTyConSingleCon tycon)
- where
- (_,_,_,tycon) = dataConSig con
-\end{code}
-
This function @collectPatBinders@ works with the ``collectBinders''
functions for @HsBinds@, etc. The order in which the binders are
collected is important; see @HsBinds.lhs@.
diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs
index 59a29b3757f6..876ba1d234ea 100644
--- a/ghc/compiler/hsSyn/HsPragmas.lhs
+++ b/ghc/compiler/hsSyn/HsPragmas.lhs
@@ -16,7 +16,7 @@ for values show up; ditto @SpecInstSig@ (for instances) and
module HsPragmas where
-import Ubiq
+IMP_Ubiq()
-- friends:
import HsCore ( UnfoldingCoreExpr )
diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
index aa4a6bdc9ba0..5e46ea26421e 100644
--- a/ghc/compiler/hsSyn/HsSyn.lhs
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -27,7 +27,7 @@ module HsSyn (
) where
-import Ubiq
+IMP_Ubiq()
-- friends:
import HsBinds
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 945ae656b812..41e552747b8c 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -23,7 +23,7 @@ module HsTypes (
) where
#ifdef COMPILING_GHC
-import Ubiq
+IMP_Ubiq()
import Outputable ( interppSP, ifnotPprForUser )
import Pretty
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index edf7a30c8265..04ae96f18215 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -15,7 +15,7 @@ module ErrUtils (
ghcExit
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Bag ( bagToList )
import PprStyle ( PprStyle(..) )
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 49c9b6999225..c0d47913cd4c 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -8,9 +8,7 @@
module Main ( main ) where
-import Ubiq{-uitous-}
-
-import PreludeGlaST ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} )
+IMP_Ubiq(){-uitous-}
import HsSyn
@@ -37,6 +35,7 @@ import RdrHsSyn ( getRawExportees )
import Specialise ( SpecialiseData(..) )
import StgSyn ( pprPlainStgBinding, GenStgBinding )
import TcInstUtil ( InstInfo )
+import TyCon ( isDataTyCon )
import UniqSupply ( mkSplitUniqSupply )
import PprAbsC ( dumpRealC, writeRealC )
@@ -65,7 +64,7 @@ main
doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
- = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.01, for Haskell 1.3" "" >>
+ = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >>
-- ******* READER
show_pass "Reader" >>
@@ -159,8 +158,8 @@ doIt (core_cmds, stg_cmds) input_pgm
case tc_results
of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
- interface_stuff,
- (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) ->
+ interface_stuff@(_,local_tycons,_,_),
+ pragma_tycon_specs, ddump_deriv) ->
doDump opt_D_dump_tc "Typechecked:"
(pp_show (ppAboves [
@@ -198,8 +197,11 @@ doIt (core_cmds, stg_cmds) input_pgm
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
show_pass "Core2Core" >>
_scc_ "Core2Core"
+ let
+ local_data_tycons = filter isDataTyCon local_tycons
+ in
core2core core_cmds mod_name pprStyle
- sm_uniqs local_tycons pragma_tycon_specs desugared
+ sm_uniqs local_data_tycons pragma_tycon_specs desugared
>>=
\ (simplified, inlinings_env,
@@ -312,15 +314,9 @@ doIt (core_cmds, stg_cmds) input_pgm
= case switch of
Nothing -> return ()
Just fname ->
- fopen fname "a+" `thenPrimIO` \ file ->
- if (file == ``NULL'') then
- error ("doOutput: failed to open:"++fname)
- else
- io_action file >>= \ () ->
- fclose file `thenPrimIO` \ status ->
- if status == 0
- then return ()
- else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
+ openFile fname WriteMode >>= \ handle ->
+ io_action handle >>
+ hClose handle
doDump switch hdr string
= if switch
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index ce876cb1b231..8083b8d89145 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -18,7 +18,7 @@ module MkIface (
ifacePragmas
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Bag ( emptyBag, snocBag, bagToList )
import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
@@ -26,7 +26,7 @@ import CmdLineOpts ( opt_ProduceHi )
import FieldLabel ( FieldLabel{-instance NamedThing-} )
import FiniteMap ( fmToList )
import HsSyn
-import Id ( idType, dataConSig, dataConFieldLabels,
+import Id ( idType, dataConRawArgTys, dataConFieldLabels,
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
@@ -60,6 +60,7 @@ ppr_name n
pp = prettyToUn (ppr PprInterface on)
in
(if isLexSym s then uppParens else id) pp
+{-OLD:
ppr_unq_name n
= let
on = origName n
@@ -67,6 +68,7 @@ ppr_unq_name n
pp = uppPStr s
in
(if isLexSym s then uppParens else id) pp
+-}
\end{code}
We have a function @startIface@ to open the output file and put
@@ -144,7 +146,7 @@ ifaceUsages (Just if_hdl) usages
upp_versions (fmToList versions), uppSemi]
upp_versions nvs
- = uppIntersperse upp'SP{-'-} [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ]
+ = uppIntersperse uppSP [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ]
\end{code}
\begin{code}
@@ -256,14 +258,13 @@ ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
ifaceDecls Nothing{-no iface handle-} _ = return ()
ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
- = let
- togo_classes = [ c | c <- classes, isLocallyDefined c ]
- togo_tycons = [ t | t <- tycons, isLocallyDefined t ]
- togo_vals = [ v | v <- vals, isLocallyDefined v ]
-
- sorted_classes = sortLt ltLexical togo_classes
- sorted_tycons = sortLt ltLexical togo_tycons
- sorted_vals = sortLt ltLexical togo_vals
+ = ASSERT(all isLocallyDefined vals)
+ ASSERT(all isLocallyDefined tycons)
+ ASSERT(all isLocallyDefined classes)
+ let
+ sorted_classes = sortLt ltLexical classes
+ sorted_tycons = sortLt ltLexical tycons
+ sorted_vals = sortLt ltLexical vals
in
if (null sorted_classes && null sorted_tycons && null sorted_vals) then
-- You could have a module with just instances in it
@@ -365,7 +366,7 @@ ppr_tycon tycon
ppr_tc (initNmbr (nmbrTyCon tycon))
------------------------
-ppr_tc (PrimTyCon _ n _)
+ppr_tc (PrimTyCon _ n _ _)
= uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
ppr_tc FunTyCon
@@ -386,7 +387,7 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
ppr_context ctxt,
ppr_name n,
uppIntersperse uppSP (map ppr_tyvar tvs),
- pp_unabstract_condecls,
+ uppEquals, pp_condecls,
uppSemi]
-- NB: we do not print deriving info in interfaces
where
@@ -401,16 +402,6 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
uppRparen, uppPStr SLIT(" =>")]
- yes_we_print_condecls
- = case (getExportFlag n) of
- ExportAbs -> False
- other -> True
-
- pp_unabstract_condecls
- = if yes_we_print_condecls
- then uppCat [uppEquals, pp_condecls]
- else uppNil
-
pp_condecls
= let
(c:cs) = cons
@@ -421,11 +412,11 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
ppr_con con
= let
- (_, _, con_arg_tys, _) = dataConSig con
+ con_arg_tys = dataConRawArgTys con
labels = dataConFieldLabels con -- none if not a record
strict_marks = dataConStrictMarks con
in
- uppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
+ uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys]
ppr_fields labels strict_marks con_arg_tys
= if null labels then -- not a record thingy
@@ -440,7 +431,7 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
(prettyToUn (pprParendType PprInterface t))
ppr_field l b t
- = uppBesides [ppr_unq_name l, uppPStr SLIT(" :: "),
+ = uppBesides [ppr_name l, uppPStr SLIT(" :: "),
case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },
ppr_ty t]
\end{code}
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 90863433d388..830e450dfcf3 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -7,7 +7,7 @@
module AbsCStixGen ( genCodeAbstractC ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
import Stix
@@ -33,6 +33,10 @@ import StixMacro ( macroCode )
import StixPrim ( primCode, amodeToStix, amodeToStix' )
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) )
import Util ( naturalMergeSortLe, panic )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
\end{code}
For each independent chunk of AbstractC code, we generate a list of
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index ac259c4feaf5..090e13fc6877 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -7,7 +7,7 @@
module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import MachMisc
import MachRegs
@@ -23,7 +23,7 @@ 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(..) )
+import Unpretty ( uppPutStr, uppShow, uppAboves, Unpretty(..) )
\end{code}
The 96/03 native-code generator has machine-independent and
@@ -73,10 +73,10 @@ The machine-dependent bits break down as follows:
So, here we go:
\begin{code}
-writeRealAsm :: _FILE -> AbstractC -> UniqSupply -> IO ()
+writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO ()
-writeRealAsm file absC us
- = uppAppendFile file 80 (runNCG absC us)
+writeRealAsm handle absC us
+ = uppPutStr handle 80 (runNCG absC us)
dumpRealAsm :: AbstractC -> UniqSupply -> String
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 6f8df0b713d5..00d5d79e5682 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -8,13 +8,14 @@
module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import MachCode ( InstrList(..) )
import MachMisc ( Instr )
import MachRegs
import RegAllocInfo
+import AbsCSyn ( MagicId )
import BitSet ( BitSet )
import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
import Maybes ( maybeToBool )
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 25d9be3f15ad..c9b671ebd6fb 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -14,7 +14,7 @@ structure should not be too overwhelming.
module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
-import Ubiq{-uitious-}
+IMP_Ubiq(){-uitious-}
import MachMisc -- may differ per-platform
import MachRegs
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index 237b3343f18b..54f761601d21 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -41,9 +41,9 @@ module MachMisc (
#endif
) where
-import Ubiq{-uitous-}
-import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia
-import NcgLoop ( underscorePrefix, fmtAsmLbl ) -- paranoia
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia
+IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) -- paranoia
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index 32159f1dc986..7493de4e9f8a 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -59,7 +59,7 @@ module MachRegs (
#endif
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
@@ -331,16 +331,19 @@ 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 Ord3 Reg where
+ cmp = cmpReg
+
instance Eq Reg where
- a == b = case cmpReg a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpReg a b of { EQ_ -> False; _ -> True }
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` 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 }
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
instance Uniquable Reg where
uniqueOf (UnmappedReg u _) = u
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index 65a5edc09211..3d4d67954df2 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -13,11 +13,12 @@ We start with the @pprXXX@s with some cross-platform commonality
module PprMach ( pprInstr ) where
-import Ubiq{-uitious-}
+IMP_Ubiq(){-uitious-}
import MachRegs -- may differ per-platform
import MachMisc
+import AbsCSyn ( MagicId )
import CLabel ( pprCLabel_asm, externallyVisibleCLabel )
import CStrings ( charToC )
import Maybes ( maybeToBool )
@@ -214,8 +215,8 @@ pprSize x = uppPStr (case x of
#endif
#if sparc_TARGET_ARCH
B -> SLIT("sb")
+ BU -> SLIT("ub")
-- HW -> SLIT("hw") UNUSED
--- BU -> SLIT("ub") UNUSED
-- HWU -> SLIT("uhw") UNUSED
W -> SLIT("")
F -> SLIT("")
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 93cda5c3a1a0..e650837176f8 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -51,12 +51,13 @@ module RegAllocInfo (
freeRegSet
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import MachMisc
import MachRegs
import MachCode ( InstrList(..) )
+import AbsCSyn ( MagicId )
import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet )
import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} )
import FiniteMap ( addToFM, lookupFM )
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index f187e9fe1d79..2dd8169c5594 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -15,7 +15,7 @@ module Stix (
getUniqLabelNCG
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn ( node, infoptr, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs
index 82b88c67608f..9afcec5480e3 100644
--- a/ghc/compiler/nativeGen/StixInfo.lhs
+++ b/ghc/compiler/nativeGen/StixInfo.lhs
@@ -7,7 +7,7 @@
module StixInfo ( genCodeInfoTable ) where
-import Ubiq{-uitious-}
+IMP_Ubiq(){-uitious-}
import AbsCSyn ( AbstractC(..), CAddrMode, ReturnInfo,
RegRelative, MagicId, CStmtMacro
diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index fe9ec744e88a..5c90139f2c19 100644
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -11,8 +11,8 @@ module StixInteger (
encodeFloatingKind, decodeFloatingKind
) where
-import Ubiq{-uitous-}
-import NcgLoop ( amodeToStix )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
import MachMisc
import MachRegs
diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 4e7b47f8a0df..62c5f9762af8 100644
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -7,8 +7,8 @@
module StixMacro ( macroCode, heapCheck ) where
-import Ubiq{-uitious-}
-import NcgLoop ( amodeToStix )
+IMP_Ubiq(){-uitious-}
+IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
import MachMisc
import MachRegs
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 01b0404176b8..c986b3117b37 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -7,8 +7,8 @@
module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
-import Ubiq{-uitous-}
-import NcgLoop -- paranoia checking only
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(NcgLoop) -- paranoia checking only
import MachMisc
import MachRegs
@@ -32,6 +32,10 @@ import StixInteger {- everything -}
import UniqSupply ( returnUs, thenUs, UniqSM(..) )
import Unpretty ( uppBeside, uppPStr, uppInt )
import Util ( panic )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
\end{code}
The main honcho here is primCode, which handles the guts of COpStmts.
diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs
index 9bb3e80a7516..d6ebf181e7d7 100644
--- a/ghc/compiler/parser/UgenAll.lhs
+++ b/ghc/compiler/parser/UgenAll.lhs
@@ -1,6 +1,8 @@
Stuff the Ugenny things show to the parser.
\begin{code}
+#include "HsVersions.h"
+
module UgenAll (
-- re-exported Prelude stuff
returnUgn, thenUgn,
@@ -25,7 +27,7 @@ module UgenAll (
import PreludeGlaST
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- friends:
import U_binding
diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs
index 860c33be3da6..a432c3cf8fa3 100644
--- a/ghc/compiler/parser/UgenUtil.lhs
+++ b/ghc/compiler/parser/UgenUtil.lhs
@@ -14,7 +14,7 @@ module UgenUtil (
import PreludeGlaST
-import Ubiq
+IMP_Ubiq()
import Name ( RdrName(..) )
import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc )
diff --git a/ghc/compiler/parser/binding.ugn b/ghc/compiler/parser/binding.ugn
index 3b130aedae52..b03ba07394ec 100644
--- a/ghc/compiler/parser/binding.ugn
+++ b/ghc/compiler/parser/binding.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_binding where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_constr
diff --git a/ghc/compiler/parser/constr.ugn b/ghc/compiler/parser/constr.ugn
index e2d37336cf3a..30cd4381212c 100644
--- a/ghc/compiler/parser/constr.ugn
+++ b/ghc/compiler/parser/constr.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_constr where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_maybe
diff --git a/ghc/compiler/parser/either.ugn b/ghc/compiler/parser/either.ugn
index a75acf94cb75..f59778cdbaaa 100644
--- a/ghc/compiler/parser/either.ugn
+++ b/ghc/compiler/parser/either.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_either where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type either;
diff --git a/ghc/compiler/parser/entidt.ugn b/ghc/compiler/parser/entidt.ugn
index eb661c0c73cb..6ae01e2dc46b 100644
--- a/ghc/compiler/parser/entidt.ugn
+++ b/ghc/compiler/parser/entidt.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_entidt where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_list
diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex
index f66949f0a24a..d5c187e05f6e 100644
--- a/ghc/compiler/parser/hslexer.flex
+++ b/ghc/compiler/parser/hslexer.flex
@@ -240,7 +240,7 @@ O [0-7]
H [0-9A-Fa-f]
N {D}+
F {N}"."{N}(("e"|"E")("+"|"-")?{N})?
-S [!#$%&*+./<=>?@\\^|-~:\xa1-\xbf\xd7\xf7]
+S [!#$%&*+./<=>?@\\^|\-~:\xa1-\xbf\xd7\xf7]
SId {S}{S}*
L [A-Z\xc0-\xd6\xd8-\xde]
l [a-z\xdf-\xf6\xf8-\xff]
@@ -304,8 +304,13 @@ NL [\n\r]
PUSH_STATE(UserPragma);
RETURN(DEFOREST_UPRAGMA);
}
+<Code,GlaExt>"{-#"{WS}*"GENERATE_SPECS" {
+ /* these are handled by hscpp */
+ nested_comments =1;
+ PUSH_STATE(Comment);
+ }
<Code,GlaExt>"{-#"{WS}*[A-Z_]+ {
- fprintf(stderr, "Warning: \"%s\", line %d: Unrecognised pragma '",
+ fprintf(stderr, "\"%s\", line %d: Warning: Unrecognised pragma '",
input_filename, hsplineno);
format_string(stderr, (unsigned char *) yytext, yyleng);
fputs("'\n", stderr);
@@ -888,8 +893,6 @@ NL [\n\r]
This allows unnamed sources to be piped into the parser.
*/
-extern BOOLEAN acceptPrim;
-
void
yyinit(void)
{
@@ -899,7 +902,7 @@ yyinit(void)
setyyin _before_ calling yylex for the first time! */
yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE));
- if (acceptPrim)
+ if (nonstandardFlag)
PUSH_STATE(GlaExt);
else
PUSH_STATE(Code);
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index 50ba88fd23e3..930f6d50d069 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -258,7 +258,7 @@ BOOLEAN inpat;
qvarid qconid qvarsym qconsym
qvar qcon qvarop qconop qop
qvark qconk qtycon qtycls
- gcon gconk gtycon qop1 qvarop1
+ gcon gconk gtycon itycon qop1 qvarop1
ename iname
%type <ubinding> topdecl topdecls letdecls
@@ -400,10 +400,16 @@ import_list:
;
import : var { $$ = mkentid(mknoqual($1)); }
- | tycon { $$ = mkenttype(mknoqual($1)); }
- | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall(mknoqual($1)); }
- | tycon OPAREN CPAREN { $$ = mkenttypenamed(mknoqual($1),Lnil); }
- | tycon OPAREN inames CPAREN { $$ = mkenttypenamed(mknoqual($1),$3); }
+ | itycon { $$ = mkenttype($1); }
+ | itycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
+ | itycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil);}
+ | itycon OPAREN inames CPAREN { $$ = mkenttypenamed($1,$3); }
+ ;
+
+itycon : tycon { $$ = mknoqual($1); }
+ | OBRACK CBRACK { $$ = creategid(-1); }
+ | OPAREN CPAREN { $$ = creategid(0); }
+ | OPAREN commas CPAREN { $$ = creategid($2); }
;
inames : iname { $$ = lsing($1); }
diff --git a/ghc/compiler/parser/list.ugn b/ghc/compiler/parser/list.ugn
index 6ffd8920c63c..b6c5908e1509 100644
--- a/ghc/compiler/parser/list.ugn
+++ b/ghc/compiler/parser/list.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_list where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type list;
diff --git a/ghc/compiler/parser/literal.ugn b/ghc/compiler/parser/literal.ugn
index fea4048ac3ff..49c68b0803d5 100644
--- a/ghc/compiler/parser/literal.ugn
+++ b/ghc/compiler/parser/literal.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_literal where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type literal;
diff --git a/ghc/compiler/parser/maybe.ugn b/ghc/compiler/parser/maybe.ugn
index a9120832c1f7..cfcf95913120 100644
--- a/ghc/compiler/parser/maybe.ugn
+++ b/ghc/compiler/parser/maybe.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_maybe where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type maybe;
diff --git a/ghc/compiler/parser/pbinding.ugn b/ghc/compiler/parser/pbinding.ugn
index 2700417e5a41..f695eac81139 100644
--- a/ghc/compiler/parser/pbinding.ugn
+++ b/ghc/compiler/parser/pbinding.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_pbinding where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_constr ( U_constr ) -- interface only
diff --git a/ghc/compiler/parser/qid.ugn b/ghc/compiler/parser/qid.ugn
index f42d5072a696..4ecd7cf3707d 100644
--- a/ghc/compiler/parser/qid.ugn
+++ b/ghc/compiler/parser/qid.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_qid where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type qid;
diff --git a/ghc/compiler/parser/tree.ugn b/ghc/compiler/parser/tree.ugn
index fb69ec100cc2..86c5174c781d 100644
--- a/ghc/compiler/parser/tree.ugn
+++ b/ghc/compiler/parser/tree.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_tree where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_constr ( U_constr ) -- interface only
diff --git a/ghc/compiler/parser/ttype.ugn b/ghc/compiler/parser/ttype.ugn
index f548b3201e1e..25d451393fc1 100644
--- a/ghc/compiler/parser/ttype.ugn
+++ b/ghc/compiler/parser/ttype.ugn
@@ -2,8 +2,10 @@
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_ttype where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_list
diff --git a/ghc/compiler/parser/util.c b/ghc/compiler/parser/util.c
index f8ebc57c09ab..e07cf7dc3c5f 100644
--- a/ghc/compiler/parser/util.c
+++ b/ghc/compiler/parser/util.c
@@ -10,24 +10,18 @@
#include "constants.h"
#include "utils.h"
-#define PARSER_VERSION "1.3-???"
+#define PARSER_VERSION "2.01 (Haskell 1.3)"
tree root; /* The root of the built syntax tree. */
list Lnil;
BOOLEAN nonstandardFlag = FALSE; /* Set if non-std Haskell extensions to be used. */
-BOOLEAN acceptPrim = FALSE; /* Set if Int#, etc., may be used */
BOOLEAN haskell1_2Flag = FALSE; /* Set if we are compiling for 1.2 */
BOOLEAN etags = FALSE; /* Set if we're parsing only to produce tags. */
BOOLEAN hashIds = FALSE; /* Set if Identifiers should be hashed. */
BOOLEAN ignoreSCC = TRUE; /* Set if we ignore/filter scc expressions. */
-static BOOLEAN verbose = FALSE; /* Set for verbose messages. */
-
-/* Forward decls */
-static void who_am_i PROTO((void));
-
/**********************************************************************
* *
* *
@@ -48,8 +42,6 @@ process_args(argc,argv)
{
BOOLEAN keep_munging_option = FALSE;
- argc--, argv++;
-
while (argc > 0 && argv[0][0] == '-') {
keep_munging_option = TRUE;
@@ -57,14 +49,8 @@ process_args(argc,argv)
while (keep_munging_option && *++*argv != '\0') {
switch(**argv) {
- case 'v':
- who_am_i(); /* identify myself */
- verbose = TRUE;
- break;
-
case 'N':
nonstandardFlag = TRUE;
- acceptPrim = TRUE;
break;
case '2':
@@ -106,12 +92,6 @@ process_args(argc,argv)
fprintf(stderr, "Cannot open %s.\n", argv[1]);
exit(1);
}
-
- if (verbose) {
- fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size);
- if(acceptPrim)
- fprintf(stderr,"Allowing special syntax for Unboxed Values\n");
- }
}
void
@@ -122,12 +102,6 @@ error(s)
exit(1);
}
-static void
-who_am_i(void)
-{
- fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION);
-}
-
list
lconc(l1, l2)
list l1;
diff --git a/ghc/compiler/parser/utils.h b/ghc/compiler/parser/utils.h
index 816304c91385..c4f60a9e75c5 100644
--- a/ghc/compiler/parser/utils.h
+++ b/ghc/compiler/parser/utils.h
@@ -12,7 +12,6 @@ extern list all;
extern BOOLEAN nonstandardFlag;
extern BOOLEAN hashIds;
-extern BOOLEAN acceptPrim;
extern BOOLEAN etags;
extern BOOLEAN ignoreSCC;
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 95af63e27c9e..ccefcf3638ce 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -15,8 +15,8 @@ module PrelInfo (
maybeCharLikeTyCon, maybeIntLikeTyCon
) where
-import Ubiq
-import PrelLoop ( primOpNameInfo )
+IMP_Ubiq()
+IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo )
-- friends:
import PrelMods -- Prelude module names
@@ -119,8 +119,7 @@ builtinNameInfo
-- tycons
map pcTyConWiredInInfo prim_tycons,
map pcTyConWiredInInfo g_tycons,
- map pcTyConWiredInInfo data_tycons,
- map pcTyConWiredInInfo synonym_tycons
+ map pcTyConWiredInInfo data_tycons
]
assoc_keys
@@ -174,13 +173,11 @@ g_con_tycons
min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
= [ boolTyCon
- , orderingTyCon
, charTyCon
, intTyCon
, floatTyCon
, doubleTyCon
, integerTyCon
- , ratioTyCon
, liftTyCon
, return2GMPsTyCon -- ADR asked for these last two (WDP 94/11)
, returnIntAndGMPTyCon
@@ -191,16 +188,16 @@ data_tycons
= [ addrTyCon
, boolTyCon
, charTyCon
- , orderingTyCon
, doubleTyCon
, floatTyCon
+ , foreignObjTyCon
, intTyCon
, integerTyCon
, liftTyCon
- , foreignObjTyCon
- , ratioTyCon
+ , primIoTyCon
, return2GMPsTyCon
, returnIntAndGMPTyCon
+ , stTyCon
, stablePtrTyCon
, stateAndAddrPrimTyCon
, stateAndArrayPrimTyCon
@@ -208,24 +205,17 @@ data_tycons
, stateAndCharPrimTyCon
, stateAndDoublePrimTyCon
, stateAndFloatPrimTyCon
- , stateAndIntPrimTyCon
, stateAndForeignObjPrimTyCon
+ , stateAndIntPrimTyCon
, stateAndMutableArrayPrimTyCon
, stateAndMutableByteArrayPrimTyCon
- , stateAndSynchVarPrimTyCon
, stateAndPtrPrimTyCon
, stateAndStablePtrPrimTyCon
+ , stateAndSynchVarPrimTyCon
, stateAndWordPrimTyCon
, stateTyCon
, wordTyCon
]
-
-synonym_tycons
- = [ primIoTyCon
- , rationalTyCon
- , stTyCon
- , stringTyCon
- ]
\end{code}
The WiredIn Ids ...
@@ -318,12 +308,28 @@ For the Ids we may also have some builtin IdInfo.
\begin{code}
id_keys_infos :: [((FAST_STRING,Module), Unique, Maybe IdInfo)]
id_keys_infos
- = [ ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing)
+ = [ -- here so we can check the type of main/mainPrimIO
+ ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing)
, ((SLIT("mainPrimIO"),SLIT("Main")), mainPrimIOIdKey, Nothing)
+
+ -- here because we use them in derived instances
+ , ((SLIT("&&"), pRELUDE), andandIdKey, Nothing)
+ , ((SLIT("."), pRELUDE), composeIdKey, Nothing)
+ , ((SLIT("lex"), pRELUDE), lexIdKey, Nothing)
+ , ((SLIT("not"), pRELUDE), notIdKey, Nothing)
+ , ((SLIT("readParen"), pRELUDE), readParenIdKey, Nothing)
+ , ((SLIT("showParen"), pRELUDE), showParenIdKey, Nothing)
+ , ((SLIT("showString"), pRELUDE), showStringIdKey,Nothing)
+ , ((SLIT("__readList"), pRELUDE), ureadListIdKey, Nothing)
+ , ((SLIT("__showList"), pRELUDE), ushowListIdKey, Nothing)
+ , ((SLIT("__showSpace"), pRELUDE), showSpaceIdKey, Nothing)
]
tysyn_keys
- = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon))
+ = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon))
+ , ((SLIT("Rational"),rATIO), (rationalTyConKey, RnImplicitTyCon))
+ , ((SLIT("Ratio"),rATIO), (ratioTyConKey, RnImplicitTyCon))
+ , ((SLIT("Ordering"),pRELUDE), (orderingTyConKey, RnImplicitTyCon))
]
-- this "class_keys" list *must* include:
@@ -351,8 +357,8 @@ class_keys
, ((SLIT("MonadZero"),pRELUDE), monadZeroClassKey)
, ((SLIT("MonadPlus"),pRELUDE), monadPlusClassKey)
, ((SLIT("Functor"),pRELUDE), functorClassKey)
- , ((SLIT("CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish
- , ((SLIT("CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish
+ , ((SLIT("_CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish
+ , ((SLIT("_CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish
]]
class_op_keys
@@ -365,6 +371,8 @@ class_op_keys
, ((SLIT("enumFromTo"),pRELUDE), enumFromToClassOpKey)
, ((SLIT("enumFromThenTo"),pRELUDE),enumFromThenToClassOpKey)
, ((SLIT("=="),pRELUDE), eqClassOpKey)
+ , ((SLIT(">>="),pRELUDE), thenMClassOpKey)
+ , ((SLIT("zero"),pRELUDE), zeroClassOpKey)
]]
\end{code}
diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs
index 17bef6a65b29..da5b7118ce8b 100644
--- a/ghc/compiler/prelude/PrelMods.lhs
+++ b/ghc/compiler/prelude/PrelMods.lhs
@@ -40,4 +40,7 @@ iX = SLIT("Ix")
fromPrelude :: FAST_STRING -> Bool
fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude"))
+ where
+ substr str beg end
+ = take (end - beg + 1) (drop beg str)
\end{code}
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index 0ce975e5ef67..9ae53002c9f4 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -8,10 +8,10 @@
module PrelVals where
-import Ubiq
-import IdLoop ( UnfoldingGuidance(..) )
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..) )
import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals )
-import PrelLoop
+IMPORT_DELOOPER(PrelLoop)
-- friends:
import PrelMods
@@ -24,7 +24,7 @@ import IdInfo -- quite a bit
import Literal ( mkMachInt )
import PrimOp ( PrimOp(..) )
import SpecEnv ( SpecEnv(..), nullSpecEnv )
-import TyVar ( alphaTyVar, betaTyVar, gammaTyVar )
+import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
import Unique -- lots of *Keys
import Util ( panic )
\end{code}
@@ -97,7 +97,7 @@ pAR_ERROR_ID
(mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
errorTy :: Type
-errorTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
+errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
\end{code}
We want \tr{_trace} (NB: name not in user namespace) to be wired in
@@ -481,16 +481,12 @@ lex :: ReadS String
%************************************************************************
%* *
-\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
+\subsection[PrelVals-void]{@void@: Magic value of type @Void@}
%* *
%************************************************************************
-I don't think this is available to the user; it's used in the
-simplifier (WDP 94/06).
\begin{code}
-voidPrimId
- = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#")
- voidPrimTy noIdInfo
+voidId = pcMiscPrelId voidIdKey pRELUDE_BUILTIN SLIT("_void") voidTy noIdInfo
\end{code}
%************************************************************************
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index d02f5e19a74b..6527a7e62b98 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -29,7 +29,7 @@ module PrimOp (
pprPrimOp, showPrimOp
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import PrimRep -- most of it
import TysPrim
@@ -38,7 +38,7 @@ import TysWiredIn
import CStrings ( identToC )
import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize )
-import PprStyle ( codeStyle )
+import PprStyle ( codeStyle, PprStyle(..){-ToDo:rm-} )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
@@ -1310,6 +1310,12 @@ primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a
primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
= AlgResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [alphaTy,betaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] liftTyCon [gammaTy]
+
+primOpInfo CopyableOp -- copyable# :: a -> a
+ = AlgResult SLIT("copyable#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+
+primOpInfo NoFollowOp -- noFollow# :: a -> a
+ = AlgResult SLIT("noFollow#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
\end{code}
%************************************************************************
@@ -1335,8 +1341,12 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
primOpInfo (CCallOp _ _ _ arg_tys result_ty)
= AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
- (result_tycon, tys_applied, _) = _trace "PrimOp.getAppDataTyConExpandingDicts" $
+ (result_tycon, tys_applied, _) = -- _trace "PrimOp.getAppDataTyConExpandingDicts" $
getAppDataTyConExpandingDicts result_ty
+
+#ifdef DEBUG
+primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op)))
+#endif
\end{code}
%************************************************************************
diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs
index 1a6d45e5e138..94ab0c50f2f7 100644
--- a/ghc/compiler/prelude/PrimRep.lhs
+++ b/ghc/compiler/prelude/PrimRep.lhs
@@ -19,7 +19,7 @@ module PrimRep (
guessPrimRep
) where
-import Ubiq
+IMP_Ubiq()
import Pretty -- pretty-printing code
import Util
@@ -65,7 +65,6 @@ data PrimRep
-- (Primitive states are mapped onto this)
deriving (Eq, Ord)
-- Kinds are used in PrimTyCons, which need both Eq and Ord
- -- Text is needed for derived-Text on PrimitiveOps
\end{code}
%************************************************************************
diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index 28b457121928..876048f4d9ce 100644
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -11,9 +11,9 @@ types and operations.''
module TysPrim where
-import Ubiq
+IMP_Ubiq(){-uitous-}
-import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind )
+import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import Name ( mkBuiltinName )
import PrelMods ( pRELUDE_BUILTIN )
import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
@@ -38,31 +38,34 @@ alphaTys = mkTyVarTys alphaTyVars
\begin{code}
-- only used herein
-pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING
- -> Int -> ([PrimRep] -> PrimRep) -> TyCon
-pcPrimTyCon key str arity{-UNUSED-} kind_fn{-UNUSED-}
- = mkPrimTyCon name mkUnboxedTypeKind
+pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon
+
+pcPrimTyCon key str arity primrep
+ = mkPrimTyCon name (mk_kind arity) primrep
where
name = mkBuiltinName key pRELUDE_BUILTIN str
+ mk_kind 0 = mkUnboxedTypeKind
+ mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1)
+
charPrimTy = applyTyCon charPrimTyCon []
-charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 (\ [] -> CharRep)
+charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 CharRep
intPrimTy = applyTyCon intPrimTyCon []
-intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 (\ [] -> IntRep)
+intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 IntRep
wordPrimTy = applyTyCon wordPrimTyCon []
-wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 (\ [] -> WordRep)
+wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 WordRep
addrPrimTy = applyTyCon addrPrimTyCon []
-addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 (\ [] -> AddrRep)
+addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 AddrRep
floatPrimTy = applyTyCon floatPrimTyCon []
-floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 (\ [] -> FloatRep)
+floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 FloatRep
doublePrimTy = applyTyCon doublePrimTyCon []
-doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 (\ [] -> DoubleRep)
+doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 DoubleRep
\end{code}
@PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need
@@ -85,32 +88,29 @@ getPrimRepInfo DoubleRep = ("Double", doublePrimTy, doublePrimTyCon)
%************************************************************************
%* *
-\subsection[TysPrim-void]{The @Void#@ type}
+\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)}
%* *
%************************************************************************
-Very similar to the @State#@ type.
-\begin{code}
-voidPrimTy = applyTyCon voidPrimTyCon []
- where
- voidPrimTyCon = pcPrimTyCon voidPrimTyConKey SLIT("Void#") 0
- (\ [] -> VoidRep)
-\end{code}
+State# is the primitive, unboxed type of states. It has one type parameter,
+thus
+ State# RealWorld
+or
+ State# s
-%************************************************************************
-%* *
-\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)}
-%* *
-%************************************************************************
+where s is a type variable. The only purpose of the type parameter is to
+keep different state threads separate. It is represented by nothing at all.
\begin{code}
mkStatePrimTy ty = applyTyCon statePrimTyCon [ty]
-statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1
- (\ [s_kind] -> VoidRep)
+statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 VoidRep
\end{code}
@_RealWorld@ is deeply magical. It {\em is primitive}, but it
{\em is not unboxed}.
+We never manipulate values of type RealWorld; it's only used in the type
+system, to parameterise State#.
+
\begin{code}
realWorldTy = applyTyCon realWorldTyCon []
realWorldTyCon
@@ -136,17 +136,13 @@ defined in \tr{TysWiredIn.lhs}, not here.
%************************************************************************
\begin{code}
-arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1
- (\ [elt_kind] -> ArrayRep)
+arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1 ArrayRep
-byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0
- (\ [] -> ByteArrayRep)
+byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0 ByteArrayRep
-mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2
- (\ [s_kind, elt_kind] -> ArrayRep)
+mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2 ArrayRep
-mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1
- (\ [s_kind] -> ByteArrayRep)
+mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1 ByteArrayRep
mkArrayPrimTy elt = applyTyCon arrayPrimTyCon [elt]
byteArrayPrimTy = applyTyCon byteArrayPrimTyCon []
@@ -161,8 +157,7 @@ mkMutableByteArrayPrimTy s = applyTyCon mutableByteArrayPrimTyCon [s]
%************************************************************************
\begin{code}
-synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2
- (\ [s_kind, elt_kind] -> PtrRep)
+synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2 PtrRep
mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt]
\end{code}
@@ -174,8 +169,7 @@ mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt]
%************************************************************************
\begin{code}
-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1
- (\ [elt_kind] -> StablePtrRep)
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1 StablePtrRep
mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty]
\end{code}
@@ -202,6 +196,5 @@ could possibly be added?)
\begin{code}
foreignObjPrimTy = applyTyCon foreignObjPrimTyCon []
-foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0
- (\ [] -> ForeignObjRep)
+foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 ForeignObjRep
\end{code}
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index a4623c2fd219..04b3e4996e74 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -25,13 +25,11 @@ module TysWiredIn (
doubleDataCon,
doubleTy,
doubleTyCon,
- eqDataCon,
falseDataCon,
floatDataCon,
floatTy,
floatTyCon,
getStatePairingConInfo,
- gtDataCon,
intDataCon,
intTy,
intTyCon,
@@ -41,7 +39,6 @@ module TysWiredIn (
liftDataCon,
liftTyCon,
listTyCon,
- ltDataCon,
foreignObjTyCon,
mkLiftTy,
mkListTy,
@@ -49,13 +46,7 @@ module TysWiredIn (
mkStateTransformerTy,
mkTupleTy,
nilDataCon,
- orderingTy,
- orderingTyCon,
primIoTyCon,
- ratioDataCon,
- ratioTyCon,
- rationalTy,
- rationalTyCon,
realWorldStateTy,
return2GMPsTyCon,
returnIntAndGMPTyCon,
@@ -78,7 +69,6 @@ module TysWiredIn (
stateDataCon,
stateTyCon,
stringTy,
- stringTyCon,
trueDataCon,
unitTy,
voidTy, voidTyCon,
@@ -95,8 +85,8 @@ module TysWiredIn (
--import PprStyle
--import Kind
-import Ubiq
-import TyLoop ( mkDataCon, StrictnessMark(..) )
+IMP_Ubiq()
+IMPORT_DELOOPER(TyLoop) ( mkDataCon, StrictnessMark(..) )
-- friends:
import PrelMods
@@ -110,8 +100,8 @@ import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
NewOrData(..), TyCon
)
-import Type ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy,
- mkFunTys, maybeAppDataTyConExpandingDicts,
+import Type ( mkTyConTy, applyTyCon, mkSigmaTy,
+ mkFunTys, maybeAppTyCon,
GenType(..), ThetaType(..), TauType(..) )
import TyVar ( tyVarKind, alphaTyVar, betaTyVar )
import Unique
@@ -122,12 +112,21 @@ addOneToSpecEnv = error "TysWiredIn:addOneToSpecEnv = "
pc_gen_specs = error "TysWiredIn:pc_gen_specs "
mkSpecInfo = error "TysWiredIn:SpecInfo"
-pcDataTyCon :: Unique{-TyConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> [Id] -> TyCon
-pcDataTyCon key mod str tyvars cons
+alpha_tyvar = [alphaTyVar]
+alpha_ty = [alphaTy]
+alpha_beta_tyvars = [alphaTyVar, betaTyVar]
+
+pcDataTyCon, pcNewTyCon
+ :: Unique{-TyConKey-} -> Module -> FAST_STRING
+ -> [TyVar] -> [Id] -> TyCon
+
+pcDataTyCon = pc_tycon DataType
+pcNewTyCon = pc_tycon NewType
+
+pc_tycon new_or_data key mod str tyvars cons
= mkDataTyCon (mkBuiltinName key mod str) tycon_kind
tyvars [{-no context-}] cons [{-no derivings-}]
- DataType
+ new_or_data
where
tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars
@@ -155,6 +154,13 @@ pcGenerateDataSpecs ty
\begin{code}
-- The Void type is represented as a data type with no constructors
+-- It's a built in type (i.e. there's no way to define it in Haskell
+-- the nearest would be
+--
+-- data Void = -- No constructors!
+--
+-- It's boxed; there is only one value of this
+-- type, namely "void", whose semantics is just bottom.
voidTy = mkTyConTy voidTyCon
voidTyCon = pcDataTyCon voidTyConKey pRELUDE_BUILTIN SLIT("Void") [] []
@@ -206,20 +212,20 @@ doubleDataCon = pcDataCon doubleDataConKey pRELUDE_BUILTIN SLIT("D#") [] [] [dou
mkStateTy ty = applyTyCon stateTyCon [ty]
realWorldStateTy = mkStateTy realWorldTy -- a common use
-stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") [alphaTyVar] [stateDataCon]
+stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") alpha_tyvar [stateDataCon]
stateDataCon
= pcDataCon stateDataConKey pRELUDE_BUILTIN SLIT("S#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
+ alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
\end{code}
\begin{code}
stablePtrTyCon
= pcDataTyCon stablePtrTyConKey gLASGOW_MISC SLIT("_StablePtr")
- [alphaTyVar] [stablePtrDataCon]
+ alpha_tyvar [stablePtrDataCon]
where
stablePtrDataCon
= pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")
- [alphaTyVar] [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
+ alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
\end{code}
\begin{code}
@@ -283,118 +289,118 @@ We fish one of these \tr{StateAnd<blah>#} things with
\begin{code}
stateAndPtrPrimTyCon
= pcDataTyCon stateAndPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
- [alphaTyVar, betaTyVar] [stateAndPtrPrimDataCon]
+ alpha_beta_tyvars [stateAndPtrPrimDataCon]
stateAndPtrPrimDataCon
= pcDataCon stateAndPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
- [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, betaTy]
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
stateAndPtrPrimTyCon nullSpecEnv
stateAndCharPrimTyCon
= pcDataTyCon stateAndCharPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
- [alphaTyVar] [stateAndCharPrimDataCon]
+ alpha_tyvar [stateAndCharPrimDataCon]
stateAndCharPrimDataCon
= pcDataCon stateAndCharPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, charPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy]
stateAndCharPrimTyCon nullSpecEnv
stateAndIntPrimTyCon
= pcDataTyCon stateAndIntPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
- [alphaTyVar] [stateAndIntPrimDataCon]
+ alpha_tyvar [stateAndIntPrimDataCon]
stateAndIntPrimDataCon
= pcDataCon stateAndIntPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, intPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy]
stateAndIntPrimTyCon nullSpecEnv
stateAndWordPrimTyCon
= pcDataTyCon stateAndWordPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
- [alphaTyVar] [stateAndWordPrimDataCon]
+ alpha_tyvar [stateAndWordPrimDataCon]
stateAndWordPrimDataCon
= pcDataCon stateAndWordPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, wordPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy]
stateAndWordPrimTyCon nullSpecEnv
stateAndAddrPrimTyCon
= pcDataTyCon stateAndAddrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
- [alphaTyVar] [stateAndAddrPrimDataCon]
+ alpha_tyvar [stateAndAddrPrimDataCon]
stateAndAddrPrimDataCon
= pcDataCon stateAndAddrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, addrPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy]
stateAndAddrPrimTyCon nullSpecEnv
stateAndStablePtrPrimTyCon
= pcDataTyCon stateAndStablePtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
- [alphaTyVar, betaTyVar] [stateAndStablePtrPrimDataCon]
+ alpha_beta_tyvars [stateAndStablePtrPrimDataCon]
stateAndStablePtrPrimDataCon
= pcDataCon stateAndStablePtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
- [alphaTyVar, betaTyVar] []
+ alpha_beta_tyvars []
[mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
stateAndStablePtrPrimTyCon nullSpecEnv
stateAndForeignObjPrimTyCon
= pcDataTyCon stateAndForeignObjPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
- [alphaTyVar] [stateAndForeignObjPrimDataCon]
+ alpha_tyvar [stateAndForeignObjPrimDataCon]
stateAndForeignObjPrimDataCon
= pcDataCon stateAndForeignObjPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
- [alphaTyVar] []
+ alpha_tyvar []
[mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []]
stateAndForeignObjPrimTyCon nullSpecEnv
stateAndFloatPrimTyCon
= pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
- [alphaTyVar] [stateAndFloatPrimDataCon]
+ alpha_tyvar [stateAndFloatPrimDataCon]
stateAndFloatPrimDataCon
= pcDataCon stateAndFloatPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, floatPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy]
stateAndFloatPrimTyCon nullSpecEnv
stateAndDoublePrimTyCon
= pcDataTyCon stateAndDoublePrimTyConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
- [alphaTyVar] [stateAndDoublePrimDataCon]
+ alpha_tyvar [stateAndDoublePrimDataCon]
stateAndDoublePrimDataCon
= pcDataCon stateAndDoublePrimDataConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, doublePrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy]
stateAndDoublePrimTyCon nullSpecEnv
\end{code}
\begin{code}
stateAndArrayPrimTyCon
= pcDataTyCon stateAndArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
- [alphaTyVar, betaTyVar] [stateAndArrayPrimDataCon]
+ alpha_beta_tyvars [stateAndArrayPrimDataCon]
stateAndArrayPrimDataCon
= pcDataCon stateAndArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
- [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
stateAndArrayPrimTyCon nullSpecEnv
stateAndMutableArrayPrimTyCon
= pcDataTyCon stateAndMutableArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
- [alphaTyVar, betaTyVar] [stateAndMutableArrayPrimDataCon]
+ alpha_beta_tyvars [stateAndMutableArrayPrimDataCon]
stateAndMutableArrayPrimDataCon
= pcDataCon stateAndMutableArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
- [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
stateAndMutableArrayPrimTyCon nullSpecEnv
stateAndByteArrayPrimTyCon
= pcDataTyCon stateAndByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
- [alphaTyVar] [stateAndByteArrayPrimDataCon]
+ alpha_tyvar [stateAndByteArrayPrimDataCon]
stateAndByteArrayPrimDataCon
= pcDataCon stateAndByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
stateAndByteArrayPrimTyCon nullSpecEnv
stateAndMutableByteArrayPrimTyCon
= pcDataTyCon stateAndMutableByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
- [alphaTyVar] [stateAndMutableByteArrayPrimDataCon]
+ alpha_tyvar [stateAndMutableByteArrayPrimDataCon]
stateAndMutableByteArrayPrimDataCon
= pcDataCon stateAndMutableByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon [alphaTy]]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty]
stateAndMutableByteArrayPrimTyCon nullSpecEnv
stateAndSynchVarPrimTyCon
= pcDataTyCon stateAndSynchVarPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
- [alphaTyVar, betaTyVar] [stateAndSynchVarPrimDataCon]
+ alpha_beta_tyvars [stateAndSynchVarPrimDataCon]
stateAndSynchVarPrimDataCon
= pcDataCon stateAndSynchVarPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
- [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
stateAndSynchVarPrimTyCon nullSpecEnv
\end{code}
@@ -409,9 +415,9 @@ getStatePairingConInfo
Type) -- type of state pair
getStatePairingConInfo prim_ty
- = case (maybeAppDataTyConExpandingDicts prim_ty) of
+ = case (maybeAppTyCon prim_ty) of
Nothing -> panic "getStatePairingConInfo:1"
- Just (prim_tycon, tys_applied, _) ->
+ Just (prim_tycon, tys_applied) ->
let
(pair_con, pair_tycon, num_tys) = assoc "getStatePairingConInfo" tbl prim_tycon
pair_ty = applyTyCon pair_tycon (realWorldTy : drop num_tys tys_applied)
@@ -445,17 +451,14 @@ getStatePairingConInfo prim_ty
This is really just an ordinary synonym, except it is ABSTRACT.
\begin{code}
-mkStateTransformerTy s a = mkSynTy stTyCon [s, a]
-
-stTyCon
- = let
- ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
- in
- mkSynTyCon
- (mkBuiltinName stTyConKey gLASGOW_ST SLIT("_ST"))
- (mkBoxedTypeKind `mkArrowKind` (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind))
- 2 [alphaTyVar, betaTyVar]
- ty
+mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
+
+stTyCon = pcNewTyCon stTyConKey pRELUDE SLIT("_ST") alpha_beta_tyvars [stDataCon]
+ where
+ ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
+
+ stDataCon = pcDataCon stDataConKey pRELUDE SLIT("_ST")
+ alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
\end{code}
%************************************************************************
@@ -467,17 +470,14 @@ stTyCon
@PrimIO@ and @IO@ really are just plain synonyms.
\begin{code}
-mkPrimIoTy a = mkSynTy primIoTyCon [a]
-
-primIoTyCon
- = let
- ty = mkStateTransformerTy realWorldTy alphaTy
- in
--- pprTrace "primIOTyCon:" (ppCat [pprType PprDebug ty, ppr PprDebug (typeKind ty)]) $
- mkSynTyCon
- (mkBuiltinName primIoTyConKey pRELUDE_PRIMIO SLIT("PrimIO"))
- (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
- 1 [alphaTyVar] ty
+mkPrimIoTy a = applyTyCon primIoTyCon [a]
+
+primIoTyCon = pcNewTyCon primIoTyConKey pRELUDE SLIT("_PrimIO") alpha_tyvar [primIoDataCon]
+ where
+ ty = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [alphaTy, mkStateTy realWorldTy])
+
+ primIoDataCon = pcDataCon primIoDataConKey pRELUDE SLIT("_PrimIO")
+ alpha_tyvar [] [ty] primIoTyCon nullSpecEnv
\end{code}
%************************************************************************
@@ -537,27 +537,6 @@ falseDataCon = pcDataCon falseDataConKey pRELUDE SLIT("False") [] [] [] boolTyCo
trueDataCon = pcDataCon trueDataConKey pRELUDE SLIT("True") [] [] [] boolTyCon nullSpecEnv
\end{code}
-%************************************************************************
-%* *
-\subsection[TysWiredIn-Ordering]{The @Ordering@ type}
-%* *
-%************************************************************************
-
-\begin{code}
----------------------------------------------
--- data Ordering = LT | EQ | GT deriving ()
----------------------------------------------
-
-orderingTy = mkTyConTy orderingTyCon
-
-orderingTyCon = pcDataTyCon orderingTyConKey pRELUDE_BUILTIN SLIT("Ordering") []
- [ltDataCon, eqDataCon, gtDataCon]
-
-ltDataCon = pcDataCon ltDataConKey pRELUDE_BUILTIN SLIT("LT") [] [] [] orderingTyCon nullSpecEnv
-eqDataCon = pcDataCon eqDataConKey pRELUDE_BUILTIN SLIT("EQ") [] [] [] orderingTyCon nullSpecEnv
-gtDataCon = pcDataCon gtDataConKey pRELUDE_BUILTIN SLIT("GT") [] [] [] orderingTyCon nullSpecEnv
-\end{code}
-
%************************************************************************
%* *
\subsection[TysWiredIn-List]{The @List@ type (incl ``build'' magic)}
@@ -577,15 +556,15 @@ ToDo: data () = ()
mkListTy :: GenType t u -> GenType t u
mkListTy ty = applyTyCon listTyCon [ty]
-alphaListTy = mkSigmaTy [alphaTyVar] [] (applyTyCon listTyCon [alphaTy])
+alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty)
listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("[]")
- [alphaTyVar] [nilDataCon, consDataCon]
+ alpha_tyvar [nilDataCon, consDataCon]
-nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") [alphaTyVar] [] [] listTyCon
+nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") alpha_tyvar [] [] listTyCon
(pcGenerateDataSpecs alphaListTy)
consDataCon = pcDataCon consDataConKey pRELUDE_BUILTIN SLIT(":")
- [alphaTyVar] [] [alphaTy, applyTyCon listTyCon [alphaTy]] listTyCon
+ alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon
(pcGenerateDataSpecs alphaListTy)
-- Interesting: polymorphic recursion would help here.
-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
@@ -646,33 +625,6 @@ mkTupleTy arity tys = applyTyCon (mkTupleTyCon arity) tys
unitTy = mkTupleTy 0 []
\end{code}
-%************************************************************************
-%* *
-\subsection[TysWiredIn-Ratios]{@Ratio@ and @Rational@}
-%* *
-%************************************************************************
-
-ToDo: make this (mostly) go away.
-
-\begin{code}
-rationalTy :: GenType t u
-
-mkRatioTy ty = applyTyCon ratioTyCon [ty]
-rationalTy = mkRatioTy integerTy
-
-ratioTyCon = pcDataTyCon ratioTyConKey rATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon]
-
-ratioDataCon = pcDataCon ratioDataConKey rATIO SLIT(":%")
- [alphaTyVar] [{-(integralClass,alphaTy)-}] [alphaTy, alphaTy] ratioTyCon nullSpecEnv
- -- context omitted to match lib/prelude/ defn of "data Ratio ..."
-
-rationalTyCon
- = mkSynTyCon
- (mkBuiltinName rationalTyConKey rATIO SLIT("Rational"))
- mkBoxedTypeKind
- 0 [] rationalTy -- == mkRatioTy integerTy
-\end{code}
-
%************************************************************************
%* *
\subsection[TysWiredIn-_Lift]{@_Lift@ type: to support array indexing}
@@ -699,14 +651,14 @@ isLiftTy ty
-}
-alphaLiftTy = mkSigmaTy [alphaTyVar] [] (applyTyCon liftTyCon [alphaTy])
+alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty)
liftTyCon
- = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") [alphaTyVar] [liftDataCon]
+ = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") alpha_tyvar [liftDataCon]
liftDataCon
= pcDataCon liftDataConKey pRELUDE_BUILTIN SLIT("_Lift")
- [alphaTyVar] [] [alphaTy] liftTyCon
+ alpha_tyvar [] alpha_ty liftTyCon
((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv`
(mkSpecInfo [Just realWorldStatePrimTy] 0 bottom))
where
@@ -722,10 +674,4 @@ liftDataCon
\begin{code}
stringTy = mkListTy charTy
-
-stringTyCon
- = mkSynTyCon
- (mkBuiltinName stringTyConKey pRELUDE SLIT("String"))
- mkBoxedTypeKind
- 0 [] stringTy
\end{code}
diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs
index 2740a5b6b86f..ad36f041f310 100644
--- a/ghc/compiler/profiling/CostCentre.lhs
+++ b/ghc/compiler/profiling/CostCentre.lhs
@@ -27,7 +27,7 @@ module CostCentre (
cmpCostCentre -- used for removing dups in a list
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Id ( externallyVisibleId, GenId, Id(..) )
import CStrings ( identToC, stringToC )
diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs
index caa46c28d5a7..331c37189bde 100644
--- a/ghc/compiler/profiling/SCCauto.lhs
+++ b/ghc/compiler/profiling/SCCauto.lhs
@@ -16,7 +16,7 @@ This is a Core-to-Core pass (usually run {\em last}).
module SCCauto ( addAutoCostCentres ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CmdLineOpts ( opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs,
diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index 970264567c2c..7a61c5520d10 100644
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -27,7 +27,7 @@ This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
module SCCfinal ( stgMassageForProfiling ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs
index e6c65c48a308..8cd388bd0673 100644
--- a/ghc/compiler/reader/PrefixSyn.lhs
+++ b/ghc/compiler/reader/PrefixSyn.lhs
@@ -22,12 +22,16 @@ module PrefixSyn (
readInteger
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn
import RdrHsSyn
import Util ( panic )
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
+
type RdrId = RdrName
type SrcLine = Int
type SrcFile = FAST_STRING
diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index c638ca2f5239..2f229553f881 100644
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -20,7 +20,7 @@ module PrefixToHs (
sepDeclsIntoSigsAndBinds
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import PrefixSyn -- and various syntaxen.
import HsSyn
diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index e884ce0de9ea..cd0ae20ef966 100644
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -50,7 +50,7 @@ module RdrHsSyn (
getRawExportees
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn
import Name ( ExportFlag(..) )
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index b35b926185bf..88ddda049db3 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -6,11 +6,9 @@
\begin{code}
#include "HsVersions.h"
-module ReadPrefix (
- rdModule
- ) where
+module ReadPrefix ( rdModule ) where
-import Ubiq
+IMP_Ubiq()
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
@@ -24,7 +22,7 @@ import ErrUtils ( addErrLoc, ghcExit )
import FiniteMap ( elemFM, FiniteMap )
import Name ( RdrName(..), isRdrLexConOrSpecial )
import PprStyle ( PprStyle(..) )
-import PrelMods ( fromPrelude )
+import PrelMods ( fromPrelude, pRELUDE )
import Pretty
import SrcLoc ( SrcLoc )
import Util ( nOfThem, pprError, panic )
@@ -307,7 +305,14 @@ wlkExpr expr
U_negate nexp -> -- prefix negation
wlkExpr nexp `thenUgn` \ expr ->
- returnUgn (NegApp expr (HsVar (Qual SLIT("Prelude") SLIT("negate"))))
+ -- this is a hack
+ let
+ neg = SLIT("negate")
+ rdr = if opt_CompilingPrelude
+ then Unqual neg
+ else Qual pRELUDE neg
+ in
+ returnUgn (NegApp expr (HsVar rdr))
U_llist llist -> -- explicit list
wlkList rdExpr llist `thenUgn` \ exprs ->
@@ -359,7 +364,13 @@ wlkPat pat
= case pat of
U_par ppat -> -- parenthesised pattern
wlkPat ppat `thenUgn` \ pat ->
- returnUgn (ParPatIn pat)
+ -- tidy things up a little:
+ returnUgn (
+ case pat of
+ VarPatIn _ -> pat
+ WildPatIn -> pat
+ other -> ParPatIn pat
+ )
U_as avar as_pat -> -- "as" pattern
wlkQid avar `thenUgn` \ var ->
@@ -453,7 +464,7 @@ wlkLiteral :: U_literal -> UgnM HsLit
wlkLiteral ulit
= returnUgn (
case ulit of
- U_integer s -> HsInt (as_integer s)
+ U_integer s -> HsInt (as_integer s)
U_floatr s -> HsFrac (as_rational s)
U_intprim s -> HsIntPrim (as_integer s)
U_doubleprim s -> HsDoublePrim (as_rational s)
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index bd7dc9d3a7f2..86c467545aef 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -3,7 +3,7 @@
module ParseIface ( parseIface ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import ParseUtils
@@ -362,6 +362,7 @@ iname :: { FAST_STRING }
iname : VARID { $1 }
| CONID { $1 }
| OPAREN VARSYM CPAREN { $2 }
+ | OPAREN BANG CPAREN { SLIT("!"){-sigh, double-sigh-} }
| OPAREN CONSYM CPAREN { $2 }
qiname :: { RdrName }
diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs
index d095ce9d434c..e3fde6b2ac80 100644
--- a/ghc/compiler/rename/ParseUtils.lhs
+++ b/ghc/compiler/rename/ParseUtils.lhs
@@ -8,7 +8,7 @@
module ParseUtils where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
@@ -278,8 +278,14 @@ lexIface str
ITinteger (read num) : lexIface rest }
-----------
- is_var_sym '_' = True
- is_var_sym c = isAlphanum c
+ is_var_sym '_' = True
+ is_var_sym '\'' = True
+ is_var_sym '#' = True -- for Glasgow-extended names
+ is_var_sym c = isAlphanum c
+
+ is_var_sym1 '\'' = False
+ is_var_sym1 '#' = False
+ is_var_sym1 c = is_var_sym c
is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
@@ -287,16 +293,17 @@ lexIface str
lex_word str@(c:cs) -- we know we have a capital letter to start
= -- we first try for "<module>." on the front...
case (module_dot str) of
- Nothing -> lex_name Nothing is_var_sym str
+ Nothing -> lex_name Nothing (in_the_club str) str
Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
- where
- in_the_club [] = panic "lex_word:in_the_club"
- in_the_club (c:_) | isAlpha c = is_var_sym
- | is_sym_sym c = is_sym_sym
- | otherwise = panic ("lex_word:in_the_club="++[c])
+ where
+ in_the_club [] = panic "lex_word:in_the_club"
+ in_the_club (c:_) | isAlpha c = is_var_sym
+ | c == '_' = is_var_sym
+ | is_sym_sym c = is_sym_sym
+ | otherwise = panic ("lex_word:in_the_club="++[c])
module_dot (c:cs)
- = if not (isUpper c) then
+ = if not (isUpper c) || c == '\'' then
Nothing
else
case (span is_var_sym cs) of { (word, rest) ->
@@ -309,8 +316,15 @@ lexIface str
lex_name module_dot in_the_club str
= case (span in_the_club str) of { (word, rest) ->
case (lookupFM keywordsFM word) of
- Just xx -> ASSERT( not (maybeToBool module_dot) )
- xx : lexIface rest
+ Just xx -> let
+ cont = xx : lexIface rest
+ in
+ case xx of
+ ITbang -> case module_dot of
+ Nothing -> cont
+ Just m -> ITqvarsym (Qual m SLIT("!"))
+ : lexIface rest
+ _ -> cont
Nothing ->
(let
f = head word -- first char
@@ -382,5 +396,5 @@ happyError ln toks = Failed (ifaceParseErr ln toks)
-----------------------------------------------------------------
ifaceParseErr ln toks sty
- = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show toks)]
+ = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
\end{code}
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 409abef3c9f3..ac41996d2ae6 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -10,7 +10,7 @@ module Rename ( renameModule ) where
import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) )
-import Ubiq
+IMP_Ubiq()
import HsSyn
import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) )
@@ -33,10 +33,10 @@ import RnMonad
import RnNames ( getGlobalNames, GlobalNameInfo(..) )
import RnSource ( rnSource )
import RnIfaces ( rnIfaces )
-import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
+import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv )
import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
-import CmdLineOpts ( opt_HiMap )
+import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude )
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
import Maybes ( catMaybes )
@@ -73,13 +73,15 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
= let
(b_names, b_keys, _) = builtinNameInfo
+ pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n]
in
- --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
- -- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids))
- -- , ppCat (map ppPStr (keysFM builtin_tcs))
- -- , ppCat (map ppPStr (keysFM b_keys))
- -- ]}) $
-
+ {-
+ pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
+ ppAboves [ ppCat (map pp_pair (keysFM builtin_ids))
+ , ppCat (map pp_pair (keysFM builtin_tcs))
+ , ppCat (map pp_pair (keysFM b_keys))
+ ]}) $
+ -}
makeHiMap opt_HiMap >>= \ hi_files ->
-- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache ->
@@ -165,6 +167,9 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
pair_orig rn = (origName rn, rn)
must_haves
+ | opt_NoImplicitPrelude
+ = [{-no Prelude.hi, no point looking-}]
+ | otherwise
= [ name_fn (mkBuiltinName u mod str)
| ((str, mod), (u, name_fn)) <- fmToList b_keys,
str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
@@ -215,6 +220,13 @@ makeHiMap (Just f)
snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath)
\end{code}
+Warning message used herein:
+\begin{code}
+multipleOccWarn (name, occs) sty
+ = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
+ ppInterleave ppComma (map (ppr sty) occs)]
+\end{code}
+
\begin{code}
{- TESTING:
pprPIface (ParsedIface m ms v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 3c27d75f93ca..a96d3ee5ad49 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -19,8 +19,8 @@ module RnBinds (
DefinedVars(..)
) where
-import Ubiq
-import RnLoop -- break the RnPass/RnExpr/RnBinds loops
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
import HsSyn
import HsPragmas ( isNoGenPragmas, noGenPragmas )
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 9b4a61ba9805..10aef2e765ba 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -17,8 +17,8 @@ module RnExpr (
checkPrecMatch
) where
-import Ubiq
-import RnLoop -- break the RnPass/RnExpr/RnBinds loops
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
import HsSyn
import RdrHsSyn
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index c80f351cc2e7..d8cfa1247366 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -8,7 +8,7 @@
module RnHsSyn where
-import Ubiq
+IMP_Ubiq()
import HsSyn
@@ -82,7 +82,7 @@ isRnField (RnField _ _) = True
isRnField _ = False
isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
-isRnClassOp cls _ = False
+isRnClassOp cls n = pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
isRnImplicit (RnImplicit _) = True
isRnImplicit (RnImplicitTyCon _) = True
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 72fb264f358b..6b0b75c4d615 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -15,7 +15,7 @@ module RnIfaces (
IfaceCache(..)
) where
-import Ubiq
+IMP_Ubiq()
import LibDirectory
import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
@@ -38,10 +38,10 @@ import Bag ( emptyBag, unitBag, consBag, snocBag,
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
fmToList, delListFromFM, sizeFM, foldFM, unitFM,
- plusFM_C, keysFM{-ToDo:rm-}
+ plusFM_C, addListToFM, keysFM{-ToDo:rm-}
)
import Maybes ( maybeToBool )
-import Name ( moduleNamePair, origName, RdrName(..) )
+import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..), Name{-instance NamedThing-} )
import PprStyle -- ToDo:rm
import Outputable -- ToDo:rm
import PrelInfo ( builtinNameInfo )
@@ -244,9 +244,11 @@ cachedDecl :: IfaceCache
-> IO (MaybeErr RdrIfaceDecl Error)
cachedDecl iface_cache class_or_tycon orig
- = cachedIface True iface_cache mod >>= \ maybe_iface ->
+ = -- pprTrace "cachedDecl:" (ppr PprDebug orig) $
+ cachedIface True iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
- Failed err -> return (Failed err)
+ Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $
+ return (Failed err)
Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
Just decl -> return (Succeeded decl)
@@ -269,7 +271,7 @@ cachedDeclByType iface_cache rn
return_failed msg = return (Failed msg)
in
case maybe_decl of
- Failed _ -> return_maybe_decl
+ Failed io_msg -> return_failed (ifaceIoErr io_msg rn)
Succeeded if_decl ->
case rn of
WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn)
@@ -315,13 +317,13 @@ readIface :: FilePath -> Module
-> IO (MaybeErr ParsedIface Error)
readIface file mod
- = --hPutStr stderr (" reading "++file) >>
+ = hPutStr stderr (" reading "++file) >>
readFile file `thenPrimIO` \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
- Right contents -> --hPutStr stderr " parsing" >>
+ Right contents -> hPutStr stderr ".." >>
let parsed = parseIface contents in
- --hPutStr stderr " done\n" >>
+ hPutStr stderr "..\n" >>
return (
case parsed of
Failed _ -> parsed
@@ -359,7 +361,6 @@ rnIfaces iface_cache imp_mods us
todo
= {-
pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
-
pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
@@ -461,8 +462,8 @@ rnIfaces iface_cache imp_mods us
Nothing
| fst (moduleNamePair n) == modname ->
-- avoid looking in interface for the module being compiled
- -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $
- do_decls ns down (add_err (thisModImplicitErr modname n) to_return)
+ --pprTrace "do_decls:this module error:" (ppr PprDebug n) $
+ do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return)
| otherwise ->
-- OK, see what the cache has for us...
@@ -470,7 +471,7 @@ rnIfaces iface_cache imp_mods us
cachedDeclByType iface_cache n >>= \ maybe_ans ->
case maybe_ans of
Failed err -> -- add the error, but keep going:
- -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
+ --pprTrace "do_decls:cache error:" (ppr PprDebug n) $
do_decls ns down (add_err err to_return)
Succeeded iface_decl -> -- something needing renaming!
@@ -528,7 +529,8 @@ new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
= case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
- ASSERT(isEmptyBag def_dups)
+ (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
+-- ASSERT(isEmptyBag def_dups)
let
val_occs = val_defds ++ fmToList val_imps
tc_occs = tc_defds ++ fmToList tc_imps
@@ -563,6 +565,7 @@ add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
+add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
\end{code}
@@ -659,6 +662,7 @@ cacheInstModules iface_cache imp_mods
(imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
in
+ --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $
accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces ->
-- Sanity Check:
@@ -753,7 +757,7 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
want_inst i@(InstSig clas tycon _ _)
= -- it's a "good instance" (one to hang onto) if we have a
-- chance of referring to *both* the class and tycon later on ...
-
+ --pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $
mentionable tycon && mentionable clas && not (is_done_inst i)
where
mentionable nm
@@ -782,6 +786,9 @@ rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
\end{code}
\begin{code}
+type BigMaps = (FiniteMap Module Version, -- module-version map
+ FiniteMap (FAST_STRING,Module) Version) -- ordinary version map
+
finalIfaceInfo ::
IfaceCache -- iface cache
-> Module -- this module's name
@@ -799,47 +806,76 @@ finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqu
-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
-- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
+ readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) ->
let
+ all_ifaces = eltsFM orig_iface_fm
+ -- all the interfaces we have looked at
+
+ big_maps
+ -- combine all the version maps we have seen into maps to
+ -- (a) lookup a module-version number, lookup an entity's
+ -- individual version number
+ = foldr mk_map (emptyFM,emptyFM) all_ifaces
+
val_stuff@(val_usages, val_versions)
- = foldFM process_item (emptyFM, emptyFM){-init-} qual
+ = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual
(all_usages, all_versions)
- = foldFM process_item val_stuff{-keep going-} tc_qual
+ = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
in
return (all_usages, all_versions, [])
where
- process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
+ mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map)
+ = (addToFM mv_map m mv, -- add this module
+ addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ])
+
+ -----------------------
+ process_item :: BigMaps
+ -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
-> (UsagesMap, VersionsMap) -- input
-> (UsagesMap, VersionsMap) -- output
- process_item (n,m) rn as_before@(usages, versions)
+ process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions)
| irrelevant rn
= as_before
| m == modname -- this module => add to "versions"
= (usages, addToFM versions n 1{-stub-})
| otherwise -- from another module => add to "usages"
- = (add_to_usages usages m n 1{-stub-}, versions)
+ = (add_to_usages usages key, versions)
+ where
+ add_to_usages usages key@(n,m)
+ = let
+ mod_v = case (lookupFM big_mv_map m) of
+ Nothing -> pprTrace "big_mv_map:miss? " (ppPStr m) $
+ 1
+ Just nv -> nv
+ key_v = case (lookupFM big_version_map key) of
+ Nothing -> pprTrace "big_version_map:miss? " (ppCat [ppPStr n, ppPStr m]) $
+ 1
+ Just nv -> nv
+ in
+ addToFM usages m (
+ case (lookupFM usages m) of
+ Nothing -> -- nothing for this module yet...
+ (mod_v, unitFM n key_v)
+
+ Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
+ ASSERT(mversion == mod_v)
+ (mversion, addToFM mstuff n key_v)
+ )
irrelevant (RnConstr _ _) = True -- We don't report these in their
irrelevant (RnField _ _) = True -- own right in usages/etc.
irrelevant (RnClassOp _ _) = True
+ irrelevant (RnImplicit n) = isRdrLexCon (origName n) -- really a RnConstr
irrelevant _ = False
- add_to_usages usages m n version
- = addToFM usages m (
- case (lookupFM usages m) of
- Nothing -> -- nothing for this module yet...
- (1{-stub-}, unitFM n version)
-
- Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
- (mversion, addToFM mstuff n version)
- )
\end{code}
\begin{code}
-thisModImplicitErr mod n sty
- = ppCat [ppPStr SLIT("Implicit import of"), ppr sty n, ppPStr SLIT("when compiling"), ppPStr mod]
+thisModImplicitWarn mod n sty
+ = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppPStr mod, ppChar '.', ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
noIfaceErr mod sty
= ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
@@ -859,4 +895,7 @@ ifaceLookupWiredErr msg n sty
badIfaceLookupErr msg name decl sty
= ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
+
+ifaceIoErr io_msg rn sty
+ = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
\end{code}
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 78f89184f7d3..3b36cf7c8bc1 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -30,7 +30,7 @@ module RnMonad (
fixIO
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import SST
@@ -42,22 +42,25 @@ import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
isRnClassOp, RenamedFixityDecl(..) )
import RnUtils ( RnEnv(..), extendLocalRnEnv,
lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
- unknownNameErr, badClassOpErr, qualNameErr,
- dupNamesErr, shadowedNameWarn
+ qualNameErr, dupNamesErr
)
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import CmdLineOpts ( opt_WarnNameShadowing )
-import ErrUtils ( Error(..), Warning(..) )
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM )
+import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
+ Error(..), Warning(..)
+ )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} )
import Maybes ( assocMaybe )
import Name ( Module(..), RdrName(..), isQual,
Name, mkLocalName, mkImplicitName,
- getOccName
+ getOccName, pprNonSym
)
import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
import PrelMods ( pRELUDE )
-import Pretty ( Pretty(..), PrettyRep )
+import PprStyle{-ToDo:rm-}
+import Outputable{-ToDo:rm-}
+import Pretty--ToDo:rm ( Pretty(..), PrettyRep )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet )
@@ -426,10 +429,13 @@ lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b
fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr
- = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in case (lookupFM b_names str_mod) of
- Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
- Just xx -> returnSST xx
+ = let
+ str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
+ in
+ --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
+ case (lookupFM b_names str_mod) of
+ Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
+ Just xx -> returnSST xx
lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
= readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
@@ -545,3 +551,24 @@ fixIO k s = let
in
result
\end{code}
+
+*********************************************************
+* *
+\subsection{Errors used in RnMonad}
+* *
+*********************************************************
+
+\begin{code}
+unknownNameErr descriptor name locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
+
+badClassOpErr clas op locn
+ = addErrLoc locn "" $ \ sty ->
+ ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
+ ppr sty clas, ppStr "'"]
+
+shadowedNameWarn locn shadow
+ = addShortWarnLocLine locn $ \ sty ->
+ ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
+\end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 921cf614f4b6..59594f20dfcf 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -13,7 +13,7 @@ module RnNames (
import PreludeGlaST ( MutableVar(..) )
-import Ubiq
+IMP_Ubiq()
import HsSyn
import RdrHsSyn
@@ -29,9 +29,9 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
unionManyBags, mapBag, filterBag, listToBag, bagToList )
-import CmdLineOpts ( opt_NoImplicitPrelude )
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude )
import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM )
+import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
import Name ( RdrName(..), Name, isQual, mkTopLevName, origName,
@@ -40,14 +40,15 @@ import Name ( RdrName(..), Name, isQual, mkTopLevName, origName,
pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..)
)
import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( fromPrelude, pRELUDE, rATIO, iX )
+import PrelMods ( fromPrelude, pRELUDE_BUILTIN, pRELUDE, rATIO, iX )
import Pretty
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import TyCon ( tyConDataCons )
import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
- equivClasses, panic, assertPanic )
+ equivClasses, panic, assertPanic, pprTrace{-ToDo:rm-}
+ )
\end{code}
@@ -134,7 +135,7 @@ getTyDeclNames :: RdrNameTyDecl
-> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
condecls `thenRn` \ (con_names, field_names) ->
let
@@ -145,15 +146,15 @@ getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- newGlobalName con_loc (Just (nameExportFlag tycon_name)) con
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
+ newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
`thenRn` \ con_name ->
returnRn (RnData tycon_name [con_name] [],
unitBag (RnConstr con_name tycon_name),
emptyBag)
getTyDeclNames (TySynonym tycon _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
returnRn (RnSyn tycon_name, emptyBag, emptyBag)
@@ -161,17 +162,17 @@ getConFieldNames exp constrs fields have []
= returnRn (bagToList constrs, bagToList fields)
getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
- = newGlobalName src_loc exp con `thenRn` \ con_name ->
+ = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
getConFieldNames exp (constrs `snocBag` con_name) fields have rest
getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
- = newGlobalName src_loc exp con `thenRn` \ con_name ->
+ = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
getConFieldNames exp (constrs `snocBag` con_name) fields have rest
getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
= mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_`
- newGlobalName src_loc exp con `thenRn` \ con_name ->
- mapRn (newGlobalName src_loc exp) new_fields `thenRn` \ field_names ->
+ newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
+ mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names ->
let
all_constrs = constrs `snocBag` con_name
all_fields = fields `unionBags` listToBag field_names
@@ -186,7 +187,7 @@ getClassNames :: RdrNameClassDecl
-> RnM_Info s (RnName, Bag RnName) -- class and class ops
getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
- = newGlobalName src_loc Nothing cname `thenRn` \ class_name ->
+ = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name ->
getClassOpNames (Just (nameExportFlag class_name))
sigs `thenRn` \ op_names ->
returnRn (RnClass class_name op_names,
@@ -195,7 +196,7 @@ getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
getClassOpNames exp []
= returnRn []
getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
- = newGlobalName src_loc exp op `thenRn` \ op_name ->
+ = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
getClassOpNames exp sigs `thenRn` \ op_names ->
returnRn (op_name : op_names)
getClassOpNames exp (_ : sigs)
@@ -254,7 +255,7 @@ doPat locn (RecPatIn name fields)
doField locn (_, pat, _) = doPat locn pat
doName locn rdr
- = newGlobalName locn Nothing rdr `thenRn` \ name ->
+ = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
returnRn (unitBag (RnName name))
\end{code}
@@ -265,27 +266,37 @@ doName locn rdr
*********************************************************
\begin{code}
-newGlobalName :: SrcLoc -> Maybe ExportFlag
+newGlobalName :: SrcLoc -> Maybe ExportFlag -> Bool{-True<=>value name,False<=>tycon/class-}
-> RdrName -> RnM_Info s Name
-- ToDo: b_names and b_keys being defined in this module !!!
-newGlobalName locn maybe_exp rdr
- = getExtraRn `thenRn` \ (_,b_keys,exp_fn,occ_fn) ->
+newGlobalName locn maybe_exp is_val_name rdr
+ = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,exp_fn,occ_fn) ->
getModuleRn `thenRn` \ mod ->
rnGetUnique `thenRn` \ u ->
let
- (uniq, unqual)
- = case rdr of
- Qual m n -> (u, n)
- Unqual n -> case (lookupFM b_keys n) of
- Nothing -> (u, n)
- Just (key,_) -> (key, n)
+ unqual = case rdr of { Qual m n -> n; Unqual n -> n }
orig = if fromPrelude mod
then (Unqual unqual)
else (Qual mod unqual)
+ uniq
+ = let
+ str_mod = case orig of { Qual m n -> (n, m); Unqual n -> (n, pRELUDE) }
+ n = fst str_mod
+ m = snd str_mod
+ in
+ --pprTrace "newGlobalName:" (ppAboves ((ppCat [ppPStr n, ppPStr m]) : [ ppCat [ppPStr x, ppPStr y] | (x,y) <- keysFM b_keys])) $
+ case (lookupFM b_keys str_mod) of
+ Just (key,_) -> key
+ Nothing -> if not opt_CompilingPrelude then u else
+ case (lookupFM (if is_val_name then b_val_names else b_tc_names) str_mod) of
+ Nothing -> u
+ Just xx -> --pprTrace "Using Unique for:" (ppCat [ppPStr n, ppPStr m]) $
+ uniqueOf xx
+
exp = case maybe_exp of
Just exp -> exp
Nothing -> exp_fn n
@@ -339,6 +350,7 @@ doImportDecls iface_cache g_info us src_imps
-- cache the imported modules
-- this ensures that all directly imported modules
-- will have their original name iface in scope
+ -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
accumulate (map (cachedIface False iface_cache) imp_mods) >>
-- process the imports
@@ -354,14 +366,18 @@ doImportDecls iface_cache g_info us src_imps
all_imps = implicit_qprel ++ the_imps
implicit_qprel = if opt_NoImplicitPrelude
- then [{- no "import qualified Prelude" -}]
+ then [{- no "import qualified Prelude" -}
+ ImportDecl pRELUDE_BUILTIN True Nothing Nothing prel_loc
+ ]
else [ImportDecl pRELUDE True Nothing Nothing prel_loc]
explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
mod == pRELUDE ])
implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude
- then [{- no "import Prelude" -}]
+ then [{- no "import Prelude" -}
+ ImportDecl pRELUDE_BUILTIN False Nothing Nothing prel_loc
+ ]
else [ImportDecl pRELUDE False Nothing Nothing prel_loc]
prel_loc = mkBuiltinSrcLoc
@@ -386,7 +402,7 @@ doImportDecls iface_cache g_info us src_imps
has_same_mod (q,ImportDecl mod2 _ _ _ _) = mod == mod2
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
+ imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= pRELUDE_BUILTIN ]
imp_warns = listToBag (map dupImportWarn imp_dups)
`unionBags`
@@ -435,15 +451,25 @@ doImport :: IfaceCache
Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
- = cachedIface False iface_cache mod >>= \ maybe_iface ->
+ = let
+ (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
+ in
+ (if mod == pRELUDE_BUILTIN then
+ return (Succeeded (panic "doImport:PreludeBuiltin"),
+ \ iface -> ([], [], emptyBag))
+ else
+ --pprTrace "doImport:" (ppPStr mod) $
+ cachedIface False iface_cache mod >>= \ maybe_iface ->
+ return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec')
+ ) >>= \ (maybe_iface, do_ies) ->
+
case maybe_iface of
Failed err ->
return (emptyBag, emptyBag, emptyBag, emptyBag,
unitBag err, emptyBag, emptyBag)
Succeeded iface ->
let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
- (ies, chk_ies, get_errs) = getOrigIEs iface maybe_spec'
+ (ies, chk_ies, get_errs) = do_ies iface
in
doOrigIEs iface_cache info mod src_loc us ies
>>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
@@ -452,9 +478,13 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
let
final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
+ final_vals_list = bagToList final_vals
in
- accumulate (map (getFixityDecl iface_cache) (bagToList final_vals))
- >>= \ fix_maybes_errs ->
+ (if mod == pRELUDE_BUILTIN then
+ return [ (Nothing, emptyBag) | _ <- final_vals_list ]
+ else
+ accumulate (map (getFixityDecl iface_cache) final_vals_list)
+ ) >>= \ fix_maybes_errs ->
let
(chk_errs, chk_warns) = unzip chk_errs_warns
(fix_maybes, fix_errs) = unzip fix_maybes_errs
@@ -482,7 +512,7 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
getBuiltins _ mod maybe_spec
- | not ((fromPrelude mod) || mod == iX || mod == rATIO )
+ | not (fromPrelude mod || mod == iX || mod == rATIO)
= (emptyBag, emptyBag, maybe_spec)
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
@@ -626,8 +656,8 @@ checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
= with_decl iface_cache n
(\ err -> (unitBag (\ mod locn -> err), emptyBag))
(\ decl -> case decl of
- NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag)
- DataSig _ cons fields _ _ -> (check_with "constructrs (and fields)" (cons++fields) ns, emptyBag)
+ NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag)
+ DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
where
check_with str has rdrs
@@ -650,6 +680,8 @@ with_decl iface_cache n do_err do_decl
getFixityDecl iface_cache (_,rn)
= let
(mod, str) = moduleNamePair rn
+
+ succeeded infx i = return (Just (infx rn i), emptyBag)
in
cachedIface True iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
@@ -658,9 +690,9 @@ getFixityDecl iface_cache (_,rn)
Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
case lookupFM fixes str of
Nothing -> return (Nothing, emptyBag)
- Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag)
- Just (InfixR _ i) -> return (Just (InfixR rn i), emptyBag)
- Just (InfixN _ i) -> return (Just (InfixN rn i), emptyBag)
+ Just (InfixL _ i) -> succeeded InfixL i
+ Just (InfixR _ i) -> succeeded InfixR i
+ Just (InfixN _ i) -> succeeded InfixN i
ie_name (IEVar n) = n
ie_name (IEThingAbs n) = n
@@ -712,12 +744,13 @@ getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
= newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- cons `thenRn` \ con_names ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- fields `thenRn` \ field_names ->
+ let
+ map_me = mapRn (newImportedName False src_loc
+ (Just (nameExportFlag tycon_name))
+ (Just (nameImportFlag tycon_name)))
+ in
+ map_me cons `thenRn` \ con_names ->
+ map_me fields `thenRn` \ field_names ->
let
rn_tycon = RnData tycon_name con_names field_names
rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
@@ -775,11 +808,11 @@ newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
Nothing ->
rnGetUnique `thenRn` \ u ->
let
- uniq = case rdr of
- Qual m n -> u
- Unqual n -> case lookupFM b_keys n of
- Nothing -> u
- Just (key,_) -> key
+ str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n,pRELUDE) }
+
+ uniq = case lookupFM b_keys str_mod of
+ Nothing -> u
+ Just (key,_) -> key
exp = case maybe_exp of
Just exp -> exp
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 043d0ebe429a..64f64c5f48a9 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -8,8 +8,8 @@
module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
-import Ubiq
-import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
import HsSyn
import HsPragmas
@@ -34,7 +34,7 @@ import SrcLoc ( SrcLoc )
import Unique ( Unique )
import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
import UniqSet ( UniqSet(..) )
-import Util ( isIn, isn'tIn, sortLt, removeDups, mapAndUnzip3, cmpPString,
+import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
@@ -236,7 +236,7 @@ rnIE mods (IEThingWith name names)
`unionBags`
listToBag (map exp_all fields))
| otherwise
- = rnWithErr "constructrs (and fields)" rn (cons++fields) rns
+ = rnWithErr "constructors (and fields)" rn (cons++fields) rns
checkIEWith rn@(RnClass n ops) rns
| same_names ops rns
= returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
@@ -298,7 +298,7 @@ rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
= pushSrcLocRn src_loc $
lookupTyCon tycon `thenRn` \ tycon' ->
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnContext tv_env context `thenRn` \ context' ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
rnConDecls tv_env condecls `thenRn` \ condecls' ->
rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
@@ -308,7 +308,7 @@ rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
= pushSrcLocRn src_loc $
lookupTyCon tycon `thenRn` \ tycon' ->
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnContext tv_env context `thenRn` \ context' ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
rnConDecls tv_env condecl `thenRn` \ condecl' ->
rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
@@ -429,27 +429,34 @@ rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
= pushSrcLocRn src_loc $
- mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
- rnContext tv_env context `thenRn` \ context' ->
- lookupClass cname `thenRn` \ cname' ->
- mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
- rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
+ mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
+ lookupClass cname `thenRn` \ cname' ->
+ mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' ->
+ rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
ASSERT(isNoClassPragmas pragmas)
returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
where
- rn_op clas tv_env (ClassOpSig op ty pragmas locn)
+ rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
= pushSrcLocRn locn $
lookupClassOp clas op `thenRn` \ op_name ->
rnPolyType tv_env ty `thenRn` \ new_ty ->
-
-{-
-*** Please check here that tyvar' appears in new_ty ***
-*** (used to be in tcClassSig, but it's better here)
-*** not_elem = isn'tIn "tcClassSigs"
-*** -- Check that the class type variable is mentioned
-*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
-*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
--}
+ let
+ (HsForAllTy tvs ctxt op_ty) = new_ty
+ ctxt_tvs = extractCtxtTyNames ctxt
+ op_tvs = extractMonoTyNames is_tyvar_name op_ty
+ in
+ -- check that class tyvar appears in op_ty
+ ( if isIn "rn_op" clas_tyvar op_tvs
+ then returnRn ()
+ else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
+ ) `thenRn_`
+
+ -- check that class tyvar *doesn't* appear in the sig's context
+ ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
+ then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
+ else returnRn ()
+ ) `thenRn_`
ASSERT(isNoClassOpPragmas pragmas)
returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
@@ -630,13 +637,13 @@ rn_poly_help tv_env tyvars ctxt ty
ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
ppStr ";ty=", ppr PprShowAll ty]) $
-}
- getSrcLocRn `thenRn` \ src_loc ->
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
+ getSrcLocRn `thenRn` \ src_loc ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
let
tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
in
- rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
- rnMonoType tv_env2 ty `thenRn` \ new_ty ->
+ rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt ->
+ rnMonoType tv_env2 ty `thenRn` \ new_ty ->
returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
\end{code}
@@ -673,75 +680,101 @@ rnMonoType tv_env (MonoTyApp name tys)
\end{code}
\begin{code}
-rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
+rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
-rnContext tv_env ctxt
- = mapRn rn_ctxt ctxt
+rnContext tv_env locn ctxt
+ = mapRn rn_ctxt ctxt `thenRn` \ result ->
+ let
+ (_, dup_asserts) = removeDups cmp_assert result
+ in
+ -- If this isn't an error, then it ought to be:
+ mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
+ returnRn result
where
rn_ctxt (clas, tyvar)
- = lookupClass clas `thenRn` \ clas_name ->
- lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
- returnRn (clas_name, tyvar_name)
+ = lookupClass clas `thenRn` \ clas_name ->
+ lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
+ returnRn (clas_name, tyvar_name)
+
+ cmp_assert (c1,tv1) (c2,tv2)
+ = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
\end{code}
\begin{code}
dupNameExportWarn locn names@((n,_):_)
- = addShortWarnLocLine locn (\ sty ->
- ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
dupLocalsExportErr locn locals@((str,_):_)
- = addErrLoc locn "exported names have same local name" (\ sty ->
- ppInterleave ppSP (map (pprNonSym sty . snd) locals))
+ = addErrLoc locn "exported names have same local name" $ \ sty ->
+ ppInterleave ppSP (map (pprNonSym sty . snd) locals)
classOpExportErr op locn
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]
synAllExportErr is_error syn locn
- = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn (\ sty ->
- ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
+ = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty ->
+ ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
withExportErr str rn has rns locn
- = addErrLoc locn "" (\ sty ->
+ = addErrLoc locn "" $ \ sty ->
ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
- ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ])
+ ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]
importAllErr rn locn
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"])
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
badModExportErr mod locn
- = addShortErrLocLine locn (\ sty ->
- ppCat [ ppStr "unknown module in export list: module", ppPStr mod])
+ = addShortErrLocLine locn $ \ sty ->
+ ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
emptyModExportWarn locn mod
- = addShortWarnLocLine locn (\ sty ->
- ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
dupModExportWarn locn mods@(mod:_)
- = addShortWarnLocLine locn (\ sty ->
- ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
derivingNonStdClassErr clas locn
- = addShortErrLocLine locn (\ sty ->
- ppCat [ppStr "non-standard class in deriving:", ppr sty clas])
+ = addShortErrLocLine locn $ \ sty ->
+ ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
= ppAboves (item1 : map dup_item dup_things)
where
item1
- = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty
+ = addShortErrLocLine locn1 (\ sty ->
+ ppStr "multiple default declarations") sty
dup_item (DefaultDecl _ locn)
- = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty
+ = addShortErrLocLine locn (\ sty ->
+ ppStr "here was another default declaration") sty
undefinedFixityDeclErr locn decl
- = addErrLoc locn "fixity declaration for unknown operator" (\ sty ->
- ppr sty decl)
+ = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
+ ppr sty decl
dupFixityDeclErr locn dups
- = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
- ppAboves (map (ppr sty) dups))
+ = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
+ ppAboves (map (ppr sty) dups)
+
+classTyVarNotInOpTyErr clas_tyvar sig locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
+ 4 (ppr sty sig)
+
+classTyVarInOpCtxtErr clas_tyvar sig locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
+ 4 (ppr sty sig)
+
+dupClassAssertWarn ctxt locn dups
+ = addShortWarnLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
+ 4 (ppr sty ctxt)
\end{code}
diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs
index 1825928e20b6..7205e915d3d2 100644
--- a/ghc/compiler/rename/RnUtils.lhs
+++ b/ghc/compiler/rename/RnUtils.lhs
@@ -14,18 +14,14 @@ module RnUtils (
lubExportFlag,
- unknownNameErr,
- badClassOpErr,
qualNameErr,
- dupNamesErr,
- shadowedNameWarn,
- multipleOccWarn
+ dupNamesErr
) where
-import Ubiq
+IMP_Ubiq(){-uitous-}
import Bag ( Bag, emptyBag, snocBag, unionBags )
-import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, addErrLoc )
+import ErrUtils ( addShortErrLocLine )
import FiniteMap ( FiniteMap, emptyFM, isEmptyFM,
lookupFM, addListToFM, addToFM )
import Maybes ( maybeToBool )
@@ -164,20 +160,11 @@ lubExportFlag ExportAbs ExportAbs = ExportAbs
*********************************************************
* *
-\subsection{Errors used in RnMonad}
+\subsection{Errors used *more than once* in the renamer}
* *
*********************************************************
\begin{code}
-unknownNameErr descriptor name locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name] )
-
-badClassOpErr clas op locn
- = addErrLoc locn "" ( \ sty ->
- ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
- ppr sty clas, ppStr "'"] )
-
qualNameErr descriptor (name,locn)
= addShortErrLocLine locn ( \ sty ->
ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonSym sty name ] )
@@ -194,13 +181,5 @@ dupNamesErr descriptor ((name1,locn1) : dup_things) sty
= addShortErrLocLine locn (\ sty ->
ppBesides [ppStr "here was another declaration of `",
pprNonSym sty name, ppStr "'" ]) sty
-
-shadowedNameWarn locn shadow
- = addShortWarnLocLine locn ( \ sty ->
- ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] )
-
-multipleOccWarn (name, occs) sty
- = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
- ppInterleave ppComma (map (ppr sty) occs)]
\end{code}
diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs
index 136c4bfeb186..6c83afa0ce7c 100644
--- a/ghc/compiler/simplCore/AnalFBWW.lhs
+++ b/ghc/compiler/simplCore/AnalFBWW.lhs
@@ -8,7 +8,7 @@
module AnalFBWW ( analFBWW ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn ( CoreBinding(..) )
import Util ( panic{-ToDo:rm-} )
diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs
index ebf64d75e70b..82e024d93bb0 100644
--- a/ghc/compiler/simplCore/BinderInfo.lhs
+++ b/ghc/compiler/simplCore/BinderInfo.lhs
@@ -16,7 +16,7 @@ module BinderInfo (
inlineUnconditionally, oneTextualOcc, oneSafeOcc,
- combineBinderInfo, combineAltsBinderInfo,
+ addBinderInfo, orBinderInfo,
argOccurrence, funOccurrence,
markMany, markDangerousToDup, markInsideSCC,
@@ -26,7 +26,7 @@ module BinderInfo (
isFun, isDupDanger -- for Simon Marlow deforestation
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty
import Util ( panic )
@@ -46,7 +46,7 @@ data BinderInfo
| ManyOcc -- Everything else besides DeadCode and OneOccs
- Int -- number of arguments on stack when called
+ Int -- number of arguments on stack when called; this is a minimum guarantee
| OneOcc -- Just one occurrence (or one each in
@@ -66,7 +66,7 @@ data BinderInfo
-- time we *use* the info; we could be more clever for
-- other cases if we really had to. (WDP/PS)
- Int -- number of arguments on stack when called
+ Int -- number of arguments on stack when called; minimum guarantee
-- In general, we are feel free to substitute unless
-- (a) is in an argument position (ArgOcc)
@@ -170,17 +170,25 @@ markInsideSCC (OneOcc posn dup_danger _ n_alts ar)
= OneOcc posn dup_danger InsideSCC n_alts ar
markInsideSCC other = other
-combineBinderInfo, combineAltsBinderInfo
+addBinderInfo, orBinderInfo
:: BinderInfo -> BinderInfo -> BinderInfo
-combineBinderInfo DeadCode info2 = info2
-combineBinderInfo info1 DeadCode = info1
-combineBinderInfo info1 info2
+addBinderInfo DeadCode info2 = info2
+addBinderInfo info1 DeadCode = info1
+addBinderInfo info1 info2
= ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
-combineAltsBinderInfo DeadCode info2 = info2
-combineAltsBinderInfo info1 DeadCode = info1
-combineAltsBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
+-- (orBinderInfo orig new) is used in two situations:
+-- First, it combines occurrence info from branches of a case
+--
+-- Second, when a variable whose occurrence
+-- info is currently "orig" is bound to a variable whose occurrence info is "new"
+-- eg (\new -> e) orig
+-- What we want to do is to *worsen* orig's info to take account of new's
+
+orBinderInfo DeadCode info2 = info2
+orBinderInfo info1 DeadCode = info1
+orBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
(OneOcc posn2 dup2 scc2 n_alts2 ar_2)
= OneOcc (combine_posns posn1 posn2)
(combine_dups dup1 dup2)
@@ -188,9 +196,6 @@ combineAltsBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
(n_alts1 + n_alts2)
(min ar_1 ar_2)
where
- combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn
- combine_posns _ _ = ArgOcc
-
combine_dups DupDanger _ = DupDanger -- Too paranoid?? ToDo
combine_dups _ DupDanger = DupDanger
combine_dups _ _ = NoDupDanger
@@ -199,9 +204,24 @@ combineAltsBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
combine_sccs _ InsideSCC = InsideSCC
combine_sccs _ _ = NotInsideSCC
-combineAltsBinderInfo info1 info2
+orBinderInfo info1 info2
= ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
+combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn
+combine_posns _ _ = ArgOcc
+
+{-
+multiplyBinderInfo orig@(ManyOcc _) new
+ = ManyOcc (min (getBinderInfoArity orig) (getBinderInfoArity new))
+
+multiplyBinderInfo orig new@(ManyOcc _)
+ = ManyOcc (min (getBinderInfoArity orig) (getBinderInfoArity new))
+
+multiplyBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
+ (OneOcc posn2 dup2 scc2 n_alts2 ar_2)
+ = OneOcc (combine_posns posn1 posn2) ???
+-}
+
setBinderInfoArityToZero :: BinderInfo -> BinderInfo
setBinderInfoArityToZero DeadCode = DeadCode
setBinderInfoArityToZero (ManyOcc _) = ManyOcc 0
diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index ef787b2d23c8..1b4c5ffeaa10 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -12,10 +12,10 @@ ToDo:
module ConFold ( completePrim ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), FormSummary(..) )
+import CoreUnfold ( whnfDetails, UnfoldingDetails(..), FormSummary(..) )
import Id ( idType )
import Literal ( mkMachInt, mkMachWord, Literal(..) )
import MagicUFs ( MagicUnfoldingFun )
@@ -23,6 +23,11 @@ import PrimOp ( PrimOp(..) )
import SimplEnv
import SimplMonad
import TysWiredIn ( trueDataCon, falseDataCon )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+chr = toEnum :: Int -> Char
+#endif
\end{code}
\begin{code}
@@ -90,17 +95,10 @@ completePrim env SeqOp [TyArg ty, LitArg lit]
= returnSmpl (Lit (mkMachInt 1))
completePrim env op@SeqOp args@[TyArg ty, VarArg var]
- = case (lookupUnfolding env var) of
- NoUnfoldingDetails -> give_up
- LitForm _ -> hooray
- OtherLitForm _ -> hooray
- ConForm _ _ -> hooray
- OtherConForm _ -> hooray
- GenForm _ WhnfForm _ _ -> hooray
- _ -> give_up
- where
- give_up = returnSmpl (Prim op args)
- hooray = returnSmpl (Lit (mkMachInt 1))
+ | whnfDetails (lookupUnfolding env var)
+ = returnSmpl (Lit (mkMachInt 1))
+ | otherwise
+ = returnSmpl (Prim op args)
\end{code}
\begin{code}
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index b09986e37005..b52523bf33fb 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -16,7 +16,7 @@ then discover that they aren't needed in the chosen branch.
module FloatIn ( floatInwards ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AnnCoreSyn
import CoreSyn
diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index 401300459f42..361b3cf86657 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -10,7 +10,7 @@
module FloatOut ( floatOutwards ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs
index 55a0e318141f..e5903cb1d711 100644
--- a/ghc/compiler/simplCore/FoldrBuildWW.lhs
+++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs
@@ -8,7 +8,7 @@
module FoldrBuildWW ( mkFoldrBuildWW ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn ( CoreBinding(..) )
import Util ( panic{-ToDo:rm?-} )
diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index a75cd48b1960..04aaa58ed4eb 100644
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -10,7 +10,7 @@
module LiberateCase ( liberateCase ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic )
liberateCase = panic "LiberateCase.liberateCase: ToDo"
diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs
index 32318fe2999e..1df7968fc86b 100644
--- a/ghc/compiler/simplCore/MagicUFs.lhs
+++ b/ghc/compiler/simplCore/MagicUFs.lhs
@@ -13,8 +13,8 @@ module MagicUFs (
applyMagicUnfoldingFun
) where
-import Ubiq{-uitous-}
-import IdLoop -- paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(IdLoop) -- paranoia checking
import CoreSyn
import SimplEnv ( SimplEnv )
@@ -320,9 +320,8 @@ foldr_fun _ _ = returnSmpl Nothing
isConsFun :: SimplEnv -> CoreArg -> Bool
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'
+ GenForm _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
+ | con == consDataCon && x==x' && y==y'
-> ASSERT ( length tys == 1 ) True
_ -> False
isConsFun env _ = False
@@ -330,12 +329,9 @@ isConsFun env _ = False
isNilForm :: SimplEnv -> CoreArg -> Bool
isNilForm env (VarArg v)
= case lookupUnfolding env v of
- GenForm _ _ (CoTyApp (Var id) _) _
- | id == nilDataCon -> True
- ConForm id _ _
- | id == nilDataCon -> True
- LitForm (NoRepStr s) | _NULL_ s -> True
- _ -> False
+ GenForm _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
+ GenForm _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
+ _ -> False
isNilForm env _ = False
getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
@@ -343,9 +339,9 @@ getBuildForm env (VarArg v)
= case lookupUnfolding env v of
GenForm False _ _ _ -> Nothing
-- not allowed to inline :-(
- GenForm _ _ (App (CoTyApp (Var bld) _) (VarArg g)) _
+ GenForm _ (App (CoTyApp (Var bld) _) (VarArg g)) _
| bld == buildId -> Just g
- GenForm _ _ (App (App (CoTyApp (Var bld) _)
+ GenForm _ (App (App (CoTyApp (Var bld) _)
(VarArg g)) h) _
| bld == augmentId && isNilForm env h -> Just g
_ -> Nothing
@@ -358,7 +354,7 @@ getAugmentForm env (VarArg v)
= case lookupUnfolding env v of
GenForm False _ _ _ -> Nothing
-- not allowed to inline :-(
- GenForm _ _ (App (App (CoTyApp (Var bld) _)
+ GenForm _ (App (App (CoTyApp (Var bld) _)
(VarArg g)) h) _
| bld == augmentId -> Just (g,h)
_ -> Nothing
@@ -373,7 +369,7 @@ getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
getAppendForm env (VarArg v) =
case lookupUnfolding env v of
GenForm False _ _ _ -> Nothing -- not allowed to inline :-(
- GenForm _ _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
+ GenForm _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
| fld == foldrId && isConsFun env con -> Just (xs,ys)
_ -> Nothing
getAppendForm env _ = Nothing
@@ -390,7 +386,7 @@ getListForm
-> Maybe ([CoreArg],CoreArg)
getListForm env (VarArg v)
= case lookupUnfolding env v of
- ConForm id _ [head,tail]
+ GenForm _ (Con id [ty_arg,head,tail]) _
| id == consDataCon ->
case getListForm env tail of
Nothing -> Just ([head],tail)
@@ -402,7 +398,7 @@ isInterestingArg :: SimplEnv -> CoreArg -> Bool
isInterestingArg env (VarArg v)
= case lookupUnfolding env v of
GenForm False _ _ UnfoldNever -> False
- GenForm _ _ exp guide -> True
+ GenForm _ exp guide -> True
_ -> False
isInterestingArg env _ = False
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index cc7d4fbdb8b2..cdb26cb13170 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -17,7 +17,7 @@ module OccurAnal (
occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import BinderInfo
import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
@@ -102,14 +102,14 @@ combineUsageDetails, combineAltsUsageDetails
:: UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetails usage1 usage2
- = combineIdEnvs combineBinderInfo usage1 usage2
+ = combineIdEnvs addBinderInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
- = combineIdEnvs combineAltsBinderInfo usage1 usage2
+ = combineIdEnvs orBinderInfo usage1 usage2
addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
addOneOcc usage id info
- = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
+ = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
-- ToDo: make this more efficient
emptyDetails = (nullIdEnv :: UsageDetails)
@@ -206,7 +206,7 @@ occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
- expr' where (_, expr') = occurAnalyseExpr emptyIdSet expr
+ snd (occurAnalyseExpr emptyIdSet expr)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs
index 72c67099fca1..cac46f1c731a 100644
--- a/ghc/compiler/simplCore/SAT.lhs
+++ b/ghc/compiler/simplCore/SAT.lhs
@@ -42,7 +42,7 @@ Experimental Evidence: Heap: +/- 7%
module SAT ( doStaticArgs ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic )
doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs
index 627ade946111..029d856a0ae1 100644
--- a/ghc/compiler/simplCore/SATMonad.lhs
+++ b/ghc/compiler/simplCore/SATMonad.lhs
@@ -14,7 +14,7 @@
module SATMonad where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic )
junk_from_SATMonad = panic "SATMonad.junk"
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index d1b50a5f837c..f4bdc82638a2 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -21,7 +21,7 @@ module SetLevels (
-- not exported: , incMajorLvl, isTopMajLvl, unTopify
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AnnCoreSyn
import CoreSyn
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 4054a144635f..58574cd6f922 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -10,13 +10,14 @@ Support code for @Simplify@.
module SimplCase ( simplCase, bindLargeRhs ) where
-import Ubiq{-uitous-}
-import SmplLoop ( simplBind, simplExpr, MagicUnfoldingFun )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
+import CoreUnfold ( whnfDetails, mkConForm, mkLitForm,
+ UnfoldingDetails(..), UnfoldingGuidance(..),
FormSummary(..)
)
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
@@ -28,13 +29,13 @@ import Id ( idType, isDataCon, getIdDemandInfo,
import IdInfo ( willBeDemanded, DemandInfo )
import Literal ( isNoRepLit, Literal{-instance Eq-} )
import Maybes ( maybeToBool )
-import PrelVals ( voidPrimId )
+import PrelVals ( voidId )
import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
import SimplEnv
import SimplMonad
import SimplUtils ( mkValLamTryingEta )
import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
-import TysPrim ( voidPrimTy )
+import TysWiredIn ( voidTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
@@ -312,11 +313,6 @@ completeCase env scrut alts rhs_c
[alt | alt@(alt_con,_,_) <- alts,
not (alt_con `is_elem` not_these)]
-#ifdef DEBUG
--- 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
other -> alts
alt_binders_unused (con, args, rhs) = all is_dead args
@@ -330,12 +326,7 @@ 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
-
+ scrut_is_evald = whnfDetails scrut_form
scrut_is_eliminable_primitive
= case scrut of
@@ -441,17 +432,17 @@ bindLargeRhs env args rhs_ty rhs_c
-- for let-binding-purposes, we will *caseify* it (!),
-- with potentially-disastrous strictness results. So
-- instead we turn it into a function: \v -> e
- -- where v::VoidPrim. Since arguments of type
+ -- where v::Void. Since arguments of type
-- VoidPrim don't generate any code, this gives the
-- desired effect.
--
-- The general structure is just the same as for the common "otherwise~ case
= newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
- newId voidPrimTy `thenSmpl` \ void_arg_id ->
+ newId voidTy `thenSmpl` \ void_arg_id ->
rhs_c env `thenSmpl` \ prim_new_body ->
returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
- App (Var prim_rhs_fun_id) (VarArg voidPrimId))
+ App (Var prim_rhs_fun_id) (VarArg voidId))
| otherwise
= -- Make the new binding Id. NB: it's an OutId
@@ -484,7 +475,7 @@ bindLargeRhs env args rhs_ty rhs_c
dead DeadCode = True
dead other = False
- prim_rhs_fun_ty = mkFunTys [voidPrimTy] rhs_ty
+ prim_rhs_fun_ty = mkFunTys [voidTy] rhs_ty
\end{code}
Case alternatives when we don't know the scrutinee
@@ -535,7 +526,7 @@ simplAlts env scrut (PrimAlts alts deflt) rhs_c
do_alt (lit, rhs)
= let
new_env = case scrut of
- Var v -> extendUnfoldEnvGivenFormDetails env v (LitForm lit)
+ Var v -> extendUnfoldEnvGivenFormDetails env v (mkLitForm lit)
other -> env
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
@@ -592,16 +583,14 @@ simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rh
= case (form_from_this_case, scrut_form) of
(OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
(OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
- -- ConForm, LitForm impossible
- -- (ASSERT? ASSERT? Hello? WDP 95/05)
other -> form_from_this_case
env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
-- Change unfold details for scrut var. We now want to unfold it
-- to binder'
- new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm
- (Var binder') UnfoldAlways
+ new_scrut_var_form = GenForm WhnfForm (Var binder') UnfoldAlways
+
new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
in
@@ -702,7 +691,7 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
let
env1 = extendIdEnvWithClone env binder id'
new_env = extendUnfoldEnvGivenFormDetails env1 id'
- (ConForm con con_args)
+ (mkConForm con con_args)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index a58f126ae8b2..c8235b226823 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -8,7 +8,7 @@
module SimplCore ( core2core ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AnalFBWW ( analFBWW )
import Bag ( isEmptyBag, foldBag )
@@ -327,7 +327,7 @@ calcInlinings scc_s_OK inline_env_so_far top_binds
where
pp_det NoUnfoldingDetails = ppStr "_N_"
--LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
- pp_det (GenForm _ _ expr guide)
+ pp_det (GenForm _ expr guide)
= ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
pp_det other = ppStr "???"
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 5406e3da09e2..7cd952426bde 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -43,27 +43,30 @@ module SimplEnv (
OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-import SmplLoop -- breaks the MagicUFs / SimplEnv loop
+IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop
-import BinderInfo ( BinderInfo{-instances-} )
+import BinderInfo ( orBinderInfo, oneSafeOcc,
+ BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
+ )
import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
+import CoreUnfold ( UnfoldingDetails(..), mkGenForm, mkConForm,
calcUnfoldingGuidance, UnfoldingGuidance(..),
- mkFormSummary, FormSummary
+ mkFormSummary, FormSummary(..)
)
import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup )
import FiniteMap -- lots of things
import Id ( idType, getIdUnfolding, getIdStrictness,
applyTypeEnvToId,
nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
- addOneToIdEnv, modifyIdEnv,
+ addOneToIdEnv, modifyIdEnv, mkIdSet,
IdEnv(..), IdSet(..), GenId )
import IdInfo ( bottomIsGuaranteed, StrictnessInfo )
import Literal ( isNoRepLit, Literal{-instances-} )
+import Maybes ( maybeToBool )
import Name ( isLocallyDefined )
import OccurAnal ( occurAnalyseExpr )
import Outputable ( Outputable(..){-instances-} )
@@ -77,16 +80,15 @@ import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
TyVarEnv(..), GenTyVar{-instance Eq-}
)
import Unique ( Unique{-instance Outputable-} )
-import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList )
-import UniqSet -- lots of things
+import UniqFM ( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly,
+ delFromUFM, ufmToList
+ )
+--import UniqSet -- lots of things
import Usage ( UVar(..), GenUsage{-instances-} )
import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
type TypeEnv = TyVarEnv Type
cmpType = panic "cmpType (SimplEnv)"
-oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
-oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
-simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
\end{code}
%************************************************************************
@@ -171,13 +173,11 @@ pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
= ppCat [ppr PprDebug v, ppStr "=>",
case form of
NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
- LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
[ppr PprDebug l | l <- ls]]
- ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
[ppr PprDebug c | c <- cs]]
- GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w,
+ GenForm w e g -> ppCat [ppStr "UF:", ppr PprDebug w,
ppr PprDebug g, ppr PprDebug e]
MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
]
@@ -258,12 +258,21 @@ data UnfoldConApp -- yet another glorified pair
data UnfoldEnv -- yup, a glorified triple...
= UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
- IdSet -- The Ids in the domain of the env
- -- which have details (GenForm True ...)
- -- i.e., they claim they are duplicatable.
- -- These are the ones we have to worry
- -- about when adding new items to the
- -- unfold env.
+
+ (IdEnv (Id,BinderInfo)) -- Occurrence info for some (but not necessarily all)
+ -- in-scope ids. The "Id" part is just so that
+ -- we can recover the domain of the mapping, which
+ -- IdEnvs don't allow directly.
+ --
+ -- Anything that isn't in here
+ -- should be assumed to occur many times.
+ -- The things in here all occur once, and the
+ -- binder-info tells about whether that "once"
+ -- is inside a lambda, or perhaps once in each branch
+ -- of a case etc.
+ -- We keep this info so we can modify it when
+ -- something changes.
+
(FiniteMap UnfoldConApp [([Type], OutId)])
-- Maps applications of constructors (to
-- value atoms) back to an association list
@@ -274,7 +283,7 @@ data UnfoldEnv -- yup, a glorified triple...
-- mapping for (part of) the main IdEnv
-- (1st part of UFE)
-null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
+null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM
\end{code}
The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
@@ -289,45 +298,40 @@ things silently grow quite big.... Here are some local functions used
elsewhere in the module:
\begin{code}
-grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
+grow_unfold_env :: UnfoldEnv -> OutId -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
lookup_unfold_env_encl_cc
:: UnfoldEnv -> OutId -> EnclosingCcDetails
-grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
+grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env
-grow_unfold_env (UFE u_env interesting_ids con_apps) id
- uf_details@(GenForm True _ _ _) encl_cc
- -- Only interested in Ids which have a "dangerous" unfolding; that is
- -- one that claims to have a single occurrence.
+grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc
= UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- (addOneToUniqSet interesting_ids id)
- con_apps
-
-grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
- = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- interesting_ids
+ new_occ_env
new_con_apps
where
+ new_occ_env = modify_occ_info occ_env id occ_info
+
new_con_apps
= case uf_details of
- ConForm con args -> snd (lookup_conapp_help con_apps con args id)
+ GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id)
not_a_constructor -> con_apps -- unchanged
-addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
+addto_unfold_env (UFE u_env occ_env con_apps) extra_items
= ASSERT(not (any constructor_form_in_those extra_items))
-- otherwise, we'd need to change con_apps
- UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
+ UFE (growIdEnvList u_env extra_items) occ_env con_apps
where
- constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
+ constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True
constructor_form_in_those _ = False
rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
-get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
+get_interesting_ids (UFE _ occ_env _)
+ = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ]
-foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
- = UFE (foldr fun u_env stuff) interesting_ids con_apps
+foldr_occ_env fun (UFE u_env occ_env con_apps) stuff
+ = UFE u_env (foldr fun occ_env stuff) con_apps
lookup_unfold_env (UFE u_env _ _) id
= case (lookupIdEnv u_env id) of
@@ -368,30 +372,27 @@ lookup_conapp_help con_apps con args outid
cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types
= if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-}
-modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
- = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
+modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _)
+ = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id
--- If the current binding claims to be a "unique" one, then
--- we modify it.
-modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
-
-modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
- = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
+modify_occ_info occ_env id other_new_occ
+ = -- Many or Dead occurrence, just delete from occ_env
+ delFromUFM occ_env id
\end{code}
The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
it, so we can use it for a @FiniteMap@ key.
\begin{code}
instance Eq UnfoldConApp where
- a == b = case cmp_app a b of { EQ_ -> True; _ -> False }
- a /= b = case cmp_app a b of { EQ_ -> False; _ -> True }
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord UnfoldConApp where
- a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
instance Ord3 UnfoldConApp where
cmp = cmp_app
@@ -402,7 +403,7 @@ cmp_app (UCA c1 as1) (UCA c2 as2)
-- ToDo: make an "instance Ord3 CoreArg"???
cmp_arg (VarArg x) (VarArg y) = x `cmp` y
- cmp_arg (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
+ cmp_arg (LitArg x) (LitArg y) = x `cmp` y
cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
cmp_arg x y
@@ -543,26 +544,19 @@ extendIdEnvWithAtom
-> InBinder -> OutArg{-Val args only, please-}
-> SimplEnv
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
+extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
+ (in_id,occ_info) atom@(LitArg lit)
= SimplEnv chkr encl_cc ty_env new_id_env unfold_env
where
new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (in_id, occ_info) atom@(VarArg out_id)
+extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env (UFE u_env occ_env con_apps))
+ (in_id, occ_info) atom@(VarArg out_id)
= SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
-
- new_unfold_env = modify_unfold_env
- unfold_env
- (modifyItem ok_to_dup occ_info)
- out_id
- -- Modify binding for in_id
- -- NO! modify out_id, because its the info on the
- -- atom that interest's us.
-
- ok_to_dup = switchIsOn chkr SimplOkToDupCode
+ new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
+ new_unfold_env = UFE u_env (modify_occ_info occ_env out_id occ_info) con_apps
+ -- Modify occ info for out_id
#ifdef DEBUG
extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
@@ -648,7 +642,8 @@ extendUnfoldEnvGivenFormDetails
NoUnfoldingDetails -> env
good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
where
- new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
+ new_unfold_env = grow_unfold_env unfold_env id fake_occ_info good_details encl_cc
+ fake_occ_info = {-ToDo!-} ManyOcc 0 -- generally paranoid
extendUnfoldEnvGivenConstructor -- specialised variant
:: SimplEnv
@@ -663,7 +658,7 @@ extendUnfoldEnvGivenConstructor env var con args
(_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty
in
extendUnfoldEnvGivenFormDetails
- env var (ConForm con (map TyArg ty_args ++ map VarArg args))
+ env var (mkConForm con (map TyArg ty_args ++ map VarArg args))
\end{code}
@@ -720,40 +715,40 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
= SimplEnv chkr encl_cc ty_env id_env new_unfold_env
where
-- Occurrence-analyse the RHS
- (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
+ (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
- interesting_fvs = get_interesting_ids unfold_env
+ interesting_fvs = get_interesting_ids unfold_env -- Ids in dom of OccEnv
-- Compute unfolding details
- details = case rhs of
- Var v -> panic "Vars already dealt with"
- Lit lit | isNoRepLit lit -> LitForm lit
- | otherwise -> panic "non-noRep Lits already dealt with"
-
- Con con args -> ConForm con args
-
- other -> mkGenForm ok_to_dup occ_info
- (mkFormSummary (getIdStrictness out_id) rhs)
- template guidance
+ details = mkGenForm (mkFormSummary (getIdStrictness out_id) rhs)
+ template guidance
-- Compute resulting unfold env
new_unfold_env = case details of
- NoUnfoldingDetails -> unfold_env
- GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
- other -> unfold_env1
+ NoUnfoldingDetails -> unfold_env
+ other -> unfold_env1
-- Add unfolding to unfold env
- unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
+ unfold_env1 = grow_unfold_env unfold_env out_id occ_info details encl_cc
+{- OLD: done in grow_unfold_env
-- Modify unfoldings of free vars of rhs, based on their
-- occurrence info in the rhs [see notes above]
- unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
-
- modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
- modify (u, occ_info) env
- = case (lookupUFM_Directly env u) of
- Nothing -> env -- ToDo: can this happen?
- Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
+ unfold_env2
+ = foldr_occ_env modify unfold_env1 (ufmToList fv_occ_info)
+ where
+ modify :: (Unique, (Id,BinderInfo)) -> IdEnv (Id,BinderInfo) -> IdEnv (Id,BinderInfo)
+ modify (u, item@(i,occ_info)) env
+ = if maybeToBool (lookupUFM_Directly env u) then
+ -- it occurred before, so now it occurs multiple times;
+ -- therefore, *delete* it from the occ(urs once) env.
+ delFromUFM_Directly env u
+
+ else if not (oneSafeOcc ok_to_dup occ_info) then
+ env -- leave it alone
+ else
+ addToUFM_Directly env u item
+-}
-- Compute unfolding guidance
guidance = if simplIdWantsToBeINLINEd out_id env
@@ -765,8 +760,8 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
Just xx -> xx
ok_to_dup = switchIsOn chkr SimplOkToDupCode
- || exprSmallEnoughToDup rhs
- -- [Andy] added, Jun 95
+--NO: || exprSmallEnoughToDup rhs
+-- -- [Andy] added, Jun 95
{- Reinstated AJG Jun 95; This is needed
--example that does not (currently) work
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 4855ede6685d..f1a125763417 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -18,13 +18,11 @@ module SimplMonad (
-- Cloning
cloneId, cloneIds, cloneTyVarSmpl, newIds, newId
-
- -- and to make the interface self-sufficient...
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-import SmplLoop -- well, cheating sort of
+IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of
import Id ( mkSysLocal, mkIdWithNewUniq )
import SimplEnv
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index 3db8a5f5c83c..692f720e7fb2 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -8,7 +8,7 @@
module SimplPgm ( simplifyPgm ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CmdLineOpts ( opt_D_verbose_core2core,
switchIsOn, intSwitchSet, SimplifierSwitch(..)
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index ac24d65fc4d1..70ed4b8079e9 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -21,7 +21,8 @@ module SimplUtils (
type_ok_for_let_to_case
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) -- paranoia checking
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index f6eecf2b3197..043cd3d5e325 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -1,5 +1,5 @@
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[SimplVar]{Simplifier stuff related to variables}
@@ -11,15 +11,15 @@ module SimplVar (
leastItCouldCost
) where
-import Ubiq{-uitous-}
-import SmplLoop ( simplExpr )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) ( simplExpr )
import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
uNFOLDING_CON_DISCOUNT_WEIGHT
)
import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
+import CoreUnfold ( whnfDetails, UnfoldingDetails(..), UnfoldingGuidance(..),
FormSummary(..)
)
import Id ( idType, getIdInfo,
@@ -55,21 +55,9 @@ completeVar env var args
in
case (lookupUnfolding env var) of
- LitForm lit
- | not (isNoRepLit lit)
- -- Inline literals, if they aren't no-repish things
- -> ASSERT( null args )
- returnSmpl (Lit lit)
-
- ConForm con con_args
- -- Always inline constructors.
- -- See comments before completeLetBinding
- -> ASSERT( null args )
- returnSmpl (Con con con_args)
-
- GenForm txt_occ form_summary template guidance
+ GenForm form_summary template guidance
-> considerUnfolding env var args
- txt_occ form_summary template guidance
+ (panic "completeVar"{-txt_occ-}) form_summary template guidance
MagicForm str magic_fun
-> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
@@ -268,10 +256,9 @@ discountedCost env con_discount_weight size no_args is_con_vec args
full_price
else
case arg of
- LitArg _ -> full_price
- VarArg v -> case lookupUnfolding env v of
- ConForm _ _ -> take_something_off v
- other_form -> full_price
+ LitArg _ -> full_price
+ VarArg v | whnfDetails (lookupUnfolding env v) -> take_something_off v
+ | otherwise -> full_price
) want_cons rest_args
\end{code}
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 27424dd02385..240f4b3026ee 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -8,8 +8,8 @@
module Simplify ( simplTopBinds, simplExpr, simplBind ) where
-import Ubiq{-uitous-}
-import SmplLoop -- paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) -- paranoia checking
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
diff --git a/ghc/compiler/simplCore/SmplLoop.lhi b/ghc/compiler/simplCore/SmplLoop.lhi
index ddffa3bbbd58..a6275b949b7a 100644
--- a/ghc/compiler/simplCore/SmplLoop.lhi
+++ b/ghc/compiler/simplCore/SmplLoop.lhi
@@ -5,6 +5,8 @@ Also break the loop between SimplVar/SimplCase (which use
Simplify.simplExpr) and SimplExpr (which uses whatever
SimplVar/SimplCase cough up).
+Tell SimplEnv about SimplUtils.simplIdWantsToBeINLINEd.
+
\begin{code}
interface SmplLoop where
@@ -13,6 +15,7 @@ import SimplEnv ( SimplEnv, InBinding(..), InExpr(..),
OutArg(..), OutExpr(..), OutType(..)
)
import Simplify ( simplExpr, simplBind )
+import SimplUtils ( simplIdWantsToBeINLINEd )
import BinderInfo(BinderInfo)
import CoreSyn(GenCoreArg, GenCoreBinding, GenCoreExpr)
@@ -27,6 +30,8 @@ import Usage(GenUsage)
data MagicUnfoldingFun
data SimplCount
+simplIdWantsToBeINLINEd :: GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -> SimplEnv -> Bool
+
simplBind :: SimplEnv -> GenCoreBinding (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> (SimplEnv -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)) -> GenType (GenTyVar (GenUsage Unique)) Unique -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)
simplExpr :: SimplEnv -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique] -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)
\end{code}
diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs
index 0562a2984635..1d88e2f54fc2 100644
--- a/ghc/compiler/simplStg/LambdaLift.lhs
+++ b/ghc/compiler/simplStg/LambdaLift.lhs
@@ -8,7 +8,7 @@
module LambdaLift ( liftProgram ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs
index eab32d0016e8..9feec285b53e 100644
--- a/ghc/compiler/simplStg/SatStgRhs.lhs
+++ b/ghc/compiler/simplStg/SatStgRhs.lhs
@@ -60,7 +60,7 @@ This is done for local definitions as well.
module SatStgRhs ( satStgRhs ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index f0aa84fa3414..f57744c94d8c 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -8,7 +8,7 @@
module SimplStg ( stg2stg ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
import StgUtils
diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs
index a70205e11b7e..3d82b27dc6f1 100644
--- a/ghc/compiler/simplStg/StgSAT.lhs
+++ b/ghc/compiler/simplStg/StgSAT.lhs
@@ -33,7 +33,7 @@ useless as map' will be transformed back to what map was.
module StgSAT ( doStaticArgs ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
import UniqSupply ( UniqSM(..) )
diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs
index dd6379c2be8c..66e138ee60a1 100644
--- a/ghc/compiler/simplStg/StgSATMonad.lhs
+++ b/ghc/compiler/simplStg/StgSATMonad.lhs
@@ -12,7 +12,7 @@
module StgSATMonad ( getArgLists, saTransform ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic )
diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs
index 8fba50ebc264..d1dd34c70d4e 100644
--- a/ghc/compiler/simplStg/StgStats.lhs
+++ b/ghc/compiler/simplStg/StgStats.lhs
@@ -25,7 +25,7 @@ The program gather statistics about
module StgStats ( showStgStats ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs
index ed675f705cfe..1947e9593a17 100644
--- a/ghc/compiler/simplStg/StgVarInfo.lhs
+++ b/ghc/compiler/simplStg/StgVarInfo.lhs
@@ -11,7 +11,7 @@ let-no-escapes.
module StgVarInfo ( setStgVarInfo ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs
index e0f4adf6b32f..103b633e2010 100644
--- a/ghc/compiler/simplStg/UpdAnal.lhs
+++ b/ghc/compiler/simplStg/UpdAnal.lhs
@@ -12,7 +12,7 @@
> module UpdAnal ( updateAnalyse ) where
>
-> import Ubiq{-uitous-}
+> IMP_Ubiq(){-uitous-}
>
> import StgSyn
> import Util ( panic )
diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs
index 64319b860e37..28b306de6545 100644
--- a/ghc/compiler/specialise/SpecEnv.lhs
+++ b/ghc/compiler/specialise/SpecEnv.lhs
@@ -13,7 +13,7 @@ module SpecEnv (
specEnvToList
) where
-import Ubiq
+IMP_Ubiq()
import MatchEnv
import Type ( matchTys, isTyVarTy )
diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs
index 7af0cc7eb7e4..68d6816bf2d2 100644
--- a/ghc/compiler/specialise/SpecUtils.lhs
+++ b/ghc/compiler/specialise/SpecUtils.lhs
@@ -21,7 +21,7 @@ module SpecUtils (
pprSpecErrs
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Bag ( isEmptyBag, bagToList )
import Class ( classOpString, GenClass{-instance NamedThing-} )
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 2b69f39cce08..dcbf88c18153 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -13,7 +13,7 @@ module Specialise (
SpecialiseData(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
partitionBag, listToBag, bagToList
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index edd2d815f3a9..a70706862be1 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -15,7 +15,7 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program.
module CoreToStg ( topCoreBindsToStg ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn -- input
import StgSyn -- output
@@ -36,10 +36,17 @@ import PrelVals ( unpackCStringId, unpackCString2Id,
import PrimOp ( PrimOp(..) )
import SpecUtils ( mkSpecialisedCon )
import SrcLoc ( mkUnknownSrcLoc )
-import Type ( getAppDataTyConExpandingDicts )
-import TysWiredIn ( stringTy, integerTy, rationalTy, ratioDataCon )
+import TyCon ( TyCon{-instance Uniquable-} )
+import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
+import TysWiredIn ( stringTy )
+import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
import UniqSupply -- all of it, really
-import Util ( panic )
+import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
+import Pretty--ToDo:rm
+import PprStyle--ToDo:rm
+import PprType --ToDo:rm
+import Outputable--ToDo:rm
+import PprEnv--ToDo:rm
isLeakFreeType x y = False -- safe option; ToDo
\end{code}
@@ -303,7 +310,7 @@ litToStgArg (NoRepStr s)
where
is_NUL c = c == '\0'
-litToStgArg (NoRepInteger i)
+litToStgArg (NoRepInteger i integer_ty)
-- extremely convenient to look out for a few very common
-- Integer literals!
| i == 0 = returnUs (StgVarArg integerZeroId, emptyBag)
@@ -312,7 +319,7 @@ litToStgArg (NoRepInteger i)
| i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
| otherwise
- = newStgVar integerTy `thenUs` \ var ->
+ = newStgVar integer_ty `thenUs` \ var ->
let
rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc -- safe
@@ -332,18 +339,33 @@ litToStgArg (NoRepInteger i)
in
returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
-litToStgArg (NoRepRational r)
- = litToStgArg (NoRepInteger (numerator r)) `thenUs` \ (num_atom, binds1) ->
- litToStgArg (NoRepInteger (denominator r)) `thenUs` \ (denom_atom, binds2) ->
- newStgVar rationalTy `thenUs` \ var ->
- let
- rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
- ratioDataCon -- Constructor
- [num_atom, denom_atom]
- in
- returnUs (StgVarArg var, binds1 `unionBags`
- binds2 `unionBags`
- unitBag (StgNonRec var rhs))
+litToStgArg (NoRepRational r rational_ty)
+ = --ASSERT(is_rational_ty)
+ (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
+ litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) ->
+ litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
+ newStgVar rational_ty `thenUs` \ var ->
+ let
+ rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
+ ratio_data_con -- Constructor
+ [num_atom, denom_atom]
+ in
+ returnUs (StgVarArg var, binds1 `unionBags`
+ binds2 `unionBags`
+ unitBag (StgNonRec var rhs))
+ where
+ (is_rational_ty, ratio_data_con, integer_ty)
+ = case (maybeAppDataTyCon rational_ty) of
+ Just (tycon, [i_ty], [con])
+ -> ASSERT(is_integer_ty i_ty)
+ (uniqueOf tycon == ratioTyConKey, con, i_ty)
+
+ _ -> (False, panic "ratio_data_con", panic "integer_ty")
+
+ is_integer_ty ty
+ = case (maybeAppDataTyCon ty) of
+ Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
+ _ -> False
litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
\end{code}
diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 48263f514276..d549f56a25a1 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -8,7 +8,7 @@
module StgLint ( lintStgBindings ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index ca50b0cc3a47..c4fca6dc56db 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -35,11 +35,9 @@ module StgSyn (
isLitLitArg,
stgArity,
collectExportedStgBinders
-
- -- and to make the interface self-sufficient...
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CostCentre ( showCostCentre )
import Id ( idPrimRep, GenId{-instance NamedThing-} )
diff --git a/ghc/compiler/stgSyn/StgUtils.lhs b/ghc/compiler/stgSyn/StgUtils.lhs
index 7c89ac37616f..d586d8e4581e 100644
--- a/ghc/compiler/stgSyn/StgUtils.lhs
+++ b/ghc/compiler/stgSyn/StgUtils.lhs
@@ -8,7 +8,7 @@ x%
module StgUtils ( mapStgBindeesRhs ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Id ( GenId{-instanced NamedThing-} )
import StgSyn
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 04ba2f0b6dc9..10f5e4221a81 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -15,13 +15,13 @@ module SaAbsInt (
isBot
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CoreUnfold ( UnfoldingDetails(..), FormSummary )
import CoreUtils ( unTagBinders )
import Id ( idType, getIdStrictness, getIdUnfolding,
- dataConSig, dataConArgTys
+ dataConTyCon, dataConArgTys
)
import IdInfo ( StrictnessInfo(..), Demand(..),
wwPrim, wwStrict, wwEnum, wwUnpack
@@ -393,14 +393,7 @@ absId anal var env
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, LitForm _) ->
- AbsTop -- Literals all terminate, and have no poison
-
- (Nothing, NoStrictnessInfo, ConForm _ _) ->
- AbsTop -- An imported constructor won't have
- -- bottom components, nor poison!
-
- (Nothing, NoStrictnessInfo, GenForm _ _ unfolding _) ->
+ (Nothing, NoStrictnessInfo, GenForm _ unfolding _) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
@@ -429,14 +422,9 @@ absId anal var env
-- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
-- Try the strictness info
absValFromStrictness anal strictness_info
-
-
- -- Done via strictness now
- -- GenForm _ BottomForm _ _ -> AbsBot
in
- -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) (
+ -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) $
result
- -- )
where
pp_anal StrAnal = ppStr "STR"
pp_anal AbsAnal = ppStr "ABS"
@@ -518,8 +506,7 @@ absEval anal (Con con as) env
then AbsBot
else AbsTop
where
- (_,_,_, tycon) = dataConSig con
- has_single_con = maybeToBool (maybeTyConSingleCon tycon)
+ has_single_con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
\end{code}
\begin{code}
diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs
index ef42acde13fa..f09e9c9a6133 100644
--- a/ghc/compiler/stranal/SaLib.lhs
+++ b/ghc/compiler/stranal/SaLib.lhs
@@ -18,7 +18,7 @@ module SaLib (
absValFromStrictness
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn ( CoreExpr(..) )
import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList,
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index 71c6e90388ee..fd4445b6511c 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -11,7 +11,7 @@ Semantique analyser) was written by Andy Gill.
module StrictAnal ( saWwTopBinds, saTopBinds ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict,
opt_D_dump_stranal, opt_D_simplifier_stats
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index d9ef03af1b22..873c25f6282e 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -8,7 +8,7 @@
module WorkWrap ( workersAndWrappers ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CoreUnfold ( UnfoldingGuidance(..) )
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index eeaafc9c0355..4f68efbcceac 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -12,7 +12,7 @@ module WwLib (
mkWwBodies, mAX_WORKER_ARGS
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import Id ( idType, mkSysLocal, dataConArgTys )
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index 079c2920b88f..e86accf40b80 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -12,7 +12,7 @@ module GenSpecEtc (
checkSigTyVars, checkSigTyVarsGivenGlobals
) where
-import Ubiq
+IMP_Ubiq()
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
@@ -20,8 +20,8 @@ import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
import TcEnv ( tcGetGlobalTyVars )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals )
import TcType ( TcType(..), TcThetaType(..), TcTauType(..),
- TcTyVarSet(..), TcTyVar(..), tcInstType,
- newTyVarTy, zonkTcType
+ TcTyVarSet(..), TcTyVar(..),
+ newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars
)
import Unify ( unifyTauTy )
@@ -41,7 +41,7 @@ import Outputable ( interppSP, interpp'SP )
import Pretty
import PprType ( GenClass, GenType, GenTyVar )
import Type ( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys,
- getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta )
+ getTyVar, getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta )
import TyVar ( GenTyVar, TyVar(..), tyVarKind, minusTyVarSet, emptyTyVarSet,
elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
import Usage ( UVar(..) )
@@ -378,24 +378,39 @@ checkSigTyVars :: [TcTyVar s] -- The original signature type variables
-> TcM s ()
checkSigTyVars sig_tyvars sig_tau
- = tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
- checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau
+ = checkSigTyVarsGivenGlobals emptyTyVarSet sig_tyvars sig_tau
checkSigTyVarsGivenGlobals
- :: TcTyVarSet s -- Consider these fully-zonked tyvars as global
+ :: TcTyVarSet s -- Consider these tyvars as global in addition to envt ones
-> [TcTyVar s] -- The original signature type variables
-> TcType s -- signature type (for err msg)
-> TcM s ()
-checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau
- = -- Check point (c)
+checkSigTyVarsGivenGlobals extra_globals sig_tyvars sig_tau
+ = zonkTcTyVars extra_globals `thenNF_Tc` \ extra_tyvars' ->
+ tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
+ let
+ globals = env_tyvars `unionTyVarSets` extra_tyvars'
+ mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
+ in
+ -- TEMPORARY FIX
+ -- Until the final Bind-handling stuff is in, several type signatures in the same
+ -- bindings group can cause the signature type variable from the different
+ -- signatures to be unified. So we still need to zonk and check point (b).
+ -- Remove when activating the new binding code
+ mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys ->
+ checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys))
+ (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' ->
+ failTc (badMatchErr sig_tau sig_tau')
+ ) `thenTc_`
+
+
+ -- 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.
checkTc (null mono_tyvars)
(notAsPolyAsSigErr sig_tau mono_tyvars)
- where
- mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
\end{code}
@@ -406,9 +421,8 @@ Contexts and errors
\begin{code}
notAsPolyAsSigErr sig_tau mono_tyvars sty
= ppHang (ppStr "A type signature is more polymorphic than the inferred type")
- 4 (ppAboves [ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)",
- ppHang (ppStr "Monomorphic type variable(s):")
- 4 (interpp'SP sty mono_tyvars),
+ 4 (ppAboves [ppStr "Some type variables in the inferred type can't be forall'd, namely:",
+ interpp'SP sty mono_tyvars,
ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction"
])
\end{code}
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 052d79631980..2aacbfe3a0af 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -23,26 +23,30 @@ module Inst (
zonkInst, instToId,
matchesInst,
- instBindingRequired, instCanBeGeneralised
-
+ instBindingRequired, instCanBeGeneralised,
+
+ pprInst
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
InPat, OutPat, Stmt, Qual, Match,
ArithSeqInfo, PolyType, Fake )
import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
- mkHsTyApp, mkHsDictApp )
+ mkHsTyApp, mkHsDictApp, tcIdTyVars )
import TcMonad hiding ( rnMtoTcM )
-import TcEnv ( tcLookupGlobalValueByKey )
+import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
tcInstType, zonkTcType )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
-import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv )
+import Class ( isCcallishClass, isNoDictClass, classInstEnv,
+ Class(..), GenClass, ClassInstEnv(..)
+ )
+import ErrUtils ( addErrLoc, Error(..) )
import Id ( GenId, idType, mkInstId )
import MatchEnv ( lookupMEnv, insertMEnv )
import Name ( mkLocalName, getLocalName, Name )
@@ -55,13 +59,16 @@ import SpecEnv ( SpecEnv(..) )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import Type ( GenType, eqSimpleTy, instantiateTy,
isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
- splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes )
-import TyVar ( GenTyVar )
+ splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
+ mkSynTy
+ )
+import TyVar ( unionTyVarSets, GenTyVar )
import TysPrim ( intPrimTy )
-import TysWiredIn ( intDataCon )
-import Unique ( Unique, showUnique,
- fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey )
-import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic )
+import TysWiredIn ( intDataCon, integerTy )
+import Unique ( showUnique, fromRationalClassOpKey, rationalTyConKey,
+ fromIntClassOpKey, fromIntegerClassOpKey, Unique
+ )
+import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
%************************************************************************
@@ -178,7 +185,9 @@ newMethod orig id tys
= -- Get the Id type and instantiate it at the specified types
(case id of
RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
- in tcInstType (zipEqual "newMethod" tyvars tys) rho
+ in
+ (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $
+ tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho
TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
) `thenNF_Tc` \ rho_ty ->
@@ -272,7 +281,9 @@ zonkInst (LitInst u lit ty orig loc)
\begin{code}
tyVarsOfInst :: Inst s -> TcTyVarSet s
tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
-tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys
+tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
+ -- The id might not be a RealId; in the case of
+ -- locally-overloaded class methods, for example
tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
\end{code}
@@ -320,19 +331,12 @@ must be witnessed by an actual binding; the second tells whether an
\begin{code}
instBindingRequired :: Inst s -> Bool
-instBindingRequired inst
- = case getInstOrigin inst of
- CCallOrigin _ _ -> False -- No binding required
- LitLitOrigin _ -> False
- OccurrenceOfCon _ -> False
- other -> True
+instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
+instBindingRequired other = True
instCanBeGeneralised :: Inst s -> Bool
-instCanBeGeneralised inst
- = case getInstOrigin inst of
- CCallOrigin _ _ -> False -- Can't be generalised
- LitLitOrigin _ -> False -- Can't be generalised
- other -> True
+instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
+instCanBeGeneralised other = True
\end{code}
@@ -343,32 +347,29 @@ relevant in error messages.
\begin{code}
instance Outputable (Inst s) where
- ppr sty (LitInst uniq lit ty orig loc)
- = ppSep [case lit of
- OverloadedIntegral i -> ppInteger i
- OverloadedFractional f -> ppRational f,
- ppStr "at",
- ppr sty ty,
- show_uniq sty uniq
- ]
-
- ppr sty (Dict uniq clas ty orig loc)
- = ppSep [ppr sty clas,
- ppStr "at",
- ppr sty ty,
- show_uniq sty uniq
- ]
-
- ppr sty (Method uniq id tys rho orig loc)
- = ppSep [ppr sty id,
- ppStr "at",
- ppr sty tys,
- show_uniq sty uniq
- ]
-
-show_uniq PprDebug uniq = ppr PprDebug uniq
-show_uniq sty uniq = ppNil
+ ppr sty inst = ppr_inst sty ppNil (\ o l -> ppNil) inst
+
+pprInst sty hdr inst = ppr_inst sty hdr (\ o l -> pprOrigin hdr o l sty) inst
+
+ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc)
+ = ppHang (ppr_orig orig loc)
+ 4 (ppCat [case lit of
+ OverloadedIntegral i -> ppInteger i
+ OverloadedFractional f -> ppRational f,
+ ppStr "at",
+ ppr sty ty,
+ show_uniq sty u])
+ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
+ = ppHang (ppr_orig orig loc)
+ 4 (ppCat [ppr sty clas, ppr sty ty, show_uniq sty u])
+
+ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
+ = ppHang (ppr_orig orig loc)
+ 4 (ppCat [ppr sty id, ppStr "at", interppSP sty tys, show_uniq sty u])
+
+show_uniq PprDebug u = ppr PprDebug u
+show_uniq sty u = ppNil
\end{code}
Printing in error messages
@@ -412,7 +413,7 @@ lookupInst :: Inst s
lookupInst dict@(Dict _ clas ty orig loc)
= case lookupMEnv matchTy (get_inst_env clas orig) ty of
Nothing -> tcAddSrcLoc loc $
- tcAddErrCtxt (pprOrigin orig) $
+ tcAddErrCtxt (pprOrigin ""{-hdr-} orig loc) $
failTc (noInstanceErr dict)
Just (dfun_id, tenv)
@@ -453,15 +454,22 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
= -- Alas, it is overloaded and a big literal!
tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
- returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) ty)))
+ returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy)))
where
intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
= tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
+
+ -- The type Rational isn't wired in so we have to conjure it up
+ tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
+ let
+ rational_ty = mkSynTy rational_tycon []
+ rational_lit = HsLitOut (HsFrac f) rational_ty
+ in
newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
- returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsFrac f) ty)))
+ returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) rational_lit))
\end{code}
There is a second, simpler interface, when you want an instance of a
@@ -611,51 +619,43 @@ get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
get_inst_env clas other_orig = classInstEnv clas
-pprOrigin :: InstOrigin s -> PprStyle -> Pretty
+pprOrigin :: String -> InstOrigin s -> SrcLoc -> Error
-pprOrigin (OccurrenceOf id) sty
- = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
+pprOrigin hdr orig locn
+ = addErrLoc locn hdr $ \ sty ->
+ case orig of
+ OccurrenceOf id ->
+ ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
ppr sty id, ppChar '\'']
-pprOrigin (OccurrenceOfCon id) sty
- = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
+ OccurrenceOfCon id ->
+ ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
ppr sty id, ppChar '\'']
-pprOrigin (InstanceDeclOrigin) sty
- = ppStr "in an instance declaration"
-pprOrigin (LiteralOrigin lit) sty
- = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
-pprOrigin (ArithSeqOrigin seq) sty
- = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
-pprOrigin (SignatureOrigin) sty
- = ppStr "in a type signature"
-pprOrigin (DoOrigin) sty
- = ppStr "in a do statement"
-pprOrigin (ClassDeclOrigin) sty
- = ppStr "in a class declaration"
--- pprOrigin (DerivingOrigin _ clas tycon) sty
--- = ppBesides [ppStr "in a `deriving' clause; class `",
--- ppr sty clas,
--- ppStr "'; offending type `",
--- ppr sty tycon,
--- ppStr "'"]
-pprOrigin (InstanceSpecOrigin _ clas ty) sty
- = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
+ InstanceDeclOrigin ->
+ ppStr "in an instance declaration"
+ LiteralOrigin lit ->
+ ppCat [ppStr "at an overloaded literal:", ppr sty lit]
+ ArithSeqOrigin seq ->
+ ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
+ SignatureOrigin ->
+ ppStr "in a type signature"
+ DoOrigin ->
+ ppStr "in a do statement"
+ ClassDeclOrigin ->
+ ppStr "in a class declaration"
+ InstanceSpecOrigin _ clas ty ->
+ ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
ppr sty clas, ppStr "\" type: ", ppr sty ty]
--- pprOrigin (DefaultDeclOrigin) sty
--- = ppStr "in a `default' declaration"
-pprOrigin (ValSpecOrigin name) sty
- = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
+ ValSpecOrigin name ->
+ ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
ppr sty name, ppStr "'"]
-pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty
- = ppBesides [ppStr "in the result of the _ccall_ to `",
+ CCallOrigin clabel Nothing{-ccall result-} ->
+ ppBesides [ppStr "in the result of the _ccall_ to `",
ppStr clabel, ppStr "'"]
-pprOrigin (CCallOrigin clabel (Just arg_expr)) sty
- = ppBesides [ppStr "in an argument in the _ccall_ to `",
+ CCallOrigin clabel (Just arg_expr) ->
+ ppBesides [ppStr "in an argument in the _ccall_ to `",
ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
-pprOrigin (LitLitOrigin s) sty
- = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
-pprOrigin UnknownOrigin sty
- = ppStr "in... oops -- I don't know where the overloading came from!"
+ LitLitOrigin s ->
+ ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
+ UnknownOrigin ->
+ ppStr "in... oops -- I don't know where the overloading came from!"
\end{code}
-
-
-
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index b4d87a7b904e..e6f78b3eedc2 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -8,7 +8,7 @@
module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..),
HsExpr, Match, PolyType, InPat, OutPat(..),
@@ -24,12 +24,12 @@ import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
-import TcLoop ( tcGRHSsAndBinds )
+IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcMatches ( tcMatchesFun )
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcType ( newTcTyVar, tcInstType )
+import TcType ( newTcTyVar, tcInstSigType )
import Unify ( unifyTauTy )
import Kind ( mkBoxedTypeKind, mkTypeKind )
@@ -209,8 +209,8 @@ tcBindAndSigs binder_rn_names bind sigs prag_info_fn
genBinds binder_names mono_ids bind' lie sig_info prag_info_fn
where
kind = case bind of
- NonRecBind _ -> mkBoxedTypeKind -- Recursive, so no unboxed types
- RecBind _ -> mkTypeKind -- Non-recursive, so we permit unboxed types
+ NonRecBind _ -> mkTypeKind -- Recursive, so no unboxed types
+ RecBind _ -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types
\end{code}
@@ -451,7 +451,7 @@ 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` \ sigma_ty' ->
+ tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
let
(tyvars', theta', tau') = splitSigmaTy sigma_ty'
in
@@ -568,7 +568,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 [] sig_sigma `thenNF_Tc` \ sig_ty ->
+ tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
let
(sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
origin = ValSpecOrigin name
@@ -580,7 +580,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
-- Get and instantiate the type of the id mentioned
tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
- tcInstType [] (idType main_id) `thenNF_Tc` \ main_ty ->
+ tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
let
(main_tyvars, main_rho) = splitForAllTy main_ty
(main_theta,main_tau) = splitRhoTy main_rho
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index d2a63baf2f77..039361851b96 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -10,7 +10,7 @@ module TcClassDcl (
tcClassDecl1, tcClassDecls2
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
@@ -23,18 +23,19 @@ import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
RnName{-instance Uniquable-}
)
import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
- mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam )
+ mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
-import TcMonad hiding ( rnMtoTcM )
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 ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars )
+import TcInstDcls ( processInstBinds, newMethodId )
import TcKind ( TcKind )
+import TcKind ( unifyKind )
+import TcMonad hiding ( rnMtoTcM )
+import TcMonoType ( tcPolyType, tcMonoType, tcContext )
+import TcSimplify ( tcSimplifyAndCheck )
+import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars, tcInstSigType )
-import Bag ( foldBag )
+import Bag ( foldBag, unionManyBags )
import Class ( GenClass, mkClass, mkClassOp, classBigSig,
classOps, classOpString, classOpLocalType,
classOpTagByString
@@ -52,16 +53,51 @@ import SrcLoc ( mkGeneratedSrcLoc )
import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
mkForAllTy, mkSigmaTy, splitSigmaTy)
import TysWiredIn ( stringTy )
-import TyVar ( GenTyVar )
+import TyVar ( mkTyVarSet, GenTyVar )
import Unique ( Unique )
import Util
+
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
tcGenPragmas ty id ps = returnNF_Tc noIdInfo
tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
-
\end{code}
+
+
+Dictionary handling
+~~~~~~~~~~~~~~~~~~~
+Every class implicitly declares a new data type, corresponding to dictionaries
+of that class. So, for example:
+
+ class (D a) => C a where
+ op1 :: a -> a
+ op2 :: forall b. Ord b => a -> b -> b
+
+would implicitly declare
+
+ data CDict a = CDict (D a)
+ (a -> a)
+ (forall b. Ord b => a -> b -> b)
+
+(We could use a record decl, but that means changing more of the existing apparatus.
+One step at at time!)
+
+For classes with just one superclass+method, we use a newtype decl instead:
+
+ class C a where
+ op :: forallb. a -> b -> b
+
+generates
+
+ newtype CDict a = CDict (forall b. a -> b -> b)
+
+Now DictTy in Type is just a form of type synomym:
+ DictTy c t = TyConTy CDict `AppTy` t
+
+Death to "ExpandingDicts".
+
+
\begin{code}
tcClassDecl1 rec_inst_mapper
(ClassDecl context class_name
@@ -88,8 +124,6 @@ tcClassDecl1 rec_inst_mapper
`thenTc` \ sig_stuff ->
-- MAKE THE CLASS OBJECT ITSELF
--- BOGUS:
--- tcGetUnique `thenNF_Tc` \ uniq ->
let
(ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
@@ -100,6 +134,32 @@ tcClassDecl1 rec_inst_mapper
\end{code}
+ let
+ clas_ty = mkTyVarTy clas_tyvar
+ dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++
+ [classOpLocalType op | op <- ops])
+ new_or_data = case dict_component_tys of
+ [_] -> NewType
+ other -> DataType
+
+ dict_con_id = mkDataCon class_name
+ [NotMarkedStrict]
+ [{- No labelled fields -}]
+ [clas_tyvar]
+ [{-No context-}]
+ dict_component_tys
+ tycon
+
+ tycon = mkDataTyCon class_name
+ (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
+ [rec_tyvar]
+ [{- Empty context -}]
+ [dict_con_id]
+ [{- No derived classes -}]
+ new_or_data
+ in
+
+
\begin{code}
tcClassContext :: Class -> TyVar
-> RenamedContext -- class context
@@ -135,10 +195,10 @@ tcClassContext rec_class rec_tyvar context pragmas
Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
) `thenNF_Tc` \ id_info ->
let
- ty = mkForAllTy rec_tyvar (
- mkFunTy (mkDictTy rec_class (mkTyVarTy rec_tyvar))
- (mkDictTy super_class (mkTyVarTy rec_tyvar))
- )
+ rec_tyvar_ty = mkTyVarTy rec_tyvar
+ ty = mkForAllTy rec_tyvar $
+ mkFunTy (mkDictTy rec_class rec_tyvar_ty)
+ (mkDictTy super_class rec_tyvar_ty)
in
-- BUILD THE SUPERCLASS ID
returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
@@ -164,21 +224,21 @@ tcClassSig :: Class -- Knot tying only!
tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
(ClassOpSig op_name
- (HsForAllTy tyvar_names context monotype)
+ op_ty
pragmas src_loc)
= tcAddSrcLoc src_loc $
fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
-- Check the type signature. NB that the envt *already has*
-- bindings for the type variables; see comments in TcTyAndClassDcls.
- tcContext context `thenTc` \ theta ->
- tcMonoType monotype `thenTc` \ tau ->
- mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (_,tyvars) ->
+
+ -- NB: Renamer checks that the class type variable is mentioned in local_ty,
+ -- and that it is not constrained by theta
+ tcPolyType op_ty `thenTc` \ local_ty ->
let
- full_tyvars = rec_clas_tyvar : tyvars
- full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
- global_ty = mkSigmaTy full_tyvars full_theta tau
- local_ty = mkSigmaTy tyvars theta tau
+ global_ty = mkSigmaTy [rec_clas_tyvar]
+ [(rec_clas, mkTyVarTy rec_clas_tyvar)]
+ local_ty
class_op_nm = getLocalName op_name
class_op = mkClassOp class_op_nm
(classOpTagByString rec_clas{-yeeps!-} class_op_nm)
@@ -333,6 +393,7 @@ buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
Make a selector expression for @sel_id@ from a dictionary @clas_dict@
consisting of @dicts@ and @methods@.
+====================== OLD ============================
We have to do a bit of jiggery pokery to get the type variables right.
Suppose we have the class decl:
\begin{verbatim}
@@ -360,6 +421,12 @@ whereas \tr{op1_sel} (the one we use) has the decent type
\begin{verbatim}
op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
\end{verbatim}
+========================= END OF OLD ===========================
+
+NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and
+the rest of the compiler darn well ought to cope.
+
+
NOTE that we return a TcMonoBinds (which is later zonked) even though
there's no real back-substitution to do. It's just simpler this way!
@@ -376,28 +443,23 @@ mkSelBind :: Id -- the selector id
-> NF_TcM s (TcMonoBinds s)
mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
- = let
- (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
- op_tys = mkTyVarTys op_tyvars
- in
- newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) ->
-
- -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
+ =
+ -- sel_id = /\ clas_tyvar -> \ clas_dict ->
-- case clas_dict of
- -- <dicts..methods> -> method_or_dict op_tyvars op_dicts
+ -- <dicts..methods> -> method_or_dict
returnNF_Tc (VarMonoBind (RealId sel_id) (
- TyLam (clas_tyvar:op_tyvars) (
- DictLam (clas_dict:op_dicts) (
+ TyLam [clas_tyvar] (
+ DictLam [clas_dict] (
HsCase
(HsVar clas_dict)
([PatMatch (DictPat dicts methods) (
GRHSMatch (GRHSsAndBindsOut
[OtherwiseGRHS
- (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
+ (HsVar method_or_dict)
mkGeneratedSrcLoc]
EmptyBinds
- op_tau))])
+ (idType op)))])
mkGeneratedSrcLoc
))))
\end{code}
@@ -425,11 +487,22 @@ we get the default methods:
defm.Foo.op1 :: forall a. Foo a => a -> Bool
defm.Foo.op1 = /\a -> \dfoo -> \x -> True
+====================== OLD ==================
+\begin{verbatim}
defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
if (op1 a dfoo x) && (< b dord y z) then y else z
\end{verbatim}
Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
+====================== END OF OLD ===================
+
+NEW:
+\begin{verbatim}
+defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
+defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
+ if (op1 a dfoo x) && (< b dord y z) then y else z
+\end{verbatim}
+
When we come across an instance decl, we may need to use the default
methods:
@@ -442,14 +515,15 @@ const.Foo.Int.op1 :: Int -> Bool
const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
-const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
+const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
dfun.Foo.Int :: Foo Int
dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
\end{verbatim}
Notice that, as with method selectors above, we assume that dictionary
application is curried, so there's no need to mention the Ord dictionary
-in const.Foo.Int.op2
+in const.Foo.Int.op2 (or the type variable).
+
\begin{verbatim}
instance Foo a => Foo [a] where {}
@@ -458,7 +532,7 @@ dfun.Foo.List
= /\ a -> \ dfoo_a ->
let rec
op1 = defm.Foo.op1 [a] dfoo_list
- op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord
+ op2 = defm.Foo.op2 [a] dfoo_list
dfoo_list = (op1, op2)
in
dfoo_list
@@ -474,16 +548,38 @@ buildDefaultMethodBinds
buildDefaultMethodBinds clas clas_tyvar
default_method_ids default_binds
- = -- Deal with the method declarations themselves
+ = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) ->
+ let
+ avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available
+ in
processInstBinds
clas
- (makeClassDeclDefaultMethodRhs clas default_method_ids)
- [] -- No tyvars in scope for "this inst decl"
- emptyLIE -- No insts available
- (map RealId default_method_ids)
- default_binds `thenTc` \ (dicts_needed, default_binds') ->
+ (makeClassDeclDefaultMethodRhs clas local_defm_ids)
+ [clas_tyvar] -- Tyvars in scope
+ avail_insts
+ local_defm_ids
+ default_binds `thenTc` \ (insts_needed, default_binds') ->
+
+ tcSimplifyAndCheck
+ (mkTyVarSet [clas_tyvar])
+ avail_insts
+ insts_needed `thenTc` \ (const_lie, dict_binds) ->
+
- returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
+ let
+ defm_binds = AbsBinds
+ [clas_tyvar]
+ [this_dict_id]
+ (local_defm_ids `zip` map RealId default_method_ids)
+ dict_binds
+ (RecBind default_binds')
+ in
+ returnTc (const_lie, defm_binds)
+ where
+ inst_ty = mkTyVarTy clas_tyvar
+ mk_method defm_id = newMethodId defm_id inst_ty origin
+ origin = ClassDeclOrigin
\end{code}
@makeClassDeclDefaultMethodRhs@ builds the default method for a
@@ -492,12 +588,21 @@ class declaration when no explicit default method is given.
\begin{code}
makeClassDeclDefaultMethodRhs
:: Class
- -> [Id]
+ -> [TcIdOcc s]
-> Int
-> NF_TcM s (TcExpr s)
makeClassDeclDefaultMethodRhs clas method_ids tag
- = tcInstType [] (idType method_id) `thenNF_Tc` \ method_ty ->
+ = -- Return the expression
+ -- error ty "No default method for ..."
+ -- The interesting thing is that method_ty is a for-all type;
+ -- this is fun, although unusual in a type application!
+
+ returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id])
+ (HsLitOut (HsString (_PK_ error_msg)) stringTy))
+
+{- OLD AND COMPLICATED
+ tcInstSigType () `thenNF_Tc` \ method_ty ->
let
(tyvars, theta, tau) = splitSigmaTy method_ty
in
@@ -507,11 +612,13 @@ makeClassDeclDefaultMethodRhs clas method_ids tag
mkHsDictLam dict_ids (
HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))))
+-}
+
where
(clas_mod, clas_name) = moduleNamePair clas
method_id = method_ids !! (tag-1)
- class_op = (classOps clas) !! (tag-1)
+ class_op = (classOps clas) !! (tag-1)
error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
++ (ppShow 80 (ppr PprForUser class_op))
diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index 964847d8d8b3..3d40162240ef 100644
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -8,7 +8,7 @@
module TcDefaults ( tcDefaults ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( DefaultDecl(..), MonoType,
HsExpr, HsLit, ArithSeqInfo, Fake, InPat)
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 5e7d91e4ca92..7304d60fd294 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcDeriv]{Deriving}
@@ -10,49 +10,59 @@ Handles @deriving@ clauses on @data@ declarations.
module TcDeriv ( tcDeriving ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
ArithSeqInfo, Fake, MonoType )
import HsPragmas ( InstancePragmas(..) )
-import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) )
+import RnHsSyn ( mkRnName, RnName(..), RenamedHsBinds(..), RenamedFixityDecl(..) )
import TcHsSyn ( TcIdOcc )
-import TcMonad hiding ( rnMtoTcM )
-import Inst ( InstOrigin(..), InstanceMapper(..) )
-import TcEnv ( getEnv_TyCons )
+import TcMonad
+import Inst ( InstanceMapper(..) )
+import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
import TcKind ( TcKind )
---import TcGenDeriv -- Deriv stuff
+import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
import RnMonad
-import RnUtils ( RnEnv(..) )
+import RnUtils ( RnEnv(..), extendGlobalRnEnv )
import RnBinds ( rnMethodBinds, rnTopBinds )
import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
-import Class ( GenClass, classKey )
+import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass )
import CmdLineOpts ( opt_CompilingPrelude )
import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
-import Id ( dataConSig, dataConArity )
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import Outputable
+import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
+import Maybes ( maybeToBool, Maybe(..) )
+import Name ( moduleNamePair, isLocallyDefined, getSrcLoc,
+ mkTopLevName, origName, mkImplicitName, ExportFlag(..),
+ RdrName{-instance Outputable-}, Name{--O only-}
+ )
+import Outputable ( Outputable(..){-instances e.g., (,)-} )
import PprType ( GenType, GenTyVar, GenClass, TyCon )
-import PprStyle
-import Pretty
-import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
+import PprStyle ( PprStyle(..) )
+import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, Pretty(..) )
+import Pretty--ToDo:rm
+import FiniteMap--ToDo:rm
+import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
- maybeTyConSingleCon, isEnumerationTyCon, TyCon )
+ tyConTheta, maybeTyConSingleCon,
+ isEnumerationTyCon, isDataTyCon, TyCon
+ )
import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon,
mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
- getAppTyCon, getAppDataTyCon
+ getAppDataTyCon, getAppTyCon
)
+import TysWiredIn ( voidTy )
import TyVar ( GenTyVar )
import UniqFM ( emptyUFM )
import Unique -- Keys stuff
-import Util ( zipWithEqual, zipEqual, sortLt, removeDups,
- thenCmp, cmpList, panic, pprPanic, pprPanic#
+import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc,
+ thenCmp, cmpList, panic, pprPanic, pprPanic#,
+ assertPanic, pprTrace{-ToDo:rm-}
)
\end{code}
@@ -69,6 +79,10 @@ Consider
| C3 (T a a)
deriving (Eq)
+[NOTE: See end of these comments for what to do with
+ data (C a, D b) => T a b = ...
+]
+
We want to come up with an instance declaration of the form
instance (Ping a, Pong b, ...) => Eq (T a b) where
@@ -147,6 +161,31 @@ type DerivRhs = [(Class, TauType)] -- Same as a ThetaType!
type DerivSoln = DerivRhs
\end{code}
+
+A note about contexts on data decls
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+ data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
+
+We will need an instance decl like:
+
+ instance (Read a, RealFloat a) => Read (Complex a) where
+ ...
+
+The RealFloat in the context is because the read method for Complex is bound
+to construct a Complex, and doing that requires that the argument type is
+in RealFloat.
+
+But this ain't true for Show, Eq, Ord, etc, since they don't construct
+a Complex; they only take them apart.
+
+Our approach: identify the offending classes, and add the data type
+context to the instance decl. The "offending classes" are
+
+ Read, Enum?
+
+
%************************************************************************
%* *
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
@@ -163,10 +202,6 @@ tcDeriving :: Module -- name of module under scrutiny
PprStyle -> Pretty) -- Printable derived instance decls;
-- for debugging via -ddump-derivings.
-tcDeriving modname rn_env inst_decl_infos_in fixities
- = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil))
-{- LATER:
-
tcDeriving modname rn_env inst_decl_infos_in fixities
= -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
@@ -184,37 +219,22 @@ tcDeriving modname rn_env inst_decl_infos_in fixities
-- "con2tag" and/or "tag2con" functions. We do these
-- separately.
- gen_taggery_Names eqns `thenTc` \ nm_alist_etc ->
- let
- nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
-
- -- We have the renamer's final "name funs" in our hands
- -- (they were passed in). So we can handle ProtoNames
- -- that refer to anything "out there". But our generated
- -- code may also mention "con2tag" (etc.). So we need
- -- to augment to "name funs" to include those.
- (rn_val_gnf, rn_tc_gnf) = renamer_name_funs
-
- deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of
- Just xx -> Just xx
- Nothing -> rn_val_gnf pname
-
- deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
-
- assoc_maybe [] _ = Nothing
- assoc_maybe ((k,v) : vs) key
- = if k `eqProtoName` key then Just v else assoc_maybe vs key
- in
- gen_tag_n_con_binds deriver_rn_env nm_alist_etc `thenTc` \ extra_binds ->
+ gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
+ gen_tag_n_con_binds rn_env nm_alist_etc
+ `thenTc` \ (extra_binds, deriver_rn_env) ->
mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos
- `thenTc` \ really_new_inst_infos ->
+ `thenTc` \ really_new_inst_infos ->
+ let
+ ddump_deriv = ddump_deriving really_new_inst_infos extra_binds
+ in
+ --pprTrace "derived:\n" (ddump_deriv PprDebug) $
returnTc (listToBag really_new_inst_infos,
extra_binds,
- ddump_deriving really_new_inst_infos extra_binds)
+ ddump_deriv)
where
- maybe_mod = if opt_CompilingPrelude then Nothing else Just mod_name
+ maybe_mod = if opt_CompilingPrelude then Nothing else Just modname
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
@@ -252,12 +272,14 @@ all those.
makeDerivEqns :: TcM s [DerivEqn]
makeDerivEqns
- = tcGetEnv `thenNF_Tc` \ env ->
+ = tcGetEnv `thenNF_Tc` \ env ->
+ tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
let
- tycons = getEnv_TyCons env
- think_about_deriving = need_deriving tycons
+ tycons = filter isDataTyCon (getEnv_TyCons env)
+ -- ToDo: what about newtypes???
+ think_about_deriving = need_deriving eval_clas tycons
in
- mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
+ mapTc chk_out think_about_deriving `thenTc_`
let
(derive_these, _) = removeDups cmp_deriv think_about_deriving
eqns = map mk_eqn derive_these
@@ -265,34 +287,48 @@ makeDerivEqns
returnTc eqns
where
------------------------------------------------------------------
- need_deriving :: [TyCon] -> [(Class, TyCon)]
- -- find the tycons that have `deriving' clauses
+ need_deriving :: Class -> [TyCon] -> [(Class, TyCon)]
+ -- find the tycons that have `deriving' clauses;
+ -- we handle the "every datatype in Eval" by
+ -- doing a dummy "deriving" for it.
- need_deriving tycons_to_consider
+ need_deriving eval_clas tycons_to_consider
= foldr ( \ tycon acc ->
+ let
+ acc_plus = if isLocallyDefined tycon
+ then (eval_clas, tycon) : acc
+ else acc
+ in
case (tyConDerivings tycon) of
- [] -> acc
- cs -> [ (clas,tycon) | clas <- cs ] ++ acc
+ [] -> acc_plus
+ cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus
)
[]
tycons_to_consider
------------------------------------------------------------------
- chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
- chk_out whole_deriving_list this_one@(clas, tycon)
+ chk_out :: (Class, TyCon) -> TcM s ()
+ chk_out this_one@(clas, tycon)
= let
clas_key = classKey clas
- in
+ is_enumeration = isEnumerationTyCon tycon
+ is_single_con = maybeToBool (maybeTyConSingleCon tycon)
+
+ chk_clas clas_uniq clas_str cond
+ = if (clas_uniq == clas_key)
+ then checkTc cond (derivingThingErr clas_str tycon)
+ else returnTc ()
+ in
-- Are things OK for deriving Enum (if appropriate)?
- checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon))
- (derivingEnumErr tycon) `thenTc_`
+ chk_clas enumClassKey "Enum" is_enumeration `thenTc_`
+
+ -- Are things OK for deriving Bounded (if appropriate)?
+ chk_clas boundedClassKey "Bounded"
+ (is_enumeration || is_single_con) `thenTc_`
-- Are things OK for deriving Ix (if appropriate)?
- checkTc (clas_key == ixClassKey
- && not (isEnumerationTyCon tycon
- || maybeToBool (maybeTyConSingleCon tycon)))
- (derivingIxErr tycon)
+ chk_clas ixClassKey "Ix.Ix" (is_enumeration || is_single_con)
------------------------------------------------------------------
cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
@@ -305,22 +341,31 @@ makeDerivEqns
-- to make the rest of the equation
mk_eqn (clas, tycon)
- = (clas, tycon, tyvars, constraints)
+ = (clas, tycon, tyvars, if_not_Eval constraints)
where
+ clas_key = classKey clas
tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
tyvar_tys = mkTyVarTys tyvars
data_cons = tyConDataCons tycon
- constraints = concat (map mk_constraints data_cons)
+
+ if_not_Eval cs = if clas_key == evalClassKey then [] else cs
+
+ constraints = extra_constraints ++ concat (map mk_constraints data_cons)
+
+ -- "extra_constraints": see notes above about contexts on data decls
+ extra_constraints
+ | offensive_class = tyConTheta tycon
+ | otherwise = []
+ where
+ offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
mk_constraints data_con
- = [ (clas, instantiateTy inst_env arg_ty)
- | arg_ty <- arg_tys,
+ = [ (clas, arg_ty)
+ | arg_ty <- instd_arg_tys,
not (isPrimType arg_ty) -- No constraints for primitive types
]
where
- (con_tyvars, _, arg_tys, _) = dataConSig data_con
- inst_env = zipEqual "mk_eqn" con_tyvars tyvar_tys
- -- same number of tyvars in data constr and type constr!
+ instd_arg_tys = dataConArgTys data_con tyvar_tys
\end{code}
%************************************************************************
@@ -334,11 +379,11 @@ terms, which is the final correct RHS for the corresponding original
equation.
\begin{itemize}
\item
-Each (k,UniTyVarTemplate tv) in a solution constrains only a type
+Each (k,TyVarTy tv) in a solution constrains only a type
variable, tv.
\item
-The (k,UniTyVarTemplate tv) pairs in a solution are canonically
+The (k,TyVarTy tv) pairs in a solution are canonically
ordered by sorting on type varible, tv, (major key) and then class, k,
(minor key)
\end{itemize}
@@ -370,24 +415,19 @@ solveDerivEqns inst_decl_infos_in orig_eqns
add_solns inst_decl_infos_in orig_eqns current_solns
`thenTc` \ (new_inst_infos, inst_mapper) ->
-
- -- Simplify each RHS, using a DerivingOrigin containing an
- -- inst_mapper reflecting the previous solution
let
- mk_deriv_origin clas ty
- = DerivingOrigin inst_mapper clas tycon
- where
- (tycon,_) = getAppTyCon ty
+ class_to_inst_env cls = fst (inst_mapper cls)
in
- listTc [ tcSimplifyThetas mk_deriv_origin rhs
- | (_, _, _, rhs) <- orig_eqns
- ] `thenTc` \ next_solns ->
+ -- Simplify each RHS
+
+ listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs
+ | (_,_,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns ->
-- Canonicalise the solutions, so they compare nicely
let canonicalised_next_solns
= [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
- if current_solns `eq_solns` canonicalised_next_solns then
+ if (current_solns `eq_solns` canonicalised_next_solns) then
returnTc new_inst_infos
else
iterateDeriv canonicalised_next_solns
@@ -407,8 +447,7 @@ solveDerivEqns inst_decl_infos_in orig_eqns
\end{code}
\begin{code}
-add_solns :: FAST_STRING
- -> Bag InstInfo -- The global, non-derived ones
+add_solns :: Bag InstInfo -- The global, non-derived ones
-> [DerivEqn] -> [DerivSoln]
-> TcM s ([InstInfo], -- The new, derived ones
InstanceMapper)
@@ -426,22 +465,34 @@ add_solns inst_infos_in eqns solns
mk_deriv_inst_info (clas, tycon, tyvars, _) theta
= InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
theta
- theta -- Blarg. This is the dfun_theta slot,
- -- which is needed by buildInstanceEnv;
- -- This works ok for solving the eqns, and
- -- gen_eqns sets it to its final value
- -- (incl super class dicts) before we
- -- finally return it.
-#ifdef DEBUG
- (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
- (panic "add_soln:binds") (panic "add_soln:from_here")
- (panic "add_soln:modname") mkGeneratedSrcLoc
- (panic "add_soln:upragmas")
-#else
- bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
+ (my_panic "dfun_theta")
+
+ dummy_dfun_id
+
+ (my_panic "const_meth_ids")
+ (my_panic "binds") (my_panic "from_here")
+ (my_panic "modname") mkGeneratedSrcLoc
+ (my_panic "upragmas")
where
- bottom = panic "add_soln"
-#endif
+ dummy_dfun_id
+ = mkDictFunId bottom bottom bottom dummy_dfun_ty
+ bottom bottom bottom bottom
+ where
+ bottom = panic "dummy_dfun_id"
+
+ dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
+ -- All we need from the dfun is its "theta" part, used during
+ -- equation simplification (tcSimplifyThetas). The final
+ -- dfun_id will have the superclass dictionaries as arguments too,
+ -- but that'll be added after the equations are solved. For now,
+ -- it's enough just to make a dummy dfun with the simple theta part.
+ --
+ -- The part after the theta is dummied here as voidTy; actually it's
+ -- (C (T a b)), but it doesn't seem worth constructing it.
+ -- We can't leave it as a panic because to get the theta part we
+ -- have to run down the type!
+
+ my_panic str = pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon])
\end{code}
%************************************************************************
@@ -465,8 +516,7 @@ We want derived instances of @Eq@ and @Ord@ (both v common) to be
``you-couldn't-do-better-by-hand'' efficient.
\item
-Deriving @Text@---also pretty common, usually just for
-@show@---should also be reasonable good code.
+Deriving @Show@---also pretty common--- should also be reasonable good code.
\item
Deriving for the other classes isn't that common or that big a deal.
@@ -476,13 +526,13 @@ PRAGMATICS:
\begin{itemize}
\item
-Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method.
+Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
\item
-Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too.
+Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
\item
-We {\em normally} generated code only for the non-defaulted methods;
+We {\em normally} generate code only for the non-defaulted methods;
there are some exceptions for @Eq@ and (especially) @Ord@...
\item
@@ -491,7 +541,6 @@ constructor's numeric (@Int#@) tag. These are generated by
@gen_tag_n_con_binds@, and the heuristic for deciding if one of
these is around is given by @hasCon2TagFun@.
-
The examples under the different sections below will make this
clearer.
@@ -500,11 +549,11 @@ Much less often (really just for deriving @Ix@), we use a
@_tag2con_<tycon>@ function. See the examples.
\item
-We use Pass~4 of the renamer!!! Reason: we're supposed to be
+We use the renamer!!! Reason: we're supposed to be
producing @RenamedMonoBinds@ for the methods, but that means
producing correctly-uniquified code on the fly. This is entirely
possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
-So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through
+So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
the renamer. What a great hack!
\end{itemize}
@@ -517,7 +566,7 @@ gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
-> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
gen_inst_info modname fixities deriver_rn_env
- info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
+ (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
=
-- Generate the various instance-related Ids
mkInstanceRelatedIds
@@ -531,18 +580,33 @@ gen_inst_info modname fixities deriver_rn_env
-- Generate the bindings for the new instance declaration,
-- rename it, and check for errors
let
- (tycon,_,_) = getAppDataTyCon ty
+ (tycon,_,_) = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $
+ getAppDataTyCon ty
proto_mbinds
- | clas_key == eqClassKey = gen_Eq_binds tycon
- | clas_key == showClassKey = gen_Show_binds fixities tycon
- | clas_key == ordClassKey = gen_Ord_binds tycon
- | clas_key == enumClassKey = gen_Enum_binds tycon
- | clas_key == ixClassKey = gen_Ix_binds tycon
- | clas_key == readClassKey = gen_Read_binds fixities tycon
- | clas_key == binaryClassKey = gen_Binary_binds tycon
- | otherwise = panic "gen_inst_info:bad derived class"
+ = assoc "gen_inst_info:bad derived class"
+ [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(evalClassKey, gen_Eval_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(showClassKey, gen_Show_binds fixities)
+ ,(readClassKey, gen_Read_binds fixities)
+ ,(ixClassKey, gen_Ix_binds)
+ ]
+ clas_key $ tycon
+ in
+{-
+ let
+ ((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env
in
+ pprTrace "gen_inst:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
+ pprTrace "gen_inst:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
+ pprTrace "gen_inst:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
+ pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
+-}
+ -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
+
rnMtoTcM deriver_rn_env (
setExtraRn emptyUFM{-no fixities-} $
rnMethodBinds clas_Name proto_mbinds
@@ -552,8 +616,6 @@ gen_inst_info modname fixities deriver_rn_env
pprPanic "gen_inst_info:renamer errs!\n"
(ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
else
- --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
-
-- All done
let
from_here = isLocallyDefined tycon -- If so, then from here
@@ -563,10 +625,8 @@ gen_inst_info modname fixities deriver_rn_env
(if from_here then mbinds else EmptyMonoBinds)
from_here modname locn [])
where
- clas_key = classKey clas
- clas_Name
- = let (mod, nm) = moduleNamePair clas in
- ClassName clas_key (mkPreludeCoreName mod nm) []
+ clas_key = classKey clas
+ clas_Name = RnImplicitClass (mkImplicitName clas_key (origName clas))
\end{code}
%************************************************************************
@@ -583,14 +643,38 @@ maxtag_Foo :: Int -- ditto (NB: not unboxed)
\begin{code}
gen_tag_n_con_binds :: RnEnv
- -> [(RdrName, RnName, TyCon, TagThingWanted)]
- -> TcM s RenamedHsBinds
+ -> [(RdrName, TyCon, TagThingWanted)]
+ -> TcM s (RenamedHsBinds,
+ RnEnv) -- input one with any new names added
-gen_tag_n_con_binds deriver_rn_env nm_alist_etc
- = let
- proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
- proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
+gen_tag_n_con_binds rn_env nm_alist_etc
+ =
+ let
+ -- We have the renamer's final "name funs" in our hands
+ -- (they were passed in). So we can handle ProtoNames
+ -- that refer to anything "out there". But our generated
+ -- code may also mention "con2tag" (etc.). So we need
+ -- to augment to "name funs" to include those.
+
+ names_to_add = [ pn | (pn,_,_) <- nm_alist_etc ]
+ in
+ tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs ->
+ let
+ pairs_to_add = [ (pn, mkRnName (mkTopLevName u pn mkGeneratedSrcLoc ExportAll []))
+ | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ]
+
+ deriver_rn_env
+ = if null names_to_add
+ then rn_env else added_rn_env
+
+ (added_rn_env, errs_bag)
+ = extendGlobalRnEnv rn_env pairs_to_add [{-no tycons-}]
+
+ ----------------
+ proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
+ proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
in
+ ASSERT(isEmptyBag errs_bag)
rnMtoTcM deriver_rn_env (
setExtraRn emptyUFM{-no fixities-} $
@@ -598,9 +682,10 @@ gen_tag_n_con_binds deriver_rn_env nm_alist_etc
) `thenNF_Tc` \ (binds, errs) ->
if not (isEmptyBag errs) then
- panic "gen_inst_info:renamer errs (2)!"
+ pprPanic "gen_tag_n_con_binds:renamer errs!\n"
+ (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds))
else
- returnTc binds
+ returnTc (binds, deriver_rn_env)
\end{code}
%************************************************************************
@@ -628,30 +713,33 @@ We're deriving @Enum@, or @Ix@ (enum type only???)
If we have a @tag2con@ function, we also generate a @maxtag@ constant.
\begin{code}
-gen_taggery_Names :: [DerivEqn]
- -> TcM s [(RdrName, RnName, -- for an assoc list
- TyCon, -- related tycon
+gen_taggery_Names :: [InstInfo]
+ -> TcM s [(RdrName, -- for an assoc list
+ TyCon, -- related tycon
TagThingWanted)]
-gen_taggery_Names eqns
- = let
- all_tycons = [ tc | (_, tc, _, _) <- eqns ]
- (tycons_of_interest, _) = removeDups cmp all_tycons
- in
- foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
- foldlTc do_tag2con names_so_far tycons_of_interest
+gen_taggery_Names inst_infos
+ = --pprTrace "gen_taggery:\n" (ppAboves [ppCat [ppr PprDebug c, ppr PprDebug t] | (c,t) <- all_CTs]) $
+ foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
+ foldlTc do_tag2con names_so_far tycons_of_interest
where
+ all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _ _ _ _) <- inst_infos ]
+
+ mk_CT c ty = (c, fst (getAppTyCon ty))
+
+ all_tycons = map snd all_CTs
+ (tycons_of_interest, _) = removeDups cmp all_tycons
+
do_con2tag acc_Names tycon
= if (we_are_deriving eqClassKey tycon
- && any ( (== 0).dataConArity ) (tyConDataCons tycon))
+ && any isNullaryDataCon (tyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
&& not (maybeToBool (maybeTyConSingleCon tycon)))
|| (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon)
then
- tcGetUnique `thenNF_Tc` ( \ u ->
- returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
- : acc_Names) )
+ returnTc ((con2tag_PN tycon, tycon, GenCon2Tag)
+ : acc_Names)
else
returnTc acc_Names
@@ -659,33 +747,26 @@ gen_taggery_Names eqns
= if (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon)
then
- tcGetUnique `thenNF_Tc` \ u1 ->
- tcGetUnique `thenNF_Tc` \ u2 ->
- returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con)
- : (maxtag_PN tycon, ValName u2 (maxtag_FN tycon), tycon, GenMaxTag)
+ returnTc ( (tag2con_PN tycon, tycon, GenTag2Con)
+ : (maxtag_PN tycon, tycon, GenMaxTag)
: acc_Names)
else
returnTc acc_Names
we_are_deriving clas_key tycon
- = is_in_eqns clas_key tycon eqns
+ = is_in_eqns clas_key tycon all_CTs
where
is_in_eqns clas_key tycon [] = False
- is_in_eqns clas_key tycon ((c,t,_,_):eqns)
+ is_in_eqns clas_key tycon ((c,t):cts)
= (clas_key == classKey c && tycon == t)
- || is_in_eqns clas_key tycon eqns
+ || is_in_eqns clas_key tycon cts
\end{code}
\begin{code}
-derivingEnumErr :: TyCon -> Error
-derivingEnumErr tycon
- = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
- ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
-
-derivingIxErr :: TyCon -> Error
-derivingIxErr tycon
- = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
- ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
--}
+derivingThingErr :: String -> TyCon -> Error
+
+derivingThingErr thing tycon sty
+ = ppHang (ppCat [ppStr "Can't make a derived instance of", ppStr thing])
+ 4 (ppBesides [ppStr "for the type `", ppr sty tycon, ppStr "'"])
\end{code}
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 7702e31d652e..0c299a5669d7 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -21,18 +21,18 @@ module TcEnv(
) where
-import Ubiq
-import TcMLoop -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(TcMLoop) -- for paranoia checking
import Id ( Id(..), GenId, idType, mkUserLocal )
import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) )
import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..),
- newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars
+ newTyVarTys, tcInstTyVars, zonkTcTyVars
)
import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
import Type ( tyVarsOfTypes )
-import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity )
+import TyCon ( TyCon, tyConKind, synTyConArity )
import Class ( Class(..), GenClass, classSig )
import TcMonad hiding ( rnMtoTcM )
@@ -294,7 +294,7 @@ newMonoIds names kind m
mk_id name uniq ty
= let
- name_str = case (getOccName name) of { Unqual n -> n }
+ name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n }
in
mkUserLocal name_str uniq ty (getSrcLoc name)
in
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 21e864e3e0e1..a45dc275e6ac 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -8,13 +8,13 @@
module TcExpr ( tcExpr ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsExpr(..), Qual(..), Stmt(..),
HsBinds(..), Bind(..), MonoBinds(..),
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
Match, Fake, InPat, OutPat, PolyType,
- irrefutablePat, collectPatBinders )
+ failureFreePat, collectPatBinders )
import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..),
RenamedStmt(..), RenamedRecordBinds(..),
RnName{-instance Outputable-}
@@ -37,17 +37,18 @@ import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
import TcType ( TcType(..), TcMaybe(..),
- tcInstId, tcInstType, tcInstTheta, tcInstTyVars,
+ tcInstId, tcInstType, tcInstSigTyVars,
+ tcInstSigType, tcInstTcType, tcInstTheta,
newTyVarTy, zonkTcTyVars, zonkTcType )
import TcKind ( TcKind )
import Class ( Class(..), classSig )
import FieldLabel ( fieldLabelName )
-import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig )
+import Id ( idType, dataConFieldLabels, dataConSig, Id(..), GenId )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
import Name ( Name{-instance Eq-} )
-import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
+import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
getTyVar_maybe, getFunTy_maybe, instantiateTy,
splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
@@ -65,7 +66,7 @@ import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- monadClassKey, monadZeroClassKey
+ thenMClassOpKey, zeroClassOpKey
)
--import Name ( Name ) -- Instance
import Outputable ( interpp'SP )
@@ -318,32 +319,8 @@ tcExpr (ListComp expr quals)
\end{code}
\begin{code}
-tcExpr (HsDo stmts src_loc)
- = -- get the Monad and MonadZero classes
- -- create type consisting of a fresh monad tyvar
- tcAddSrcLoc src_loc $
- 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"])
- ) `thenNF_Tc` \ (mz_lie, [mz_id]) ->
-
- returnTc (HsDoOut stmts' m_id mz_id src_loc,
- lie `plusLIE` m_lie `plusLIE` mz_lie,
- do_ty)
- where
- monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
+tcExpr expr@(HsDo stmts src_loc)
+ = tcDoStmts stmts src_loc
\end{code}
\begin{code}
@@ -487,7 +464,7 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty)
-- Check the tau-type part
tcSetErrCtxt (exprSigCtxt in_expr) $
- tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' ->
+ tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
let
(sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
in
@@ -590,11 +567,17 @@ tcArg expected_arg_ty arg
-- of instantiating a function involving rank-2 polymorphism, so there
-- isn't any danger of using the same tyvars twice
-- The argument type shouldn't be overloaded type (hence ASSERT)
+
+ -- To ensure that the forall'd type variables don't get unified with each
+ -- other or any other types, we make fresh *signature* type variables
+ -- and unify them with the tyvars.
let
(expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
in
ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things
-
+ tcInstSigTyVars expected_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
+ unifyTauTyLists (mkTyVarTys expected_tyvars) sig_tyvar_tys `thenTc_`
+
-- Type-check the arg and unify with expected type
tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
unifyTauTy expected_tau actual_arg_ty `thenTc_` (
@@ -609,11 +592,10 @@ tcArg expected_arg_ty arg
-- So now s' isn't unconstrained because it's linked to a.
-- Conclusion: include the free vars of the expected arg type in the
-- list of "free vars" for the signature check.
+
tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
- tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
- zonkTcTyVars (tyVarsOfType expected_arg_ty) `thenNF_Tc` \ free_tyvars ->
checkSigTyVarsGivenGlobals
- (env_tyvars `unionTyVarSets` free_tyvars)
+ (tyVarsOfType expected_arg_ty)
expected_tyvars expected_tau `thenTc_`
-- Check that there's no overloading involved
@@ -649,42 +631,45 @@ tcId name
= -- Look up the Id and instantiate its type
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) ->
- let
- rho' = instantiateTy tenv rho
- in
- returnNF_Tc (TcId tc_id, arg_tys', rho')
-
- Nothing -> 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 (RealId id, arg_tys, rho')
-
- ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
-
- -- Is it overloaded?
- case splitRhoTy rho of
- ([], tau) -> -- Not overloaded, so just make a type application
- returnNF_Tc (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) ->
- returnNF_Tc (HsVar meth_id, lie, tau)
-\end{code}
+ case maybe_local of
+ Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
+ Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ tcInstType [] (idType id) `thenNF_Tc` \ inst_ty ->
+ let
+ (tyvars, rho) = splitForAllTy inst_ty
+ in
+ instantiate_it2 (RealId id) tyvars rho
+ where
+ -- The instantiate_it loop runs round instantiating the Id.
+ -- It has to be a loop because we are now prepared to entertain
+ -- types like
+ -- f:: forall a. Eq a => forall b. Baz b => tau
+ -- We want to instantiate this to
+ -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
+ instantiate_it tc_id_occ ty
+ = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
+ instantiate_it2 tc_id_occ tyvars rho
+
+ instantiate_it2 tc_id_occ tyvars rho
+ | null theta -- Is it overloaded?
+ = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+
+ | otherwise -- Yes, it's overloaded
+ = newMethodWithGivenTy (OccurrenceOf tc_id_occ)
+ tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
+ instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
+
+ where
+ (theta, tau) = splitRhoTy rho
+ arg_tys = mkTyVarTys tyvars
+\end{code}
%************************************************************************
%* *
-\subsection{@tcQuals@ typchecks list comprehension qualifiers}
+\subsection{@tcQuals@ typechecks list-comprehension qualifiers}
%* *
%************************************************************************
@@ -749,67 +734,78 @@ tcListComp expr (LetQual binds : quals)
%************************************************************************
\begin{code}
-tcDoStmts :: Bool -- True => require a monad
- -> TcType s -- m
- -> [RenamedStmt]
- -> TcM s (([TcStmt s],
- Bool, -- True => Monad
- Bool), -- True => MonadZero
- LIE s,
- TcType s)
-
-tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
- = tcAddSrcLoc src_loc $
- tcSetErrCtxt (stmtCtxt stmt) $
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
- (if monad then
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy (mkAppTy m a) exp_ty
- else
- returnTc ()
- ) `thenTc_`
- returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
-
-tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
- = tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt stmt) (
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
- returnTc (ExprStmt exp' src_loc, exp_lie)
- )) `thenTc` \ (stmt', stmt_lie) ->
- tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
- returnTc ((stmt':stmts', True, mzero),
- stmt_lie `plusLIE` stmts_lie,
- stmts_ty)
-
-tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
- = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt stmt) (
- tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
-
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+tcDoStmts stmts src_loc
+ = -- get the Monad and MonadZero classes
+ -- create type consisting of a fresh monad tyvar
+ tcAddSrcLoc src_loc $
+ newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
+
+
+ -- Build the then and zero methods in case we need them
+ tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
+ tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
+ newMethod DoOrigin
+ (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) ->
+ newMethod DoOrigin
+ (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) ->
+
+ let
+ get_m_arg ty
+ = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty ->
+ unifyTauTy (mkAppTy m arg_ty) ty `thenTc_`
+ returnTc arg_ty
+
+ go [stmt@(ExprStmt exp src_loc)]
+ = tcAddSrcLoc src_loc $
+ tcSetErrCtxt (stmtCtxt stmt) $
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty)
+
+ go (stmt@(ExprStmt exp src_loc) : stmts)
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ get_m_arg exp_ty `thenTc` \ a ->
+ returnTc (a, exp', exp_lie)
+ )) `thenTc` \ (a, exp', exp_lie) ->
+ go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
+ get_m_arg stmts_ty `thenTc` \ b ->
+ returnTc (ExprStmtOut exp' src_loc a b : stmts',
+ exp_lie `plusLIE` stmts_lie `plusLIE` m_lie,
+ stmts_ty)
+
+ go (stmt@(BindStmt pat exp src_loc) : stmts)
+ = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
-- See comments with tcListComp on GeneratorQual
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy a pat_ty `thenTc_`
- unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
- returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
- )) `thenTc` \ (stmt', stmt_lie, failure_free) ->
- tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
- returnTc ((stmt':stmts', True, mzero || not failure_free),
- stmt_lie `plusLIE` stmts_lie,
- stmts_ty)
-
-tcDoStmts monad m (LetStmt binds : stmts)
- = tcBindsAndThen -- No error context, but a binding group is
- combine -- rather a large thing for an error context anyway
- binds
- (tcDoStmts monad m stmts)
- where
- combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
+ get_m_arg exp_ty `thenTc` \ a ->
+ unifyTauTy a pat_ty `thenTc_`
+ returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
+ )) `thenTc` \ (a, pat', exp', stmt_lie) ->
+ go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
+ get_m_arg stmts_ty `thenTc` \ b ->
+ returnTc (BindStmtOut pat' exp' src_loc a b : stmts',
+ stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE`
+ (if failureFreePat pat' then emptyLIE else mz_lie),
+ stmts_ty)
+
+ go (LetStmt binds : stmts)
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine -- rather a large thing for an error context anyway
+ binds
+ (go stmts)
+ where
+ combine binds' stmts' = LetStmt binds' : stmts'
+ in
+ go stmts `thenTc` \ (stmts', final_lie, final_ty) ->
+ returnTc (HsDoOut stmts' then_id zero_id src_loc,
+ final_lie,
+ final_ty)
\end{code}
Game plan for record bindings
diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index edc286982900..4a532ae00960 100644
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -4,10 +4,12 @@
\section[TcGRHSs]{Typecheck guarded right-hand-sides}
\begin{code}
+#include "HsVersions.h"
+
module TcGRHSs ( tcGRHSsAndBinds ) where
-import Ubiq{-uitous-}
-import TcLoop -- for paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(TcLoop) -- for paranoia checking
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr, HsBinds(..), InPat, OutPat, Bind, Sig, Fake )
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 8f19aef1c7d6..743851770d57 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -11,7 +11,7 @@ This is where we do all the grimy bindings' generation.
\begin{code}
#include "HsVersions.h"
-module TcGenDeriv {- (
+module TcGenDeriv (
a_Expr,
a_PN,
a_Pat,
@@ -29,15 +29,16 @@ module TcGenDeriv {- (
d_PN,
d_Pat,
dh_PN,
- eqH_PN,
+ eqH_Int_PN,
eqTag_Expr,
eq_PN,
error_PN,
false_Expr,
false_PN,
geH_PN,
- gen_Binary_binds,
+ gen_Bounded_binds,
gen_Enum_binds,
+ gen_Eval_binds,
gen_Eq_binds,
gen_Ix_binds,
gen_Ord_binds,
@@ -47,7 +48,7 @@ module TcGenDeriv {- (
gtTag_Expr,
gt_PN,
leH_PN,
- ltH_PN,
+ ltH_Int_PN,
ltTag_Expr,
lt_PN,
minusH_PN,
@@ -56,49 +57,50 @@ module TcGenDeriv {- (
true_Expr,
true_PN,
- con2tag_FN, tag2con_FN, maxtag_FN,
con2tag_PN, tag2con_PN, maxtag_PN,
TagThingWanted(..)
- ) -} where
+ ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt,
ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
import RdrHsSyn ( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) )
-import RnHsSyn ( RnName(..), RenamedFixityDecl(..) )
+import RnHsSyn ( RenamedFixityDecl(..) )
+--import RnUtils
---import RnMonad4 -- initRn4, etc.
-import RnUtils
-
-import Id ( GenId, dataConArity, dataConTag,
- dataConSig, fIRST_TAG,
+import Id ( GenId, dataConArity, isNullaryDataCon, dataConTag,
+ dataConRawArgTys, fIRST_TAG,
isDataCon, DataCon(..), ConTag(..) )
import IdUtils ( primOpId )
import Maybes ( maybeToBool )
---import Name ( Name(..) )
-import Outputable
-import PrimOp
---import PrelInfo
-import Pretty
+import Name ( moduleNamePair, origName, RdrName(..) )
+import PrelMods ( fromPrelude, pRELUDE, pRELUDE_BUILTIN, pRELUDE_LIST, pRELUDE_TEXT )
+import PrelVals ( eRROR_ID )
+
+import PrimOp ( PrimOp(..) )
import SrcLoc ( mkGeneratedSrcLoc )
import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
import Type ( eqTy, isPrimType )
-import Unique
-import Util
+import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
+ floatPrimTy, doublePrimTy
+ )
+import TysWiredIn ( falseDataCon, trueDataCon, intDataCon )
+--import Unique
+import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
\end{code}
%************************************************************************
%* *
-\subsection[TcGenDeriv-classes]{Generating code, by derivable class}
+\subsection{Generating code, by derivable class}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Eq]{Generating @Eq@ instance declarations}
+\subsubsection{Generating @Eq@ instance declarations}
%* *
%************************************************************************
@@ -170,18 +172,15 @@ instance ... Eq (Foo ...) where
\end{itemize}
\begin{code}
-foo_TcGenDeriv = panic "Nothing in TcGenDeriv LATER ToDo"
-
-{- LATER:
gen_Eq_binds :: TyCon -> RdrNameMonoBinds
gen_Eq_binds tycon
- = case (partition (\ con -> dataConArity con == 0)
- (tyConDataCons tycon))
- of { (nullary_cons, nonnullary_cons) ->
- let
+ = let
+ (nullary_cons, nonnullary_cons)
+ = partition isNullaryDataCon (tyConDataCons tycon)
+
rest
- = if null nullary_cons then
+ = if (null nullary_cons) then
case maybeTyConSingleCon tycon of
Just _ -> []
Nothing -> -- if cons don't match, then False
@@ -189,11 +188,10 @@ gen_Eq_binds tycon
else -- calc. and compare the tags
[([a_Pat, b_Pat],
untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)]
- (cmp_tags_Expr eqH_PN ah_PN bh_PN true_Expr false_Expr))]
+ (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN true_Expr false_Expr))]
in
mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest)
`AndMonoBinds` boring_ne_method
- }
where
------------------------------------------------------------------
pats_etc data_con
@@ -201,31 +199,37 @@ gen_Eq_binds tycon
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- data_con_PN = Prel (WiredInId data_con)
- 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
+ data_con_PN = origName data_con
+ con_arity = dataConArity data_con
+ as_needed = take con_arity as_PNs
+ bs_needed = take con_arity bs_PNs
+ tys_needed = dataConRawArgTys data_con
in
([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
where
+ nested_eq_expr [] [] [] = true_Expr
+ nested_eq_expr tys as bs
+ = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+ where
+ nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
+{-OLD:
nested_eq_expr [] [] [] = true_Expr
- nested_eq_expr [ty] [a] [b] = eq_Expr ty (HsVar a) (HsVar b)
+ nested_eq_expr [ty] [a] [b] =
nested_eq_expr (t:ts) (a:as) (b:bs)
= let
rest_expr = nested_eq_expr ts as bs
in
and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr
+-}
boring_ne_method
- = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] (
- HsApp (HsVar not_PN) (HsApp (HsApp (HsVar eq_PN) a_Expr) b_Expr)
- )
+ = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $
+ HsApp (HsVar not_PN) (HsPar (mk_easy_App eq_PN [a_PN, b_PN]))
\end{code}
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Ord]{Generating @Ord@ instance declarations}
+\subsubsection{Generating @Ord@ instance declarations}
%* *
%************************************************************************
@@ -245,13 +249,13 @@ data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
We do all the other @Ord@ methods with calls to @compare@:
\begin{verbatim}
instance ... (Ord <wurble> <wurble>) where
- a < b = case compare a b of { LT -> True; EQ -> False; GT -> False }
- a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False }
- a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True }
- a > b = case compare a b of { LT -> False; EQ -> False; GT -> True }
+ a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
+ a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
+ a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
- max a b = case compare a b of { LT -> b; EQ -> a; GT -> a }
- min a b = case compare a b of { LT -> a; EQ -> b; GT -> b }
+ max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
+ min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
-- compare to come...
\end{verbatim}
@@ -263,7 +267,7 @@ instance ... (Ord <wurble> <wurble>) where
\begin{verbatim}
compare a b = case (con2tag_Foo a) of { a# ->
case (con2tag_Foo b) of { b# ->
- case (a# ==# b#) of {
+ case (a# ==# b#) of {
True -> cmp_eq a b
False -> case (a# <# b#) of
True -> _LT
@@ -329,7 +333,7 @@ gen_Ord_binds tycon
cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
else
untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
- (cmp_tags_Expr eqH_PN ah_PN bh_PN
+ (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN
-- True case; they are equal
-- If an enumeration type we are done; else
-- recursively compare their components
@@ -340,7 +344,7 @@ gen_Ord_binds tycon
)
-- False case; they aren't equal
-- So we need to do a less-than comparison on the tags
- (cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
+ (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
(nullary_cons, nonnullary_cons)
= partition (\ con -> dataConArity con == 0) (tyConDataCons tycon)
@@ -355,11 +359,11 @@ gen_Ord_binds tycon
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- data_con_PN = Prel (WiredInId data_con)
- 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
+ data_con_PN = origName data_con
+ con_arity = dataConArity data_con
+ as_needed = take con_arity as_PNs
+ bs_needed = take con_arity bs_PNs
+ tys_needed = dataConRawArgTys data_con
nested_compare_expr [ty] [a] [b]
= careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
@@ -393,7 +397,7 @@ min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Enum]{Generating @Enum@ instance declarations}
+\subsubsection{Generating @Enum@ instance declarations}
%* *
%************************************************************************
@@ -434,26 +438,70 @@ gen_Enum_binds tycon
= enum_from `AndMonoBinds` enum_from_then
where
enum_from
- = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] (
- untag_Expr tycon [(a_PN, ah_PN)] (
- HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
- enum_from_to_Expr
- (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
- (HsVar (maxtag_PN tycon)))))
+ = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] $
+ untag_Expr tycon [(a_PN, ah_PN)] $
+ HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ HsPar (enum_from_to_Expr
+ (mk_easy_App mkInt_PN [ah_PN])
+ (HsVar (maxtag_PN tycon)))
enum_from_then
- = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] (
- untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] (
- HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
- enum_from_then_to_Expr
- (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
- (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
- (HsVar (maxtag_PN tycon)))))
+ = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] $
+ untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] $
+ HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ HsPar (enum_from_then_to_Expr
+ (mk_easy_App mkInt_PN [ah_PN])
+ (mk_easy_App mkInt_PN [bh_PN])
+ (HsVar (maxtag_PN tycon)))
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Generating @Eval@ instance declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+gen_Eval_binds tycon = EmptyMonoBinds
\end{code}
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Ix]{Generating @Ix@ instance declarations}
+\subsubsection{Generating @Bounded@ instance declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+gen_Bounded_binds tycon
+ = if isEnumerationTyCon tycon then
+ min_bound_enum `AndMonoBinds` max_bound_enum
+ else
+ ASSERT(length data_cons == 1)
+ min_bound_1con `AndMonoBinds` max_bound_1con
+ where
+ data_cons = tyConDataCons tycon
+
+ ----- enum-flavored: ---------------------------
+ min_bound_enum = mk_easy_FunMonoBind minBound_PN [] [] (HsVar data_con_1_PN)
+ max_bound_enum = mk_easy_FunMonoBind maxBound_PN [] [] (HsVar data_con_N_PN)
+
+ data_con_1 = head data_cons
+ data_con_N = last data_cons
+ data_con_1_PN = origName data_con_1
+ data_con_N_PN = origName data_con_N
+
+ ----- single-constructor-flavored: -------------
+ arity = dataConArity data_con_1
+
+ min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $
+ mk_easy_App data_con_1_PN (nOfThem arity minBound_PN)
+ max_bound_1con = mk_easy_FunMonoBind maxBound_PN [] [] $
+ mk_easy_App data_con_1_PN (nOfThem arity maxBound_PN)
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Generating @Ix@ instance declarations}
%* *
%************************************************************************
@@ -524,25 +572,24 @@ gen_Ix_binds tycon
enum_index `AndMonoBinds` enum_inRange
enum_range
- = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] (
- untag_Expr tycon [(a_PN, ah_PN)] (
- untag_Expr tycon [(b_PN, bh_PN)] (
- HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
- enum_from_to_Expr
- (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
- (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
- ))))
+ = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] $
+ untag_Expr tycon [(a_PN, ah_PN)] $
+ untag_Expr tycon [(b_PN, bh_PN)] $
+ HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ HsPar (enum_from_to_Expr
+ (mk_easy_App mkInt_PN [ah_PN])
+ (mk_easy_App mkInt_PN [bh_PN]))
enum_index
= mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
- HsIf (HsApp (HsApp (HsVar inRange_PN) c_Expr) d_Expr) (
+ HsIf (HsPar (mk_easy_App inRange_PN [c_PN, d_PN])) (
untag_Expr tycon [(a_PN, ah_PN)] (
untag_Expr tycon [(d_PN, dh_PN)] (
let
- grhs = [OtherwiseGRHS (HsApp (HsVar mkInt_PN) (HsVar c_PN)) mkGeneratedSrcLoc]
+ grhs = [OtherwiseGRHS (mk_easy_App mkInt_PN [c_PN]) mkGeneratedSrcLoc]
in
HsCase
- (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN))
+ (HsPar (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN)))
[PatMatch (VarPatIn c_PN)
(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
mkGeneratedSrcLoc
@@ -557,7 +604,7 @@ gen_Ix_binds tycon
untag_Expr tycon [(a_PN, ah_PN)] (
untag_Expr tycon [(b_PN, bh_PN)] (
untag_Expr tycon [(c_PN, ch_PN)] (
- HsIf (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN)) (
+ HsIf (HsPar (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN))) (
(OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
) {-else-} (
false_Expr
@@ -570,22 +617,19 @@ gen_Ix_binds tycon
data_con
= case maybeTyConSingleCon tycon of -- just checking...
Nothing -> panic "get_Ix_binds"
- Just dc -> let
- (_, _, arg_tys, _) = dataConSig dc
- in
- if any isPrimType arg_tys then
+ Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
else
dc
con_arity = dataConArity data_con
- data_con_PN = Prel (WiredInId data_con)
+ data_con_PN = origName data_con
con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
- con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs)
+ con_expr xs = mk_easy_App data_con_PN xs
- as_needed = take (dataConArity data_con) as_PNs
- bs_needed = take (dataConArity data_con) bs_PNs
- cs_needed = take (dataConArity data_con) cs_PNs
+ as_needed = take con_arity as_PNs
+ bs_needed = take con_arity bs_PNs
+ cs_needed = take con_arity cs_PNs
--------------------------------------------------------------
single_con_range
@@ -626,7 +670,7 @@ gen_Ix_binds tycon
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Text]{Generating @Show@ and @Read@ instance declarations}
+\subsubsection{Generating @Read@ instance declarations}
%* *
%************************************************************************
@@ -634,14 +678,13 @@ Ignoring all the infix-ery mumbo jumbo (ToDo)
\begin{code}
gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
-gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
gen_Read_binds fixities tycon
= reads_prec `AndMonoBinds` read_list
where
-----------------------------------------------------------------------
read_list = mk_easy_FunMonoBind readList_PN [] []
- (HsApp (HsVar _readList_PN) (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))
+ (HsApp (HsVar _readList_PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))))
-----------------------------------------------------------------------
reads_prec
= let
@@ -654,12 +697,13 @@ gen_Read_binds fixities tycon
where
read_con data_con -- note: "b" is the string being "read"
= let
- data_con_PN = Prel (WiredInId data_con)
+ data_con_PN = origName data_con
data_con_str= snd (moduleNamePair data_con)
- 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 = dataConArity data_con == 0
+ con_arity = dataConArity data_con
+ as_needed = take con_arity as_PNs
+ bs_needed = take con_arity bs_PNs
+ con_expr = mk_easy_App data_con_PN as_needed
+ nullary_con = isNullaryDataCon data_con
con_qual
= GeneratorQual
@@ -672,39 +716,51 @@ gen_Read_binds fixities tycon
= if nullary_con then -- must be False (parens are surely optional)
false_Expr
else -- parens depend on precedence...
- OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9))
+ HsPar (OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9)))
in
HsApp (
- readParen_Expr read_paren_arg (
+ readParen_Expr read_paren_arg $ HsPar $
HsLam (mk_easy_Match [c_Pat] [] (
ListComp (ExplicitTuple [con_expr,
if null bs_needed then d_Expr else HsVar (last bs_needed)])
(con_qual : field_quals)))
- )) (HsVar b_PN)
+ ) (HsVar b_PN)
where
mk_qual draw_from (con_field, str_left)
= (HsVar str_left, -- what to draw from down the line...
GeneratorQual
(TuplePatIn [VarPatIn con_field, VarPatIn str_left])
(HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
+\end{code}
+%************************************************************************
+%* *
+\subsubsection{Generating @Show@ instance declarations}
+%* *
+%************************************************************************
+
+Ignoring all the infix-ery mumbo jumbo (ToDo)
+
+\begin{code}
+gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
gen_Show_binds fixities tycon
= shows_prec `AndMonoBinds` show_list
where
-----------------------------------------------------------------------
show_list = mk_easy_FunMonoBind showList_PN [] []
- (HsApp (HsVar _showList_PN) (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0))))
+ (HsApp (HsVar _showList_PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))))
-----------------------------------------------------------------------
shows_prec
= mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
where
pats_etc data_con
= let
- data_con_PN = Prel (WiredInId data_con)
- bs_needed = take (dataConArity data_con) bs_PNs
+ data_con_PN = origName data_con
+ con_arity = dataConArity data_con
+ bs_needed = take con_arity bs_PNs
con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- nullary_con = dataConArity data_con == 0
+ nullary_con = isNullaryDataCon data_con
show_con
= let (mod, nm) = moduleNamePair data_con
@@ -723,8 +779,8 @@ gen_Show_binds fixities tycon
([a_Pat, con_pat], show_con)
else
([a_Pat, con_pat],
- showParen_Expr (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10)))
- (nested_compose_Expr show_thingies))
+ showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10))))
+ (HsPar (nested_compose_Expr show_thingies)))
where
spacified [] = []
spacified [x] = [x]
@@ -733,22 +789,7 @@ gen_Show_binds fixities tycon
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations}
-%* *
-%************************************************************************
-
-ToDo: NOT DONE YET.
-
-\begin{code}
-gen_Binary_binds :: TyCon -> RdrNameMonoBinds
-
-gen_Binary_binds tycon
- = panic "gen_Binary_binds"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
+\subsection{Generating extra binds (@con2tag@ and @tag2con@)}
%* *
%************************************************************************
@@ -768,12 +809,12 @@ data TagThingWanted
= GenCon2Tag | GenTag2Con | GenMaxTag
gen_tag_n_con_monobind
- :: (RdrName, RnName, -- (proto)Name for the thing in question
+ :: (RdrName, -- (proto)Name for the thing in question
TyCon, -- tycon in question
TagThingWanted)
-> RdrNameMonoBinds
-gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
+gen_tag_n_con_monobind (pn, tycon, GenCon2Tag)
= mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
where
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
@@ -783,9 +824,9 @@ gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
- var_PN = Prel (WiredInId var)
+ var_PN = origName var
-gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
+gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
= mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
where
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
@@ -795,9 +836,9 @@ gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
([lit_pat], HsVar var_PN)
where
lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
- var_PN = Prel (WiredInId var)
+ var_PN = origName var
-gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
+gen_tag_n_con_monobind (pn, tycon, GenMaxTag)
= mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
where
max_tag = case (tyConDataCons tycon) of
@@ -806,7 +847,7 @@ gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
%************************************************************************
%* *
-\subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings}
+\subsection{Utility bits for generating bindings}
%* *
%************************************************************************
@@ -833,9 +874,7 @@ mk_easy_FunMonoBind fun pats binds expr
= FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
mk_easy_Match pats binds expr
- = foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
- pats
+ = mk_match pats expr (mkbind binds)
where
mkbind [] = EmptyBinds
mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
@@ -849,12 +888,21 @@ mk_FunMonoBind :: RdrName
mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
mk_FunMonoBind fun pats_and_exprs
- = FunMonoBind fun False{-not infix-} (map mk_match pats_and_exprs) mkGeneratedSrcLoc
+ = FunMonoBind fun False{-not infix-}
+ [ mk_match p e EmptyBinds | (p,e) <-pats_and_exprs ]
+ mkGeneratedSrcLoc
+
+mk_match pats expr binds
+ = foldr PatMatch
+ (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] binds))
+ (map paren pats)
where
- mk_match (pats, expr)
- = foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds))
- pats
+ paren p@(VarPatIn _) = p
+ paren other_p = ParPatIn other_p
+\end{code}
+
+\begin{code}
+mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
\end{code}
\begin{code}
@@ -877,7 +925,7 @@ compare_Case = compare_gen_Case compare_PN
cmp_eq_Expr = compare_gen_Case cmp_eq_PN
compare_gen_Case fun lt eq gt a b
- = HsCase (HsApp (HsApp (HsVar fun) a) b) {-of-}
+ = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
[PatMatch (ConPatIn ltTag_PN [])
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
@@ -893,9 +941,9 @@ careful_compare_Case ty lt eq gt a b
compare_gen_Case compare_PN lt eq gt a b
else -- we have to do something special for primitive things...
- HsIf (OpApp a (HsVar relevant_eq_op) b)
+ HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b))
eq
- (HsIf (OpApp a (HsVar relevant_lt_op) b) lt gt mkGeneratedSrcLoc)
+ (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc)
mkGeneratedSrcLoc
where
relevant_eq_op = assoc_ty_id eq_op_tbl ty
@@ -907,21 +955,23 @@ assoc_ty_id tyids ty
where
res = [id | (ty',id) <- tyids, eqTy ty ty']
-eq_op_tbl = [
- (charPrimTy, Prel (WiredInId (primOpId CharEqOp))),
- (intPrimTy, Prel (WiredInId (primOpId IntEqOp))),
- (wordPrimTy, Prel (WiredInId (primOpId WordEqOp))),
- (addrPrimTy, Prel (WiredInId (primOpId AddrEqOp))),
- (floatPrimTy, Prel (WiredInId (primOpId FloatEqOp))),
- (doublePrimTy, Prel (WiredInId (primOpId DoubleEqOp))) ]
-
-lt_op_tbl = [
- (charPrimTy, Prel (WiredInId (primOpId CharLtOp))),
- (intPrimTy, Prel (WiredInId (primOpId IntLtOp))),
- (wordPrimTy, Prel (WiredInId (primOpId WordLtOp))),
- (addrPrimTy, Prel (WiredInId (primOpId AddrLtOp))),
- (floatPrimTy, Prel (WiredInId (primOpId FloatLtOp))),
- (doublePrimTy, Prel (WiredInId (primOpId DoubleLtOp))) ]
+eq_op_tbl =
+ [(charPrimTy, eqH_Char_PN)
+ ,(intPrimTy, eqH_Int_PN)
+ ,(wordPrimTy, eqH_Word_PN)
+ ,(addrPrimTy, eqH_Addr_PN)
+ ,(floatPrimTy, eqH_Float_PN)
+ ,(doublePrimTy, eqH_Double_PN)
+ ]
+
+lt_op_tbl =
+ [(charPrimTy, ltH_Char_PN)
+ ,(intPrimTy, ltH_Int_PN)
+ ,(wordPrimTy, ltH_Word_PN)
+ ,(addrPrimTy, ltH_Addr_PN)
+ ,(floatPrimTy, ltH_Float_PN)
+ ,(doublePrimTy, ltH_Double_PN)
+ ]
-----------------------------------------------------------------------
@@ -932,7 +982,7 @@ append_Expr a b = OpApp a (HsVar append_PN) b
-----------------------------------------------------------------------
-eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
eq_Expr ty a b
= if not (isPrimType ty) then
OpApp a (HsVar eq_PN) b
@@ -946,21 +996,21 @@ eq_Expr ty a b
untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
- = HsCase (HsApp (con2tag_Expr tycon) (HsVar untag_this)) {-of-}
+ = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
[PatMatch (VarPatIn put_tag_here)
(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
mkGeneratedSrcLoc
where
grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
-cmp_tags_Expr :: RdrName -- Comparison op
- -> RdrName -> RdrName -- Things to compare
+cmp_tags_Expr :: RdrName -- Comparison op
+ -> RdrName -> RdrName -- Things to compare
-> RdrNameHsExpr -- What to return if true
- -> RdrNameHsExpr -- What to return if false
+ -> RdrNameHsExpr -- What to return if false
-> RdrNameHsExpr
cmp_tags_Expr op a b true_case false_case
- = HsIf (OpApp (HsVar a) (HsVar op) (HsVar b)) true_case false_case mkGeneratedSrcLoc
+ = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc
enum_from_to_Expr
:: RdrNameHsExpr -> RdrNameHsExpr
@@ -981,26 +1031,29 @@ readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
-nested_compose_Expr [e] = e
+nested_compose_Expr [e] = parenify e
nested_compose_Expr (e:es)
- = HsApp (HsApp (HsVar compose_PN) e) (nested_compose_Expr es)
+ = HsApp (HsApp (HsVar compose_PN) (parenify e)) (nested_compose_Expr es)
+
+parenify e@(HsVar _) = e
+parenify e = HsPar e
\end{code}
\begin{code}
-a_PN = Unk SLIT("a")
-b_PN = Unk SLIT("b")
-c_PN = Unk SLIT("c")
-d_PN = Unk SLIT("d")
-ah_PN = Unk SLIT("a#")
-bh_PN = Unk SLIT("b#")
-ch_PN = Unk SLIT("c#")
-dh_PN = Unk SLIT("d#")
-cmp_eq_PN = Unk SLIT("cmp_eq")
-rangeSize_PN = Unk SLIT("rangeSize")
-
-as_PNs = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
-bs_PNs = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
-cs_PNs = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
+a_PN = Unqual SLIT("a")
+b_PN = Unqual SLIT("b")
+c_PN = Unqual SLIT("c")
+d_PN = Unqual SLIT("d")
+ah_PN = Unqual SLIT("a#")
+bh_PN = Unqual SLIT("b#")
+ch_PN = Unqual SLIT("c#")
+dh_PN = Unqual SLIT("d#")
+cmp_eq_PN = Unqual SLIT("cmp_eq")
+rangeSize_PN = Unqual SLIT("rangeSize")
+
+as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
+cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
eq_PN = prelude_method SLIT("Eq") SLIT("==")
ne_PN = prelude_method SLIT("Eq") SLIT("/=")
@@ -1011,9 +1064,11 @@ gt_PN = prelude_method SLIT("Ord") SLIT(">")
max_PN = prelude_method SLIT("Ord") SLIT("max")
min_PN = prelude_method SLIT("Ord") SLIT("min")
compare_PN = prelude_method SLIT("Ord") SLIT("compare")
-ltTag_PN = Prel (WiredInId ltDataCon)
-eqTag_PN = Prel (WiredInId eqDataCon)
-gtTag_PN = Prel (WiredInId gtDataCon)
+minBound_PN = prelude_method SLIT("Bounded") SLIT("minBound")
+maxBound_PN = prelude_method SLIT("Bounded") SLIT("maxBound")
+ltTag_PN = Unqual SLIT("LT")
+eqTag_PN = Unqual SLIT("EQ")
+gtTag_PN = Unqual SLIT("GT")
enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
@@ -1028,30 +1083,41 @@ showList_PN = prelude_method SLIT("Show") SLIT("showList")
plus_PN = prelude_method SLIT("Num") SLIT("+")
times_PN = prelude_method SLIT("Num") SLIT("*")
-false_PN = Prel (WiredInId falseDataCon)
-true_PN = Prel (WiredInId trueDataCon)
-eqH_PN = Prel (WiredInId (primOpId IntEqOp))
-geH_PN = Prel (WiredInId (primOpId IntGeOp))
-leH_PN = Prel (WiredInId (primOpId IntLeOp))
-ltH_PN = Prel (WiredInId (primOpId IntLtOp))
-minusH_PN = Prel (WiredInId (primOpId IntSubOp))
+false_PN = prelude_val pRELUDE SLIT("False")
+true_PN = prelude_val pRELUDE SLIT("True")
+eqH_Char_PN = prelude_primop CharEqOp
+ltH_Char_PN = prelude_primop CharLtOp
+eqH_Word_PN = prelude_primop WordEqOp
+ltH_Word_PN = prelude_primop WordLtOp
+eqH_Addr_PN = prelude_primop AddrEqOp
+ltH_Addr_PN = prelude_primop AddrLtOp
+eqH_Float_PN = prelude_primop FloatEqOp
+ltH_Float_PN = prelude_primop FloatLtOp
+eqH_Double_PN = prelude_primop DoubleEqOp
+ltH_Double_PN = prelude_primop DoubleLtOp
+eqH_Int_PN = prelude_primop IntEqOp
+ltH_Int_PN = prelude_primop IntLtOp
+geH_PN = prelude_primop IntGeOp
+leH_PN = prelude_primop IntLeOp
+minusH_PN = prelude_primop IntSubOp
and_PN = prelude_val pRELUDE SLIT("&&")
not_PN = prelude_val pRELUDE SLIT("not")
append_PN = prelude_val pRELUDE_LIST SLIT("++")
map_PN = prelude_val pRELUDE_LIST SLIT("map")
compose_PN = prelude_val pRELUDE SLIT(".")
-mkInt_PN = Prel (WiredInId intDataCon)
-error_PN = Prel (WiredInId eRROR_ID)
-showSpace_PN = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std
+mkInt_PN = prelude_val pRELUDE_BUILTIN SLIT("I#")
+error_PN = prelude_val pRELUDE SLIT("error")
showString_PN = prelude_val pRELUDE_TEXT SLIT("showString")
showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen")
lex_PN = prelude_val pRELUDE_TEXT SLIT("lex")
-_showList_PN = prelude_val pRELUDE SLIT("_showList")
-_readList_PN = prelude_val pRELUDE SLIT("_readList")
+showSpace_PN = prelude_val pRELUDE_TEXT SLIT("__showSpace")
+_showList_PN = prelude_val pRELUDE SLIT("__showList")
+_readList_PN = prelude_val pRELUDE SLIT("__readList")
-prelude_val m s = Imp m s [m] s
-prelude_method c o = Imp pRELUDE o [pRELUDE] o -- class not used...
+prelude_val m s = Unqual s
+prelude_method c o = Unqual o
+prelude_primop o = origName (primOpId o)
a_Expr = HsVar a_PN
b_Expr = HsVar b_PN
@@ -1070,47 +1136,23 @@ b_Pat = VarPatIn b_PN
c_Pat = VarPatIn c_PN
d_Pat = VarPatIn d_PN
-
con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
con2tag_PN tycon
= let (mod, nm) = moduleNamePair tycon
con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
in
- Imp mod con2tag [mod] con2tag
+ (if fromPrelude mod then Unqual else Qual mod) con2tag
tag2con_PN tycon
= let (mod, nm) = moduleNamePair tycon
tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
in
- Imp mod tag2con [mod] tag2con
+ (if fromPrelude mod then Unqual else Qual mod) tag2con
maxtag_PN tycon
= let (mod, nm) = moduleNamePair tycon
maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
in
- Imp mod maxtag [mod] maxtag
-
-
-con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> RnName
-
-tag2con_FN tycon
- = let (mod, nm) = moduleNamePair tycon
- tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
-
-maxtag_FN tycon
- = let (mod, nm) = moduleNamePair tycon
- maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
-
-con2tag_FN tycon
- = let (mod, nm) = moduleNamePair tycon
- con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc
--}
+ (if fromPrelude mod then Unqual else Qual mod) maxtag
\end{code}
-
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index ba6947514874..54d2b7a26215 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -7,6 +7,8 @@ This module is an extension of @HsSyn@ syntax, for use in the type
checker.
\begin{code}
+#include "HsVersions.h"
+
module TcHsSyn (
TcIdBndr(..), TcIdOcc(..),
@@ -25,13 +27,13 @@ module TcHsSyn (
mkHsTyApp, mkHsDictApp,
mkHsTyLam, mkHsDictLam,
- tcIdType,
+ tcIdType, tcIdTyVars,
zonkBinds,
zonkDictBinds
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- friends:
import HsSyn -- oodles of it
@@ -44,16 +46,15 @@ import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
import Name ( Name{--O only-} )
import TcMonad hiding ( rnMtoTcM )
import TcType ( TcType(..), TcMaybe, TcTyVar(..),
- zonkTcTypeToType, zonkTcTyVarToTyVar,
- tcInstType
+ zonkTcTypeToType, zonkTcTyVarToTyVar
)
import Usage ( UVar(..) )
import Util ( zipEqual, panic, pprPanic, pprTrace )
import PprType ( GenType, GenTyVar ) -- instances
-import Type ( mkTyVarTy )
+import Type ( mkTyVarTy, tyVarsOfType )
import TyVar ( GenTyVar {- instances -},
- TyVarEnv(..), growTyVarEnvList ) -- instances
+ TyVarEnv(..), growTyVarEnvList, emptyTyVarSet )
import TysWiredIn ( voidTy )
import Unique ( Unique ) -- instances
import UniqFM
@@ -122,9 +123,10 @@ mkHsDictLam dicts expr = DictLam dicts expr
tcIdType :: TcIdOcc s -> TcType s
tcIdType (TcId id) = idType id
tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id)
-\end{code}
-
+tcIdTyVars (TcId id) = tyVarsOfType (idType id)
+tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables
+\end{code}
\begin{code}
instance Eq (TcIdOcc s) where
@@ -396,17 +398,14 @@ zonkExpr te ve (HsIf e1 e2 e3 src_loc)
zonkExpr te ve (HsLet binds expr)
= zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
+ zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
zonkExpr te ve (HsDo _ _) = panic "zonkExpr te ve:HsDo"
-zonkExpr te ve (HsDoOut stmts m_id mz_id src_loc)
+zonkExpr te ve (HsDoOut stmts then_id zero_id src_loc)
= zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc)
- where
- m_new = zonkIdOcc ve m_id
- mz_new = zonkIdOcc ve mz_id
+ returnNF_Tc (HsDoOut new_stmts (zonkIdOcc ve then_id) (zonkIdOcc ve zero_id) src_loc)
zonkExpr te ve (ListComp expr quals)
= zonkQuals te ve quals `thenNF_Tc` \ (new_quals, new_ve) ->
@@ -558,27 +557,36 @@ zonkQuals te ve (LetQual binds : quals)
zonkStmts :: TyVarEnv Type -> IdEnv Id
-> [TcStmt s] -> NF_TcM s [TypecheckedStmt]
-zonkStmts te ve []
- = returnNF_Tc []
+zonkStmts te ve [] = returnNF_Tc []
+
+zonkStmts te ve [ExprStmt expr locn]
+ = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc [ExprStmt new_expr locn]
-zonkStmts te ve (BindStmt pat expr src_loc : stmts)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
- zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkStmts te ve (ExprStmtOut expr locn a b : stmts)
+ = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
+ zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
+ zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (ExprStmtOut new_expr locn new_a new_b : new_stmts)
+
+zonkStmts te ve (LetStmt binds : stmts)
+ = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
+ zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (LetStmt new_binds : new_stmts)
+
+zonkStmts te ve (BindStmtOut pat expr locn a b : stmts)
+ = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
+ zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
let
new_ve = extend_ve ve ids
in
zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (BindStmt new_pat new_expr src_loc : new_stmts)
+ returnNF_Tc (BindStmtOut new_pat new_expr locn new_a new_b : new_stmts)
-zonkStmts te ve (ExprStmt expr src_loc : stmts)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ExprStmt new_expr src_loc : new_stmts)
-zonkStmts te ve (LetStmt binds : stmts)
- = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (LetStmt new_binds : new_stmts)
-------------------------------------------------------------------------
zonkRbinds :: TyVarEnv Type -> IdEnv Id
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 9e60168493c4..7326d93f3b2a 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -8,7 +8,7 @@
module TcIfaceSig ( tcInterfaceSigs ) where
-import Ubiq
+IMP_Ubiq()
import TcMonad hiding ( rnMtoTcM )
import TcMonoType ( tcPolyType )
@@ -19,6 +19,7 @@ import RnHsSyn ( RenamedSig(..), RnName(..) )
import CmdLineOpts ( opt_CompilingPrelude )
import Id ( mkImported )
--import Name ( Name(..) )
+import Maybes ( maybeToBool )
import Pretty
import Util ( panic )
@@ -41,7 +42,8 @@ tcInterfaceSigs :: [RenamedSig] -> TcM s [Id]
tcInterfaceSigs [] = returnTc []
-tcInterfaceSigs (Sig name@(RnName full_name) ty pragmas src_loc : sigs)
+tcInterfaceSigs (Sig name ty pragmas src_loc : sigs)
+ | has_full_name
= tcAddSrcLoc src_loc (
tcPolyType ty `thenTc` \ sigma_ty ->
fixTc ( \ rec_id ->
@@ -52,13 +54,19 @@ tcInterfaceSigs (Sig name@(RnName full_name) ty pragmas src_loc : sigs)
tcInterfaceSigs sigs `thenTc` \ sigs' ->
returnTc (id:sigs')
-
-tcInterfaceSigs (Sig odd_name _ _ src_loc : sigs)
- = case odd_name of
+ | otherwise -- odd name...
+ = case name of
WiredInId _ | opt_CompilingPrelude
-> tcInterfaceSigs sigs
_ -> tcAddSrcLoc src_loc $
- failTc (ifaceSigNameErr odd_name)
+ failTc (ifaceSigNameErr name)
+ where
+ has_full_name = maybeToBool full_name_maybe
+ (Just full_name) = full_name_maybe
+ full_name_maybe = case name of
+ RnName fn -> Just fn
+ RnImplicit fn -> Just fn
+ _ -> Nothing
ifaceSigNameErr name sty
= ppHang (ppStr "Bad name in an interface type signature (a Prelude name?)")
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 0f1a61a8edfe..80238ffce9da 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -9,11 +9,12 @@
module TcInstDcls (
tcInstDecls1,
tcInstDecls2,
- processInstBinds
+ processInstBinds,
+ newMethodId
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( InstDecl(..), FixityDecl, Sig(..),
SpecInstSig(..), HsBinds(..), Bind(..),
@@ -33,7 +34,7 @@ import TcHsSyn ( TcIdOcc(..), TcHsBinds(..),
import TcMonad hiding ( rnMtoTcM )
-import GenSpecEtc ( checkSigTyVars )
+import GenSpecEtc ( checkSigTyVarsGivenGlobals )
import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
import TcBinds ( tcPragmaSigs )
@@ -44,11 +45,11 @@ import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcKind ( TcKind, unifyKind )
import TcMatches ( tcMatchesFun )
import TcMonoType ( tcContext, tcMonoTypeKind )
-import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas )
+import TcSimplify ( tcSimplifyAndCheck )
import TcType ( TcType(..), TcTyVar(..),
- tcInstSigTyVars, tcInstType, tcInstTheta
+ tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
)
-import Unify ( unifyTauTy )
+import Unify ( unifyTauTy, unifyTauTyLists )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
@@ -76,9 +77,9 @@ import RnUtils ( RnEnv(..) )
import TyCon ( isSynTyCon, derivedFor )
import Type ( GenType(..), ThetaType(..), mkTyVarTys,
splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
- getTyCon_maybe, maybeBoxedPrimType
+ getTyCon_maybe, maybeBoxedPrimType, splitRhoTy
)
-import TyVar ( GenTyVar, mkTyVarSet )
+import TyVar ( GenTyVar, mkTyVarSet, unionTyVarSets )
import TysWiredIn ( stringTy )
import Unique ( Unique )
import Util ( zipEqual, panic )
@@ -368,7 +369,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
let
sc_theta' = super_classes `zip` repeat inst_ty'
origin = InstanceDeclOrigin
- mk_method sel_id = newMethodId sel_id inst_ty' origin locn
+ mk_method sel_id = newMethodId sel_id inst_ty' origin
in
-- Create dictionary Ids from the specified instance contexts.
newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
@@ -447,6 +448,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
returnTc (const_lie `plusLIE` spec_lie, inst_binds)
\end{code}
+============= OLD ================
+
@mkMethodId@ manufactures an id for a local method.
It's rather turgid stuff, because there are two cases:
@@ -473,10 +476,15 @@ It's rather turgid stuff, because there are two cases:
So for these we just make a local (non-Inst) id with a suitable type.
How disgusting.
+=============== END OF OLD ===================
\begin{code}
-newMethodId sel_id inst_ty origin loc
- = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id)
+newMethodId sel_id inst_ty origin
+ = newMethod origin (RealId sel_id) [inst_ty]
+
+
+{- REMOVE SOON: (this was pre-split-poly selector types)
+let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id)
(_:meth_theta) = sel_theta -- The local theta is all except the
-- first element of the context
in
@@ -493,6 +501,7 @@ newMethodId sel_id inst_ty origin loc
`thenNF_Tc` \ method_ty ->
newLocalId (getLocalName sel_id) method_ty `thenNF_Tc` \ meth_id ->
returnNF_Tc (emptyLIE, meth_id)
+-}
\end{code}
The next function makes a default method which calls the global default method, at
@@ -511,22 +520,13 @@ makeInstanceDeclDefaultMethodExpr
-> NF_TcM s (TcExpr s)
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 (
- mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
- (inst_ty : mkTyVarTys op_tyvars))
- (this_dict : op_dicts)
- )))
+ =
+ -- def_op_id = defm_id inst_ty this_dict
+ returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
where
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
@@ -539,23 +539,19 @@ makeInstanceDeclNoDefaultExpr
-> NF_TcM s (TcExpr s)
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
warnTc (not err_defm_ok)
(omitDefaultMethodWarn clas_op clas_name inst_ty)
`thenNF_Tc_`
- returnNF_Tc (mkHsTyLam op_tyvars (
- mkHsDictLam op_dicts (
- HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [op_tau])
- (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
+ returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
+ (HsLitOut (HsString (_PK_ error_msg)) stringTy))
where
idx = tag - 1
meth_id = meth_ids !! idx
clas_op = (classOps clas) !! idx
defm_id = defm_ids !! idx
- (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id)
Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
@@ -666,16 +662,12 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
let
tag = classOpTagByString clas occ
method_id = method_ids !! (tag-1)
+ method_ty = tcIdType method_id
in
- -- The "method" might be a RealId, when processInstBinds is used by
- -- TcClassDcls:buildDefaultMethodBinds to make default-method bindings
- (case method_id of
- TcId id -> returnNF_Tc (idType id)
- RealId id -> tcInstType [] (idType id)
- ) `thenNF_Tc` \ method_ty ->
+ tcInstTcType method_ty `thenNF_Tc` \ (method_tyvars, method_rho) ->
let
- (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
+ (method_theta, method_tau) = splitRhoTy method_rho
in
newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
@@ -694,10 +686,17 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
-- The latter is needed just so we can return an AbsBinds wrapped
-- up inside a MonoBinds.
+
+ -- Make the method_tyvars into signature tyvars so they
+ -- won't get unified with anything.
+ tcInstSigTyVars method_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
+ unifyTauTyLists (mkTyVarTys method_tyvars) sig_tyvar_tys `thenTc_`
+
newLocalId occ method_tau `thenNF_Tc` \ local_id ->
newLocalId occ method_ty `thenNF_Tc` \ copy_id ->
let
- inst_method_tyvars = inst_tyvars ++ method_tyvars
+ inst_tyvar_set = mkTyVarSet inst_tyvars
+ inst_method_tyvar_set = inst_tyvar_set `unionTyVarSets` (mkTyVarSet sig_tyvars)
in
-- Typecheck the method
tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
@@ -712,12 +711,17 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
-- Here we must simplify constraints on "a" to catch all
-- the Bar-ish things.
tcAddErrCtxt (methodSigCtxt op method_ty) (
+ checkSigTyVarsGivenGlobals
+ inst_tyvar_set
+ sig_tyvars method_tau `thenTc_`
+
tcSimplifyAndCheck
- (mkTyVarSet inst_method_tyvars)
+ inst_method_tyvar_set
(method_dicts `plusLIE` avail_insts)
lieIop
) `thenTc` \ (f_dicts, dict_binds) ->
+
returnTc ([tag],
f_dicts,
VarMonoBind method_id
@@ -926,8 +930,8 @@ scrutiniseInstanceType from_here clas inst_tau
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
isCcallishClass clas
- && not opt_CompilingPrelude -- which allows anything
- && maybeToBool (maybeBoxedPrimType inst_tau)
+-- && not opt_CompilingPrelude -- which allows anything
+ && not (maybeToBool (maybeBoxedPrimType inst_tau))
= failTc (nonBoxedPrimCCallErr clas inst_tau)
| otherwise
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index b41b4ea94395..04717e360598 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -14,7 +14,7 @@ module TcInstUtil (
buildInstanceEnvs
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( MonoBinds, Fake, InPat, Sig )
import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
@@ -219,7 +219,7 @@ addClassInstance
addClassInstance
(class_inst_env, op_spec_envs)
- (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
+ (InstInfo clas inst_tyvars inst_ty _ _
dfun_id const_meth_ids _ _ _ src_loc _)
=
diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs
index 5e7becfa5c9e..5f669078ad7c 100644
--- a/ghc/compiler/typecheck/TcKind.lhs
+++ b/ghc/compiler/typecheck/TcKind.lhs
@@ -1,4 +1,6 @@
\begin{code}
+#include "HsVersions.h"
+
module TcKind (
Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind,
@@ -14,7 +16,7 @@ module TcKind (
tcDefaultKind -- TcKind s -> NF_TcM s Kind
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Kind
import TcMonad hiding ( rnMtoTcM )
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 87628cf432dd..fed6045d7c00 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -8,7 +8,7 @@
module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
HsExpr, HsBinds, OutPat, Fake,
@@ -19,7 +19,7 @@ import TcHsSyn ( TcIdOcc(..), TcMatch(..) )
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, LIE(..), plusLIE )
import TcEnv ( newMonoIds )
-import TcLoop ( tcGRHSsAndBinds )
+IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcPat ( tcPat )
import TcType ( TcType(..), TcMaybe, zonkTcType )
import Unify ( unifyTauTy, unifyTauTyList )
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 006777ac1aaf..1dd4a4297d58 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -11,12 +11,11 @@ module TcModule (
TcResults(..),
TcResultBinds(..),
TcIfaceInfo(..),
- TcLocalTyConsAndClasses(..),
TcSpecialiseRequests(..),
TcDDumpDeriv(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
TyDecl, SpecDataSig, ClassDecl, InstDecl,
@@ -45,13 +44,13 @@ import TcTyDecls ( mkDataBinds )
import Bag ( listToBag )
import Class ( GenClass, classSelIds )
import ErrUtils ( Warning(..), Error(..) )
-import Id ( GenId, isDataCon, isMethodSelId, idType, IdEnv(..), nullIdEnv )
+import Id ( idType, isMethodSelId, isTopLevId, GenId, IdEnv(..), nullIdEnv )
import Maybes ( catMaybes )
import Name ( isExported, isLocallyDefined )
import Pretty
import RnUtils ( RnEnv(..) )
-import TyCon ( isDataTyCon, TyCon )
-import Type ( mkSynTy )
+import TyCon ( TyCon )
+import Type ( applyTyCon )
import TysWiredIn ( unitTy, mkPrimIoTy )
import TyVar ( TyVarEnv(..), nullTyVarEnv )
import Unify ( unifyTauTy )
@@ -70,7 +69,6 @@ Outside-world interface:
type TcResults
= (TcResultBinds,
TcIfaceInfo,
- TcLocalTyConsAndClasses,
TcSpecialiseRequests,
TcDDumpDeriv)
@@ -87,10 +85,6 @@ type TcResultBinds
type TcIfaceInfo -- things for the interface generator
= ([Id], [TyCon], [Class], Bag InstInfo)
-type TcLocalTyConsAndClasses -- things defined in this module
- = ([TyCon], [Class])
- -- not sure the classes are used at all (ToDo)
-
type TcSpecialiseRequests
= FiniteMap TyCon [(Bool, [Maybe Type])]
-- source tycon specialisation requests
@@ -242,22 +236,20 @@ tcModule rn_env
let
localids = getEnv_LocalIds final_env
- tycons = getEnv_TyCons final_env
- classes = getEnv_Classes final_env
+ tycons = getEnv_TyCons final_env
+ classes = getEnv_Classes final_env
- local_tycons = [ tc | tc <- tycons, isLocallyDefined tc && isDataTyCon tc ]
+ local_tycons = filter isLocallyDefined tycons
local_classes = filter isLocallyDefined classes
- exported_ids' = filter isExported (eltsUFM ve2)
- in
-
+ local_vals = [ v | v <- eltsUFM ve2, isLocallyDefined v && isTopLevId v ]
+ -- the isTopLevId is doubtful...
+ in
-- FINISHED AT LAST
returnTc (
(data_binds', cls_binds', inst_binds', val_binds', const_insts'),
-- the next collection is just for mkInterface
- (exported_ids', tycons, classes, inst_info),
-
- (local_tycons, local_classes),
+ (local_vals, local_tycons, local_classes, inst_info),
tycon_specs,
@@ -267,7 +259,6 @@ tcModule rn_env
ty_decls_bag = listToBag ty_decls
cls_decls_bag = listToBag cls_decls
inst_decls_bag = listToBag inst_decls
-
\end{code}
@@ -294,7 +285,7 @@ checkTopLevelIds mod final_env
case (maybe_main, maybe_prim) of
(Just main, Nothing) -> tcAddErrCtxt mainCtxt $
- unifyTauTy (mkSynTy io_tc [unitTy])
+ unifyTauTy (applyTyCon io_tc [unitTy])
(idType main)
(Nothing, Just prim) -> tcAddErrCtxt primCtxt $
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 876564daad28..b5853aa544cd 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,4 +1,6 @@
\begin{code}
+#include "HsVersions.h"
+
module TcMonad(
TcM(..), NF_TcM(..), TcDown, TcEnv,
SST_R, FSST_R,
@@ -33,9 +35,9 @@ module TcMonad(
MutableVar(..), _MutableArray
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
+IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
import Type ( Type(..), GenType )
import TyVar ( TyVar(..), GenTyVar )
@@ -44,12 +46,14 @@ import ErrUtils ( Error(..), Message(..), ErrCtxt(..),
Warning(..) )
import SST
-import RnMonad ( RnM(..), RnDown, initRn, setExtraRn )
+import RnMonad ( RnM(..), RnDown, initRn, setExtraRn,
+ returnRn, thenRn, getImplicitUpRn
+ )
import RnUtils ( RnEnv(..) )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
-import FiniteMap ( FiniteMap, emptyFM )
+import FiniteMap ( FiniteMap, emptyFM, isEmptyFM )
--import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
import ErrUtils ( Error(..) )
import Maybes ( MaybeErr(..) )
@@ -459,7 +463,18 @@ rnMtoTcM rn_env rn_action down env
writeMutVarSST u_var new_uniq_supply `thenSST_`
let
(rn_result, rn_errs, rn_warns)
- = initRn True (panic "rnMtoTcM:module") rn_env uniq_s rn_action
+ = initRn False{-*interface* mode! so we can see the builtins-}
+ (panic "rnMtoTcM:module")
+ rn_env uniq_s (
+ rn_action `thenRn` \ result ->
+
+ -- Though we are in "interface mode", we must
+ -- not have added anything to the ImplicitEnv!
+ getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) ->
+ if (isEmptyFM v_env && isEmptyFM tc_env)
+ then returnRn result
+ else panic "rnMtoTcM: non-empty ImplicitEnv!"
+ )
in
returnSST (rn_result, rn_errs)
where
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index eee6f125e10f..dfa3e597eb41 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -8,7 +8,7 @@
module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( PolyType(..), MonoType(..), Fake )
import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
@@ -31,7 +31,7 @@ import Type ( GenType, Type(..), ThetaType(..),
import TyVar ( GenTyVar, TyVar(..), mkTyVar )
import Type ( mkDictTy )
import Class ( cCallishClassKeys )
-import TyCon ( TyCon, Arity(..) )
+import TyCon ( TyCon )
import TysWiredIn ( mkListTy, mkTupleTy )
import Unique ( Unique )
import PprStyle
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 0c8470cbd1f7..b857bb00f048 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -8,7 +8,7 @@
module TcPat ( tcPat ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
Match, HsBinds, Qual, PolyType,
@@ -23,7 +23,7 @@ import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
)
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
tcLookupLocalValueOK )
-import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId )
+import TcType ( TcType(..), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index fcde43dc7fbb..21f45479df6e 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcSimplify]{TcSimplify}
@@ -12,7 +12,7 @@ module TcSimplify (
bindInstsOfLocalFuns
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
Match, HsBinds, Qual, PolyType, ArithSeqInfo,
@@ -21,10 +21,13 @@ import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
import TcMonad hiding ( rnMtoTcM )
import Inst ( lookupInst, lookupSimpleInst,
- tyVarsOfInst, isTyVarDict, isDict, matchesInst,
- instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc,
- Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE,
- InstOrigin(..), OverloadedLit )
+ tyVarsOfInst, isTyVarDict, isDict,
+ matchesInst, instToId, instBindingRequired,
+ instCanBeGeneralised, newDictsAtLoc,
+ pprInst,
+ Inst(..), LIE(..), zonkLIE, emptyLIE,
+ plusLIE, unitLIE, consLIE, InstOrigin(..),
+ OverloadedLit )
import TcEnv ( tcGetGlobalTyVars )
import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
import Unify ( unifyTauTy )
@@ -378,7 +381,7 @@ elimTyCons squash_consts is_free_tv givens wanteds
%************************************************************************
%* *
\subsection[elimSCs]{@elimSCs@}
-%* 2 *
+%* *
%************************************************************************
\begin{code}
@@ -554,7 +557,10 @@ elimSCsSimple givens (c_t@(clas,ty) : rest)
where
rest' = elimSCsSimple rest
(c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 &&
- maybeToBool (c2 `isSuperClassOf` c1)
+ (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1))
+-- We deal with duplicates here ^^^^^^^^
+-- It's a simple place to do it, although it's done in elimTyCons in the
+-- full-blown version of the simpifier.
\end{code}
%************************************************************************
@@ -668,8 +674,6 @@ the most common use of defaulting is code like:
\end{verbatim}
Since we're not using the result of @foo@, the result if (presumably)
@void@.
-WDP Comment: no such thing as voidTy; so not quite in yet (94/07).
-SLPJ comment: since
\begin{code}
disambigOne :: [SimpleDictInfo s] -> TcM s ()
@@ -740,8 +744,7 @@ genCantGenErr insts sty -- Can't generalise these Insts
\begin{code}
ambigErr insts sty
- = ppHang (ppStr "Ambiguous overloading")
- 4 (ppAboves (map (ppr sty) insts))
+ = ppAboves (map (pprInst sty "Ambiguous overloading") insts)
\end{code}
@reduceErr@ complains if we can't express required dictionaries in
@@ -749,10 +752,8 @@ terms of the signature.
\begin{code}
reduceErr insts sty
- = ppHang (ppStr "Type signature lacks context required by inferred type")
- 4 (ppHang (ppStr "Context reqd: ")
- 4 (ppAboves (map (ppr sty) (bagToList insts)))
- )
+ = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature")
+ (bagToList insts))
\end{code}
\begin{code}
@@ -760,7 +761,7 @@ defaultErr dicts defaulting_tys sty
= ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
4 (ppAboves [
ppHang (ppStr "Conflicting:")
- 4 (ppInterleave ppSemi (map (ppr sty) dicts)),
+ 4 (ppInterleave ppSemi (map (pprInst sty ""{-???-}) dicts)),
ppHang (ppStr "Defaulting types :")
4 (ppr sty defaulting_tys),
ppStr "([Int, Double] is the default list of defaulting types.)" ])
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 495c0a5fec82..680753e2c6bd 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -10,7 +10,7 @@ module TcTyClsDecls (
tcTyAndClassDecls1
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
ClassDecl(..), MonoType(..), PolyType(..),
@@ -39,9 +39,9 @@ import UniqSet ( UniqSet(..), emptyUniqSet,
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon, tyConDataCons, isDataTyCon, isSynTyCon )
+import TyCon ( TyCon )
import Unique ( Unique )
-import Util ( panic, pprTrace )
+import Util ( panic{-, pprTrace-} )
\end{code}
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index e248b90d0eb9..47649c76bbeb 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -12,7 +12,7 @@ module TcTyDecls (
mkDataBinds
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
@@ -250,7 +250,6 @@ mkConstructor con_id
checkTc (null eval_theta')
(missingEvalErr con_id eval_theta') `thenTc_`
-
-- Build the data constructor
let
con_rhs = mkHsTyLam tc_tyvars $
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 0a602c731c66..b386d1ade211 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -1,4 +1,6 @@
\begin{code}
+#include "HsVersions.h"
+
module TcType (
TcTyVar(..),
@@ -18,13 +20,15 @@ module TcType (
tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s)
- tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s)
+ tcInstTyVars,
tcInstSigTyVars,
- tcInstType, tcInstTheta, tcInstId,
+ tcInstType, tcInstSigType, tcInstTcType,
+ tcInstTheta, tcInstId,
zonkTcTyVars,
zonkTcType,
zonkTcTypeToType,
+ zonkTcTyVar,
zonkTcTyVarToTyVar
) where
@@ -34,10 +38,12 @@ module TcType (
-- friends:
import Type ( Type(..), ThetaType(..), GenType(..),
tyVarsOfTypes, getTyVar_maybe,
- splitForAllTy, splitRhoTy
+ splitForAllTy, splitRhoTy,
+ mkForAllTys, instantiateTy
)
import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..),
- TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv, mkTyVarEnv,
+ TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv,
+ nullTyVarEnv, mkTyVarEnv,
tyVarSetToList
)
@@ -51,11 +57,11 @@ import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
import TysWiredIn ( voidTy )
-import Ubiq
+IMP_Ubiq()
import Unique ( Unique )
import UniqFM ( UniqFM )
import Maybes ( assocMaybe )
-import Util ( zipEqual, nOfThem, panic, pprPanic )
+import Util ( zipEqual, nOfThem, panic, pprPanic, pprTrace{-ToDo:rm-} )
import Outputable ( Outputable(..) ) -- Debugging messages
import PprType ( GenTyVar, GenType )
@@ -121,15 +127,14 @@ newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n 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
@@ -143,23 +148,43 @@ inst_tyvar initial_cts (TyVar _ kind name _)
returnNF_Tc (TyVar uniq kind name box)
\end{code}
-@tcInstType@ and @tcInstTcType@ both create a fresh instance of a
+@tcInstType@ and @tcInstSigType@ both create a fresh instance of a
type, returning a @TcType@. All inner for-alls are instantiated with
fresh TcTyVars.
-There are two versions, one for instantiating a @Type@, and one for a @TcType@.
-The former must instantiate everything; all tyvars must be bound either
-by a forall or by an environment passed in. The latter can do some sharing,
-and is happy with free tyvars (which is vital when instantiating the type
-of local functions). In the future @tcInstType@ may try to be clever about not
-instantiating constant sub-parts.
+The difference is that tcInstType instantiates all forall'd type
+variables (and their bindees) with UnBound type variables, whereas
+tcInstSigType instantiates them with DontBind types variables.
+@tcInstSigType@ also doesn't take an environment.
+
+On the other hand, @tcInstTcType@ instantiates a TcType. It uses
+instantiateTy which could take advantage of sharing some day.
\begin{code}
+tcInstTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s)
+tcInstTcType ty
+ = case tyvars of
+ [] -> returnNF_Tc ([], ty) -- Nothing to do
+ other -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
+ returnNF_Tc (tyvars', instantiateTy tenv rho)
+ where
+ (tyvars, rho) = splitForAllTy ty
+
tcInstType :: [(GenTyVar flexi,TcType s)]
-> GenType (GenTyVar flexi) UVar
-> NF_TcM s (TcType s)
tcInstType tenv ty_to_inst
= tcConvert bind_fn occ_fn (mkTyVarEnv tenv) ty_to_inst
+ where
+ bind_fn = inst_tyvar UnBound
+ occ_fn env tyvar = case lookupTyVarEnv env tyvar of
+ Just ty -> returnNF_Tc ty
+ Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst,
+ ppr PprDebug tyvar])
+
+tcInstSigType :: GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s)
+tcInstSigType ty_to_inst
+ = tcConvert bind_fn occ_fn nullTyVarEnv ty_to_inst
where
bind_fn = inst_tyvar DontBind
occ_fn env tyvar = case lookupTyVarEnv env tyvar of
@@ -168,9 +193,15 @@ tcInstType tenv ty_to_inst
ppr PprDebug tyvar])
zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
-zonkTcTyVarToTyVar tyvar
- = zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') ->
- returnNF_Tc (tcTyVarToTyVar tyvar')
+zonkTcTyVarToTyVar tv
+ = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
+ case tv_ty of -- Should be a tyvar!
+
+ TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv')
+
+ _ -> pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
+ returnNF_Tc (tcTyVarToTyVar tv)
+
zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type
zonkTcTypeToType env ty
@@ -331,9 +362,14 @@ zonkTcType (SynTy tc tys ty)
returnNF_Tc (SynTy tc tys' ty')
zonkTcType (ForAllTy tv ty)
- = zonkTcTyVar tv `thenNF_Tc` \ (TyVarTy tv') -> -- Should be a tyvar!
+ = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
zonkTcType ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (ForAllTy tv' ty')
+ case tv_ty of -- Should be a tyvar!
+ TyVarTy tv' ->
+ returnNF_Tc (ForAllTy tv' ty')
+ _ -> pprTrace "zonkTcType:ForAllTy:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
+
+ returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty')
zonkTcType (ForAllUsageTy uv uvs ty)
= panic "zonk:ForAllUsageTy"
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index 39c27f32396d..77742f4db54f 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -11,7 +11,7 @@ updatable substitution).
module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where
-import Ubiq
+IMP_Ubiq()
-- friends:
import TcMonad hiding ( rnMtoTcM )
@@ -229,15 +229,24 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1)
case (maybe_ty1, maybe_ty2) of
(_, BoundTo ty2') -> uUnboundVar tv1 maybe_ty1 ty2' ty2'
- (DontBind,DontBind)
- -> failTc (unifyDontBindErr tv1 ps_ty2)
-
(UnBound, _) | kind2 `hasMoreBoxityInfo` kind1
-> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc ()
(_, UnBound) | kind1 `hasMoreBoxityInfo` kind2
-> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
+-- TEMPORARY FIX
+-- (DontBind,DontBind)
+-- -> failTc (unifyDontBindErr tv1 ps_ty2)
+
+-- TEMPORARILY allow two type-sig variables to be bound together.
+-- See notes in tcCheckSigVars
+ (DontBind,DontBind) | kind2 `hasMoreBoxityInfo` kind1
+ -> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc ()
+
+ | kind1 `hasMoreBoxityInfo` kind2
+ -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
+
other -> failTc (unifyKindErr tv1 ps_ty2)
-- Second one isn't a type variable
diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index 0cf92a5ad8e7..2a38d47ca2e6 100644
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -16,7 +16,8 @@ module Class (
isSuperClassOf,
classOpTagByString,
- derivableClassKeys, cCallishClassKeys,
+ derivableClassKeys, needsDataDeclCtxtClassKeys,
+ cCallishClassKeys, isNoDictClass,
isNumericClass, isStandardClass, isCcallishClass,
GenClassOp(..), ClassOp(..),
@@ -29,7 +30,7 @@ module Class (
CHK_Ubiq() -- debugging consistency check
-import TyLoop
+IMPORT_DELOOPER(TyLoop)
import TyCon ( TyCon )
import TyVar ( TyVar(..), GenTyVar )
@@ -191,25 +192,33 @@ isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map
key `is_elem` numericClassKeys
isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
+isNoDictClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys
is_elem = isIn "is_X_Class"
numericClassKeys
- = [ numClassKey,
- realClassKey,
- integralClassKey,
- fractionalClassKey,
- floatingClassKey,
- realFracClassKey,
- realFloatClassKey ]
+ = [ numClassKey
+ , realClassKey
+ , integralClassKey
+ , fractionalClassKey
+ , floatingClassKey
+ , realFracClassKey
+ , realFloatClassKey
+ ]
derivableClassKeys
- = [ eqClassKey,
- showClassKey,
- ordClassKey,
- boundedClassKey,
- enumClassKey,
- ixClassKey,
- readClassKey ]
+ = [ eqClassKey
+ , ordClassKey
+ , enumClassKey
+ , evalClassKey
+ , boundedClassKey
+ , showClassKey
+ , readClassKey
+ , ixClassKey
+ ]
+
+needsDataDeclCtxtClassKeys -- see comments in TcDeriv
+ = [ readClassKey
+ ]
cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
@@ -222,6 +231,16 @@ standardClassKeys
-- _ccall_ foo ... 93{-numeric literal-} ...
--
-- ... it can do The Right Thing on the 93.
+
+noDictClassKeys -- These classes are used only for type annotations;
+ -- they are not implemented by dictionaries, ever.
+ = cCallishClassKeys
+ -- I used to think that class Eval belonged in here, but
+ -- we really want functions with type (Eval a => ...) and that
+ -- means that we really want to pass a placeholder for an Eval
+ -- dictionary. The unit tuple is what we'll get if we leave things
+ -- alone, and that'll do for now. Could arrange to drop that parameter
+ -- in the end.
\end{code}
%************************************************************************
diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index 249ad6c76bec..ab77d1980545 100644
--- a/ghc/compiler/types/Kind.lhs
+++ b/ghc/compiler/types/Kind.lhs
@@ -17,10 +17,11 @@ module Kind (
hasMoreBoxityInfo,
resultKind, argKind,
- isUnboxedKind, isTypeKind
+ isUnboxedKind, isTypeKind,
+ notArrowKind
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic, assertPanic )
--import Outputable ( Outputable(..) )
@@ -66,7 +67,6 @@ kind1@(ArrowKind _ _) `hasMoreBoxityInfo` kind2@(ArrowKind _ _) = ASSERT( kind1
kind1 `hasMoreBoxityInfo` kind2 = False
--- Not exported
notArrowKind (ArrowKind _ _) = False
notArrowKind other_kind = True
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 472060547cef..eb6ed43bdcad 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -19,14 +19,14 @@ module PprType(
GenClass,
GenClassOp, pprGenClassOp,
- addTyVar, nmbrTyVar,
+ addTyVar{-ToDo:don't export-}, nmbrTyVar,
addUVar, nmbrUsage,
nmbrType, nmbrTyCon, nmbrClass
) where
-import Ubiq
-import IdLoop -- for paranoia checking
-import TyLoop -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-- friends:
-- (PprType can see all the representations it's trying to print)
@@ -289,9 +289,9 @@ showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
pprTyCon :: PprStyle -> TyCon -> Pretty
-pprTyCon sty FunTyCon = ppStr "(->)"
-pprTyCon sty (TupleTyCon _ name _) = ppr sty name
-pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
+pprTyCon sty FunTyCon = ppStr "(->)"
+pprTyCon sty (TupleTyCon _ name _) = ppr sty name
+pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
= ppr sty name
@@ -455,7 +455,13 @@ addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
= --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
case (lookupUFM_Directly tvenv u) of
- Just xx -> pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
+ Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
+ -- (It gets triggered when we do a datatype: first we
+ -- "addTyVar" the tyvars for the datatype as a whole;
+ -- we will subsequently "addId" the data cons, including
+ -- the type for each of them -- each of which includes
+ -- _forall_ ...tvs..., which we will addTyVar.
+ -- Harmless, if that's all that happens....
(nenv, xx)
Nothing ->
let
@@ -480,9 +486,9 @@ nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
nmbrTyCon : only called from ``top-level'', if you know what I mean.
\begin{code}
-nmbrTyCon tc@FunTyCon = returnNmbr tc
-nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
-nmbrTyCon tc@(PrimTyCon _ _ _) = returnNmbr tc
+nmbrTyCon tc@FunTyCon = returnNmbr tc
+nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
+nmbrTyCon tc@(PrimTyCon _ _ _ _) = returnNmbr tc
nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
= --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index b9836648638b..be4eccd0299c 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -28,7 +28,9 @@ module TyCon(
tyConDataCons,
tyConFamilySize,
tyConDerivings,
- tyConArity, synTyConArity,
+ tyConTheta,
+ tyConPrimRep,
+ synTyConArity,
getSynTyConDefn,
maybeTyConSingleCon,
@@ -38,10 +40,10 @@ module TyCon(
CHK_Ubiq() -- debugging consistency check
-import TyLoop ( Type(..), GenType,
+IMPORT_DELOOPER(TyLoop) ( Type(..), GenType,
Class(..), GenClass,
Id(..), GenId,
- mkTupleCon, dataConSig,
+ mkTupleCon, isNullaryDataCon,
specMaybeTysSuffix
)
@@ -55,6 +57,7 @@ import Name ( Name, RdrName(..), appendRdr, nameUnique,
)
import Unique ( Unique, funTyConKey, mkTupleTyConUnique )
import Pretty ( Pretty(..), PrettyRep )
+import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import Util ( panic, panic#, pprPanic{-ToDo:rm-}, nOfThem, isIn, Ord3(..) )
import {-hide me-}
@@ -91,6 +94,7 @@ data TyCon
Unique -- Always unboxed; hence never represented by a closure
Name -- Often represented by a bit-pattern for the thing
Kind -- itself (eg Int#), but sometimes by a pointer to
+ PrimRep
| SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#)
TyCon
@@ -138,7 +142,7 @@ mkSynTyCon name
isFunTyCon FunTyCon = True
isFunTyCon _ = False
-isPrimTyCon (PrimTyCon _ _ _) = True
+isPrimTyCon (PrimTyCon _ _ _ _) = True
isPrimTyCon _ = False
-- At present there are no unboxed non-primitive types, so
@@ -166,7 +170,7 @@ kind2 = mkBoxedTypeKind `mkArrowKind` kind1
tyConKind :: TyCon -> Kind
tyConKind FunTyCon = kind2
tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind
-tyConKind (PrimTyCon _ _ kind) = kind
+tyConKind (PrimTyCon _ _ kind _) = kind
tyConKind (SynTyCon _ _ k _ _ _) = k
tyConKind (TupleTyCon _ _ n)
@@ -191,18 +195,10 @@ tyConUnique :: TyCon -> Unique
tyConUnique FunTyCon = funTyConKey
tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq
tyConUnique (TupleTyCon uniq _ _) = uniq
-tyConUnique (PrimTyCon uniq _ _) = uniq
+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
@@ -214,8 +210,10 @@ tyConTyVars FunTyCon = [alphaTyVar,betaTyVar]
tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs
tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars
tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs
-tyConTyVars (PrimTyCon _ _ _) = panic "tyConTyVars:PrimTyCon"
+#ifdef DEBUG
+tyConTyVars (PrimTyCon _ _ _ _) = panic "tyConTyVars:PrimTyCon"
tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon"
+#endif
\end{code}
\begin{code}
@@ -234,6 +232,10 @@ tyConFamilySize (TupleTyCon _ _ _) = 1
#ifdef DEBUG
tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
#endif
+
+tyConPrimRep :: TyCon -> PrimRep
+tyConPrimRep (PrimTyCon _ _ _ rep) = rep
+tyConPrimRep _ = PtrRep
\end{code}
\begin{code}
@@ -242,6 +244,13 @@ tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs
tyConDerivings other = []
\end{code}
+\begin{code}
+tyConTheta :: TyCon -> [(Class,Type)]
+tyConTheta (DataTyCon _ _ _ _ theta _ _ _) = theta
+tyConTheta (TupleTyCon _ _ _) = []
+-- should ask about anything else
+\end{code}
+
\begin{code}
getSynTyConDefn :: TyCon -> ([TyVar], Type)
getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
@@ -253,17 +262,14 @@ maybeTyConSingleCon :: TyCon -> Maybe Id
maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (mkTupleCon arity)
maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing
-maybeTyConSingleCon (PrimTyCon _ _ _) = Nothing
+maybeTyConSingleCon (PrimTyCon _ _ _ _) = Nothing
maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon"
-- requires DataCons of TyCon
isEnumerationTyCon (TupleTyCon _ _ arity)
= arity == 0
isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _)
- = not (null data_cons) && all is_nullary data_cons
- where
- is_nullary con = case (dataConSig con) of { (_,_, arg_tys, _) ->
- null arg_tys }
+ = not (null data_cons) && all isNullaryDataCon data_cons
\end{code}
@derivedFor@ reports if we have an {\em obviously}-derived instance
@@ -292,28 +298,7 @@ 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)
- = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx }
-
- -- now we *know* the tags are different, so...
- cmp other_1 other_2
- | tag1 _LT_ tag2 = LT_
- | otherwise = GT_
- 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 (SynTyCon _ _ _ _ _ _) = ILIT(6)
+ cmp tc1 tc2 = uniqueOf tc1 `cmp` uniqueOf tc2
instance Eq TyCon where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
@@ -329,7 +314,7 @@ instance Ord TyCon where
instance Uniquable TyCon where
uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u
uniqueOf (TupleTyCon u _ _) = u
- uniqueOf (PrimTyCon u _ _) = u
+ uniqueOf (PrimTyCon u _ _ _) = u
uniqueOf (SynTyCon u _ _ _ _ _) = u
uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon"
uniqueOf tc = uniqueOf (getName tc)
@@ -338,7 +323,7 @@ instance Uniquable TyCon where
\begin{code}
instance NamedThing TyCon where
getName (DataTyCon _ n _ _ _ _ _ _) = n
- getName (PrimTyCon _ n _) = n
+ getName (PrimTyCon _ n _ _) = n
getName (SpecTyCon tc _) = getName tc
getName (SynTyCon _ n _ _ _ _) = n
getName FunTyCon = mkFunTyConName
diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi
index d36e74e1cb96..2491f4c638b0 100644
--- a/ghc/compiler/types/TyLoop.lhi
+++ b/ghc/compiler/types/TyLoop.lhi
@@ -9,7 +9,7 @@ import Unique ( Unique )
import FieldLabel ( FieldLabel )
import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
- dataConSig, dataConArgTys )
+ isNullaryDataCon, dataConArgTys )
import PprType ( specMaybeTysSuffix )
import Name ( Name )
import TyCon ( TyCon )
@@ -17,6 +17,7 @@ import TyVar ( GenTyVar, TyVar )
import Type ( GenType, Type )
import Usage ( GenUsage )
import Class ( Class, GenClass )
+import TysWiredIn ( voidTy )
data GenId ty
data GenType tyvar uvar
@@ -31,12 +32,13 @@ type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
-- Needed in TyCon
mkTupleCon :: Int -> Id
-dataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon)
+isNullaryDataCon :: Id -> Bool
specMaybeTysSuffix :: [Maybe Type] -> _PackedString
instance Eq (GenClass a b)
-- Needed in Type
dataConArgTys :: Id -> [Type] -> [Type]
+voidTy :: Type
-- Needed in TysWiredIn
data StrictnessMark = MarkedStrict | NotMarkedStrict
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index 980f1dd1e255..7ba82cdab2b4 100644
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -7,6 +7,7 @@ module TyVar (
tyVarKind, -- TyVar -> Kind
cloneTyVar,
+ openAlphaTyVar,
alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
-- We also export "environments" keyed off of
@@ -23,11 +24,11 @@ module TyVar (
) where
CHK_Ubiq() -- debugging consistency check
-import IdLoop -- for paranoia checking
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-- friends
import Usage ( GenUsage, Usage(..), usageOmega )
-import Kind ( Kind, mkBoxedTypeKind )
+import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-- others
import UniqSet -- nearly all of it
@@ -77,10 +78,16 @@ cloneTyVar (TyVar _ k n x) u = TyVar u k n x
Fixed collection of type variables
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
+ -- openAlphaTyVar is prepared to be instantiated
+ -- to a boxed or unboxed type variable. It's used for the
+ -- result type for "error", so that we can have (error Int# "Help")
+openAlphaTyVar = TyVar (mkAlphaTyVarUnique 1) mkTypeKind Nothing usageOmega
+
alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing usageOmega
- | u <- map mkAlphaTyVarUnique [1..] ]
+ | u <- map mkAlphaTyVarUnique [2..] ]
(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
+
\end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index aff733f8247f..41f3cce9c2f4 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -10,7 +10,7 @@ module Type (
getFunTy_maybe, getFunTyExpandingDicts_maybe,
mkTyConTy, getTyCon_maybe, applyTyCon,
mkSynTy,
- mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
+ mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy,
mkForAllUsageTy, getForAllUsageTy,
applyTy,
#ifdef DEBUG
@@ -39,15 +39,15 @@ module Type (
tyVarsOfType, tyVarsOfTypes, typeKind
) where
-import Ubiq
-import IdLoop -- for paranoia checking
-import TyLoop -- for paranoia checking
-import PrelLoop -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
+IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
-- friends:
import Class ( classSig, classOpLocalType, GenClass{-instances-} )
-import Kind ( mkBoxedTypeKind, resultKind )
-import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity,
+import Kind ( mkBoxedTypeKind, resultKind, notArrowKind )
+import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
@@ -58,9 +58,11 @@ import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..),
eqUsage )
-- others
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, assocMaybe )
import PrimRep ( PrimRep(..) )
-import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
+import Unique -- quite a few *Keys
+import Util ( thenCmp, zipEqual, assoc,
+ panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
Ord3(..){-instances-}
)
-- ToDo:rm all these
@@ -69,11 +71,11 @@ import {-mumble-}
import {-mumble-}
PprStyle
import {-mumble-}
- PprType (pprType )
+ PprType --(pprType )
import {-mumble-}
UniqFM (ufmToList )
-import {-mumble-}
- Unique (pprUnique )
+import {-mumble-}
+ Outputable
\end{code}
Data types
@@ -144,6 +146,8 @@ expandTy (SynTy _ _ t) = expandTy t
expandTy (DictTy clas ty u)
= case all_arg_tys of
+ [] -> voidTy -- Empty dictionary represented by Void
+
[arg_ty] -> expandTy arg_ty -- just the <whatever> itself
-- The extra expandTy is to make sure that
@@ -258,7 +262,8 @@ mkTyConTy tycon
applyTyCon :: TyCon -> [GenType t u] -> GenType t u
applyTyCon tycon tys
- = ASSERT (not (isSynTyCon tycon))
+ = --ASSERT (not (isSynTyCon tycon))
+ (if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
foldl AppTy (TyConTy tycon usageOmega) tys
getTyCon_maybe :: GenType t u -> Maybe TyCon
@@ -341,6 +346,12 @@ getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t
getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
getForAllTy_maybe _ = Nothing
+getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type)
+getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t
+getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t)
+getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty)
+getForAllTyExpandingDicts_maybe _ = Nothing
+
splitForAllTy :: GenType t u-> ([t], GenType t u)
splitForAllTy t = go t []
where
@@ -392,9 +403,9 @@ Applied data tycons (give back constrs)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
maybeAppDataTyCon
- :: GenType tyvar uvar
+ :: GenType (GenTyVar any) uvar
-> Maybe (TyCon, -- the type constructor
- [GenType tyvar uvar], -- types to which it is applied
+ [GenType (GenTyVar any) uvar], -- types to which it is applied
[Id]) -- its family of data-constructors
maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
:: Type -> Maybe (TyCon, [Type], [Id])
@@ -405,26 +416,30 @@ maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
maybe_app_data_tycon expand ty
- = case (getTyCon_maybe app_ty) of
- Just tycon | isDataTyCon tycon &&
- tyConArity tycon == length arg_tys
+ = let
+ expanded_ty = expand ty
+ (app_ty, arg_tys) = splitAppTy expanded_ty
+ in
+ case (getTyCon_maybe app_ty) of
+ Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
+ isDataTyCon tycon &&
+ notArrowKind (typeKind expanded_ty)
-- Must be saturated for ty to be a data type
-> Just (tycon, arg_tys, tyConDataCons tycon)
other -> Nothing
- where
- (app_ty, arg_tys) = splitAppTy (expand ty)
getAppDataTyCon, getAppSpecDataTyCon
- :: GenType tyvar uvar
+ :: GenType (GenTyVar any) uvar
-> (TyCon, -- the type constructor
- [GenType tyvar uvar], -- types to which it is applied
+ [GenType (GenTyVar any) uvar], -- types to which it is applied
[Id]) -- its family of data-constructors
getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
:: Type -> (TyCon, [Type], [Id])
getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty
-getAppDataTyConExpandingDicts ty = get_app_data_tycon maybeAppDataTyConExpandingDicts ty
+getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $
+ get_app_data_tycon maybeAppDataTyConExpandingDicts ty
-- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
getAppSpecDataTyCon = getAppDataTyCon
@@ -467,6 +482,7 @@ Finding the kind of a type
~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
typeKind :: GenType (GenTyVar any) u -> Kind
+
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (TyConTy tycon usage) = tyConKind tycon
typeKind (SynTy _ _ ty) = typeKind ty
@@ -619,9 +635,33 @@ This is *not* right: it is a placeholder (ToDo 96/03 WDP):
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 (TyConTy tc _) = if not (isPrimTyCon tc) then
+ PtrRep
+ else
+ case (assocMaybe tc_primrep_list (uniqueOf tc)) of
+ Just xx -> xx
+ Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
+
typePrimRep _ = PtrRep -- the "default"
+
+tc_primrep_list
+ = [(addrPrimTyConKey, AddrRep)
+ ,(arrayPrimTyConKey, ArrayRep)
+ ,(byteArrayPrimTyConKey, ByteArrayRep)
+ ,(charPrimTyConKey, CharRep)
+ ,(doublePrimTyConKey, DoubleRep)
+ ,(floatPrimTyConKey, FloatRep)
+ ,(foreignObjPrimTyConKey, ForeignObjRep)
+ ,(intPrimTyConKey, IntRep)
+ ,(mutableArrayPrimTyConKey, ArrayRep)
+ ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
+ ,(stablePtrPrimTyConKey, StablePtrRep)
+ ,(statePrimTyConKey, VoidRep)
+ ,(synchVarPrimTyConKey, PtrRep)
+ ,(voidTyConKey, VoidRep)
+ ,(wordPrimTyConKey, WordRep)
+ ]
\end{code}
%************************************************************************
diff --git a/ghc/compiler/types/Usage.lhs b/ghc/compiler/types/Usage.lhs
index e5c4eb147f4f..c5e26d2cbc59 100644
--- a/ghc/compiler/types/Usage.lhs
+++ b/ghc/compiler/types/Usage.lhs
@@ -14,7 +14,7 @@ module Usage (
eqUVar, eqUsage
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty ( Pretty(..), PrettyRep, ppPStr, ppBeside )
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs
index 857dda2c974e..6085e37123c3 100644
--- a/ghc/compiler/utils/Bag.lhs
+++ b/ghc/compiler/utils/Bag.lhs
@@ -4,6 +4,8 @@
\section[Bags]{@Bag@: an unordered collection with duplicates}
\begin{code}
+#include "HsVersions.h"
+
module Bag (
Bag, -- abstract type
@@ -15,7 +17,8 @@ module Bag (
) where
#ifdef COMPILING_GHC
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(partition))
import Outputable ( interpp'SP )
import Pretty
diff --git a/ghc/compiler/utils/CharSeq.lhs b/ghc/compiler/utils/CharSeq.lhs
index 68948f4c6678..43dfb7f47811 100644
--- a/ghc/compiler/utils/CharSeq.lhs
+++ b/ghc/compiler/utils/CharSeq.lhs
@@ -31,12 +31,12 @@ module CharSeq (
#if ! defined(COMPILING_GHC)
) where
#else
- , cAppendFile
+ , cPutStr
) where
CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(IO)
-import PreludeGlaST
#endif
\end{code}
@@ -65,7 +65,7 @@ cCh :: Char -> CSeq
cInt :: Int -> CSeq
#if defined(COMPILING_GHC)
-cAppendFile :: _FILE -> CSeq -> IO ()
+cPutStr :: Handle -> CSeq -> IO ()
#endif
\end{code}
@@ -86,7 +86,7 @@ data CSeq
| CCh Char
| CInt Int -- equiv to "CStr (show the_int)"
#if defined(COMPILING_GHC)
- | CPStr _PackedString
+ | CPStr FAST_STRING
#endif
\end{code}
@@ -125,11 +125,6 @@ cShow seq = flatten ILIT(0) _TRUE_ seq []
cShows seq rest = cShow seq ++ rest
cLength seq = length (cShow seq) -- *not* the best way to do this!
#endif
-
-#if defined(COMPILING_GHC)
-cAppendFile file_star seq
- = flattenIO file_star seq `seqPrimIO` return ()
-#endif
\end{code}
This code is {\em hammered}. We are not above doing sleazy
@@ -156,14 +151,14 @@ flatten n _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs
flatten n _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs
flatten n _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs
#if defined(COMPILING_GHC)
-flatten n _FALSE_ (CPStr s) seqs = _unpackPS s ++ flattenS _FALSE_ seqs
+flatten n _FALSE_ (CPStr s) seqs = _UNPK_ s ++ flattenS _FALSE_ seqs
#endif
flatten n _TRUE_ (CStr s) seqs = mkIndent n (s ++ flattenS _FALSE_ seqs)
flatten n _TRUE_ (CCh c) seqs = mkIndent n (c : flattenS _FALSE_ seqs)
flatten n _TRUE_ (CInt i) seqs = mkIndent n (show i ++ flattenS _FALSE_ seqs)
#if defined(COMPILING_GHC)
-flatten n _TRUE_ (CPStr s) seqs = mkIndent n (_unpackPS s ++ flattenS _FALSE_ seqs)
+flatten n _TRUE_ (CPStr s) seqs = mkIndent n ( _UNPK_ s ++ flattenS _FALSE_ seqs)
#endif
\end{code}
@@ -187,61 +182,21 @@ Now the I/O version.
This code is massively {\em hammered}.
It {\em ignores} indentation.
+(NB: 1.3 compiler: efficiency hacks removed for now!)
+
\begin{code}
#if defined(COMPILING_GHC)
-flattenIO :: _FILE -- file we are writing to
- -> CSeq -- Seq to print
- -> PrimIO ()
-
-flattenIO file sq
- | file == ``NULL'' = error "panic:flattenIO" -- really just to force eval :-)
- | otherwise
- = flat sq
+cPutStr handle sq = flat sq
where
- flat CNil = returnPrimIO ()
+ flat CNil = return ()
flat (CIndent n2 seq) = flat seq
- flat (CAppend s1 s2) = flat s1 `seqPrimIO` flat s2
- flat CNewline = _ccall_ stg_putc '\n' file
- flat (CCh c) = _ccall_ stg_putc c file
- flat (CInt i) = _ccall_ fprintf file percent_d i
- flat (CStr s) = put_str s
- flat (CPStr s) = put_pstr s
-
- -----
- put_str, put_str2 :: String -> PrimIO ()
-
- put_str str
- = --put_str2 ``stderr'' (str ++ "\n") `seqPrimIO`
- put_str2 str
-
- put_str2 [] = returnPrimIO ()
-
- put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _) : cs)
- = _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- _ccall_ stg_putc c3 file `seqPrimIO`
- _ccall_ stg_putc c4 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
-
- put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : cs)
- = _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- _ccall_ stg_putc c3 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
-
- put_str2 (c1@(C# _) : c2@(C# _) : cs)
- = _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
-
- put_str2 (c1@(C# _) : cs)
- = _ccall_ stg_putc c1 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
-
- put_pstr ps = _putPS file ps
-
-percent_d = _psToByteArray SLIT("%d")
+ flat (CAppend s1 s2) = flat s1 >> flat s2
+ flat CNewline = hPutChar handle '\n'
+ flat (CCh c) = hPutChar handle c
+ flat (CInt i) = hPutStr handle (show i)
+ flat (CStr s) = hPutStr handle s
+ flat (CPStr s) = hPutStr handle (_UNPK_ s)
#endif {- COMPILING_GHC -}
\end{code}
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index 384a7d122a64..e2a9ec5960bb 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -63,17 +63,12 @@ module FiniteMap (
, FiniteSet(..), emptySet, mkSet, isEmptySet
, elementOf, setToList, union, minusSet
#endif
-
- -- To make it self-sufficient
-#if __HASKELL1__ < 3
- , Maybe
-#endif
) where
import Maybes
#ifdef COMPILING_GHC
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
# ifdef DEBUG
import Pretty
# endif
@@ -757,97 +752,65 @@ When the FiniteMap module is used in GHC, we specialise it for
\tr{Uniques}, for dastardly efficiency reasons.
\begin{code}
-#if 0
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__
+#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3)
-{-# SPECIALIZE listToFM
- :: [(Int,elt)] -> FiniteMap Int elt,
- [(CLabel,elt)] -> FiniteMap CLabel elt,
- [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt,
- [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
- IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addToFM
- :: FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt,
- FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt,
- FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
{-# SPECIALIZE addListToFM
- :: FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt,
- FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt
+ :: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
#-}
-{-NOT EXPORTED!! # SPECIALIZE addToFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
{-# SPECIALIZE addListToFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt
+ :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt,
+ (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
#-}
-{-NOT EXPORTED!!! # SPECIALIZE delFromFM
- :: FiniteMap Int elt -> Int -> FiniteMap Int elt,
- FiniteMap CLabel elt -> CLabel -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE delListFromFM
- :: FiniteMap Int elt -> [Int] -> FiniteMap Int elt,
- FiniteMap CLabel elt -> [CLabel] -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
+{-# SPECIALIZE addToFM
+ :: FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt,
+ FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt,
+ FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt,
+ FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt
+ IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
#-}
-{-# SPECIALIZE elemFM
- :: FAST_STRING -> FiniteMap FAST_STRING elt -> Bool
+{-# SPECIALIZE addToFM_C
+ :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt,
+ (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
+ IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
#-}
-{-not EXPORTED!!! # SPECIALIZE filterFM
- :: (Int -> elt -> Bool) -> FiniteMap Int elt -> FiniteMap Int elt,
- (CLabel -> elt -> Bool) -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (Reg -> elt -> Bool) -> FiniteMap Reg elt -> FiniteMap Reg elt)
+{-# SPECIALIZE bagToFM
+ :: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt
#-}
-{-NOT EXPORTED!!! # SPECIALIZE intersectFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
+{-# SPECIALIZE delListFromFM
+ :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt,
+ FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt
+ IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
#-}
-{-not EXPORTED !!!# SPECIALIZE intersectFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
+{-# SPECIALIZE listToFM
+ :: [([Char],elt)] -> FiniteMap [Char] elt,
+ [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt,
+ [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
+ IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
#-}
{-# SPECIALIZE lookupFM
- :: FiniteMap Int elt -> Int -> Maybe elt,
- FiniteMap CLabel elt -> CLabel -> Maybe elt,
+ :: FiniteMap CLabel elt -> CLabel -> Maybe elt,
+ FiniteMap [Char] elt -> [Char] -> Maybe elt,
FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt,
- FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
+ FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt,
+ FiniteMap RdrName elt -> RdrName -> Maybe elt,
+ FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt
IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt)
#-}
{-# SPECIALIZE lookupWithDefaultFM
- :: FiniteMap Int elt -> elt -> Int -> elt,
- FiniteMap CLabel elt -> elt -> CLabel -> elt
+ :: FiniteMap FAST_STRING elt -> elt -> FAST_STRING -> elt
IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt)
#-}
-{-# SPECIALIZE minusFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt,
- FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
{-# SPECIALIZE plusFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
+ :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt,
+ FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
#-}
{-# SPECIALIZE plusFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
+ :: (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
#-}
#endif {- compiling for GHC -}
-#endif {- 0 -}
\end{code}
diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs
index 3be4d8932564..5a46b2391be9 100644
--- a/ghc/compiler/utils/ListSetOps.lhs
+++ b/ghc/compiler/utils/ListSetOps.lhs
@@ -4,6 +4,8 @@
\section[ListSetOps]{Set-like operations on lists}
\begin{code}
+#include "HsVersions.h"
+
module ListSetOps (
unionLists,
intersectLists,
@@ -14,7 +16,7 @@ module ListSetOps (
) where
#if defined(COMPILING_GHC)
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( isIn, isn'tIn )
#endif
diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs
index 1c6a863eaa9a..c40ffb2ae676 100644
--- a/ghc/compiler/utils/Maybes.lhs
+++ b/ghc/compiler/utils/Maybes.lhs
@@ -24,11 +24,9 @@ module Maybes (
failMaB,
failMaybe,
seqMaybe,
- mapMaybe,
returnMaB,
returnMaybe,
- thenMaB,
- thenMaybe
+ thenMaB
#if ! defined(COMPILING_GHC)
, findJust
@@ -113,12 +111,6 @@ returnMaybe = Just
failMaybe :: Maybe a
failMaybe = Nothing
-
-mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b]
-mapMaybe f [] = returnMaybe []
-mapMaybe f (x:xs) = f x `thenMaybe` \ x' ->
- mapMaybe f xs `thenMaybe` \ xs' ->
- returnMaybe (x':xs')
\end{code}
Lookup functions
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index 455cea2f2713..0ed69ce60be4 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -19,7 +19,7 @@ module Outputable (
ifPprInterface
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import PprStyle ( PprStyle(..) )
import Pretty
diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index e5c20cc17503..8cb244056c2a 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -12,7 +12,7 @@
#endif
module Pretty (
- Pretty(..),
+ SYN_IE(Pretty),
#if defined(COMPILING_GHC)
prettyToUn,
@@ -32,21 +32,20 @@ module Pretty (
ppShow, speakNth,
#if defined(COMPILING_GHC)
- ppAppendFile,
+ ppPutStr,
#endif
-- abstract type, to complete the interface...
- PrettyRep(..), CSeq, Delay
-#if defined(COMPILING_GHC)
- , Unpretty(..)
-#endif
+ PrettyRep(..), Delay
) where
#if defined(COMPILING_GHC)
CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(Ratio)
+IMPORT_1_3(IO)
-import Unpretty ( Unpretty(..) )
+import Unpretty ( SYN_IE(Unpretty) )
#endif
import CharSeq
@@ -94,7 +93,7 @@ ppNest :: Int -> Pretty -> Pretty
ppShow :: Int -> Pretty -> [Char]
#if defined(COMPILING_GHC)
-ppAppendFile :: _FILE -> Int -> Pretty -> IO ()
+ppPutStr :: Handle -> Int -> Pretty -> IO ()
#endif
\end{code}
@@ -129,9 +128,9 @@ ppShow width p
MkPrettyRep seq ll emp sl -> cShow seq
#if defined(COMPILING_GHC)
-ppAppendFile f width p
+ppPutStr f width p
= case (p width False) of
- MkPrettyRep seq ll emp sl -> cAppendFile f seq
+ MkPrettyRep seq ll emp sl -> cPutStr f seq
#endif
ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0)
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
index b2f07e4d302d..82e31b4b1449 100644
--- a/ghc/compiler/utils/Ubiq.lhi
+++ b/ghc/compiler/utils/Ubiq.lhi
@@ -28,6 +28,7 @@ import Id ( StrictnessMark, GenId, Id(..) )
import IdInfo ( IdInfo, OptIdInfo(..), ArityInfo, DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
import Kind ( Kind )
import Literal ( Literal )
+import MachRegs ( Reg )
import Maybes ( MaybeErr )
import MatchEnv ( MatchEnv )
import Name ( Module(..), RdrName, Name, ExportFlag, NamedThing(..) )
@@ -111,6 +112,7 @@ data MaybeErr a b
data MatchEnv a b
data Name
data RdrName = Unqual _PackedString | Qual _PackedString _PackedString
+data Reg
data OutPat a b c
data PprStyle
data PragmaInfo
@@ -144,4 +146,14 @@ type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
type Type = GenType (GenTyVar (GenUsage Unique)) Unique
type TyVar = GenTyVar (GenUsage Unique)
type Usage = GenUsage Unique
+
+-- These are here only for SPECIALIZing in FiniteMap (ToDo:move?)
+instance Ord Reg
+instance Ord RdrName
+instance Ord CLabel
+instance Ord TyCon
+instance Eq Reg
+instance Eq RdrName
+instance Eq CLabel
+instance Eq TyCon
\end{code}
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 166688c07c9f..a2f48801a424 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -35,6 +35,7 @@ module UniqFM (
IF_NOT_GHC(addToUFM_C COMMA)
addListToUFM_C,
delFromUFM,
+ delFromUFM_Directly,
delListFromUFM,
plusUFM,
plusUFM_C,
@@ -53,7 +54,7 @@ module UniqFM (
) where
#if defined(COMPILING_GHC)
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
#endif
import Unique ( Unique, u2i, mkUniqueGrimily )
@@ -101,6 +102,7 @@ addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
+delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
@@ -329,7 +331,8 @@ Now ways of removing things from UniqFM.
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (u2i (uniqueOf key))
+delFromUFM fm key = delete fm (u2i (uniqueOf key))
+delFromUFM_Directly fm u = delete fm (u2i u)
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs
index 9df9fc852a11..4e516acd415b 100644
--- a/ghc/compiler/utils/UniqSet.lhs
+++ b/ghc/compiler/utils/UniqSet.lhs
@@ -20,7 +20,7 @@ module UniqSet (
isEmptyUniqSet
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Maybes ( maybeToBool, Maybe )
import UniqFM
diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs
index cf90116dc8cf..8e35e3c1956b 100644
--- a/ghc/compiler/utils/Unpretty.lhs
+++ b/ghc/compiler/utils/Unpretty.lhs
@@ -7,7 +7,7 @@
#include "HsVersions.h"
module Unpretty (
- Unpretty(..),
+ SYN_IE(Unpretty),
uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger,
uppSP, upp'SP, uppLbrack, uppRbrack, uppLparen, uppRparen,
@@ -17,13 +17,14 @@ module Unpretty (
uppCat, uppBeside, uppBesides, uppAbove, uppAboves,
uppNest, uppSep, uppInterleave, uppIntersperse,
uppShow,
- uppAppendFile,
+ uppPutStr,
-- abstract type, to complete the interface...
CSeq
) where
CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(IO)
import CharSeq
\end{code}
@@ -69,7 +70,7 @@ uppNest :: Int -> Unpretty -> Unpretty
uppShow :: Int -> Unpretty -> [Char]
-uppAppendFile :: _FILE -> Int -> Unpretty -> IO ()
+uppPutStr :: Handle -> Int -> Unpretty -> IO ()
\end{code}
%************************************************
@@ -81,7 +82,7 @@ uppAppendFile :: _FILE -> Int -> Unpretty -> IO ()
\begin{code}
uppShow _ p = cShow p
-uppAppendFile f _ p = cAppendFile f p
+uppPutStr f _ p = cPutStr f p
uppNil = cNil
uppStr s = cStr s
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index c026524ecf85..8ae4b4b727b0 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -582,11 +582,11 @@ transitiveClosure :: (a -> [a]) -- Successor function
-> [a] -- The transitive closure
transitiveClosure succ eq xs
- = do [] xs
+ = go [] xs
where
- do done [] = done
- do done (x:xs) | x `is_in` done = do done xs
- | otherwise = do (x:done) (succ x ++ xs)
+ go done [] = done
+ go done (x:xs) | x `is_in` done = go done xs
+ | otherwise = go (x:done) (succ x ++ xs)
x `is_in` [] = False
x `is_in` (y:ys) | eq x y = True
--
GitLab