From 9d4c03805bafb6b1e1d47306b6a6c591c998e517 Mon Sep 17 00:00:00 2001
From: partain <unknown>
Date: Sun, 30 Jun 1996 16:01:37 +0000
Subject: [PATCH] [project @ 1996-06-30 15:56:44 by partain] partain 1.3
changes through 960629
---
ghc/compiler/Jmakefile | 2 +-
ghc/compiler/absCSyn/AbsCLoop_1_3.lhi | 13 ++
ghc/compiler/absCSyn/PprAbsC.lhs | 11 +-
ghc/compiler/basicTypes/IdInfo.lhs | 3 +-
ghc/compiler/basicTypes/IdLoop.lhi | 2 +-
ghc/compiler/basicTypes/IdUtils.lhs | 6 +-
ghc/compiler/basicTypes/Unique.lhs | 2 -
ghc/compiler/codeGen/CgBindery.lhs | 4 +-
ghc/compiler/codeGen/CgCase.lhs | 4 +-
ghc/compiler/codeGen/CgClosure.lhs | 5 +-
ghc/compiler/codeGen/CgCon.lhs | 2 +-
ghc/compiler/codeGen/CgConTbls.lhs | 5 +-
ghc/compiler/codeGen/CgExpr.lhs | 2 +-
ghc/compiler/codeGen/CgHeapery.lhs | 1 -
ghc/compiler/codeGen/CgLetNoEscape.lhs | 3 +-
ghc/compiler/codeGen/CgLoop2_1_3.lhi | 3 +-
ghc/compiler/codeGen/CgTailCall.lhs | 3 +-
ghc/compiler/codeGen/CodeGen.lhs | 2 +
ghc/compiler/coreSyn/CoreUtils.lhs | 4 +-
ghc/compiler/deSugar/Desugar.lhs | 2 +-
ghc/compiler/deSugar/DsBinds.lhs | 6 +-
ghc/compiler/deSugar/DsExpr.lhs | 8 +-
ghc/compiler/deSugar/DsGRHSs.lhs | 12 +-
ghc/compiler/deSugar/DsHsSyn.lhs | 4 +-
ghc/compiler/deSugar/DsListComp.lhs | 13 +-
ghc/compiler/deSugar/DsLoop_1_3.lhi | 5 +-
ghc/compiler/deSugar/DsMonad.lhs | 6 +-
ghc/compiler/deSugar/DsUtils.lhs | 8 +-
ghc/compiler/deSugar/Match.lhs | 4 +-
ghc/compiler/deSugar/MatchLit.lhs | 4 +-
ghc/compiler/main/Main.lhs | 1 +
ghc/compiler/main/MkIface.lhs | 47 +++--
ghc/compiler/nativeGen/AbsCStixGen.lhs | 1 +
ghc/compiler/nativeGen/AsmCodeGen.lhs | 3 +-
ghc/compiler/nativeGen/AsmRegAlloc.lhs | 2 +-
ghc/compiler/nativeGen/MachCode.lhs | 238 ++++++++++++------------
ghc/compiler/nativeGen/MachMisc.lhs | 19 +-
ghc/compiler/nativeGen/MachRegs.lhs | 24 +--
ghc/compiler/nativeGen/NcgLoop_1_3.lhi | 1 +
ghc/compiler/nativeGen/PprMach.lhs | 43 +++--
ghc/compiler/nativeGen/RegAllocInfo.lhs | 11 +-
ghc/compiler/nativeGen/Stix.lhs | 5 +-
ghc/compiler/nativeGen/StixPrim.lhs | 2 +-
ghc/compiler/prelude/PrelLoop.lhi | 3 +-
ghc/compiler/prelude/PrelLoop_1_3.lhi | 1 +
ghc/compiler/prelude/PrimOp.lhs | 8 +-
ghc/compiler/prelude/TysWiredIn.lhs | 30 +--
ghc/compiler/reader/ReadPrefix.lhs | 8 +-
ghc/compiler/rename/ParseIface.y | 12 +-
ghc/compiler/rename/ParseUtils.lhs | 6 +-
ghc/compiler/rename/Rename.lhs | 32 ++--
ghc/compiler/rename/RnIfaces.lhs | 43 +++--
ghc/compiler/rename/RnLoop_1_3.lhi | 4 +-
ghc/compiler/rename/RnNames.lhs | 12 +-
ghc/compiler/rename/RnSource.lhs | 1 +
ghc/compiler/simplCore/SimplCase.lhs | 4 +-
ghc/compiler/simplCore/SimplCore.lhs | 2 +
ghc/compiler/simplCore/Simplify.lhs | 1 +
ghc/compiler/typecheck/GenSpecEtc.lhs | 8 +-
ghc/compiler/typecheck/Inst.lhs | 16 +-
ghc/compiler/typecheck/TcBinds.lhs | 13 +-
ghc/compiler/typecheck/TcClassDcl.lhs | 17 +-
ghc/compiler/typecheck/TcDeriv.lhs | 4 +-
ghc/compiler/typecheck/TcEnv.lhs | 7 +-
ghc/compiler/typecheck/TcExpr.lhs | 18 +-
ghc/compiler/typecheck/TcGRHSs.lhs | 8 +-
ghc/compiler/typecheck/TcHsSyn.lhs | 28 +--
ghc/compiler/typecheck/TcInstDcls.lhs | 12 +-
ghc/compiler/typecheck/TcInstUtil.lhs | 8 +-
ghc/compiler/typecheck/TcLoop_1_3.lhi | 2 +-
ghc/compiler/typecheck/TcMLoop_1_3.lhi | 4 +-
ghc/compiler/typecheck/TcMatches.lhs | 9 +-
ghc/compiler/typecheck/TcModule.lhs | 16 +-
ghc/compiler/typecheck/TcMonad.lhs | 27 ++-
ghc/compiler/typecheck/TcMonoType.lhs | 10 +-
ghc/compiler/typecheck/TcPat.lhs | 9 +-
ghc/compiler/typecheck/TcSimplify.lhs | 6 +-
ghc/compiler/typecheck/TcTyClsDecls.lhs | 6 +-
ghc/compiler/typecheck/TcTyDecls.lhs | 7 +-
ghc/compiler/typecheck/TcType.lhs | 34 ++--
ghc/compiler/typecheck/Unify.lhs | 2 +-
ghc/compiler/types/TyVar.lhs | 6 +-
ghc/compiler/types/Type.lhs | 44 +++--
ghc/compiler/utils/Ubiq_1_3.lhi | 6 +-
84 files changed, 579 insertions(+), 461 deletions(-)
diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index e3496adfa276..766582e6f209 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -611,7 +611,7 @@ compile(reader/PrefixToHs,lhs,)
compile(reader/ReadPrefix,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser '-#include"hspincl.h"'))
compile(reader/RdrHsSyn,lhs,)
-compile(rename/ParseIface,hs,)
+compile(rename/ParseIface,hs,-Onot) /* sigh */
compile(rename/ParseUtils,lhs,)
compile(rename/RnHsSyn,lhs,)
compile(rename/RnMonad,lhs,if_ghc(-fvia-C))
diff --git a/ghc/compiler/absCSyn/AbsCLoop_1_3.lhi b/ghc/compiler/absCSyn/AbsCLoop_1_3.lhi
index 63f3690dd7f2..a7401e1c753d 100644
--- a/ghc/compiler/absCSyn/AbsCLoop_1_3.lhi
+++ b/ghc/compiler/absCSyn/AbsCLoop_1_3.lhi
@@ -5,4 +5,17 @@ MachMisc fixedHdrSizeInWords (..)
MachMisc varHdrSizeInWords (..)
CgRetConv ctrlReturnConvAlg (..)
CgRetConv CtrlReturnConvention(..)
+ClosureInfo closureKind (..)
+ClosureInfo closureLabelFromCI (..)
+ClosureInfo closureNonHdrSize (..)
+ClosureInfo closurePtrsSize (..)
+ClosureInfo closureSMRep (..)
+ClosureInfo closureSemiTag (..)
+ClosureInfo closureSizeWithoutFixedHdr (..)
+ClosureInfo closureTypeDescr (..)
+ClosureInfo closureUpdReqd (..)
+ClosureInfo infoTableLabelFromCI (..)
+ClosureInfo maybeSelectorInfo (..)
+ClosureInfo entryLabelFromCI (..)
+ClosureInfo fastLabelFromCI (..)
\end{code}
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index fa3d01b918fe..2f11f1acf67c 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -20,6 +20,9 @@ module PprAbsC (
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
+IMPORT_1_3(IO(Handle))
+IMPORT_1_3(Char(isDigit,isPrint))
+IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards
import AbsCSyn
@@ -35,7 +38,7 @@ import CmdLineOpts ( opt_SccProfilingOn )
import CostCentre ( uppCostCentre, uppCostCentreDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC )
-import FiniteMap ( addToFM, emptyFM, lookupFM )
+import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
import Literal ( showLiteral, Literal(..) )
import Maybes ( maybeToBool, catMaybes )
@@ -799,7 +802,11 @@ process_casm results args string = process results args string
_ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
other ->
- case readDec other of
+ let
+ read_int :: ReadS Int
+ read_int = reads
+ in
+ case (read_int other) of
[(num,css)] ->
if 0 <= num && num < length args
then uppBeside (uppParens (args !! num))
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index f6afdc1c91ef..ad761add83f5 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -83,6 +83,7 @@ import PprStyle ( PprStyle(..) )
import Pretty
import SrcLoc ( mkUnknownSrcLoc )
import Type ( eqSimpleTy, splitFunTyExpandingDicts )
+import Unique ( pprUnique )
import Util ( mapAccumL, panic, assertPanic, pprPanic )
#ifdef REALLY_HASKELL_1_3
@@ -766,7 +767,7 @@ pp_unfolding sty for_this_id inline_env uf_details
pp NoUnfoldingDetails = pp_NONE
pp (MagicForm tag _)
- = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
+ = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
pp (GenForm _ _ BadUnfolding) = pp_NONE
diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi
index aea554af7384..455902d4df7f 100644
--- a/ghc/compiler/basicTypes/IdLoop.lhi
+++ b/ghc/compiler/basicTypes/IdLoop.lhi
@@ -70,7 +70,7 @@ data UnfoldingDetails
| OtherLitForm [Literal]
| OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
| GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
- | MagicForm _PackedString MagicUnfoldingFun
+ | MagicForm Unique MagicUnfoldingFun
data UnfoldingGuidance
= UnfoldNever
diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs
index e17f17a5567c..167a23167001 100644
--- a/ghc/compiler/basicTypes/IdUtils.lhs
+++ b/ghc/compiler/basicTypes/IdUtils.lhs
@@ -20,7 +20,7 @@ import PrelMods ( gHC_BUILTINS )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
PrimOpInfo(..), PrimOpResultInfo(..) )
import RnHsSyn ( RnName(..) )
-import Type ( mkForAllTys, mkFunTys, mkTyVarTy, applyTyCon )
+import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
import TysWiredIn ( boolTy )
import Unique ( mkPrimOpIdUnique )
import Util ( panic )
@@ -44,7 +44,7 @@ primOpId op
mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
Coercing str ty1 ty2 ->
- mk_prim_Id op str [] [ty1] (mkFunTys [ty1] ty2) 1
+ mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
mk_prim_Id op str
@@ -72,7 +72,7 @@ primOpId op
\begin{code}
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
-monadic_fun_ty ty = mkFunTys [ty] ty
+monadic_fun_ty ty = ty `mkFunTy` ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 2f2b1c81d138..953f435214b4 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -132,7 +132,6 @@ module Unique (
parIdKey,
patErrorIdKey,
primIoTyConKey,
- primIoDataConKey,
ratioDataConKey,
ratioTyConKey,
rationalTyConKey,
@@ -590,7 +589,6 @@ stateDataConKey = mkPreludeDataConUnique 39
trueDataConKey = mkPreludeDataConUnique 40
wordDataConKey = mkPreludeDataConUnique 41
stDataConKey = mkPreludeDataConUnique 42
-primIoDataConKey = mkPreludeDataConUnique 43
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 0fc6bed0b780..6e0c8bdf4ada 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -7,7 +7,7 @@
#include "HsVersions.h"
module CgBindery (
- CgBindings(..), CgIdInfo(..){-dubiously concrete-},
+ SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-},
StableLoc, VolatileLoc,
maybeAStkLoc, maybeBStkLoc,
@@ -34,7 +34,7 @@ import CgMonad
import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
import CLabel ( mkClosureLabel )
-import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument )
+import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
import HeapOffs ( SYN_IE(VirtualHeapOffset),
SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
)
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 538a9e397e70..939c87ddc11c 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -63,8 +63,8 @@ import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
)
import TyCon ( isEnumerationTyCon )
import Type ( typePrimRep,
- getAppSpecDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
- isEnumerationTyCon
+ getAppSpecDataTyConExpandingDicts,
+ maybeAppSpecDataTyConExpandingDicts
)
import Util ( sortLt, isIn, isn'tIn, zipEqual,
pprError, panic, assertPanic
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index e2d6de9f86b6..8bf533fcc40e 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -24,15 +24,14 @@ import CgBindery ( getCAddrMode, getArgAmodes,
getCAddrModeAndInfo, bindNewToNode,
bindNewToAStack, bindNewToBStack,
bindNewToReg, bindArgsToRegs,
- stableAmodeIdInfo, heapIdInfo
+ stableAmodeIdInfo, heapIdInfo, CgIdInfo
)
import CgCompInfo ( spARelToInt, spBRelToInt )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
, heapCheckOnly, fetchAndReschedule, yield -- HWL
)
-import CgRetConv ( mkLiveRegsMask,
- ctrlReturnConvAlg, dataReturnConvAlg,
+import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg,
CtrlReturnConvention(..), DataReturnConvention(..)
)
import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index c2aa1f5fe4a1..21507e3e01c9 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -26,7 +26,7 @@ import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgBindery ( getArgAmodes, bindNewToNode,
bindArgsToRegs, newTempAmodeAndIdInfo,
idInfoToAmode, stableAmodeIdInfo,
- heapIdInfo
+ heapIdInfo, CgIdInfo
)
import CgClosure ( cgTopRhsClosure )
import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE )
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index e13d043b37b6..ea53371fbc54 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -16,8 +16,7 @@ import CgMonad
import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
import CgCompInfo ( uF_UPDATEE )
import CgHeapery ( heapCheck, allocDynClosure )
-import CgRetConv ( mkLiveRegsMask,
- dataReturnConvAlg, ctrlReturnConvAlg,
+import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
CtrlReturnConvention(..),
DataReturnConvention(..)
)
@@ -33,7 +32,7 @@ import ClosureInfo ( layOutStaticClosure, layOutDynCon,
infoTableLabelFromCI, dataConLiveness
)
import CostCentre ( dontCareCostCentre )
-import FiniteMap ( fmToList )
+import FiniteMap ( fmToList, FiniteMap )
import HeapOffs ( zeroOff, SYN_IE(VirtualHeapOffset) )
import Id ( dataConTag, dataConRawArgTys,
dataConNumFields, fIRST_TAG,
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 212a728f977b..05264e624b38 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -20,7 +20,7 @@ import CgMonad
import AbsCSyn
import AbsCUtils ( mkAbsCStmts, mkAbstractCs )
-import CgBindery ( getArgAmodes )
+import CgBindery ( getArgAmodes, CgIdInfo )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index 2d4abe27d98d..1e7b2c99c9e3 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -20,7 +20,6 @@ import AbsCSyn
import CgMonad
import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgRetConv ( mkLiveRegsMask )
import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp,
initHeapUsage
)
diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index 3126b25d7871..591e775f98f8 100644
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -20,7 +20,8 @@ import CgMonad
import AbsCSyn
import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
- bindNewToAStack, bindNewToBStack
+ bindNewToAStack, bindNewToBStack,
+ CgIdInfo
)
import CgHeapery ( heapCheck )
import CgRetConv ( assignRegs )
diff --git a/ghc/compiler/codeGen/CgLoop2_1_3.lhi b/ghc/compiler/codeGen/CgLoop2_1_3.lhi
index 7a0feb086b67..e813a302c9f4 100644
--- a/ghc/compiler/codeGen/CgLoop2_1_3.lhi
+++ b/ghc/compiler/codeGen/CgLoop2_1_3.lhi
@@ -1,5 +1,6 @@
\begin{code}
interface CgLoop2_1_3 1
__exports__
-Outputable Outputable (..)
+CgExpr cgExpr (..)
+CgExpr getPrimOpArgAmodes (..)
\end{code}
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 590a80a2076c..95055d854ea8 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -34,7 +34,8 @@ import CgStackery ( adjustRealSps, mkStkAmodes )
import CgUsages ( getSpARelOffset )
import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
import ClosureInfo ( nodeMustPointToIt,
- getEntryConvention, EntryConvention(..)
+ getEntryConvention, EntryConvention(..),
+ LambdaFormInfo
)
import CmdLineOpts ( opt_DoSemiTagging )
import HeapOffs ( zeroOff, SYN_IE(VirtualSpAOffset) )
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 4a1fed5c3ad4..5879c0f87701 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -27,6 +27,7 @@ import AbsCSyn
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import Bag ( foldBag )
+import CgBindery ( CgIdInfo )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon )
import CgConTbls ( genStaticConBits )
@@ -35,6 +36,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingGhcInternals,
opt_EnsureSplittableC, opt_SccGroup
)
import CStrings ( modnameToC )
+import FiniteMap ( FiniteMap )
import Maybes ( maybeToBool )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Util ( panic, assertPanic )
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index e0e65de4af05..2000b32f85fe 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -50,7 +50,7 @@ import SrcLoc ( mkUnknownSrcLoc )
import TyVar ( cloneTyVar,
isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
)
-import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
+import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
getFunTy_maybe, applyTy, isPrimType,
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
)
@@ -91,7 +91,7 @@ coreExprType (Con con args) = applyTypeToArgs (idType con) args
coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
coreExprType (Lam (ValBinder binder) expr)
- = mkFunTys [idType binder] (coreExprType expr)
+ = idType binder `mkFunTy` coreExprType expr
coreExprType (Lam (TyBinder tyvar) expr)
= mkForAllTy tyvar (coreExprType expr)
diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index da8603176d8d..697c32dd2f6e 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -11,7 +11,7 @@ module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where
IMP_Ubiq(){-uitous-}
import HsSyn ( HsBinds, HsExpr )
-import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
+import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
import CoreSyn
import DsMonad
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 99cf6d437c2e..250c98ec2825 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -18,9 +18,9 @@ IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn -- lots of things
hiding ( collectBinders{-also in CoreSyn-} )
import CoreSyn -- lots of things
-import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
- TypecheckedBind(..), TypecheckedMonoBinds(..),
- TypecheckedPat(..)
+import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
+ SYN_IE(TypecheckedBind), SYN_IE(TypecheckedMonoBinds),
+ SYN_IE(TypecheckedPat)
)
import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index d7b8e68ffdc3..e8f4398cc38d 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -16,9 +16,9 @@ import HsSyn ( failureFreePat,
Stmt(..), Match(..), Qualifier, HsBinds, PolyType,
GRHSsAndBinds
)
-import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
- TypecheckedRecordBinds(..), TypecheckedPat(..),
- TypecheckedStmt(..)
+import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
+ SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedPat),
+ SYN_IE(TypecheckedStmt)
)
import CoreSyn
@@ -28,7 +28,7 @@ import DsHsSyn ( outPatType )
import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
mkErrorAppDs, showForErr, EquationInfo,
- MatchResult, DsCoreArg(..)
+ MatchResult, SYN_IE(DsCoreArg)
)
import Match ( matchWrapper )
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index ee11244ec36f..6b95110a284c 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -13,9 +13,9 @@ IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr, HsBinds )
-import TcHsSyn ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
- TypecheckedPat(..), TypecheckedHsBinds(..),
- TypecheckedHsExpr(..) )
+import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
+ SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
+ SYN_IE(TypecheckedHsExpr) )
import CoreSyn ( SYN_IE(CoreBinding), SYN_IE(CoreExpr), mkCoLetsAny )
import DsMonad
@@ -78,23 +78,21 @@ dsGRHSs ty kind pats (grhs:grhss)
combineGRHSMatchResults match_result1 match_result2
dsGRHS ty kind pats (OtherwiseGRHS expr locn)
- = putSrcLocDs locn (
+ = putSrcLocDs locn $
dsExpr expr `thenDs` \ core_expr ->
let
expr_fn = \ ignore -> core_expr
in
returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
- )
dsGRHS ty kind pats (GRHS guard expr locn)
- = putSrcLocDs locn (
+ = putSrcLocDs locn $
dsExpr guard `thenDs` \ core_guard ->
dsExpr expr `thenDs` \ core_expr ->
let
expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
in
returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
- )
\end{code}
diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs
index fa3f0fe6f690..08288bd97c85 100644
--- a/ghc/compiler/deSugar/DsHsSyn.lhs
+++ b/ghc/compiler/deSugar/DsHsSyn.lhs
@@ -12,8 +12,8 @@ IMP_Ubiq()
import HsSyn ( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..),
Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
-import TcHsSyn ( TypecheckedPat(..), TypecheckedBind(..),
- TypecheckedMonoBinds(..) )
+import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedBind),
+ SYN_IE(TypecheckedMonoBinds) )
import Id ( idType )
import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index f0e388d6f281..8be75c125380 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -12,7 +12,7 @@ IMP_Ubiq()
IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn ( Qualifier(..), HsExpr, HsBinds )
-import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
+import TcHsSyn ( SYN_IE(TypecheckedQual), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) )
import DsHsSyn ( outPatType )
import CoreSyn
@@ -22,7 +22,7 @@ import DsUtils
import CmdLineOpts ( opt_FoldrBuildOn )
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PrelVals ( mkBuild, foldrId )
-import Type ( mkTyVarTy, mkForAllTy, mkFunTys )
+import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy )
import TysPrim ( alphaTy )
import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
import TyVar ( alphaTyVar )
@@ -49,11 +49,14 @@ dsListComp expr quals
else -- foldr/build lives!
new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) ->
let
- alpha_to_alpha = mkFunTys [alphaTy] alphaTy
+ alpha_to_alpha = alphaTy `mkFunTy` alphaTy
c_ty = mkFunTys [expr_ty, n_ty] n_ty
g_ty = mkForAllTy alphaTyVar (
- (mkFunTys [expr_ty, alpha_to_alpha] alpha_to_alpha))
+ (expr_ty `mkFunTy` alpha_to_alpha)
+ `mkFunTy`
+ alpha_to_alpha
+ )
in
newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] ->
@@ -138,7 +141,7 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
u2_ty = outPatType pat
res_ty = coreExprType core_list2
- h_ty = mkFunTys [u1_ty] res_ty
+ h_ty = u1_ty `mkFunTy` res_ty
in
newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
`thenDs` \ [h', u1, u2, u3] ->
diff --git a/ghc/compiler/deSugar/DsLoop_1_3.lhi b/ghc/compiler/deSugar/DsLoop_1_3.lhi
index 6f115029f38a..b0ae22a56dd7 100644
--- a/ghc/compiler/deSugar/DsLoop_1_3.lhi
+++ b/ghc/compiler/deSugar/DsLoop_1_3.lhi
@@ -1,5 +1,8 @@
\begin{code}
interface DsLoop_1_3 1
__exports__
-Outputable Outputable (..)
+Match match (..)
+Match matchSimply (..)
+DsBinds dsBinds (..)
+DsExpr dsExpr (..)
\end{code}
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index a6c8b6193420..3ea0bc2eb1bf 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -7,7 +7,7 @@
#include "HsVersions.h"
module DsMonad (
- DsM(..),
+ SYN_IE(DsM),
initDs, returnDs, thenDs, andDs, mapDs, listDs,
mapAndUnzipDs, zipWithDs,
uniqSMtoDsM,
@@ -17,7 +17,7 @@ module DsMonad (
getSrcLocDs, putSrcLocDs,
getModuleAndGroupDs,
extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
- DsIdEnv(..),
+ SYN_IE(DsIdEnv),
lookupId,
dsShadowError,
@@ -38,7 +38,7 @@ import PprType ( GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
import Pretty
import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TcHsSyn ( TypecheckedPat(..) )
+import TcHsSyn ( SYN_IE(TypecheckedPat) )
import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instances-} )
import UniqSupply ( splitUniqSupply, getUnique, getUniques,
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index b5024698cfbe..4e2126c0dbbb 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -13,7 +13,7 @@ module DsUtils (
combineGRHSMatchResults,
combineMatchResults,
- dsExprToAtom, DsCoreArg(..),
+ dsExprToAtom, SYN_IE(DsCoreArg),
mkCoAlgCaseMatchResult,
mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
mkCoLetsMatchResult,
@@ -32,7 +32,7 @@ IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
-import TcHsSyn ( TypecheckedPat(..) )
+import TcHsSyn ( SYN_IE(TypecheckedPat) )
import DsHsSyn ( outPatType )
import CoreSyn
@@ -47,7 +47,7 @@ import Id ( idType, dataConArgTys, mkTupleCon,
SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
-import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
+import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon
)
import TysPrim ( voidTy )
@@ -578,7 +578,7 @@ mkFailurePair :: Type -- Result type of the whole case expression
-- applied to unit tuple
mkFailurePair ty
| isUnboxedType ty
- = newFailLocalDs (mkFunTys [voidTy] ty) `thenDs` \ fail_fun_var ->
+ = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
returnDs (\ body ->
NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index e63d55930e7d..eea766773db9 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -13,8 +13,8 @@ IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
-- and to break dsExpr/dsBinds-ish loop
import HsSyn hiding ( collectBinders{-also from CoreSyn-} )
-import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..),
- TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
+import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
+ SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
import DsHsSyn ( outPatType, collectTypedPatBinders )
import CoreSyn
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index 15c5519dbc43..26206ffb17e4 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -13,8 +13,8 @@ IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
-import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
- TypecheckedPat(..)
+import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
+ SYN_IE(TypecheckedPat)
)
import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding) )
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 8bd7f2438582..5afed2e89749 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -9,6 +9,7 @@
module Main ( main ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(hGetContents,stdin,stderr,hPutStr,hClose,openFile,IOMode(..)))
import HsSyn
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 99f12ea47e6f..e5604554deef 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -19,17 +19,19 @@ module MkIface (
) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
-import Bag ( emptyBag, snocBag, bagToList )
+import Bag ( bagToList )
import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
import CmdLineOpts ( opt_ProduceHi )
import FieldLabel ( FieldLabel{-instance NamedThing-} )
-import FiniteMap ( fmToList, eltsFM )
+import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
import HsSyn
import Id ( idType, dataConRawArgTys, dataConFieldLabels,
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
+import Maybes ( maybeToBool )
import Name ( origName, nameOf, moduleOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
isLexSym, isLocallyDefined, isWiredInName,
@@ -45,12 +47,12 @@ import PprType -- most of it (??)
import PrelInfo ( builtinNameInfo )
import Pretty ( prettyToUn )
import Unpretty -- ditto
-import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
-import TcModule ( TcIfaceInfo(..) )
+import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName{-instance NamedThing-} )
+import TcModule ( SYN_IE(TcIfaceInfo) )
import TcInstUtil ( InstInfo(..) )
import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
-import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
+import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
ppr_ty ty = prettyToUn (pprType PprInterface ty)
@@ -189,24 +191,23 @@ ifaceExportList (Just if_hdl)
= let
(vals_wired, tcs_wired)
= case builtinNameInfo of { ((vals_fm,tcs_fm), _, _) ->
- ([ getName rn | rn <- eltsFM vals_fm ]
- ,[ getName rn | rn <- eltsFM tcs_fm ]) }
+ (eltsFM vals_fm, eltsFM tcs_fm) }
- name_flag_pairs :: Bag (OrigName, ExportFlag)
+ name_flag_pairs :: FiniteMap OrigName ExportFlag
name_flag_pairs
- = foldr from_wired
- (foldr from_wired
+ = foldr (from_wired True{-val-ish-})
+ (foldr (from_wired False{-tycon-ish-})
(foldr from_ty
(foldr from_cls
(foldr from_sig
- (from_binds binds emptyBag{-init accum-})
+ (from_binds binds emptyFM{-init accum-})
sigs)
classdecls)
typedecls)
tcs_wired)
vals_wired
- sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
+ sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
in
hPutStr if_hdl "\n__exports__\n" >>
@@ -223,21 +224,33 @@ ifaceExportList (Just if_hdl)
from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
--------------
- from_wired n acc
- | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef)
+ from_wired is_val_ish rn acc
+ | on_in_acc = acc -- if already in acc (presumably from real decl),
+ -- don't take the dubious export flag from the
+ -- wired-in chappy
+ | is_val_ish && isRnConstr rn
+ = acc -- these things don't cause export-ery
+ | exportFlagOn ef = addToFM acc on ef
| otherwise = acc
where
+ n = getName rn
ef = export_fn n
+ on = origName "from_wired" n
+ (OrigName _ str) = on
+ on_in_acc = maybeToBool (lookupFM acc on)
--------------
- maybe_add :: Bag (OrigName, ExportFlag) -> RnName -> Bag (OrigName, ExportFlag)
+ maybe_add :: FiniteMap OrigName ExportFlag -> RnName -> FiniteMap OrigName ExportFlag
maybe_add acc rn
- | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef)
+ | on_in_acc = trace "maybe_add?" acc -- surprising!
+ | exportFlagOn ef = addToFM acc on ef
| otherwise = acc
where
- n = getName rn
ef = nameExportFlag n
+ n = getName rn
+ on = origName "maybe_add" n
+ on_in_acc = maybeToBool (lookupFM acc on)
--------------
maybe_add_list acc [] = acc
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 144f586bd56e..223b0157d6b3 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -8,6 +8,7 @@
module AbsCStixGen ( genCodeAbstractC ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ratio(Rational))
import AbsCSyn
import Stix
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 50c6faeb23bc..d88986893c0e 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -8,6 +8,7 @@
module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(Handle))
import MachMisc
import MachRegs
@@ -23,7 +24,7 @@ import PrimRep ( PrimRep{-instance Eq-} )
import RegAllocInfo ( mkMRegsState, MRegsState )
import Stix ( StixTree(..), StixReg(..), CodeSegment )
import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM) )
-import Unpretty ( uppPutStr, uppShow, uppAboves, Unpretty(..) )
+import Unpretty ( uppPutStr, uppShow, uppAboves, SYN_IE(Unpretty) )
\end{code}
The 96/03 native-code generator has machine-independent and
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 00d5d79e5682..b7e85f8eb11a 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -10,7 +10,7 @@ module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
IMP_Ubiq(){-uitous-}
-import MachCode ( InstrList(..) )
+import MachCode ( SYN_IE(InstrList) )
import MachMisc ( Instr )
import MachRegs
import RegAllocInfo
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 031c3ba038a0..6a51d9c22d70 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -12,7 +12,7 @@ structure should not be too overwhelming.
#include "HsVersions.h"
#include "nativeGen/NCG.h"
-module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
+module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where
IMP_Ubiq(){-uitious-}
@@ -334,46 +334,46 @@ getRegister (StPrim primop [x]) -- unary PrimOps
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
- CharGtOp -> trivialCode (CMP LT) y x
+ CharGtOp -> trivialCode (CMP LTT) y x
CharGeOp -> trivialCode (CMP LE) y x
- CharEqOp -> trivialCode (CMP EQ) x y
+ CharEqOp -> trivialCode (CMP EQQ) x y
CharNeOp -> int_NE_code x y
- CharLtOp -> trivialCode (CMP LT) x y
+ CharLtOp -> trivialCode (CMP LTT) x y
CharLeOp -> trivialCode (CMP LE) x y
- IntGtOp -> trivialCode (CMP LT) y x
+ IntGtOp -> trivialCode (CMP LTT) y x
IntGeOp -> trivialCode (CMP LE) y x
- IntEqOp -> trivialCode (CMP EQ) x y
+ IntEqOp -> trivialCode (CMP EQQ) x y
IntNeOp -> int_NE_code x y
- IntLtOp -> trivialCode (CMP LT) x y
+ IntLtOp -> trivialCode (CMP LTT) x y
IntLeOp -> trivialCode (CMP LE) x y
WordGtOp -> trivialCode (CMP ULT) y x
WordGeOp -> trivialCode (CMP ULE) x y
- WordEqOp -> trivialCode (CMP EQ) x y
+ WordEqOp -> trivialCode (CMP EQQ) x y
WordNeOp -> int_NE_code x y
WordLtOp -> trivialCode (CMP ULT) x y
WordLeOp -> trivialCode (CMP ULE) x y
AddrGtOp -> trivialCode (CMP ULT) y x
AddrGeOp -> trivialCode (CMP ULE) y x
- AddrEqOp -> trivialCode (CMP EQ) x y
+ AddrEqOp -> trivialCode (CMP EQQ) x y
AddrNeOp -> int_NE_code x y
AddrLtOp -> trivialCode (CMP ULT) x y
AddrLeOp -> trivialCode (CMP ULE) x y
- FloatGtOp -> cmpF_code (FCMP TF LE) EQ x y
- FloatGeOp -> cmpF_code (FCMP TF LT) EQ x y
- FloatEqOp -> cmpF_code (FCMP TF EQ) NE x y
- FloatNeOp -> cmpF_code (FCMP TF EQ) EQ x y
- FloatLtOp -> cmpF_code (FCMP TF LT) NE x y
+ FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+ FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+ FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+ FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+ FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
- DoubleGtOp -> cmpF_code (FCMP TF LE) EQ x y
- DoubleGeOp -> cmpF_code (FCMP TF LT) EQ x y
- DoubleEqOp -> cmpF_code (FCMP TF EQ) NE x y
- DoubleNeOp -> cmpF_code (FCMP TF EQ) EQ x y
- DoubleLtOp -> cmpF_code (FCMP TF LT) NE x y
+ DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
+ DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
+ DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
+ DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
+ DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
IntAddOp -> trivialCode (ADD Q False) x y
@@ -416,7 +416,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
int_NE_code :: StixTree -> StixTree -> UniqSM Register
int_NE_code x y
- = trivialCode (CMP EQ) x y `thenUs` \ register ->
+ = trivialCode (CMP EQQ) x y `thenUs` \ register ->
getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
@@ -443,9 +443,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
result = registerName register tmp
code__2 dst = code . mkSeqInstrs [
- OR zero (RIImm (ImmInt 1)) dst,
- BF cond result (ImmCLbl lbl),
- OR zero (RIReg zero) dst,
+ OR zeroh (RIImm (ImmInt 1)) dst,
+ BF cond result (ImmCLbl lbl),
+ OR zeroh (RIReg zeroh) dst,
LABEL lbl]
in
returnUs (Any IntRep code__2)
@@ -466,7 +466,7 @@ getRegister (StInd pk mem)
getRegister (StInt i)
| fits8Bits i
= let
- code dst = mkSeqInstr (OR zero (RIImm src) dst)
+ code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
in
returnUs (Any IntRep code)
| otherwise
@@ -584,46 +584,46 @@ getRegister (StPrim primop [x]) -- unary PrimOps
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
- CharGtOp -> condIntReg GT x y
+ CharGtOp -> condIntReg GTT x y
CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQ x y
+ CharEqOp -> condIntReg EQQ x y
CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LT x y
+ CharLtOp -> condIntReg LTT x y
CharLeOp -> condIntReg LE x y
- IntGtOp -> condIntReg GT x y
+ IntGtOp -> condIntReg GTT x y
IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQ x y
+ IntEqOp -> condIntReg EQQ x y
IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LT x y
+ IntLtOp -> condIntReg LTT x y
IntLeOp -> condIntReg LE x y
WordGtOp -> condIntReg GU x y
WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQ x y
+ WordEqOp -> condIntReg EQQ x y
WordNeOp -> condIntReg NE x y
WordLtOp -> condIntReg LU x y
WordLeOp -> condIntReg LEU x y
AddrGtOp -> condIntReg GU x y
AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQ x y
+ AddrEqOp -> condIntReg EQQ x y
AddrNeOp -> condIntReg NE x y
AddrLtOp -> condIntReg LU x y
AddrLeOp -> condIntReg LEU x y
- FloatGtOp -> condFltReg GT x y
+ FloatGtOp -> condFltReg GTT x y
FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQ x y
+ FloatEqOp -> condFltReg EQQ x y
FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LT x y
+ FloatLtOp -> condFltReg LTT x y
FloatLeOp -> condFltReg LE x y
- DoubleGtOp -> condFltReg GT x y
+ DoubleGtOp -> condFltReg GTT x y
DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQ x y
+ DoubleEqOp -> condFltReg EQQ x y
DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LT x y
+ DoubleLtOp -> condFltReg LTT x y
DoubleLeOp -> condFltReg LE x y
IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
@@ -931,46 +931,46 @@ getRegister (StPrim primop [x]) -- unary PrimOps
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
- CharGtOp -> condIntReg GT x y
+ CharGtOp -> condIntReg GTT x y
CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQ x y
+ CharEqOp -> condIntReg EQQ x y
CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LT x y
+ CharLtOp -> condIntReg LTT x y
CharLeOp -> condIntReg LE x y
- IntGtOp -> condIntReg GT x y
+ IntGtOp -> condIntReg GTT x y
IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQ x y
+ IntEqOp -> condIntReg EQQ x y
IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LT x y
+ IntLtOp -> condIntReg LTT x y
IntLeOp -> condIntReg LE x y
WordGtOp -> condIntReg GU x y
WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQ x y
+ WordEqOp -> condIntReg EQQ x y
WordNeOp -> condIntReg NE x y
WordLtOp -> condIntReg LU x y
WordLeOp -> condIntReg LEU x y
AddrGtOp -> condIntReg GU x y
AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQ x y
+ AddrEqOp -> condIntReg EQQ x y
AddrNeOp -> condIntReg NE x y
AddrLtOp -> condIntReg LU x y
AddrLeOp -> condIntReg LEU x y
- FloatGtOp -> condFltReg GT x y
+ FloatGtOp -> condFltReg GTT x y
FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQ x y
+ FloatEqOp -> condFltReg EQQ x y
FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LT x y
+ FloatLtOp -> condFltReg LTT x y
FloatLeOp -> condFltReg LE x y
- DoubleGtOp -> condFltReg GT x y
+ DoubleGtOp -> condFltReg GTT x y
DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQ x y
+ DoubleEqOp -> condFltReg EQQ x y
DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LT x y
+ DoubleLtOp -> condFltReg LTT x y
DoubleLeOp -> condFltReg LE x y
IntAddOp -> trivialCode (ADD False False) x y
@@ -1263,46 +1263,46 @@ getCondCode = panic "MachCode.getCondCode: not on Alphas"
getCondCode (StPrim primop [x, y])
= case primop of
- CharGtOp -> condIntCode GT x y
+ CharGtOp -> condIntCode GTT x y
CharGeOp -> condIntCode GE x y
- CharEqOp -> condIntCode EQ x y
+ CharEqOp -> condIntCode EQQ x y
CharNeOp -> condIntCode NE x y
- CharLtOp -> condIntCode LT x y
+ CharLtOp -> condIntCode LTT x y
CharLeOp -> condIntCode LE x y
- IntGtOp -> condIntCode GT x y
+ IntGtOp -> condIntCode GTT x y
IntGeOp -> condIntCode GE x y
- IntEqOp -> condIntCode EQ x y
+ IntEqOp -> condIntCode EQQ x y
IntNeOp -> condIntCode NE x y
- IntLtOp -> condIntCode LT x y
+ IntLtOp -> condIntCode LTT x y
IntLeOp -> condIntCode LE x y
WordGtOp -> condIntCode GU x y
WordGeOp -> condIntCode GEU x y
- WordEqOp -> condIntCode EQ x y
+ WordEqOp -> condIntCode EQQ x y
WordNeOp -> condIntCode NE x y
WordLtOp -> condIntCode LU x y
WordLeOp -> condIntCode LEU x y
AddrGtOp -> condIntCode GU x y
AddrGeOp -> condIntCode GEU x y
- AddrEqOp -> condIntCode EQ x y
+ AddrEqOp -> condIntCode EQQ x y
AddrNeOp -> condIntCode NE x y
AddrLtOp -> condIntCode LU x y
AddrLeOp -> condIntCode LEU x y
- FloatGtOp -> condFltCode GT x y
+ FloatGtOp -> condFltCode GTT x y
FloatGeOp -> condFltCode GE x y
- FloatEqOp -> condFltCode EQ x y
+ FloatEqOp -> condFltCode EQQ x y
FloatNeOp -> condFltCode NE x y
- FloatLtOp -> condFltCode LT x y
+ FloatLtOp -> condFltCode LTT x y
FloatLeOp -> condFltCode LE x y
- DoubleGtOp -> condFltCode GT x y
+ DoubleGtOp -> condFltCode GTT x y
DoubleGeOp -> condFltCode GE x y
- DoubleEqOp -> condFltCode EQ x y
+ DoubleEqOp -> condFltCode EQQ x y
DoubleNeOp -> condFltCode NE x y
- DoubleLtOp -> condFltCode LT x y
+ DoubleLtOp -> condFltCode LTT x y
DoubleLeOp -> condFltCode LE x y
#endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
@@ -1460,8 +1460,8 @@ condFltCode cond x y
fix_FP_cond :: Cond -> Cond
fix_FP_cond GE = GEU
-fix_FP_cond GT = GU
-fix_FP_cond LT = LU
+fix_FP_cond GTT = GU
+fix_FP_cond LTT = LU
fix_FP_cond LE = LEU
fix_FP_cond any = any
@@ -1570,7 +1570,7 @@ assignIntCode pk dst src
= getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
let
- dst__2 = registerName register1 zero
+ dst__2 = registerName register1 zeroh
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2
@@ -1704,7 +1704,7 @@ assignFltCode pk dst src
= getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
let
- dst__2 = registerName register1 zero
+ dst__2 = registerName register1 zeroh
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2
@@ -1853,7 +1853,7 @@ genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
genJump (StCLbl lbl)
| isAsmTemp lbl = returnInstr (BR target)
- | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
+ | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
where
target = ImmCLbl lbl
@@ -1866,9 +1866,9 @@ genJump tree
target = registerName register pv
in
if isFixed register then
- returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
+ returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
else
- returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
+ returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -1973,30 +1973,30 @@ genCondJump lbl (StPrim op [x, StInt 0])
in
returnSeq code [BI (cmpOp op) value target]
where
- cmpOp CharGtOp = GT
+ cmpOp CharGtOp = GTT
cmpOp CharGeOp = GE
- cmpOp CharEqOp = EQ
+ cmpOp CharEqOp = EQQ
cmpOp CharNeOp = NE
- cmpOp CharLtOp = LT
+ cmpOp CharLtOp = LTT
cmpOp CharLeOp = LE
- cmpOp IntGtOp = GT
+ cmpOp IntGtOp = GTT
cmpOp IntGeOp = GE
- cmpOp IntEqOp = EQ
+ cmpOp IntEqOp = EQQ
cmpOp IntNeOp = NE
- cmpOp IntLtOp = LT
+ cmpOp IntLtOp = LTT
cmpOp IntLeOp = LE
cmpOp WordGtOp = NE
cmpOp WordGeOp = ALWAYS
- cmpOp WordEqOp = EQ
+ cmpOp WordEqOp = EQQ
cmpOp WordNeOp = NE
cmpOp WordLtOp = NEVER
- cmpOp WordLeOp = EQ
+ cmpOp WordLeOp = EQQ
cmpOp AddrGtOp = NE
cmpOp AddrGeOp = ALWAYS
- cmpOp AddrEqOp = EQ
+ cmpOp AddrEqOp = EQQ
cmpOp AddrNeOp = NE
cmpOp AddrLtOp = NEVER
- cmpOp AddrLeOp = EQ
+ cmpOp AddrLeOp = EQQ
genCondJump lbl (StPrim op [x, StDouble 0.0])
= getRegister x `thenUs` \ register ->
@@ -2010,17 +2010,17 @@ genCondJump lbl (StPrim op [x, StDouble 0.0])
in
returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
where
- cmpOp FloatGtOp = GT
+ cmpOp FloatGtOp = GTT
cmpOp FloatGeOp = GE
- cmpOp FloatEqOp = EQ
+ cmpOp FloatEqOp = EQQ
cmpOp FloatNeOp = NE
- cmpOp FloatLtOp = LT
+ cmpOp FloatLtOp = LTT
cmpOp FloatLeOp = LE
- cmpOp DoubleGtOp = GT
+ cmpOp DoubleGtOp = GTT
cmpOp DoubleGeOp = GE
- cmpOp DoubleEqOp = EQ
+ cmpOp DoubleEqOp = EQQ
cmpOp DoubleNeOp = NE
- cmpOp DoubleLtOp = LT
+ cmpOp DoubleLtOp = LTT
cmpOp DoubleLeOp = LE
genCondJump lbl (StPrim op [x, y])
@@ -2051,17 +2051,17 @@ genCondJump lbl (StPrim op [x, y])
DoubleLeOp -> True
_ -> False
(instr, cond) = case op of
- FloatGtOp -> (FCMP TF LE, EQ)
- FloatGeOp -> (FCMP TF LT, EQ)
- FloatEqOp -> (FCMP TF EQ, NE)
- FloatNeOp -> (FCMP TF EQ, EQ)
- FloatLtOp -> (FCMP TF LT, NE)
+ FloatGtOp -> (FCMP TF LE, EQQ)
+ FloatGeOp -> (FCMP TF LTT, EQQ)
+ FloatEqOp -> (FCMP TF EQQ, NE)
+ FloatNeOp -> (FCMP TF EQQ, EQQ)
+ FloatLtOp -> (FCMP TF LTT, NE)
FloatLeOp -> (FCMP TF LE, NE)
- DoubleGtOp -> (FCMP TF LE, EQ)
- DoubleGeOp -> (FCMP TF LT, EQ)
- DoubleEqOp -> (FCMP TF EQ, NE)
- DoubleNeOp -> (FCMP TF EQ, EQ)
- DoubleLtOp -> (FCMP TF LT, NE)
+ DoubleGtOp -> (FCMP TF LE, EQQ)
+ DoubleGeOp -> (FCMP TF LTT, EQQ)
+ DoubleEqOp -> (FCMP TF EQQ, NE)
+ DoubleNeOp -> (FCMP TF EQQ, EQQ)
+ DoubleLtOp -> (FCMP TF LTT, NE)
DoubleLeOp -> (FCMP TF LE, NE)
genCondJump lbl (StPrim op [x, y])
@@ -2075,28 +2075,28 @@ genCondJump lbl (StPrim op [x, y])
returnUs (code . mkSeqInstr (BI cond result target))
where
(instr, cond) = case op of
- CharGtOp -> (CMP LE, EQ)
- CharGeOp -> (CMP LT, EQ)
- CharEqOp -> (CMP EQ, NE)
- CharNeOp -> (CMP EQ, EQ)
- CharLtOp -> (CMP LT, NE)
+ CharGtOp -> (CMP LE, EQQ)
+ CharGeOp -> (CMP LTT, EQQ)
+ CharEqOp -> (CMP EQQ, NE)
+ CharNeOp -> (CMP EQQ, EQQ)
+ CharLtOp -> (CMP LTT, NE)
CharLeOp -> (CMP LE, NE)
- IntGtOp -> (CMP LE, EQ)
- IntGeOp -> (CMP LT, EQ)
- IntEqOp -> (CMP EQ, NE)
- IntNeOp -> (CMP EQ, EQ)
- IntLtOp -> (CMP LT, NE)
+ IntGtOp -> (CMP LE, EQQ)
+ IntGeOp -> (CMP LTT, EQQ)
+ IntEqOp -> (CMP EQQ, NE)
+ IntNeOp -> (CMP EQQ, EQQ)
+ IntLtOp -> (CMP LTT, NE)
IntLeOp -> (CMP LE, NE)
- WordGtOp -> (CMP ULE, EQ)
- WordGeOp -> (CMP ULT, EQ)
- WordEqOp -> (CMP EQ, NE)
- WordNeOp -> (CMP EQ, EQ)
+ WordGtOp -> (CMP ULE, EQQ)
+ WordGeOp -> (CMP ULT, EQQ)
+ WordEqOp -> (CMP EQQ, NE)
+ WordNeOp -> (CMP EQQ, EQQ)
WordLtOp -> (CMP ULT, NE)
WordLeOp -> (CMP ULE, NE)
- AddrGtOp -> (CMP ULE, EQ)
- AddrGeOp -> (CMP ULT, EQ)
- AddrEqOp -> (CMP EQ, NE)
- AddrNeOp -> (CMP EQ, EQ)
+ AddrGtOp -> (CMP ULE, EQQ)
+ AddrGeOp -> (CMP ULT, EQQ)
+ AddrEqOp -> (CMP EQQ, NE)
+ AddrNeOp -> (CMP EQQ, EQQ)
AddrLtOp -> (CMP ULT, NE)
AddrLeOp -> (CMP ULE, NE)
@@ -2453,7 +2453,7 @@ condFltReg cond x y
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
-condIntReg EQ x (StInt 0)
+condIntReg EQQ x (StInt 0)
= getRegister x `thenUs` \ register ->
getNewRegNCG IntRep `thenUs` \ tmp ->
let
@@ -2465,7 +2465,7 @@ condIntReg EQ x (StInt 0)
in
returnUs (Any IntRep code__2)
-condIntReg EQ x y
+condIntReg EQQ x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
getNewRegNCG IntRep `thenUs` \ tmp1 ->
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index 54f761601d21..055f9eb474ec 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -44,6 +44,7 @@ module MachMisc (
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia
IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) -- paranoia
+IMPORT_1_3(Char(isDigit))
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
@@ -295,11 +296,11 @@ exactLog2 x
data Cond
#if alpha_TARGET_ARCH
= ALWAYS -- For BI (same as BR)
- | EQ -- For CMP and BI
+ | EQQ -- For CMP and BI (NB: "EQ" is a 1.3 Prelude name)
| GE -- For BI only
- | GT -- For BI only
+ | GTT -- For BI only (NB: "GT" is a 1.3 Prelude name)
| LE -- For CMP and BI
- | LT -- For CMP and BI
+ | LTT -- For CMP and BI (NB: "LT" is a 1.3 Prelude name)
| NE -- For BI only
| NEVER -- For BI (null instruction)
| ULE -- For CMP only
@@ -307,14 +308,14 @@ data Cond
#endif
#if i386_TARGET_ARCH
= ALWAYS -- What's really used? ToDo
- | EQ
+ | EQQ
| GE
| GEU
- | GT
+ | GTT
| GU
| LE
| LEU
- | LT
+ | LTT
| LU
| NE
| NEG
@@ -322,14 +323,14 @@ data Cond
#endif
#if sparc_TARGET_ARCH
= ALWAYS -- What's really used? ToDo
- | EQ
+ | EQQ
| GE
| GEU
- | GT
+ | GTT
| GU
| LE
| LEU
- | LT
+ | LTT
| LU
| NE
| NEG
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index b48f136dc551..19ad5718cbae 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -19,7 +19,7 @@ module MachRegs (
Imm(..),
Addr(..),
RegLoc(..),
- RegNo(..),
+ SYN_IE(RegNo),
addrOffset,
argRegs,
@@ -44,7 +44,7 @@ module MachRegs (
, allArgRegs
, fits8Bits
, fReg
- , gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zero
+ , gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh
#endif
#if i386_TARGET_ARCH
, eax, ebx, ecx, edx, esi, esp
@@ -73,7 +73,7 @@ import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
Unique{-instance Ord3-}
)
import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) )
-import Unpretty ( uppStr, Unpretty(..) )
+import Unpretty ( uppStr, SYN_IE(Unpretty) )
import Util ( panic )
\end{code}
@@ -378,14 +378,14 @@ is defined in StgRegs.h. We are, of course, prepared for any eventuality.
fReg :: Int -> Int
fReg x = (32 + x)
-v0, f0, ra, pv, gp, sp, zero :: Reg
-v0 = realReg 0
-f0 = realReg (fReg 0)
-ra = FixedReg ILIT(26)
-pv = t12
-gp = FixedReg ILIT(29)
-sp = FixedReg ILIT(30)
-zero = FixedReg ILIT(31)
+v0, f0, ra, pv, gp, sp, zeroh :: Reg
+v0 = realReg 0
+f0 = realReg (fReg 0)
+ra = FixedReg ILIT(26)
+pv = t12
+gp = FixedReg ILIT(29)
+sp = FixedReg ILIT(30)
+zeroh = FixedReg ILIT(31) -- "zero" is used in 1.3 (MonadZero method)
t9, t10, t11, t12 :: Reg
t9 = realReg 23
@@ -910,7 +910,7 @@ freeReg ILIT(26) = _FALSE_ -- return address (ra)
freeReg ILIT(28) = _FALSE_ -- reserved for the assembler (at)
freeReg ILIT(29) = _FALSE_ -- global pointer (gp)
freeReg ILIT(30) = _FALSE_ -- stack pointer (sp)
-freeReg ILIT(31) = _FALSE_ -- always zero (zero)
+freeReg ILIT(31) = _FALSE_ -- always zero (zeroh)
freeReg ILIT(63) = _FALSE_ -- always zero (f31)
#endif
diff --git a/ghc/compiler/nativeGen/NcgLoop_1_3.lhi b/ghc/compiler/nativeGen/NcgLoop_1_3.lhi
index 5cc8f208d13c..34415d81255b 100644
--- a/ghc/compiler/nativeGen/NcgLoop_1_3.lhi
+++ b/ghc/compiler/nativeGen/NcgLoop_1_3.lhi
@@ -3,4 +3,5 @@ interface NcgLoop_1_3 1
__exports__
MachMisc underscorePrefix (..)
MachMisc fmtAsmLbl (..)
+StixPrim amodeToStix (..)
\end{code}
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index 3d4d67954df2..be9b18d7b131 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -14,6 +14,13 @@ We start with the @pprXXX@s with some cross-platform commonality
module PprMach ( pprInstr ) where
IMP_Ubiq(){-uitious-}
+IMPORT_1_3(Char(isPrint,isDigit))
+IMPORT_1_3(qualified GHCbase(Addr(..))) -- to see innards
+#if __GLASGOW_HASKELL__ >= 200
+# define A_HASH GHCbase.A#
+#else
+# define A_HASH A#
+#endif
import MachRegs -- may differ per-platform
import MachMisc
@@ -237,20 +244,20 @@ pprCond :: Cond -> Unpretty
pprCond c = uppPStr (case c of {
#if alpha_TARGET_ARCH
- EQ -> SLIT("eq");
- LT -> SLIT("lt");
+ EQQ -> SLIT("eq");
+ LTT -> SLIT("lt");
LE -> SLIT("le");
ULT -> SLIT("ult");
ULE -> SLIT("ule");
NE -> SLIT("ne");
- GT -> SLIT("gt");
+ GTT -> SLIT("gt");
GE -> SLIT("ge")
#endif
#if i386_TARGET_ARCH
GEU -> SLIT("ae"); LU -> SLIT("b");
- EQ -> SLIT("e"); GT -> SLIT("g");
+ EQQ -> SLIT("e"); GTT -> SLIT("g");
GE -> SLIT("ge"); GU -> SLIT("a");
- LT -> SLIT("l"); LE -> SLIT("le");
+ LTT -> SLIT("l"); LE -> SLIT("le");
LEU -> SLIT("be"); NE -> SLIT("ne");
NEG -> SLIT("s"); POS -> SLIT("ns");
ALWAYS -> SLIT("mp") -- hack
@@ -258,9 +265,9 @@ pprCond c = uppPStr (case c of {
#if sparc_TARGET_ARCH
ALWAYS -> SLIT(""); NEVER -> SLIT("n");
GEU -> SLIT("geu"); LU -> SLIT("lu");
- EQ -> SLIT("e"); GT -> SLIT("g");
+ EQQ -> SLIT("e"); GTT -> SLIT("g");
GE -> SLIT("ge"); GU -> SLIT("gu");
- LT -> SLIT("l"); LE -> SLIT("le");
+ LTT -> SLIT("l"); LE -> SLIT("le");
LEU -> SLIT("leu"); NE -> SLIT("ne");
NEG -> SLIT("neg"); POS -> SLIT("pos");
VC -> SLIT("vc"); VS -> SLIT("vs")
@@ -289,12 +296,12 @@ pprImm (ImmLab s) | underscorePrefix = uppBeside (uppChar '_') s
pprImm (LO i)
= uppBesides [ pp_lo, pprImm i, uppRparen ]
where
- pp_lo = uppPStr (_packCString (A# "%lo("#))
+ pp_lo = uppPStr (_packCString (A_HASH "%lo("#))
pprImm (HI i)
= uppBesides [ pp_hi, pprImm i, uppRparen ]
where
- pp_hi = uppPStr (_packCString (A# "%hi("#))
+ pp_hi = uppPStr (_packCString (A_HASH "%hi("#))
#endif
\end{code}
@@ -808,8 +815,14 @@ pprInstr (FUNBEGIN clab)
]
where
pp_lab = pprCLabel_asm clab
- pp_ldgp = uppPStr (_packCString (A# ":\n\tldgp $29,0($27)\n"#))
- pp_frame = uppPStr (_packCString (A# "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
+
+#if __GLASGOW_HASKELL__ >= 200
+# define PACK_STR packCString
+#else
+# define PACK_STR _packCString
+#endif
+ pp_ldgp = uppPStr (PACK_STR (A_HASH ":\n\tldgp $29,0($27)\n"#))
+ pp_frame = uppPStr (PACK_STR (A_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
pprInstr (FUNEND clab)
= uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
@@ -1318,10 +1331,10 @@ pprRIReg name b ri reg1
pprReg reg1
]
-pp_ld_lbracket = uppPStr (_packCString (A# "\tld\t["#))
-pp_rbracket_comma = uppPStr (_packCString (A# "],"#))
-pp_comma_lbracket = uppPStr (_packCString (A# ",["#))
-pp_comma_a = uppPStr (_packCString (A# ",a"#))
+pp_ld_lbracket = uppPStr (PACK_STR (A_HASH "\tld\t["#))
+pp_rbracket_comma = uppPStr (PACK_STR (A_HASH "],"#))
+pp_comma_lbracket = uppPStr (PACK_STR (A_HASH ",["#))
+pp_comma_a = uppPStr (PACK_STR (A_HASH ",a"#))
#endif {-sparc_TARGET_ARCH-}
\end{code}
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index e650837176f8..22a7618e5454 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -24,8 +24,8 @@ module RegAllocInfo (
regUsage,
FutureLive(..),
- RegAssignment(..),
- RegConflicts(..),
+ SYN_IE(RegAssignment),
+ SYN_IE(RegConflicts),
RegFuture(..),
RegHistory(..),
RegInfo(..),
@@ -37,7 +37,7 @@ module RegAllocInfo (
regLiveness,
spillReg,
- RegSet(..),
+ SYN_IE(RegSet),
elementOfRegSet,
emptyRegSet,
isEmptyRegSet,
@@ -52,15 +52,16 @@ module RegAllocInfo (
) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(partition))
import MachMisc
import MachRegs
-import MachCode ( InstrList(..) )
+import MachCode ( SYN_IE(InstrList) )
import AbsCSyn ( MagicId )
import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet )
import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} )
-import FiniteMap ( addToFM, lookupFM )
+import FiniteMap ( addToFM, lookupFM, FiniteMap )
import OrdList ( mkUnitList, OrdList )
import PrimRep ( PrimRep(..) )
import Stix ( StixTree, CodeSegment )
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index c6ab81b757d6..10521a3d68aa 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -6,7 +6,7 @@
#include "HsVersions.h"
module Stix (
- CodeSegment(..), StixReg(..), StixTree(..), StixTreeList(..),
+ CodeSegment(..), StixReg(..), StixTree(..), SYN_IE(StixTreeList),
sStLitLbl,
stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
@@ -16,12 +16,13 @@ module Stix (
) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ratio(Rational))
import AbsCSyn ( node, infoptr, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
import CLabel ( mkAsmTempLabel )
import UniqSupply ( returnUs, thenUs, getUnique, SYN_IE(UniqSM) )
-import Unpretty ( uppPStr, Unpretty(..) )
+import Unpretty ( uppPStr, SYN_IE(Unpretty) )
\end{code}
Here is the tag at the nodes of our @StixTree@. Notice its
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index cdb4fdb65f6b..845078e17ad6 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -27,7 +27,7 @@ import OrdList ( OrdList )
import PprStyle ( PprStyle(..) )
import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
import Stix
-import StixMacro ( heapCheck, smStablePtrTable )
+import StixMacro ( heapCheck )
import StixInteger {- everything -}
import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
import Unpretty ( uppBeside, uppPStr, uppInt )
diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi
index 724a8a29cb08..5f6b5e917708 100644
--- a/ghc/compiler/prelude/PrelLoop.lhi
+++ b/ghc/compiler/prelude/PrelLoop.lhi
@@ -11,7 +11,7 @@ import IdUtils ( primOpNameInfo )
import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName, ExportFlag )
import PrimOp ( PrimOp )
import RnHsSyn ( RnName )
-import Type ( mkSigmaTy, mkFunTys, GenType )
+import Type ( mkSigmaTy, mkFunTy, mkFunTys, GenType )
import TyVar ( GenTyVar )
import Unique ( Unique )
import Usage ( GenUsage )
@@ -21,6 +21,7 @@ mkPrimitiveName :: Unique -> OrigName -> Name
mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b
mkFunTys :: [GenType a b] -> GenType a b -> GenType a b
+mkFunTy :: GenType a b -> GenType a b -> GenType a b
primOpNameInfo :: PrimOp -> (_PackedString, RnName)
\end{code}
diff --git a/ghc/compiler/prelude/PrelLoop_1_3.lhi b/ghc/compiler/prelude/PrelLoop_1_3.lhi
index cee1c6751b32..73aca3b2494e 100644
--- a/ghc/compiler/prelude/PrelLoop_1_3.lhi
+++ b/ghc/compiler/prelude/PrelLoop_1_3.lhi
@@ -4,5 +4,6 @@ __exports__
Name mkWiredInName (..)
Type mkSigmaTy (..)
Type mkFunTys (..)
+Type mkFunTy (..)
IdUtils primOpNameInfo (..)
\end{code}
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 8ab3a4bf5a36..0aa3a74d1fc6 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -44,7 +44,7 @@ import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import TyCon ( TyCon{-instances-} )
import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts,
- mkForAllTys, mkFunTys, applyTyCon, typePrimRep
+ mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep
)
import TyVar ( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instance Eq-} )
@@ -1332,7 +1332,7 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
statePrimTyCon VoidRep [realWorldTy]
where
primio_ish_ty result
- = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [result, mkStateTy realWorldTy])
+ = mkFunTy (mkStateTy realWorldTy) (mkTupleTy 2 [result, mkStateTy realWorldTy])
\end{code}
%************************************************************************
@@ -1660,7 +1660,7 @@ primOpType op
Dyadic str ty -> dyadic_fun_ty ty
Monadic str ty -> monadic_fun_ty ty
Compare str ty -> compare_fun_ty ty
- Coercing str ty1 ty2 -> mkFunTys [ty1] ty2
+ Coercing str ty1 ty2 -> mkFunTy ty1 ty2
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))
@@ -1726,7 +1726,7 @@ commutableOp _ = False
Utils:
\begin{code}
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
-monadic_fun_ty ty = mkFunTys [ty] ty
+monadic_fun_ty ty = mkFunTy ty ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 6a5285a460dd..ff2f55a6f97a 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -48,11 +48,11 @@ module TysWiredIn (
mkTupleTy,
nilDataCon,
primIoTyCon,
- primIoDataCon,
realWorldStateTy,
return2GMPsTyCon,
returnIntAndGMPTyCon,
stTyCon,
+ stDataCon,
stablePtrTyCon,
stateAndAddrPrimTyCon,
stateAndArrayPrimTyCon,
@@ -101,7 +101,7 @@ import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
NewOrData(..), TyCon
)
import Type ( mkTyConTy, applyTyCon, mkSigmaTy,
- mkFunTys, maybeAppTyCon,
+ mkFunTy, maybeAppTyCon,
GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) )
import TyVar ( tyVarKind, alphaTyVar, betaTyVar )
import Unique
@@ -130,6 +130,11 @@ pc_tycon new_or_data key mod str tyvars cons
where
tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars
+pcSynTyCon key mod str kind arity tyvars expansion
+ = mkSynTyCon
+ (mkWiredInName key (OrigName mod str) ExportAll)
+ kind arity tyvars expansion
+
pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
-> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
pcDataCon key mod str tyvars context arg_tys tycon specenv
@@ -442,28 +447,27 @@ This is really just an ordinary synonym, except it is ABSTRACT.
mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
stTyCon = pcNewTyCon stTyConKey gHC__ SLIT("ST") alpha_beta_tyvars [stDataCon]
- where
- ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
- stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST")
+stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST")
alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
+ where
+ ty = mkFunTy (mkStateTy alphaTy) (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
\end{code}
%************************************************************************
%* *
-\subsection[TysWiredIn-IO]{The @PrimIO@ and @IO@ monadic-I/O types}
+\subsection[TysWiredIn-IO]{The @PrimIO@ monadic-I/O type}
%* *
%************************************************************************
\begin{code}
-mkPrimIoTy a = applyTyCon primIoTyCon [a]
+mkPrimIoTy a = mkStateTransformerTy realWorldTy a
-primIoTyCon = pcNewTyCon primIoTyConKey gHC__ SLIT("PrimIO") alpha_tyvar [primIoDataCon]
-
-primIoDataCon = pcDataCon primIoDataConKey gHC__ SLIT("PrimIO")
- alpha_tyvar [] [ty] primIoTyCon nullSpecEnv
- where
- ty = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [alphaTy, mkStateTy realWorldTy])
+primIoTyCon
+ = pcSynTyCon
+ primIoTyConKey gHC__ SLIT("PrimIO")
+ (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
+ 1 alpha_tyvar (mkPrimIoTy alphaTy)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 17f2a498958b..3e3fb44415fa 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -10,6 +10,7 @@ module ReadPrefix ( rdModule ) where
IMP_Ubiq()
IMPORT_1_3(IO(hPutStr, stderr))
+IMPORT_1_3(GHCio(stThen))
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
@@ -80,7 +81,7 @@ cvFlag 1 = True
\begin{code}
#if __GLASGOW_HASKELL__ >= 200
# define PACK_STR packCString
-# define CCALL_THEN `GHCbase.ccallThen`
+# define CCALL_THEN `stThen`
#else
# define PACK_STR _packCString
# define CCALL_THEN `thenPrimIO`
@@ -410,8 +411,13 @@ wlkPat pat
(\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
msg = ppShow 100 (err PprForUser)
in
+#if __GLASGOW_HASKELL__ >= 200
+ ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
+ ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
+#else
ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
+#endif
returnUgn (error "ReadPrefix")
) `thenUgn` \ (n, arg_pats) ->
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 935c227128f7..015f6aa04005 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -230,9 +230,8 @@ class : gtycon VARID { ($1, Unqual $2) }
ctype :: { RdrNamePolyType }
ctype : FORALL OBRACK tyvars CBRACK context DARROW type { HsForAllTy (map Unqual $3) $5 $7 }
- | FORALL OBRACK tyvars CBRACK type { HsForAllTy (map Unqual $3) [] $5 }
- | context DARROW type {{-ToDo:rm-} HsPreForAllTy $1 $3 }
- | type {{-ToDo:change-} HsPreForAllTy [] $1 }
+ | FORALL OBRACK tyvars CBRACK type { HsForAllTy (map Unqual $3) [] $5 }
+ | type { HsForAllTy [] [] $1 }
type :: { RdrNameMonoType }
type : btype { $1 }
@@ -364,10 +363,9 @@ instdecls : instd { unitBag $1 }
| instdecls instd { $1 `snocBag` $2 }
instd :: { RdrIfaceInst }
-instd : INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (Just (map Unqual $4)) $6 $8 $9 }
- | INSTANCE FORALL OBRACK tyvars CBRACK gtycon general_inst SEMI { mk_inst (Just (map Unqual $4)) [] $6 $7 }
- | INSTANCE context DARROW gtycon restrict_inst SEMI {{-ToDo:rm-} mk_inst Nothing $2 $4 $5 }
- | INSTANCE gtycon general_inst SEMI {{-ToDo:rm-} mk_inst Nothing [] $2 $3 }
+instd : INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (map Unqual $4) $6 $8 $9 }
+ | INSTANCE FORALL OBRACK tyvars CBRACK gtycon general_inst SEMI { mk_inst (map Unqual $4) [] $6 $7 }
+ | INSTANCE gtycon general_inst SEMI { mk_inst [] [] $2 $3 }
restrict_inst :: { RdrNameMonoType }
restrict_inst : gtycon { MonoTyApp $1 [] }
diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs
index dea7549cc467..04d4302e917b 100644
--- a/ghc/compiler/rename/ParseUtils.lhs
+++ b/ghc/compiler/rename/ParseUtils.lhs
@@ -209,7 +209,7 @@ mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs
where
opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
-mk_inst :: Maybe [RdrName] -- ToDo: de-maybe
+mk_inst :: [RdrName]
-> RdrNameContext
-> RdrName -- class
-> RdrNameMonoType -- fish the tycon out yourself...
@@ -217,9 +217,7 @@ mk_inst :: Maybe [RdrName] -- ToDo: de-maybe
mk_inst tvs ctxt qclas@(Qual cmod cname) mono_ty
= let
- ty = case tvs of
- Nothing -> HsPreForAllTy ctxt mono_ty -- ToDo: get rid of this
- Just ts -> HsForAllTy ts ctxt mono_ty
+ ty = HsForAllTy tvs ctxt mono_ty
in
-- pprTrace "mk_inst:" (ppr PprDebug ty) $
InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod ->
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 8e9c81d3509a..02194ae2ec63 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -11,26 +11,27 @@ module Rename ( renameModule ) where
import PreludeGlaST ( thenPrimIO )
IMP_Ubiq()
+IMPORT_1_3(List(partition))
import HsSyn
import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) )
-import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, RenamedHsModule(..), isRnTyConOrClass, isRnWired )
+import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, SYN_IE(RenamedHsModule), isRnTyConOrClass, isRnWired )
--ToDo:rm: all for debugging only
-import Maybes
-import Name
-import Outputable
-import RnIfaces
-import PprStyle
-import Pretty
-import FiniteMap
-import Util (pprPanic, pprTrace)
+--import Maybes
+--import Name
+--import Outputable
+--import RnIfaces
+--import PprStyle
+--import Pretty
+--import FiniteMap
+--import Util (pprPanic, pprTrace)
import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
UsagesMap(..), VersionsMap(..)
)
import RnMonad
-import RnNames ( getGlobalNames, GlobalNameInfo(..) )
+import RnNames ( getGlobalNames, SYN_IE(GlobalNameInfo) )
import RnSource ( rnSource )
import RnIfaces ( rnIfaces, initIfaceCache, IfaceCache )
import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv )
@@ -38,14 +39,19 @@ import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv )
import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
-import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
+import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, lookupFM{-ToDo:rm-}, FiniteMap )
import Maybes ( catMaybes )
-import Name ( isLocallyDefined, mkWiredInName, Name, RdrName(..), ExportFlag(..) )
+import Name ( isLocallyDefined, mkWiredInName, getLocalName, isLocalName,
+ origName,
+ Name, RdrName(..), ExportFlag(..)
+ )
+import PprStyle -- ToDo:rm
import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
+import Pretty -- ToDo:rm
import Unique ( ixClassKey )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
-import Util ( panic, assertPanic )
+import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
\begin{code}
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 965ab3f922d7..51366dbcf701 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -15,7 +15,15 @@ module RnIfaces (
IMP_Ubiq()
-import PreludeGlaST ( thenPrimIO, seqPrimIO, newVar, readVar, writeVar, MutableVar(..) )
+import PreludeGlaST ( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) )
+#if __GLASGOW_HASKELL__ >= 200
+# define ST_THEN `stThen`
+# define TRY_IO tryIO
+IMPORT_1_3(GHCio(stThen,tryIO))
+#else
+# define ST_THEN `thenPrimIO`
+# define TRY_IO try
+#endif
import HsSyn
import HsPragmas ( noGenPragmas )
@@ -35,16 +43,15 @@ import Bag ( emptyBag, unitBag, consBag, snocBag,
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
fmToList, delListFromFM, sizeFM, foldFM, unitFM,
- plusFM_C, addListToFM, keysFM{-ToDo:rm-}
+ plusFM_C, addListToFM, keysFM{-ToDo:rm-}, FiniteMap
)
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, MaybeErr(..) )
import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
isLexCon, RdrName(..), Name{-instance NamedThing-} )
import PprStyle -- ToDo:rm
import Outputable -- ToDo:rm
import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames) )
import Pretty
-import Maybes ( MaybeErr(..) )
import UniqFM ( emptyUFM )
import UniqSupply ( splitUniqSupply )
import Util ( sortLt, removeDups, cmpPString, startsWith,
@@ -55,19 +62,25 @@ import Util ( sortLt, removeDups, cmpPString, startsWith,
type ModuleToIfaceContents = FiniteMap Module ParsedIface
type ModuleToIfaceFilePath = FiniteMap Module FilePath
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
data IfaceCache
= IfaceCache
Module -- the name of the module being compiled
BuiltinNames -- so we can avoid going after things
-- the compiler already knows about
- (MutableVar _RealWorld
+ (MutableVar REAL_WORLD
(ModuleToIfaceContents, -- interfaces for individual interface files
ModuleToIfaceContents, -- merged interfaces based on module name
-- used for extracting info about original names
ModuleToIfaceFilePath))
initIfaceCache mod hi_files
- = newVar (emptyFM,emptyFM,hi_files) `thenPrimIO` \ iface_var ->
+ = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var ->
return (IfaceCache mod b_names iface_var)
where
b_names = case builtinNameInfo of (b_names,_,_) -> b_names
@@ -110,7 +123,7 @@ cachedIface :: IfaceCache
-> IO (MaybeErr ParsedIface Error)
cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
- = readVar iface_var `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
+ = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) ->
case (lookupFM iface_fm modname) of
Just iface -> return (want_iface iface orig_fm)
@@ -127,7 +140,7 @@ cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
iface_fm' = addToFM iface_fm modname iface
orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
in
- writeVar iface_var (iface_fm', orig_fm', file_fm) `seqPrimIO`
+ writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ ->
return (want_iface iface orig_fm')
where
want_iface iface orig_fm
@@ -274,7 +287,7 @@ readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error
readIface file modname item
= --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >>
- readFile file `thenPrimIO` \ read_result ->
+ TRY_IO (readFile file) >>= \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
Right contents -> --hPutStr stderr ".." >>
@@ -540,7 +553,7 @@ data AddedDecl -- purely local
| AddedSig RenamedSig
rnIfaceDecl :: RdrIfaceDecl
- -> RnM_Fixes _RealWorld
+ -> RnM_Fixes REAL_WORLD
(AddedDecl, -- the resulting decl to add to the pot
([(RdrName,RnName)], [(RdrName,RnName)]),
-- new val/tycon-class names that have
@@ -621,7 +634,7 @@ sub (val_ment, tc_ment) (val_defds, tc_defds)
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
- = readVar iface_var `thenPrimIO` \ (iface_fm, _, _) ->
+ = readVar iface_var ST_THEN \ (iface_fm, _, _) ->
let
imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
(imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
@@ -634,7 +647,7 @@ cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
-- Assert that instance modules given by direct imports contains
-- instance modules extracted from all visited modules
- readVar iface_var `thenPrimIO` \ (all_iface_fm, _, _) ->
+ readVar iface_var ST_THEN \ (all_iface_fm, _, _) ->
let
all_ifaces = eltsFM all_iface_fm
(all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
@@ -670,7 +683,7 @@ rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_
= -- all the instance decls we might even want to consider
-- are in the ParsedIfaces that are in our cache
- readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) ->
+ readVar iface_var ST_THEN \ (_, orig_iface_fm, _) ->
let
all_ifaces = eltsFM orig_iface_fm
all_insts = concat (map get_insts all_ifaces)
@@ -752,7 +765,7 @@ rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_
\end{code}
\begin{code}
-rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes _RealWorld RenamedInstDecl
+rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl
rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod)
\end{code}
@@ -778,7 +791,7 @@ finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) modname if_final_env@((qua
-- 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_var `thenPrimIO` \ (_, orig_iface_fm, _) ->
+ readVar iface_var ST_THEN \ (_, orig_iface_fm, _) ->
let
all_ifaces = eltsFM orig_iface_fm
-- all the interfaces we have looked at
diff --git a/ghc/compiler/rename/RnLoop_1_3.lhi b/ghc/compiler/rename/RnLoop_1_3.lhi
index d87183d6f57c..b26f8ff5f77c 100644
--- a/ghc/compiler/rename/RnLoop_1_3.lhi
+++ b/ghc/compiler/rename/RnLoop_1_3.lhi
@@ -1,5 +1,7 @@
\begin{code}
interface RnLoop_1_3 1
__exports__
-Outputable Outputable (..)
+RnBinds rnBinds (..)
+RnBinds FreeVars
+RnSource rnPolyType (..)
\end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 55aeb1bec821..b94dd7fb3a1d 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -8,10 +8,10 @@
module RnNames (
getGlobalNames,
- GlobalNameInfo(..)
+ SYN_IE(GlobalNameInfo)
) where
-import PreludeGlaST ( MutableVar(..) )
+import PreludeGlaST ( SYN_IE(MutableVar) )
IMP_Ubiq()
@@ -31,7 +31,7 @@ import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
unionManyBags, mapBag, filterBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
+import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-}, FiniteMap )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
@@ -514,7 +514,7 @@ doImport :: IfaceCache
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
= let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
+ (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec -- NB: a no-op ToDo:rm
in
(if mod == gHC_BUILTINS then
return (Succeeded (panic "doImport:GHC fake import!"),
@@ -591,9 +591,10 @@ getBuiltins :: ImportNameInfo
)
getBuiltins _ modname maybe_spec
- | modname `notElem` modulesWithBuiltins
+--OLD: | modname `notElem` modulesWithBuiltins
= (emptyBag, emptyBag, maybe_spec)
+{-
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
= case maybe_spec of
Nothing -> (all_vals, all_tcs, Nothing)
@@ -649,6 +650,7 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
_ -> panic "importing builtin names (2)"
where
(vals, tcs, ies_left) = do_builtin ies
+-}
-------------------------
getOrigIEs :: ParsedIface
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index ce3359feabef..3829b51be665 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -10,6 +10,7 @@ module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) wher
IMP_Ubiq()
IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+IMPORT_1_3(List(partition))
import HsSyn
import HsPragmas
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index aa63f03cb6bc..3a784494b058 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -34,7 +34,7 @@ import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
import SimplEnv
import SimplMonad
import SimplUtils ( mkValLamTryingEta )
-import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
+import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
import TysPrim ( voidTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
@@ -475,7 +475,7 @@ bindLargeRhs env args rhs_ty rhs_c
dead DeadCode = True
dead other = False
- prim_rhs_fun_ty = mkFunTys [voidTy] rhs_ty
+ prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
\end{code}
Case alternatives when we don't know the scrutinee
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index ebd97c2c7a5a..e2f3a7de7a27 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -9,6 +9,7 @@
module SimplCore ( core2core ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(hPutStr,stderr))
import AnalFBWW ( analFBWW )
import Bag ( isEmptyBag, foldBag )
@@ -35,6 +36,7 @@ import CoreSyn
import CoreUnfold
import CoreUtils ( substCoreBindings, manifestlyWHNF )
import ErrUtils ( ghcExit )
+import FiniteMap ( FiniteMap )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW )
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 99367d2e9612..a6e44d3fb4d7 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -10,6 +10,7 @@ module Simplify ( simplTopBinds, simplExpr, simplBind ) where
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(SmplLoop) -- paranoia checking
+IMPORT_1_3(List(partition))
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index 5c06e2f8a20b..f3cf96af0026 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -15,12 +15,12 @@ module GenSpecEtc (
IMP_Ubiq()
import TcMonad hiding ( rnMtoTcM )
-import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
+import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE,
newDicts, tyVarsOfInst, instToId )
import TcEnv ( tcGetGlobalTyVars, tcExtendGlobalTyVars )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
-import TcType ( TcType(..), TcThetaType(..), TcTauType(..),
- TcTyVarSet(..), TcTyVar(..),
+import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
+ SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars
)
import Unify ( unifyTauTy )
@@ -28,7 +28,7 @@ import Unify ( unifyTauTy )
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..),
Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake
)
-import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..), tcIdType )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcExpr), tcIdType )
import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag )
import Class ( GenClass )
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index d33c7a74d1d0..4424e98310c7 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -10,9 +10,9 @@ module Inst (
Inst(..), -- Visible only to TcSimplify
InstOrigin(..), OverloadedLit(..),
- LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
+ SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
- InstanceMapper(..),
+ SYN_IE(InstanceMapper),
newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
@@ -29,22 +29,25 @@ module Inst (
) where
IMP_Ubiq()
+IMPORT_1_3(Ratio(Rational))
import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
InPat, OutPat, Stmt, Qualifier, Match,
ArithSeqInfo, PolyType, Fake )
-import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
-import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
+import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr),
+ RnName{-instance NamedThing-}
+ )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr),
mkHsTyApp, mkHsDictApp, tcIdTyVars )
import TcMonad hiding ( rnMtoTcM )
import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
-import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
+import TcType ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
tcInstType, zonkTcType )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
import Class ( isCcallishClass, isNoDictClass, classInstEnv,
- SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv)
+ SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp)
)
import ErrUtils ( addErrLoc, SYN_IE(Error) )
import Id ( GenId, idType, mkInstId )
@@ -54,7 +57,6 @@ import Outputable
import PprType ( GenClass, TyCon, GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
import Pretty
-import RnHsSyn ( RnName{-instance NamedThing-} )
import SpecEnv ( SYN_IE(SpecEnv) )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import Type ( GenType, eqSimpleTy, instantiateTy,
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 4348b0101337..a733638c9ef4 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -14,15 +14,15 @@ import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..),
HsExpr, Match, PolyType, InPat, OutPat(..),
GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
collectBinders )
-import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..),
- RenamedMonoBinds(..), RnName(..)
+import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedBind), RenamedSig(..),
+ SYN_IE(RenamedMonoBinds), RnName(..)
)
-import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
- TcIdOcc(..), TcIdBndr(..) )
+import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcMonoBinds),
+ TcIdOcc(..), SYN_IE(TcIdBndr) )
import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
-import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
+import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcMatches ( tcMatchesFun )
@@ -36,10 +36,9 @@ import Kind ( mkBoxedTypeKind, mkTypeKind )
import Id ( GenId, idType, mkUserId )
import IdInfo ( noIdInfo )
import Maybes ( assocMaybe, catMaybes )
-import Name ( pprNonSym )
+import Name ( pprNonSym, Name )
import PragmaInfo ( PragmaInfo(..) )
import Pretty
-import RnHsSyn ( RnName ) -- instances
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy,
mkSigmaTy, splitSigmaTy,
splitRhoTy, mkForAllTy, splitForAllTy )
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 298df688ba10..8e1c047aa04e 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -6,9 +6,7 @@
\begin{code}
#include "HsVersions.h"
-module TcClassDcl (
- tcClassDecl1, tcClassDecls2
- ) where
+module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
IMP_Ubiq()
@@ -18,27 +16,26 @@ import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
import HsPragmas ( ClassPragmas(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
- RenamedClassOpSig(..), RenamedMonoBinds(..),
+ RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
RenamedGenPragmas(..), RenamedContext(..),
RnName{-instance Uniquable-}
)
-import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
-import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts, newMethod )
+import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
import TcInstDcls ( processInstBinds )
-import TcKind ( TcKind )
-import TcKind ( unifyKind )
+import TcKind ( unifyKind, TcKind )
import TcMonad hiding ( rnMtoTcM )
import TcMonoType ( tcPolyType, tcMonoType, tcContext )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars, tcInstSigType )
+import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
import Bag ( foldBag, unionManyBags )
import Class ( GenClass, mkClass, mkClassOp, classBigSig,
classOps, classOpString, classOpLocalType,
- classOpTagByString
+ classOpTagByString, SYN_IE(ClassOp)
)
import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
idType )
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 39f6968df40f..572fcb99aa1a 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -16,11 +16,11 @@ import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
ArithSeqInfo, Fake, MonoType )
import HsPragmas ( InstancePragmas(..) )
-import RnHsSyn ( mkRnName, RnName(..), RenamedHsBinds(..), RenamedFixityDecl(..) )
+import RnHsSyn ( mkRnName, RnName(..), SYN_IE(RenamedHsBinds), RenamedFixityDecl(..) )
import TcHsSyn ( TcIdOcc )
import TcMonad
-import Inst ( InstanceMapper(..) )
+import Inst ( SYN_IE(InstanceMapper) )
import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
import TcKind ( TcKind )
import TcGenDeriv -- Deriv stuff
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 896d581eb66d..1360c47b9c68 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -25,13 +25,13 @@ IMP_Ubiq()
IMPORT_DELOOPER(TcMLoop) -- for paranoia checking
import Id ( SYN_IE(Id), GenId, idType, mkUserLocal )
-import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) )
+import TcHsSyn ( SYN_IE(TcIdBndr), TcIdOcc(..) )
import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
-import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..),
+import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
newTyVarTys, tcInstTyVars, zonkTcTyVars
)
import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
-import Type ( tyVarsOfTypes )
+import Type ( tyVarsOfTypes, splitForAllTy )
import TyCon ( TyCon, tyConKind, synTyConArity )
import Class ( SYN_IE(Class), GenClass, classSig )
@@ -41,7 +41,6 @@ import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
import PprStyle
import Pretty
import RnHsSyn ( RnName(..) )
-import Type ( splitForAllTy )
import Unique ( pprUnique10, pprUnique{-ToDo:rm-} )
import UniqFM
import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index d3860c7e9f63..77308e5f25d9 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -15,18 +15,18 @@ import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..),
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
Match, Fake, InPat, OutPat, PolyType,
failureFreePat, collectPatBinders )
-import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..),
- RenamedStmt(..), RenamedRecordBinds(..),
+import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual),
+ SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds),
RnName{-instance Outputable-}
)
-import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
- TcIdOcc(..), TcRecordBinds(..),
+import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt),
+ TcIdOcc(..), SYN_IE(TcRecordBinds),
mkHsTyApp
)
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
- LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
+ SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
@@ -37,7 +37,7 @@ import TcMatches ( tcMatchesCase, tcMatch )
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
-import TcType ( TcType(..), TcMaybe(..),
+import TcType ( SYN_IE(TcType), TcMaybe(..),
tcInstId, tcInstType, tcInstSigTcType,
tcInstSigType, tcInstTcType, tcInstTheta,
newTyVarTy, zonkTcTyVars, zonkTcType )
@@ -57,11 +57,11 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
)
import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
- floatPrimTy, addrPrimTy
+ floatPrimTy, addrPrimTy, realWorldTy
)
import TysWiredIn ( addrTy,
boolTy, charTy, stringTy, mkListTy,
- mkTupleTy, mkPrimIoTy, primIoDataCon
+ mkTupleTy, mkPrimIoTy, stDataCon
)
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
@@ -269,7 +269,7 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
- returnTc (HsCon primIoDataCon [result_ty] [CCall lbl args' may_gc is_asm result_ty],
+ returnTc (HsCon stDataCon [realWorldTy, result_ty] [CCall lbl args' may_gc is_asm result_ty],
-- do the wrapping in the newtype constructor here
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
mkPrimIoTy result_ty)
diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs
index 4a532ae00960..309149e6afb0 100644
--- a/ghc/compiler/typecheck/TcGRHSs.lhs
+++ b/ghc/compiler/typecheck/TcGRHSs.lhs
@@ -13,14 +13,14 @@ IMPORT_DELOOPER(TcLoop) -- for paranoia checking
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr, HsBinds(..), InPat, OutPat, Bind, Sig, Fake )
-import RnHsSyn ( RenamedGRHSsAndBinds(..), RenamedGRHS(..) )
-import TcHsSyn ( TcGRHSsAndBinds(..), TcGRHS(..), TcIdOcc(..) )
+import RnHsSyn ( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) )
+import TcHsSyn ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), TcIdOcc(..) )
import TcMonad hiding ( rnMtoTcM )
-import Inst ( Inst, LIE(..), plusLIE )
+import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcBinds ( tcBindsAndThen )
import TcExpr ( tcExpr )
-import TcType ( TcType(..) )
+import TcType ( SYN_IE(TcType) )
import Unify ( unifyTauTy )
import TysWiredIn ( boolTy )
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index a0f779fcafa5..00eb7544e772 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -10,20 +10,20 @@ checker.
#include "HsVersions.h"
module TcHsSyn (
- TcIdBndr(..), TcIdOcc(..),
+ SYN_IE(TcIdBndr), TcIdOcc(..),
- TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..),
- TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..),
- TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..),
- TcHsModule(..),
+ SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcPat),
+ SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch),
+ SYN_IE(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
+ SYN_IE(TcHsModule),
- TypecheckedHsBinds(..), TypecheckedBind(..),
- TypecheckedMonoBinds(..), TypecheckedPat(..),
- TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
- TypecheckedQual(..), TypecheckedStmt(..),
- TypecheckedMatch(..), TypecheckedHsModule(..),
- TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
- TypecheckedRecordBinds(..),
+ SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind),
+ SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
+ SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo),
+ SYN_IE(TypecheckedQual), SYN_IE(TypecheckedStmt),
+ SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule),
+ SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
+ SYN_IE(TypecheckedRecordBinds),
mkHsTyApp, mkHsDictApp,
mkHsTyLam, mkHsDictLam,
@@ -37,7 +37,7 @@ IMP_Ubiq(){-uitous-}
-- friends:
import HsSyn -- oodles of it
-import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
+import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids
SYN_IE(DictVar), idType,
SYN_IE(IdEnv), growIdEnvList, lookupIdEnv
)
@@ -45,7 +45,7 @@ import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
-- others:
import Name ( Name{--O only-} )
import TcMonad hiding ( rnMtoTcM )
-import TcType ( TcType(..), TcMaybe, TcTyVar(..),
+import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
zonkTcTypeToType, zonkTcTyVarToTyVar
)
import Usage ( SYN_IE(UVar) )
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index cef6f6ad4319..6f7e3a372ce5 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -21,21 +21,21 @@ import HsSyn ( InstDecl(..), FixityDecl, Sig(..),
InPat(..), OutPat(..), HsExpr(..), HsLit(..),
Stmt, Qualifier, ArithSeqInfo, Fake,
PolyType(..), MonoType )
-import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..),
+import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
RenamedInstDecl(..), RenamedFixityDecl(..),
RenamedSig(..), RenamedSpecInstSig(..),
RnName(..){-incl instance Outputable-}
)
-import TcHsSyn ( TcIdOcc(..), TcHsBinds(..),
- TcMonoBinds(..), TcExpr(..), tcIdType,
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds),
+ SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
mkHsTyLam, mkHsTyApp,
mkHsDictLam, mkHsDictApp )
import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars )
-import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
- newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
+import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
+ newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
import TcBinds ( tcPragmaSigs )
import TcDeriv ( tcDeriving )
import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
@@ -45,7 +45,7 @@ import TcKind ( TcKind, unifyKind )
import TcMatches ( tcMatchesFun )
import TcMonoType ( tcContext, tcMonoTypeKind )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..),
+import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
)
import Unify ( unifyTauTy, unifyTauTyLists )
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index c30a90ae9245..12e0f14bb91e 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -17,15 +17,17 @@ module TcInstUtil (
IMP_Ubiq()
import HsSyn ( MonoBinds, Fake, InPat, Sig )
-import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
+import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
RenamedInstancePragmas(..) )
import TcMonad hiding ( rnMtoTcM )
-import Inst ( InstanceMapper(..) )
+import Inst ( SYN_IE(InstanceMapper) )
import Bag ( bagToList )
import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
- classBigSig, classOps, classOpLocalType )
+ classBigSig, classOps, classOpLocalType,
+ SYN_IE(ClassOp)
+ )
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
import MatchEnv ( nullMEnv, insertMEnv )
diff --git a/ghc/compiler/typecheck/TcLoop_1_3.lhi b/ghc/compiler/typecheck/TcLoop_1_3.lhi
index 69488fe65629..0fcf3ed975fb 100644
--- a/ghc/compiler/typecheck/TcLoop_1_3.lhi
+++ b/ghc/compiler/typecheck/TcLoop_1_3.lhi
@@ -1,5 +1,5 @@
\begin{code}
interface TcLoop_1_3 1
__exports__
-Outputable Outputable (..)
+TcGRHSs tcGRHSsAndBinds (..)
\end{code}
diff --git a/ghc/compiler/typecheck/TcMLoop_1_3.lhi b/ghc/compiler/typecheck/TcMLoop_1_3.lhi
index 1ea9fcf225b5..869c5c7531ac 100644
--- a/ghc/compiler/typecheck/TcMLoop_1_3.lhi
+++ b/ghc/compiler/typecheck/TcMLoop_1_3.lhi
@@ -1,5 +1,7 @@
\begin{code}
interface TcMLoop_1_3 1
__exports__
-Outputable Outputable (..)
+TcEnv TcEnv
+TcEnv initEnv (..)
+TcType TcMaybe
\end{code}
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 3cd3df53910c..313dc5a63342 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -13,20 +13,19 @@ IMP_Ubiq()
import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
HsExpr, HsBinds, OutPat, Fake,
collectPatBinders, pprMatch )
-import RnHsSyn ( RenamedMatch(..) )
-import TcHsSyn ( TcIdOcc(..), TcMatch(..) )
+import RnHsSyn ( SYN_IE(RenamedMatch), RnName{-instance Outputable-} )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
import TcMonad hiding ( rnMtoTcM )
-import Inst ( Inst, LIE(..), plusLIE )
+import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcEnv ( newMonoIds )
IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcPat ( tcPat )
-import TcType ( TcType(..), TcMaybe, zonkTcType )
+import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
import Unify ( unifyTauTy, unifyTauTyList )
import Kind ( Kind, mkTypeKind )
import Pretty
-import RnHsSyn ( RnName{-instance Outputable-} )
import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
import Util
\end{code}
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 7410a7f78c08..091ce48d7f58 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -8,11 +8,11 @@
module TcModule (
typecheckModule,
- TcResults(..),
- TcResultBinds(..),
- TcIfaceInfo(..),
- TcSpecialiseRequests(..),
- TcDDumpDeriv(..)
+ SYN_IE(TcResults),
+ SYN_IE(TcResultBinds),
+ SYN_IE(TcIfaceInfo),
+ SYN_IE(TcSpecialiseRequests),
+ SYN_IE(TcDDumpDeriv)
) where
IMP_Ubiq(){-uitous-}
@@ -22,8 +22,8 @@ import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
SpecInstSig, DefaultDecl, Sig, Fake, InPat,
FixityDecl, IE, ImportDecl
)
-import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
-import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
+import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) )
+import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
TcIdOcc(..), zonkBinds, zonkDictBinds )
import TcMonad hiding ( rnMtoTcM )
@@ -59,7 +59,7 @@ import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
import Util
-import FiniteMap ( emptyFM )
+import FiniteMap ( emptyFM, FiniteMap )
tycon_specs = emptyFM
\end{code}
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 8a636e69f561..fa642c55ec06 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -2,7 +2,7 @@
#include "HsVersions.h"
module TcMonad(
- TcM(..), NF_TcM(..), TcDown, TcEnv,
+ SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv,
SST_R, FSST_R,
initTc,
@@ -28,22 +28,26 @@ module TcMonad(
rnMtoTcM,
- TcError(..), TcWarning(..),
+ SYN_IE(TcError), SYN_IE(TcWarning),
mkTcErr, arityErr,
-- For closure
- MutableVar(..), _MutableArray
+ SYN_IE(MutableVar),
+#if __GLASGOW_HASKELL__ >= 200
+ GHCbase.MutableArray
+#else
+ _MutableArray
+#endif
) where
IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(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 ( SYN_IE(Type), GenType )
import TyVar ( SYN_IE(TyVar), GenTyVar )
import Usage ( SYN_IE(Usage), GenUsage )
-import ErrUtils ( SYN_IE(Error), SYN_IE(Message), ErrCtxt(..),
- SYN_IE(Warning) )
+import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
import SST
import RnMonad ( SYN_IE(RnM), RnDown, initRn, setExtraRn,
@@ -55,7 +59,6 @@ import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, keysFM{-ToDo:rm-} )
--import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
-import ErrUtils ( SYN_IE(Error) )
import Maybes ( MaybeErr(..) )
--import Name ( Name )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
@@ -79,11 +82,17 @@ type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
\end{code}
\begin{code}
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
-- With a builtin polymorphic type for runSST the type for
-- initTc should use TcM s r instead of TcM RealWorld r
initTc :: UniqSupply
- -> TcM _RealWorld r
+ -> TcM REAL_WORLD r
-> MaybeErr (r, Bag Warning)
(Bag Error, Bag Warning)
@@ -465,7 +474,7 @@ getErrCtxt (TcDown def us loc ctxt errs) = ctxt
%~~~~~~~~~~~~~~~~~~
\begin{code}
-rnMtoTcM :: RnEnv -> RnM _RealWorld a -> NF_TcM s (a, Bag Error)
+rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error)
rnMtoTcM rn_env rn_action down env
= readMutVarSST u_var `thenSST` \ uniq_supply ->
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 35f8353323c5..5988dbb7f757 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -12,10 +12,10 @@ IMP_Ubiq(){-uitous-}
import HsSyn ( PolyType(..), MonoType(..), Fake )
import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
- RenamedContext(..), RnName(..)
+ RenamedContext(..), RnName(..),
+ isRnLocal, isRnClass, isRnTyCon
)
-
import TcMonad hiding ( rnMtoTcM )
import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
tcTyVarScope, tcTyVarScopeGivenKinds
@@ -26,19 +26,15 @@ import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
)
import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType),
mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
- mkSigmaTy
+ mkSigmaTy, mkDictTy
)
import TyVar ( GenTyVar, SYN_IE(TyVar) )
-import Type ( mkDictTy )
import Class ( cCallishClassKeys )
import TyCon ( TyCon )
import TysWiredIn ( mkListTy, mkTupleTy )
import Unique ( Unique )
import PprStyle
import Pretty
-import RnHsSyn ( isRnLocal, isRnClass, isRnTyCon,
- RnName{-instance NamedThing-}
- )
import Util ( zipWithEqual, panic, pprPanic{-ToDo:rm-} )
\end{code}
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index e7056b200f69..a81a1125b93e 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -13,17 +13,17 @@ IMP_Ubiq(){-uitous-}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
Match, HsBinds, Qualifier, PolyType,
ArithSeqInfo, Stmt, Fake )
-import RnHsSyn ( RenamedPat(..) )
-import TcHsSyn ( TcPat(..), TcIdOcc(..) )
+import RnHsSyn ( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
+import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) )
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
- emptyLIE, plusLIE, plusLIEs, LIE(..),
+ emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
newMethod, newOverloadedLit
)
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
tcLookupLocalValueOK )
-import TcType ( TcType(..), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
+import TcType ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
@@ -34,7 +34,6 @@ import Maybes ( maybeToBool )
import PprType ( GenType, GenTyVar )
import PprStyle--ToDo:rm
import Pretty
-import RnHsSyn ( RnName{-instance Outputable-} )
import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
getFunTy_maybe, maybeAppDataTyCon,
SYN_IE(Type), GenType
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index a1e987a14176..e6fc6890fe19 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -17,7 +17,7 @@ IMP_Ubiq()
import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
Match, HsBinds, Qualifier, PolyType, ArithSeqInfo,
GRHSsAndBinds, Stmt, Fake )
-import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
+import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) )
import TcMonad hiding ( rnMtoTcM )
import Inst ( lookupInst, lookupSimpleInst,
@@ -25,11 +25,11 @@ import Inst ( lookupInst, lookupSimpleInst,
matchesInst, instToId, instBindingRequired,
instCanBeGeneralised, newDictsAtLoc,
pprInst,
- Inst(..), LIE(..), zonkLIE, emptyLIE,
+ Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE,
plusLIE, unitLIE, consLIE, InstOrigin(..),
OverloadedLit )
import TcEnv ( tcGetGlobalTyVars )
-import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
+import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType )
import Unify ( unifyTauTy )
import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index ae2cb40e71d1..78417f8e706a 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -18,13 +18,13 @@ import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
import RnHsSyn ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
RnName(..){-instance Uniquable-}
)
-import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
+import TcHsSyn ( SYN_IE(TcHsBinds), TcIdOcc(..) )
import TcMonad hiding ( rnMtoTcM )
-import Inst ( InstanceMapper(..) )
+import Inst ( SYN_IE(InstanceMapper) )
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
- tcTyVarScope, tcGetEnv )
+ tcTyVarScope )
import TcKind ( TcKind, newKindVars )
import TcTyDecls ( tcTyDecl, mkDataBinds )
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index a45e60003005..a6f55f2c451e 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -24,7 +24,7 @@ import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..),
RnName{-instance Outputable-}
)
import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
- TcHsBinds(..), TcIdOcc(..)
+ SYN_IE(TcHsBinds), TcIdOcc(..)
)
import Inst ( newDicts, InstOrigin(..), Inst )
import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
@@ -36,7 +36,9 @@ import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
import TcMonad hiding ( rnMtoTcM )
import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
-import PprType ( GenClass, GenType{-instance Outputable-} )
+import PprType ( GenClass, GenType{-instance Outputable-},
+ GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
+ )
import Class ( GenClass{-instance Eq-}, classInstEnv )
import Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
dataConFieldLabels, dataConStrictMarks,
@@ -59,7 +61,6 @@ import Type ( GenType, -- instances
applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
splitFunTy, mkTyVarTy, getTyVar_maybe
)
-import PprType ( GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} )
import TyVar ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
import Unique ( Unique {- instance Eq -}, evalClassKey )
import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) )
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 5b18277c65ac..e27dab5442cc 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -3,17 +3,17 @@
module TcType (
- TcTyVar(..),
+ SYN_IE(TcTyVar),
newTcTyVar,
newTyVarTy, -- Kind -> NF_TcM s (TcType s)
newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType s]
- TcTyVarSet(..),
+ SYN_IE(TcTyVarSet),
-----------------------------------------
- TcType(..), TcMaybe(..),
- TcTauType(..), TcThetaType(..), TcRhoType(..),
+ SYN_IE(TcType), TcMaybe(..),
+ SYN_IE(TcTauType), SYN_IE(TcThetaType), SYN_IE(TcRhoType),
-- Find the type to which a type variable is bound
tcWriteTyVar, -- :: TcTyVar s -> TcType s -> NF_TcM (TcType s)
@@ -229,37 +229,37 @@ zonkTcTypeToType env ty
tcConvert bind_fn occ_fn env ty_to_convert
- = do env ty_to_convert
+ = doo env ty_to_convert
where
- do env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage)
+ doo env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage)
- do env (SynTy tycon tys ty) = mapNF_Tc (do env) tys `thenNF_Tc` \ tys' ->
- do env ty `thenNF_Tc` \ ty' ->
+ doo env (SynTy tycon tys ty) = mapNF_Tc (doo env) tys `thenNF_Tc` \ tys' ->
+ doo env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (SynTy tycon tys' ty')
- do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
- do env res `thenNF_Tc` \ res' ->
+ doo env (FunTy arg res usage) = doo env arg `thenNF_Tc` \ arg' ->
+ doo env res `thenNF_Tc` \ res' ->
returnNF_Tc (FunTy arg' res' usage)
- do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
- do env arg `thenNF_Tc` \ arg' ->
+ doo env (AppTy fun arg) = doo env fun `thenNF_Tc` \ fun' ->
+ doo env arg `thenNF_Tc` \ arg' ->
returnNF_Tc (AppTy fun' arg')
- do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' ->
+ doo env (DictTy clas ty usage)= doo env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (DictTy clas ty' usage)
- do env (ForAllUsageTy u us ty) = do env ty `thenNF_Tc` \ ty' ->
+ doo env (ForAllUsageTy u us ty) = doo env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (ForAllUsageTy u us ty')
-- The two interesting cases!
- do env (TyVarTy tv) = occ_fn env tv
+ doo env (TyVarTy tv) = occ_fn env tv
- do env (ForAllTy tyvar ty)
+ doo env (ForAllTy tyvar ty)
= bind_fn tyvar `thenNF_Tc` \ tyvar' ->
let
new_env = addOneToTyVarEnv env tyvar (TyVarTy tyvar')
in
- do new_env ty `thenNF_Tc` \ ty' ->
+ doo new_env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (ForAllTy tyvar' ty')
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index bc654dc33ab0..638058718bdc 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -18,7 +18,7 @@ import TcMonad hiding ( rnMtoTcM )
import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe )
import TyCon ( TyCon, mkFunTyCon )
import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind )
-import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..),
+import TcType ( SYN_IE(TcType), TcMaybe(..), SYN_IE(TcTauType), SYN_IE(TcTyVar),
newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
)
-- others:
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index 553ad736a1a6..913a7b29e171 100644
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -14,7 +14,7 @@ module TyVar (
-- TyVars and "sets" containing TyVars:
SYN_IE(TyVarEnv),
nullTyVarEnv, mkTyVarEnv, addOneToTyVarEnv,
- growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv,
+ growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
SYN_IE(GenTyVarSet), SYN_IE(TyVarSet),
emptyTyVarSet, unitTyVarSet, unionTyVarSets,
@@ -33,7 +33,7 @@ import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-- others
import UniqSet -- nearly all of it
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
- plusUFM, sizeUFM, UniqFM
+ plusUFM, sizeUFM, delFromUFM, UniqFM
)
import Name ( mkLocalName, changeUnique, Name, RdrName(..) )
import Pretty ( SYN_IE(Pretty), PrettyRep, ppBeside, ppPStr )
@@ -107,11 +107,13 @@ addOneToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a
growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a
isNullTyVarEnv :: TyVarEnv a -> Bool
lookupTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> Maybe a
+delFromTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> TyVarEnv a
nullTyVarEnv = emptyUFM
mkTyVarEnv = listToUFM
addOneToTyVarEnv = addToUFM
lookupTyVarEnv = lookupUFM
+delFromTyVarEnv = delFromUFM
growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
isNullTyVarEnv env = sizeUFM env == 0
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index bebf0f5c83d5..581167995510 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -53,7 +53,7 @@ import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
- unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
+ unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) )
import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv),
nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
@@ -612,20 +612,38 @@ instantiateTauTy tenv ty
bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
+
+-- applyTypeEnv applies a type environment to a type.
+-- It can handle shadowing; for example:
+-- f = /\ t1 t2 -> \ d ->
+-- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
+-- in f' t1
+-- Here, when we clone t1 to t1', say, we'll come across shadowing
+-- when applying the clone environment to the type of f'.
+--
+-- As a sanity check, we should also check that name capture
+-- doesn't occur, but that means keeping track of the free variables of the
+-- range of the TyVarEnv, which I don't do just yet.
+--
+-- We don't use instant_help because we need to carry in the environment
+
applyTypeEnvToTy tenv ty
- = instant_help ty lookup_tv deflt_tv choose_tycon
- if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
+ = go tenv ty
where
- lookup_tv = lookupTyVarEnv tenv
- deflt_tv tv = TyVarTy tv
- choose_tycon ty _ _ = ty
- if_usage ty = ty
- if_forall ty = ty
- bound_forall_tv_BAD = False -- ToDo: probably should be True (i.e., no shadowing)
- deflt_forall_tv tv = case (lookup_tv tv) of
- Nothing -> tv
- Just (TyVarTy tv2) -> tv2
- _ -> pprPanic "applyTypeEnvToTy:" (ppAbove (ppr PprShowAll tv) (ppr PprShowAll ty))
+ go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
+ Nothing -> ty
+ Just ty -> ty
+ go tenv ty@(TyConTy tycon usage) = ty
+ go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty)
+ go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage
+ go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg)
+ go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage
+ go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
+ go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
+ where
+ tenv' = case lookupTyVarEnv tenv tv of
+ Nothing -> tenv
+ Just _ -> delFromTyVarEnv tenv tv
\end{code}
\begin{code}
diff --git a/ghc/compiler/utils/Ubiq_1_3.lhi b/ghc/compiler/utils/Ubiq_1_3.lhi
index ffc378a985bd..f0995efe0b72 100644
--- a/ghc/compiler/utils/Ubiq_1_3.lhi
+++ b/ghc/compiler/utils/Ubiq_1_3.lhi
@@ -2,10 +2,8 @@
interface Ubiq_1_3 1
__exports__
GHCbase trace (..)
-GHCbase PrimIO -- this is here because of the bug preventing it getting into PreludeGlaST
+GHCps tailPS (..)
GHCps nilPS (..)
--- GHCps substrPS (..)
--- GHCps tailPS (..)
GHCps appendPS (..)
GHCps concatPS (..)
GHCps consPS (..)
@@ -21,6 +19,7 @@ BinderInfo BinderInfo
CLabel CLabel
Class Class
ClosureInfo ClosureInfo
+CmdLineOpts SwitchResult
CoreSyn GenCoreExpr
CoreUnfold UnfoldingDetails
CoreUnfold UnfoldingGuidance
@@ -50,6 +49,7 @@ Name OrigName (..)
Name RdrName (..)
Outputable Outputable (..)
PprStyle PprStyle
+PragmaInfo PragmaInfo
PrimOp PrimOp
PrimRep PrimRep
SrcLoc SrcLoc
--
GitLab