From 47eef4b5780f0a5b5a37847097842daebd0f9285 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 6 Nov 2000 08:15:24 +0000 Subject: [PATCH] [project @ 2000-11-06 08:15:20 by simonpj] Dealing with instance-decl imports; and removing unnecessary imports --- ghc/compiler/Makefile | 4 +- ghc/compiler/absCSyn/AbsCUtils.lhs | 2 - ghc/compiler/absCSyn/CLabel.lhs | 7 +- ghc/compiler/absCSyn/PprAbsC.lhs | 6 +- ghc/compiler/codeGen/CgBindery.lhs | 6 - ghc/compiler/codeGen/CgClosure.lhs | 44 +---- ghc/compiler/codeGen/CgConTbls.lhs | 3 - ghc/compiler/codeGen/CgHeapery.lhs | 5 +- ghc/compiler/codeGen/CgMonad.lhs | 4 +- ghc/compiler/codeGen/CgTailCall.lhs | 5 +- ghc/compiler/main/HscMain.lhs | 6 +- ghc/compiler/main/HscTypes.lhs | 13 +- ghc/compiler/nativeGen/AbsCStixGen.lhs | 4 +- ghc/compiler/nativeGen/AsmCodeGen.lhs | 16 +- ghc/compiler/nativeGen/AsmRegAlloc.lhs | 9 +- ghc/compiler/nativeGen/PprMach.lhs | 3 +- ghc/compiler/nativeGen/RegAllocInfo.lhs | 4 +- ghc/compiler/nativeGen/Stix.lhs | 2 +- ghc/compiler/nativeGen/StixInfo.lhs | 2 +- ghc/compiler/nativeGen/StixInteger.lhs | 6 +- ghc/compiler/nativeGen/StixMacro.lhs | 4 +- ghc/compiler/nativeGen/StixPrim.lhs | 2 +- ghc/compiler/parser/RdrHsSyn.lhs | 1 + ghc/compiler/prelude/PrelInfo.lhs | 10 +- ghc/compiler/prelude/TysWiredIn.lhs | 1 - ghc/compiler/rename/Rename.lhs | 36 ++-- ghc/compiler/rename/RnHiFiles.lhs | 46 ++--- ghc/compiler/rename/RnIfaces.lhs | 310 ++++++++++--------------------- ghc/compiler/simplStg/LambdaLift.lhs | 4 - ghc/compiler/simplStg/SimplStg.lhs | 2 +- ghc/compiler/simplStg/StgVarInfo.lhs | 3 +- ghc/compiler/stgSyn/StgLint.lhs | 6 +- ghc/compiler/stranal/SaLib.lhs | 2 +- ghc/compiler/typecheck/TcDeriv.lhs | 107 +++++------ ghc/compiler/typecheck/TcInstDcls.lhs | 25 +-- ghc/compiler/typecheck/TcTyDecls.lhs | 6 +- ghc/compiler/types/TyCon.lhs | 15 +- ghc/compiler/types/Type.lhs | 2 +- ghc/compiler/usageSP/UsageSPUtils.lhs | 2 +- 39 files changed, 253 insertions(+), 482 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 3c2ac9c..5c7496c 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.108 2000/11/03 17:09:00 simonmar Exp $ +# $Id: Makefile,v 1.109 2000/11/06 08:15:20 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -91,7 +91,7 @@ $(HS_PROG) :: $(HS_SRCS) DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ - profiling parser usageSP cprAnalysis javaGen compMan + profiling parser usageSP cprAnalysis javaGen compMan ghci ifeq ($(GhcWithNativeCodeGen),YES) DIRS += nativeGen diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 2dfab65..a5a36c8 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -419,8 +419,6 @@ We use the strongly-connected component algorithm, in which type CVertex = (Int, AbstractC) -- Give each vertex a unique number, -- for fast comparison -type CEdge = (CVertex, CVertex) - doSimultaneously abs_c = let enlisted = en_list abs_c diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 8f2a547..a40f559 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CLabel.lhs,v 1.40 2000/10/16 13:57:43 sewardj Exp $ +% $Id: CLabel.lhs,v 1.41 2000/11/06 08:15:20 simonpj Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -83,15 +83,14 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) import CStrings ( pp_cSEP ) -import DataCon ( ConTag, DataCon ) -import Module ( ModuleName, moduleName, moduleNameFS, +import DataCon ( ConTag ) +import Module ( moduleName, moduleNameFS, Module, isModuleInThisPackage ) import Name ( Name, getName, isDllName, isExternallyVisibleName ) import TyCon ( TyCon ) import Unique ( pprUnique, Unique ) import PrimOp ( PrimOp, pprPrimOp ) import CostCentre ( CostCentre, CostCentreStack ) -import Util import Outputable \end{code} diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 5eb0cc1..b8924ab 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -43,7 +43,7 @@ import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) import Name ( NamedThing(..) ) -import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId ) +import DataCon ( dataConWrapId ) import Maybes ( maybeToBool, catMaybes ) import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp, PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget ) @@ -60,7 +60,6 @@ import GlaExts import Util ( nOfThem ) import ST -import MutableArray infixr 9 `thenTE` \end{code} @@ -648,9 +647,6 @@ pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") \end{code} \begin{code} -has_srt (_, NoSRT) = False -has_srt _ = True - pp_srt_info srt = case srt of (lbl, NoSRT) -> diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 4548136..5e1f11f 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -38,7 +38,6 @@ import CLabel ( mkClosureLabel, import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) import BitSet ( mkBS, emptyBS ) import PrimRep ( isFollowableRep, getPrimRepSize ) -import DataCon ( DataCon, dataConName ) import Id ( Id, idPrimRep, idType, isDataConWrapId ) import Type ( typePrimRep ) import VarEnv @@ -398,11 +397,6 @@ bindNewToReg name magic_id lf_info where info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info -bindNewToLit name lit - = addBindC name info - where - info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit") - bindArgsToRegs :: [Id] -> [MagicId] -> Code bindArgsToRegs args regs = listCs (zipWithEqual "bindArgsToRegs" bind args regs) diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index b2bd1fe..5fba8c0 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.42 2000/10/24 08:40:09 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.43 2000/11/06 08:15:21 simonpj Exp $ % \section[CgClosure]{Code generation for closures} @@ -58,8 +58,6 @@ import Outputable import Name ( nameOccName ) import OccName ( occNameFS ) import FastTypes ( iBox ) - -getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} %******************************************************** @@ -745,43 +743,3 @@ chooseDynCostCentres ccs args fvs body -======================================================================== -OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS - -It's pretty wierd, so I've nuked it for now. SLPJ Nov 96 - -\begin{pseudocode} -getWrapperArgTypeCategories - :: Type -- wrapper's type - -> StrictnessInfo bdee -- strictness info about its args - -> Maybe String - -getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing -getWrapperArgTypeCategories _ BottomGuaranteed - = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong -getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing - -getWrapperArgTypeCategories ty (StrictnessInfo arg_info _) - = Just (mkWrapperArgTypeCategories ty arg_info) - -mkWrapperArgTypeCategories - :: Type -- wrapper's type - -> [Demand] -- info about its arguments - -> String -- a string saying lots about the args - -mkWrapperArgTypeCategories wrapper_ty wrap_info - = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) -> - map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) } - where - -- ToDo: this needs FIXING UP (it was a hack anyway...) - do_one (WwPrim, _) = 'P' - do_one (WwEnum, _) = 'E' - do_one (WwStrict, arg_ty_char) = arg_ty_char - do_one (WwUnpack _ _ _, arg_ty_char) - = if arg_ty_char `elem` "CIJFDTS" - then toLower arg_ty_char - else if arg_ty_char == '+' then 't' - else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-' - do_one (other_wrap_info, _) = '-' -\end{pseudocode} - diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index e3197fa..299eceb 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -17,11 +17,9 @@ import CLabel ( mkConEntryLabel ) import ClosureInfo ( layOutStaticClosure, layOutDynCon, mkConLFInfo, ClosureInfo ) -import CostCentre ( dontCareCCS ) import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon ) import Name ( getOccName ) import OccName ( occNameUserString ) -import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon ) import Type ( typePrimRep ) \end{code} @@ -140,7 +138,6 @@ genConInfo comp_info tycon data_con -- just one more thing to go wrong. arg_tys = dataConRepArgTys data_con - entry_label = mkConEntryLabel con_name con_name = dataConName data_con \end{code} diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index be8e4e0..a48079e 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.24 2000/10/24 08:40:10 simonpj Exp $ +% $Id: CgHeapery.lhs,v 1.25 2000/11/06 08:15:21 simonpj Exp $ % \section[CgHeapery]{Heap management functions} @@ -26,8 +26,7 @@ import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp, initHeapUsage ) import ClosureInfo ( closureSize, closureGoodStuffSize, - slopSize, allocProfilingMsg, ClosureInfo, - closureSMRep + slopSize, allocProfilingMsg, ClosureInfo ) import PrimRep ( PrimRep(..), isFollowableRep ) import Unique ( Unique ) diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index fc7e6ab..9c6d172 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.25 2000/09/04 14:07:29 simonmar Exp $ +% $Id: CgMonad.lhs,v 1.26 2000/11/06 08:15:21 simonpj Exp $ % \section[CgMonad]{The code generation monad} @@ -42,7 +42,7 @@ module CgMonad ( #include "HsVersions.h" -import {-# SOURCE #-} CgBindery ( CgIdInfo, CgBindings, nukeVolatileBinds ) +import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) import {-# SOURCE #-} CgUsages ( getSpRelOffset ) import AbsCSyn diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 7b721a4..9a96edb 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.27 2000/10/03 08:43:00 simonpj Exp $ +% $Id: CgTailCall.lhs,v 1.28 2000/11/06 08:15:21 simonpj Exp $ % %******************************************************** %* * @@ -50,13 +50,12 @@ import Id ( Id, idType, idName ) import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG ) import Maybes ( maybeToBool ) import PrimRep ( PrimRep(..) ) -import StgSyn ( StgArg, GenStgArg(..) ) +import StgSyn ( StgArg ) import Type ( isUnLiftedType ) import TyCon ( TyCon ) import PrimOp ( PrimOp ) import Util ( zipWithEqual ) import ListSetOps ( assocMaybe ) -import Unique ( mkPseudoUnique1 ) import Outputable import Panic ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index bf5857e..b7e1577 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -380,9 +380,9 @@ initPersistentRenamerState :: IO PersistentRenamerState return ( PRS { prsOrig = Orig { origNames = initOrigNames, origIParam = emptyFM }, - prsDecls = emptyNameEnv, - prsInsts = emptyBag, - prsRules = emptyBag, + prsDecls = (emptyNameEnv, 0), + prsInsts = (emptyBag, 0), + prsRules = (emptyBag, 0), prsNS = ns } ) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 8846a0d..d29b7f4 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -48,7 +48,6 @@ import RdrName ( RdrNameEnv, emptyRdrEnv ) import Name ( Name, NamedThing, isLocallyDefined, getName, nameModule, nameSrcLoc ) import Name -- Env -import NameSet ( NameSet ) import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv @@ -62,7 +61,7 @@ import TyCon ( TyCon ) import BasicTypes ( Version, initialVersion, Fixity ) import HsSyn ( DeprecTxt ) -import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl ) +import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl ) import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) import CoreSyn ( IdCoreRule ) @@ -471,12 +470,14 @@ including the constructors of a type decl etc. The Bool is True just for the 'main' Name. \begin{code} -type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl)) +type DeclsMap = (NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl)), Int) + -- The Int says how many have been sucked in -type IfaceInsts = Bag GatedDecl -type IfaceRules = Bag GatedDecl +type IfaceInsts = GatedDecls RdrNameInstDecl +type IfaceRules = GatedDecls RdrNameRuleDecl -type GatedDecl = ([Name], (Module, RdrNameHsDecl)) +type GatedDecls d = (Bag (GatedDecl d), Int) -- The Int says how many have been sucked in +type GatedDecl d = ([Name], (Module, d)) \end{code} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 2a3fe2d..51a29c6 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -24,8 +24,7 @@ import SMRep ( fixedItblSize, import Constants ( mIN_UPD_SIZE ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, mkClosureLabel, - moduleRegdLabel, labelDynamic, - mkSplitMarkerLabel ) + labelDynamic, mkSplitMarkerLabel ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, closureUpdReqd, staticClosureNeedsLink @@ -45,7 +44,6 @@ import TyCon ( tyConDataCons ) import DataCon ( dataConWrapId ) import BitSet ( intBS ) import Name ( NamedThing(..) ) -import Char ( ord ) import CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) \end{code} diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 0234819..146605d 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -16,23 +16,23 @@ import MachCode import PprMach import AbsCStixGen ( genCodeAbstractC ) -import AbsCSyn ( AbstractC, MagicId ) +import AbsCSyn ( AbstractC ) import AbsCUtils ( mkAbsCStmtList ) import AsmRegAlloc ( runRegAllocate ) import PrimOp ( commutableOp, PrimOp(..) ) import RegAllocInfo ( findReservedRegs ) import Stix ( StixTree(..), StixReg(..), - pprStixTrees, pprStixTree, CodeSegment(..), + pprStixTrees, pprStixTree, stixCountTempUses, stixSubst, - NatM, initNat, mapNat, - NatM_State, mkNatM_State, + initNat, mapNat, + mkNatM_State, uniqOfNatM_State, deltaOfNatM_State ) -import UniqSupply ( returnUs, thenUs, mapUs, initUs, - initUs_, UniqSM, UniqSupply, - lazyThenUs, lazyMapUs ) +import UniqSupply ( returnUs, thenUs, initUs, + UniqSM, UniqSupply, + lazyMapUs ) import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) ) -import OrdList ( fromOL, concatOL ) +import OrdList ( concatOL ) import Outputable \end{code} diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index d9e6cf2..5922411 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -14,11 +14,10 @@ import PprMach ( pprInstr ) -- Just for debugging import MachRegs import RegAllocInfo -import FiniteMap ( FiniteMap, emptyFM, addListToFM, delListFromFM, - lookupFM, keysFM, eltsFM, mapFM, addToFM_C, addToFM, - listToFM, fmToList, lookupWithDefaultFM ) -import Unique ( mkBuiltinUnique ) -import OrdList ( unitOL, appOL, fromOL, concatOL ) +import FiniteMap ( FiniteMap, emptyFM, + lookupFM, eltsFM, addToFM_C, addToFM, + listToFM, fmToList ) +import OrdList ( fromOL ) import Outputable import Unique ( Unique, Uniquable(..), mkPseudoUnique3 ) import CLabel ( CLabel, pprCLabel ) diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 979207e..f647768 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -18,8 +18,7 @@ import MachRegs -- may differ per-platform import MachMisc import CLabel ( pprCLabel_asm, externallyVisibleCLabel, labelDynamic ) -import Stix ( CodeSegment(..), StixTree(..) ) -import Char ( isPrint, isDigit ) +import Stix ( CodeSegment(..) ) import Outputable import ST diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index 216046d..09f7083 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -36,11 +36,11 @@ module RegAllocInfo ( #include "HsVersions.h" -import List ( partition, sort ) +import List ( sort ) import MachMisc import MachRegs import Stix ( DestInfo(..) ) -import CLabel ( pprCLabel_asm, isAsmTemp, CLabel{-instance Ord-} ) +import CLabel ( isAsmTemp, CLabel{-instance Ord-} ) import FiniteMap ( addToFM, lookupFM, FiniteMap ) import Outputable import Constants ( rESERVED_C_STACK_BYTES ) diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 1e04305..bb69123 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -30,7 +30,7 @@ import Ratio ( Rational ) import AbsCSyn ( node, tagreg, MagicId(..) ) import CallConv ( CallConv, pprCallConv ) -import CLabel ( mkAsmTempLabel, CLabel, pprCLabel, pprCLabel_asm ) +import CLabel ( mkAsmTempLabel, CLabel, pprCLabel ) import PrimRep ( PrimRep(..), showPrimRep ) import PrimOp ( PrimOp, pprPrimOp ) import Unique ( Unique ) diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index 16feabc..bb26435 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -17,7 +17,7 @@ import ClosureInfo ( closurePtrsSize, infoTblNeedsSRT, getSRTInfo, closureSemiTag ) import PrimRep ( PrimRep(..) ) -import SMRep ( SMRep(..), getSMRepClosureTypeInt ) +import SMRep ( getSMRepClosureTypeInt ) import Stix -- all of it import UniqSupply ( returnUs, UniqSM ) import BitSet ( intBS ) diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index bb96cff..f0e9905 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -14,17 +14,13 @@ module StixInteger ( #include "HsVersions.h" import {-# SOURCE #-} StixPrim ( amodeToStix ) -import MachMisc -import MachRegs import AbsCSyn hiding (spRel) -- bits and bobs.. -import Literal ( Literal(..) ) import CallConv ( cCallConv ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) -import SMRep ( arrWordsHdrSize ) import Stix ( StixTree(..), StixTreeList, arrWordsHS ) -import UniqSupply ( returnUs, thenUs, UniqSM ) +import UniqSupply ( returnUs, UniqSM ) \end{code} Although gmpCompare doesn't allocate space, it does temporarily use diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 7127883..09cdc42 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -11,9 +11,9 @@ module StixMacro ( macroCode, checkCode ) where import {-# SOURCE #-} StixPrim ( amodeToStix ) import MachRegs -import AbsCSyn ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg, +import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) -import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE ) +import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE ) import CallConv ( cCallConv ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 8177892..ffca3c2 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -16,7 +16,7 @@ import AbsCUtils ( getAmodeRep, mixedTypeLocn ) import SMRep ( fixedHdrSize ) import Literal ( Literal(..), word2IntLit ) import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) -import PrimRep ( PrimRep(..), isFloatingRep ) +import PrimRep ( PrimRep(..) ) import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, rESERVED_STACK_WORDS ) diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index b76c269..54e9408 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -108,6 +108,7 @@ type RdrNameHsTyVar = HsTyVarBndr RdrName type RdrNameSig = Sig RdrName type RdrNameStmt = Stmt RdrName RdrNamePat type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat + type RdrNameRuleBndr = RuleBndr RdrName type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat type RdrNameDeprecation = DeprecDecl RdrName diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index e62d663..f1a64ed 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -40,7 +40,7 @@ import TysWiredIn ( wiredInTyCons ) import HscTypes ( TyThing(..), TypeEnv, mkTypeEnv ) -- others: -import TyCon ( tyConDataConsIfAvailable, TyCon ) +import TyCon ( tyConDataConsIfAvailable, tyConGenIds, TyCon ) import Class ( Class, classKey ) import Type ( funTyCon ) import Util ( isIn ) @@ -70,9 +70,13 @@ wiredInThings ] wiredInTyConThings :: TyCon -> [TyThing] +-- This is a bit of a cheat (c.f. TcTyDecls.mkImplicitDataBinds +-- It assumes that wired in tycons have no record selectors wiredInTyConThings tc - = ATyCon tc : [ AnId n | dc <- tyConDataConsIfAvailable tc, - n <- [dataConId dc, dataConWrapId dc] ] + = [ATyCon tc] + ++ [ AnId i | i <- tyConGenIds tc ] + ++ [ AnId n | dc <- tyConDataConsIfAvailable tc, + n <- [dataConId dc, dataConWrapId dc] ] -- Synonyms return empty list of constructors wiredInThingEnv :: TypeEnv diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 2ebd942..507a567 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -169,7 +169,6 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons argvrcs cons (length cons) - [] -- No derivings new_or_data is_rec gen_info diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c1e1dad..edec952 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -735,39 +735,31 @@ getRnStats imported_decls ifaces where n_mods = length [() | _ <- moduleEnvElts (iPIT ifaces)] -- This is really only right for a one-shot compile + + (decls_map, n_decls_slurped) = iDecls ifaces - decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces) + n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map -- Data, newtype, and class decls are in the decls_fm -- under multiple names; the tycon/class, and each -- constructor/class op too. -- The 'True' selects just the 'main' decl ] - (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read - (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls + (insts_left, n_insts_slurped) = iInsts ifaces + n_insts_left = length (bagToList insts_left) - unslurped_insts = iInsts ifaces - inst_decls_unslurped = length (bagToList unslurped_insts) - inst_decls_read = id_sp + inst_decls_unslurped + (rules_left, n_rules_slurped) = iRules ifaces + n_rules_left = length (bagToList rules_left) stats = vcat [int n_mods <+> text "interfaces read", - hsep [ int cd_sp, text "class decls imported, out of", - int cd_rd, text "read"], - hsep [ int dd_sp, text "data decls imported, out of", - int dd_rd, text "read"], - hsep [ int nd_sp, text "newtype decls imported, out of", - int nd_rd, text "read"], - hsep [int sd_sp, text "type synonym decls imported, out of", - int sd_rd, text "read"], - hsep [int vd_sp, text "value signatures imported, out of", - int vd_rd, text "read"], - hsep [int id_sp, text "instance decls imported, out of", - int inst_decls_read, text "read"], - text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- imported_decls, isClassDecl d]), - text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) - [d | d <- decls_read, isClassDecl d])] + hsep [ int n_decls_slurped, text "class decls imported, out of", + int (n_decls_slurped + n_decls_left), text "read"], + hsep [ int n_insts_slurped, text "instance decls imported, out of", + int (n_insts_slurped + n_insts_left), text "read"], + hsep [ int n_rules_slurped, text "rule decls imported, out of", + int (n_rules_slurped + n_rules_left), text "read"] + ] count_decls decls = (class_decls, diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 7a2cd23..20c6ece 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -26,7 +26,7 @@ import HscTypes ( ModuleLocation(..), DeclsMap, GatedDecl, IfaceInsts, IfaceRules, AvailInfo, GenAvailInfo(..), Avails, Deprecations(..) ) -import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), +import HsSyn ( TyClDecl(..), InstDecl(..), HsType(..), ConDecl(..), FixitySig(..), RuleDecl(..), tyClDeclNames @@ -50,7 +50,6 @@ import Module ( Module, extendModuleEnv, mkVanillaModule ) import RdrName ( RdrName, rdrNameOcc ) -import NameSet import SrcLoc ( mkSrcLoc ) import Maybes ( maybeToBool, orElse ) import StringBuffer ( hGetStringBuffer ) @@ -175,7 +174,7 @@ tryLoadInterface doc_str mod_name from loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) -> - foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> + loadInstDecls mod (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> @@ -283,13 +282,10 @@ loadDecls :: Module -> DeclsMap -> [(Version, RdrNameTyClDecl)] -> RnM d (NameEnv Version, DeclsMap) -loadDecls mod decls_map decls - = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls +loadDecls mod (decls_map, n_slurped) decls + = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls `thenRn` \ (vers, decls_map') -> + returnRn (vers, (decls_map', n_slurped)) -loadDecl :: Module - -> (NameEnv Version, DeclsMap) - -> (Version, RdrNameTyClDecl) - -> RnM d (NameEnv Version, DeclsMap) loadDecl mod (version_map, decls_map) (version, decl) = getIfaceDeclBinders mod decl `thenRn` \ full_avail -> let @@ -321,13 +317,18 @@ loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) -- Loading instance decls ----------------------------------------------------- -loadInstDecl :: Module - -> IfaceInsts - -> RdrNameInstDecl - -> RnM d IfaceInsts -loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) - = - -- Find out what type constructors and classes are "gates" for the +loadInstDecls :: Module + -> IfaceInsts + -> [RdrNameInstDecl] + -> RnM d IfaceInsts +loadInstDecls mod (insts, n_slurped) decls + = setModuleRn mod $ + foldlRn (loadInstDecl mod) insts decls `thenRn` \ insts' -> + returnRn (insts', n_slurped) + + +loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) + = -- Find out what type constructors and classes are "gates" for the -- instance declaration. If all these "gates" are slurped in then -- we should slurp the instance decl too. -- @@ -340,9 +341,8 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) munged_inst_ty = removeContext inst_ty free_names = extractHsTyRdrNames munged_inst_ty in - setModuleRn mod $ mapRn lookupIfaceName free_names `thenRn` \ gate_names -> - returnRn ((gate_names, (mod, InstD decl)) `consBag` insts) + returnRn ((gate_names, (mod, decl)) `consBag` insts) -- In interface files, the instance decls now look like @@ -363,20 +363,20 @@ removeFuns ty = ty loadRules :: Module -> IfaceRules -> (Version, [RdrNameRuleDecl]) -> RnM d (Version, IfaceRules) -loadRules mod rule_bag (version, rules) +loadRules mod (rule_bag, n_slurped) (version, rules) | null rules || opt_IgnoreIfacePragmas - = returnRn (version, rule_bag) + = returnRn (version, (rule_bag, n_slurped)) | otherwise = setModuleRn mod $ mapRn (loadRule mod) rules `thenRn` \ new_rules -> - returnRn (version, rule_bag `unionBags` listToBag new_rules) + returnRn (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) -loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl +loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl) -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) = lookupIfaceName var `thenRn` \ var_name -> - returnRn ([var_name], (mod, RuleD decl)) + returnRn ([var_name], (mod, decl)) ----------------------------------------------------- diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index c8691df..91ce759 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -24,23 +24,25 @@ import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..), InstDecl(..), HsType(..), hsTyVarNames, getBangType ) import HsImpExp ( ImportDecl(..) ) -import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl ) -import RnHsSyn ( RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames, tyClDeclFVs ) +import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) +import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, + extractHsTyNames, extractHsCtxtTyNames, + tyClDeclFVs, ruleDeclFVs, instDeclFVs + ) import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface, loadOrphanModules ) -import RnSource ( rnTyClDecl, rnDecl ) +import RnSource ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl ) import RnEnv import RnMonad import Id ( idType ) -import DataCon ( classDataCon, dataConId ) import Type ( namesOfType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import Name ( Name {-instance NamedThing-}, nameOccName, nameModule, isLocalName, nameUnique, - NamedThing(..), + NamedThing(..) ) -import Name ( elemNameEnv ) +import Name ( elemNameEnv, delFromNameEnv ) import Module ( Module, ModuleEnv, moduleName, isModuleInThisPackage, ModuleName, WhereFrom(..), @@ -254,12 +256,7 @@ slurpImpDecls source_fvs slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) -> -- Then get everything else - closeDecls decls needed `thenRn` \ decls1 -> - - -- Finally, get any deferred data type decls - slurpDeferredDecls decls1 `thenRn` \ final_decls -> - - returnRn final_decls + closeDecls decls needed ------------------------------------------------------- @@ -280,24 +277,15 @@ slurpSourceRefs source_binders source_fvs -- and the instance decls -- The outer loop is needed because consider - -- instance Foo a => Baz (Maybe a) where ... - -- It may be that @Baz@ and @Maybe@ are used in the source module, - -- but not @Foo@; so we need to chase @Foo@ too. - -- - -- We also need to follow superclass refs. In particular, 'chasing @Foo@' must - -- include actually getting in Foo's class decl - -- class Wib a => Foo a where .. - -- so that its superclasses are discovered. The point is that Wib is a gate too. - -- We do this for tycons too, so that we look through type synonyms. go_outer decls fvs all_gates [] = returnRn (decls, fvs) go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet = traceRn (text "go_outer" <+> ppr refs) `thenRn_` + getImportedInstDecls all_gates `thenRn` \ inst_decls -> foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> - getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> - rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> + rnIfaceInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> go_outer decls2 fvs2 (all_gates `plusFV` gates2) (nameSetToList (gates2 `minusNameSet` all_gates)) -- Knock out the all_gates because even if we don't slurp any new @@ -308,21 +296,11 @@ slurpSourceRefs source_binders source_fvs case import_result of AlreadySlurped -> returnRn (decls, fvs, gates) InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing) - Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> returnRn (TyClD new_decl : decls, fvs1 `plusFV` fvs, gates `plusFV` getGates source_fvs new_decl) - -rnInstDecls decls fvs gates [] - = returnRn (decls, fvs, gates) -rnInstDecls decls fvs gates (d:ds) - = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnInstDecls (new_decl:decls) - (fvs1 `plusFV` fvs) - (gates `plusFV` getInstDeclGates new_decl) - ds \end{code} @@ -338,8 +316,9 @@ closeDecls decls needed = getImportedRules `thenRn` \ rule_decls -> case rule_decls of [] -> returnRn decls -- No new rules, so we are done - other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) -> - closeDecls decls1 needed1 + other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenRn` \ rule_decls' -> + closeDecls (map RuleD rule_decls' ++ decls) + (plusFVs (map ruleDeclFVs rule_decls')) ------------------------------------------------------- @@ -365,14 +344,15 @@ slurpDecl decls fvs wanted_name ------------------------------------------------------- -rnIfaceDecls :: [RenamedHsDecl] -> FreeVars - -> [(Module, RdrNameHsDecl)] - -> RnM d ([RenamedHsDecl], FreeVars) -rnIfaceDecls decls fvs [] = returnRn (decls, fvs) -rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds - -rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) +rnIfaceDecls rn decls = mapRn (rnIfaceDecl rn) decls +rnIfaceDecl rn (mod, decl) = initIfaceRnMS mod (rn decl) + +rnIfaceInstDecls decls fvs gates inst_decls + = rnIfaceDecls rnInstDecl inst_decls `thenRn` \ inst_decls' -> + returnRn (map InstD inst_decls' ++ decls, + fvs `plusFV` plusFVs (map instDeclFVs inst_decls'), + gates `plusFV` plusFVs (map getInstDeclGates inst_decls')) + rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ decl' -> returnRn (decl', tyClDeclFVs decl') \end{code} @@ -383,13 +363,18 @@ getSlurped = getIfacesRn `thenRn` \ ifaces -> returnRn (iSlurp ifaces) -recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = (imp_mods, imp_names) }) +recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), + iSlurp = slurped_names, + iVSlurp = (imp_mods, imp_names) }) avail = ASSERT2( not (isLocalName (availName avail)), ppr avail ) - ifaces { iSlurp = new_slurped_names, iVSlurp = new_vslurp } + ifaces { iDecls = (decls_map', n_slurped+1), + iSlurp = new_slurped_names, + iVSlurp = new_vslurp } where - main_name = availName avail - mod = nameModule main_name + decls_map' = foldl delFromNameEnv decls_map (availNames avail) + main_name = availName avail + mod = nameModule main_name new_slurped_names = addAvailToNameSet slurped_names avail new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names main_name) | otherwise = (extendModuleSet imp_mods mod, imp_names) @@ -406,53 +391,6 @@ recordLocalSlurps local_avails %********************************************************* %* * -\subsection{Deferred declarations} -%* * -%********************************************************* - -The idea of deferred declarations is this. Suppose we have a function - f :: T -> Int - data T = T1 A | T2 B - data A = A1 X | A2 Y - data B = B1 P | B2 Q -Then we don't want to load T and all its constructors, and all -the types those constructors refer to, and all the types *those* -constructors refer to, and so on. That might mean loading many more -interface files than is really necessary. So we 'defer' loading T. - -But f might be strict, and the calling convention for evaluating -values of type T depends on how many constructors T has, so -we do need to load T, but not the full details of the type T. -So we load the full decl for T, but only skeleton decls for A and B: - f :: T -> Int - data T = {- 2 constructors -} - -Whether all this is worth it is moot. - -\begin{code} -slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] -slurpDeferredDecls decls = returnRn decls - -{- OMIT FOR NOW -slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] -slurpDeferredDecls decls - = getDeferredDecls `thenRn` \ def_decls -> - rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) -> - ASSERT( isEmptyFVs fvs ) - returnRn decls1 - -stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2)) - = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc - name1 name2)) - -- Nuke the context and constructors - -- But retain the *number* of constructors! - -- Also the tvs will have kinds on them. --} -\end{code} - - -%********************************************************* -%* * \subsection{Extracting the `gates'} %* * %********************************************************* @@ -465,52 +403,64 @@ its 'head' are all available in the program being compiled. E.g. instance (..) => C (T1 a) (T2 b) where ... -is only useful if C, T1 and T2 are all available. So we keep +is only useful if C, T1 and T2 are all "available". So we keep instance decls that have been parsed from .hi files, but not yet slurped in, in a pool called the 'gated instance pool'. Each has its set of 'gates': {C, T1, T2} in the above example. -THE GATING INVARIANT +More precisely, the gates of a module are the types and classes +that are mentioned in: + + a) the source code + b) the type of an Id that's mentioned in the source code + [includes constructors and selectors] + c) the RHS of a type synonym that is a gate + d) the superclasses of a class that is a gate + e) the context of an instance decl that is slurped in + +We slurp in an instance decl from the gated instance pool iff + + all its gates are either in the gates of the module, + or are a previously-loaded class. - *All* the instances whose gates are entirely in the stuff that's - already been through the type checker (i.e. are already in the - Persistent Type Environment or Home Symbol Table) have already been - slurped in, and are no longer in the gated instance pool. +The latter constraint is because there might have been an instance +decl slurped in during an earlier compilation, like this: -Hence, when we read a new module, we see what new gates we have, -and let in any instance decls whose gates are - either in the new gates, - or in the HST/PTE + instance Foo a => Baz (Maybe a) where ... -An earlier optimisation: now infeasible -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the module being compiled we might need (Baz (Maybe T)), where T +is defined in this module, and hence we need (Foo T). So @Foo@ becomes +a gate. But there's no way to 'see' that, so we simply treat all +previously-loaded classes as gates. + +Consructors and class operations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we import a declaration like -\begin{verbatim} + data T = T1 Wibble | T2 Wobble -\end{verbatim} + we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless} -@T1@, @T2@ respectively are mentioned by the user program. If only +@T1@, @T2@ respectively are mentioned by the user program. If only @T@ is mentioned we want only @T@ to be a gate; that way we don't suck in useless instance decls for (say) @Eq Wibble@, when they can't possibly be useful. -BUT, I can't see how to do this and still maintain the GATING INVARIANT. -So I've simply ditched the optimisation to get things working. - - - +And that's just what (b) says: we only treat T1's type as a gate if +T1 is mentioned. getGates, which deals with decls we are slurping in, +has to be a bit careful, because a mention of T1 will slurp in T's whole +declaration. +----------------------------- @getGates@ takes a newly imported (and renamed) decl, and the free vars of the source program, and extracts from the decl the gate names. \begin{code} getGates :: FreeVars -- Things mentioned in the source program - -> RenamedHsDecl + -> RenamedTyClDecl -> FreeVars -get_gates source_fvs decl = get_gates (\n -> True) decl - -- We'd use (\n -> n `elemNameSet` source_fvs) - -- if we were using the 'earlier optimisation above +getGates source_fvs decl + = get_gates (\n -> n `elemNameSet` source_fvs) decl get_gates is_used (IfaceSig _ ty _ _) = extractHsTyNames ty @@ -569,38 +519,34 @@ get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _) get_bang bty = extractHsTyNames (getBangType bty) \end{code} -@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@ -rather than a declaration. +@getWiredInGates@ is just like @getGates@, but it sees a previously-loaded +thing rather than a declaration. \begin{code} getWiredInGates :: TyThing -> FreeVars -- The TyThing is one that we already have in our type environment, either -- a) because the TyCon or Id is wired in, or -- b) from a previous compile --- Either way, we might have instance decls in the (persistend) collection +-- Either way, we might have instance decls in the (persistent) collection -- of parsed-but-not-slurped instance decls that should be slurped in. -- This might be the first module that mentions both the type and the class -- for that instance decl, even though both the type and the class were -- mentioned in other modules, and hence are in the type environment -getWiredInGates (AnId the_id) = getWiredInGates_s (namesOfType (idType the_id)) -getWiredInGates (AClass cl) = namesOfType (idType (dataConId (classDataCon cl))) -- Cunning +getWiredInGates (AnId the_id) = namesOfType (idType the_id) +getWiredInGates (AClass cl) = emptyFVs -- The superclasses must also be previously + -- loaded, and hence are automatically gates getWiredInGates (ATyCon tc) - | isSynTyCon tc = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars)) + | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars) | otherwise = unitFV (getName tc) where (tyvars,ty) = getSynTyConDefn tc -getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) +getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty \end{code} \begin{code} -getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty -getInstDeclGates other = emptyFVs -\end{code} - -\begin{code} -getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)] +getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameInstDecl)] getImportedInstDecls gates = -- First, load any orphan-instance modules that aren't aready loaded -- Orphan-instance modules are recorded in the module dependecnies @@ -629,12 +575,12 @@ getImportedInstDecls gates where gate_list = nameSetToList gates -ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _)) +ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _) = case inst_ty of HsForAllTy _ _ tau -> ppr tau other -> ppr inst_ty -getImportedRules :: RnMG [(Module,RdrNameHsDecl)] +getImportedRules :: RnMG [(Module,RdrNameRuleDecl)] getImportedRules | opt_IgnoreIfacePragmas = returnRn [] | otherwise @@ -653,18 +599,24 @@ getImportedRules text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` returnRn decls -selectGated gates lookup decl_bag +selectGated gates lookup (decl_bag, n_slurped) -- Select only those decls whose gates are *all* in 'gates' - -- or are in the range of lookup + -- or are a class in 'lookup' #ifdef DEBUG | opt_NoPruneDecls -- Just to try the effect of not gating at all - = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all + = let + decls = foldrBag (\ (_,d) ds -> d:ds) [] decl_bag -- Grab them all + in + (decls, (emptyBag, n_slurped + length decls)) | otherwise #endif - = foldrBag select ([], emptyBag) decl_bag + = case foldrBag select ([], emptyBag) decl_bag of + (decls, new_bag) -> (decls, (new_bag, n_slurped + length decls)) where - available n = n `elemNameSet` gates || maybeToBool (lookup n) + available n = n `elemNameSet` gates + || case lookup n of { Just (AClass c) -> True; other -> False } + select (reqd, decl) (yes, no) | all available reqd = (decl:yes, no) | otherwise = (yes, (reqd,decl) `consBag` no) @@ -683,7 +635,6 @@ importDecl :: Name -> RnMG ImportDeclResult data ImportDeclResult = AlreadySlurped | InTypeEnv TyThing - | Deferred | HereItIs (Module, RdrNameTyClDecl) importDecl name @@ -700,10 +651,10 @@ importDecl name -> -- When we find a wired-in name we must load its home -- module so that we find any instance decls lurking therein loadHomeInterface wi_doc name `thenRn_` - returnRn (InTypeEnv (getWiredInGates ty_thing)) + returnRn (InTypeEnv ty_thing) | otherwise - -> returnRn (InTypeEnv ty_thing) ; + -> returnRn (InTypeEnv ty_thing) ; Nothing -> @@ -720,7 +671,10 @@ importDecl name getIfacesRn `thenRn` \ ifaces -> -- STEP 5: Get the declaration out - case lookupNameEnv (iDecls ifaces) name of + let + (decls_map, _) = iDecls ifaces + in + case lookupNameEnv decls_map name of Just (avail,_,decl) -> setIfacesRn (recordSlurp ifaces avail) `thenRn_` returnRn (HereItIs decl) @@ -733,80 +687,8 @@ importDecl name wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name nd_doc = ptext SLIT("need decl for") <+> ppr name - -{- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS - Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _))) - -- This case deals with deferred import of algebraic data types - - | not opt_NoPruneTyDecls - - && (opt_IgnoreIfacePragmas || ncons > 1) - -- We only defer if imported interface pragmas are ingored - -- or if it's not a product type. - -- Sole reason: The wrapper for a strict function may need to look - -- inside its arg, and hence need to see its arg type's constructors. - - && not (getUnique tycon_name `elem` cCallishTyKeys) - -- Never defer ccall types; we have to unbox them, - -- and importing them does no harm - - - -> -- OK, so we're importing a deferrable data type - if needed_name == tycon_name - -- The needed_name is the TyCon of a data type decl - -- Record that it's slurped, put it in the deferred set - -- and don't return a declaration at all - setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces - `addOneToNameSet` tycon_name}) - version (AvailTC needed_name [needed_name])) `thenRn_` - returnRn Deferred - - else - -- The needed name is a constructor of a data type decl, - -- getting a constructor, so remove the TyCon from the deferred set - -- (if it's there) and return the full declaration - setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces - `delFromNameSet` tycon_name}) - version avail) `thenRn_` - returnRn (HereItIs decl) - where - tycon_name = availName avail --} - -{- OMIT FOR NOW -getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)] -getDeferredDecls - = getIfacesRn `thenRn` \ ifaces -> - let - decls_map = iDecls ifaces - deferred_names = nameSetToList (iDeferred ifaces) - get_abstract_decl n = case lookupNameEnv decls_map n of - Just (_, _, _, decl) -> decl - in - traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))]) `thenRn_` - returnRn (map get_abstract_decl deferred_names) --} \end{code} -@getWiredInDecl@ maps a wired-in @Name@ to what it makes available. -It behaves exactly as if the wired in decl were actually in an interface file. -Specifically, -\begin{itemize} -\item if the wired-in name is a data type constructor or a data constructor, - it brings in the type constructor and all the data constructors; and - marks as ``occurrences'' any free vars of the data con. - -\item similarly for synonum type constructor - -\item if the wired-in name is another wired-in Id, it marks as ``occurrences'' - the free vars of the Id's type. - -\item it loads the interface file for the wired-in thing for the - sole purpose of making sure that its instance declarations are available -\end{itemize} -All this is necessary so that we know all types that are ``in play'', so -that we know just what instances to bring into scope. - %******************************************************** %* * diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 20c6c10..5694475 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -543,8 +543,4 @@ co_rec_ify binds = StgRec (concat (map f binds)) getScBinds :: LiftInfo -> [StgBinding] getScBinds binds = bagToList binds - -looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ _ ls _)] (StgApp f' args) - = (f == f') && (length args == length ls) -looksLikeSATRhs _ _ = False \end{code} diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 7fd03ea..07c5be3 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -23,7 +23,7 @@ import CmdLineOpts ( DynFlags, DynFlag(..), dopt, StgToDo(..), dopt_StgToDo ) import Id ( Id ) -import Module ( Module, moduleString ) +import Module ( Module ) import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn ) import UniqSupply ( splitUniqSupply, UniqSupply ) import IO ( hPutStr, stdout ) diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 6b3f65f..2056be2 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -17,8 +17,7 @@ import Id ( setIdArityInfo, idArity, setIdOccInfo, Id ) import VarSet import VarEnv import Var -import IdInfo ( ArityInfo(..), OccInfo(..), - setInlinePragInfo ) +import IdInfo ( ArityInfo(..), OccInfo(..) ) import PrimOp ( PrimOp(..), ccallMayGC ) import TysWiredIn ( isForeignObjTy ) import Maybes ( maybeToBool, orElse ) diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 6a72b9e..433ab2a 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -10,7 +10,7 @@ module StgLint ( lintStgBindings ) where import StgSyn -import Bag ( Bag, emptyBag, isEmptyBag, snocBag, foldBag ) +import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import Id ( Id, idType ) import VarSet import DataCon ( DataCon, dataConArgTys, dataConRepType ) @@ -22,7 +22,7 @@ import ErrUtils ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErr import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, isUnLiftedType, isTyVarTy, splitForAllTys, Type ) -import TyCon ( TyCon, isDataTyCon ) +import TyCon ( TyCon ) import Util ( zipEqual ) import Outputable @@ -389,8 +389,6 @@ addInScopeVars ids m loc scope errs -- a real error out of it... let new_set = mkVarSet ids - - shadowed = scope `intersectVarSet` new_set in -- After adding -fliberate-case, Simon decided he likes shadowed -- names after all. WDP 94/07 diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index 7e485c9..ac9c267 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -21,7 +21,7 @@ module SaLib ( import Type ( Type ) import VarEnv import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand, pprDemands ) +import Demand ( Demand ) import Outputable \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index cd59646..e068f8a 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -10,13 +10,16 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" -import HsSyn ( HsBinds(..), MonoBinds(..), collectLocatedMonoBinders ) +import HsSyn ( HsBinds(..), MonoBinds(..), TyClDecl(..), + collectLocatedMonoBinders ) import RdrHsSyn ( RdrNameMonoBinds ) -import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds ) +import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl ) import CmdLineOpts ( DynFlag(..), DynFlags ) import TcMonad -import TcEnv ( TcEnv, tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo ) +import TcEnv ( TcEnv, tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo, + tcLookupClass, tcLookupTyCon + ) import TcGenDeriv -- Deriv stuff import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv ) import TcSimplify ( tcSimplifyThetas ) @@ -35,19 +38,20 @@ import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon ) import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool, catMaybes ) import Module ( Module ) -import Name ( Name, isFrom, getSrcLoc ) +import Name ( Name, getSrcLoc ) import RdrName ( RdrName ) -import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, +import TyCon ( tyConTyVars, tyConDataCons, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, TyCon ) import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp, isUnboxedType ) import Var ( TyVar ) import PrelNames -import Util ( zipWithEqual, sortLt, thenCmp ) +import Util ( zipWithEqual, sortLt ) import ListSetOps ( removeDups, assoc ) import Outputable +import List ( nub ) \end{code} %************************************************************************ @@ -181,16 +185,16 @@ tcDeriving :: PersistentRenamerState -> Module -- name of module under scrutiny -> InstEnv -- What we already know about instances -> (Name -> Maybe Fixity) -- used in deriving Show and Read - -> [TyCon] -- All type constructors + -> [RenamedTyClDecl] -- All type constructors -> TcM ([InstInfo], -- The generated "instance decls". RenamedHsBinds) -- Extra generated bindings -tcDeriving prs mod inst_env_in get_fixity tycons +tcDeriving prs mod inst_env_in get_fixity tycl_decls = recoverTc (returnTc ([], EmptyBinds)) $ -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - makeDerivEqns mod tycons `thenTc` \ eqns -> + makeDerivEqns mod tycl_decls `thenTc` \ eqns -> if null eqns then returnTc ([], EmptyBinds) else @@ -273,68 +277,57 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: Module -> [TyCon] -> TcM [DerivEqn] +makeDerivEqns :: Module -> [RenamedTyClDecl] -> TcM [DerivEqn] -makeDerivEqns this_mod tycons - = let - think_about_deriving = need_deriving tycons - (derive_these, _) = removeDups cmp_deriv think_about_deriving - in - if null think_about_deriving then - returnTc [] -- Bale out now - else - mapTc mk_eqn derive_these `thenTc` \ maybe_eqns -> +makeDerivEqns this_mod tycl_decls + = mapTc mk_eqn derive_these `thenTc` \ maybe_eqns -> returnTc (catMaybes maybe_eqns) where ------------------------------------------------------------------ - need_deriving :: [TyCon] -> [(Class, TyCon)] - -- find the tycons that have `deriving' clauses; - - need_deriving tycons_to_consider - = [ (clas,tycon) | tycon <- tycons_to_consider, - isFrom this_mod tycon, - clas <- tyConDerivings tycon ] + derive_these :: [(Name, Name)] + -- Find the (Class,TyCon) pairs that must be `derived' + -- NB: only source-language decls have deriving, no imported ones do + derive_these = [ (clas,tycon) + | TyData _ _ tycon _ _ _ (Just classes) _ _ _ <- tycl_decls, + clas <- nub classes ] ------------------------------------------------------------------ - cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> Ordering - cmp_deriv (c1, t1) (c2, t2) - = (c1 `compare` c2) `thenCmp` (t1 `compare` t2) - - ------------------------------------------------------------------ - mk_eqn :: (Class, TyCon) -> NF_TcM (Maybe DerivEqn) + mk_eqn :: (Name, Name) -> NF_TcM (Maybe DerivEqn) -- we swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation - mk_eqn (clas, tycon) - = case chk_out clas tycon of + mk_eqn (clas_name, tycon_name) + = tcLookupClass clas_name `thenNF_Tc` \ clas -> + tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> + let + clas_key = classKey clas + tyvars = tyConTyVars tycon + tyvar_tys = mkTyVarTys tyvars + ty = mkTyConApp tycon tyvar_tys + data_cons = tyConDataCons tycon + locn = getSrcLoc tycon + constraints = extra_constraints ++ concat (map mk_constraints data_cons) + + -- "extra_constraints": see notes above about contexts on data decls + extra_constraints + | offensive_class = tyConTheta tycon + | otherwise = [] + + offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys + + mk_constraints data_con + = [ (clas, [arg_ty]) + | arg_ty <- dataConArgTys data_con tyvar_tys, + not (isUnboxedType arg_ty) -- No constraints for unboxed types? + ] + in + case chk_out clas tycon of Just err -> addErrTc err `thenNF_Tc_` returnNF_Tc Nothing Nothing -> newDFunName this_mod clas [ty] locn `thenNF_Tc` \ dfun_name -> returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints)) - where - clas_key = classKey clas - tyvars = tyConTyVars tycon - tyvar_tys = mkTyVarTys tyvars - ty = mkTyConApp tycon tyvar_tys - data_cons = tyConDataCons tycon - locn = getSrcLoc tycon - - constraints = extra_constraints ++ concat (map mk_constraints data_cons) - - -- "extra_constraints": see notes above about contexts on data decls - extra_constraints - | offensive_class = tyConTheta tycon - | otherwise = [] - where - offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys - mk_constraints data_con - = [ (clas, [arg_ty]) - | arg_ty <- instd_arg_tys, - not (isUnboxedType arg_ty) -- No constraints for unboxed types? - ] - where - instd_arg_tys = dataConArgTys data_con tyvar_tys + ------------------------------------------------------------------ chk_out :: Class -> TyCon -> Maybe Message diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 0280341..54967ac 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -33,7 +33,7 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv, InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, newDFunName, tcExtendTyVarEnv ) -import InstEnv ( InstEnv, classDataCon, extendInstEnv ) +import InstEnv ( InstEnv, extendInstEnv ) import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( zonkTcSigTyVars ) @@ -42,6 +42,7 @@ import HscTypes ( HomeSymbolTable, DFunId, ) import Bag ( unionManyBags ) +import DataCon ( classDataCon ) import Class ( Class, DefMeth(..), classBigSig ) import Var ( idName, idType ) import Maybes ( maybeToBool ) @@ -52,7 +53,7 @@ import Name ( getSrcLoc ) import NameSet ( emptyNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) import PprType ( pprConstraint, pprPred ) -import TyCon ( TyCon, isSynTyCon, tyConDerivings ) +import TyCon ( TyCon, isSynTyCon ) import Type ( splitDFunTy, isTyVarTy, splitTyConApp_maybe, splitDictTy, splitAlgTyConApp_maybe, splitForAllTys, @@ -172,8 +173,9 @@ tcInstDecls1 :: PackageInstEnv tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls = let - inst_decls = [inst_decl | InstD inst_decl <- decls] - clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl] + inst_decls = [inst_decl | InstD inst_decl <- decls] + tycl_decls = [decl | TyClD decl <- decls] + clas_decls = filter isClassDecl tycl_decls in -- (1) Do the ordinary instance declarations mapNF_Tc (tcInstDecl1 mod unf_env) inst_decls `thenNF_Tc` \ inst_infos -> @@ -205,7 +207,7 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls -- we ignore deriving decls from interfaces! -- This stuff computes a context for the derived instance decl, so it -- needs to know about all the instances possible; hecne inst_env4 - tcDeriving prs mod inst_env4 get_fixity tycons `thenTc` \ (deriv_inst_info, deriv_binds) -> + tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) -> addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env -> returnTc (inst_env1, @@ -687,13 +689,6 @@ scrutiniseInstanceHead clas inst_taus && not (creturnable_type first_inst_tau)) -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau) - -- DERIVING CHECK - -- It is obviously illegal to have an explicit instance - -- for something that we are also planning to `derive' - | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon) - -> addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau) - -- Kind check will have ensured inst_taus is of length 1 - -- Allow anything for AllowUndecidableInstances | dopt Opt_AllowUndecidableInstances dflags -> returnNF_Tc () @@ -790,12 +785,6 @@ instTypeErr clas tys msg nest 4 (parens msg) ] -derivingWhenInstanceExistsErr clas tycon - = hang (hsep [ptext SLIT("Deriving class"), - quotes (ppr clas), - ptext SLIT("type"), quotes (ppr tycon)]) - 4 (ptext SLIT("when an explicit instance exists")) - nonBoxedPrimCCallErr clas inst_ty = hang (ptext SLIT("Unacceptable instance type for ccall-ish class")) 4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"), diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index b2d82be..24896ab 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -88,13 +88,9 @@ tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc -- Typecheck the pieces tcClassContext context `thenTc` \ ctxt -> - tc_derivs derivings `thenTc` \ derived_classes -> mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> - returnTc (tycon_name, DataTyDetails ctxt data_cons derived_classes) - where - tc_derivs Nothing = returnTc [] - tc_derivs (Just ds) = mapTc tcLookupClass ds + returnTc (tycon_name, DataTyDetails ctxt data_cons) \end{code} \begin{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 624c9c7..ccd7618 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -31,7 +31,6 @@ module TyCon( tyConArgVrcs_maybe, tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize, - tyConDerivings, tyConTheta, tyConPrimRep, tyConArity, @@ -55,7 +54,7 @@ import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind ) import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) -import Class ( Class, ClassContext ) +import Class ( ClassContext ) import Var ( TyVar, Id ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, EP(..) ) @@ -110,8 +109,6 @@ data TyCon -- abstractly we still need to know the number of constructors -- so we can get the return convention right. Tiresome! - algTyConDerivings :: [Class], -- Classes which have derived instances - algTyConFlavour :: AlgTyConFlavour, algTyConRec :: RecFlag, -- Tells whether the data type is part of -- a mutually-recursive group or not @@ -243,7 +240,7 @@ tyConGenIds tycon = case tyConGenInfo tycon of -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyConRep name kind tyvars theta argvrcs cons ncons derivs flavour rec +mkAlgTyConRep name kind tyvars theta argvrcs cons ncons flavour rec gen_info = AlgTyCon { tyConName = name, @@ -255,7 +252,6 @@ mkAlgTyConRep name kind tyvars theta argvrcs cons ncons derivs flavour rec algTyConTheta = theta, dataCons = cons, noOfDataCons = ncons, - algTyConDerivings = derivs, algTyConClass = False, algTyConFlavour = flavour, algTyConRec = rec, @@ -273,7 +269,6 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour algTyConTheta = [], dataCons = [con], noOfDataCons = 1, - algTyConDerivings = [], algTyConClass = True, algTyConFlavour = flavour, algTyConRec = NonRecursive, @@ -414,12 +409,6 @@ tyConPrimRep _ = PtrRep \end{code} \begin{code} -tyConDerivings :: TyCon -> [Class] -tyConDerivings (AlgTyCon {algTyConDerivings = derivs}) = derivs -tyConDerivings other = [] -\end{code} - -\begin{code} tyConTheta :: TyCon -> ClassContext tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta -- should ask about anything else diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 5a675a4..dde73b1 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -860,7 +860,7 @@ namesOfType (NoteTy other_note ty2) = namesOfType ty2 namesOfType (PredTy p) = namesOfType (predRepTy p) namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg -namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar) +namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys \end{code} diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index cd3a956..9ad57cc 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -26,7 +26,7 @@ module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, import CoreSyn import CoreFVs ( mustHaveLocalBinding ) -import Var ( Var, varName, varType, setVarType, mkUVar ) +import Var ( Var, varType, setVarType, mkUVar ) import Id ( isExportedId ) import Name ( isLocallyDefined ) import TypeRep ( Type(..), TyNote(..) ) -- friend -- 1.7.10.4