diff options
149 files changed, 7731 insertions, 14535 deletions
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 04c8d8b618..c91154f10d 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -232,7 +232,7 @@ CLEAN_FILES += $(CONFIG_HS) ALL_DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ - profiling parser cprAnalysis compMan ndpFlatten cbits + profiling parser cprAnalysis compMan ndpFlatten cbits iface # Make sure we include Config.hs even if it doesn't exist yet... ALL_SRCS += $(CONFIG_HS) @@ -345,7 +345,9 @@ endif # The standard suffix rule for compiling a Haskell file # adds these flags to the command line -prelude/PrimOp_HC_OPTS = -no-recomp -H80m +# There used to be a -no-recomp flag on PrimOp, but why? +# It's an expensive module to recompile! +prelude/PrimOp_HC_OPTS = -H80m # because the NCG can't handle the 64-bit math in here prelude/PrelRules_HC_OPTS = -fvia-C diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index f842d195d7..24067c0a87 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -423,13 +423,6 @@ flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt) \end{code} -\begin{code} -flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC) -flat_maybe Nothing = returnFlt (Nothing, AbsCNop) -flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) -> - returnFlt (Just heres, tops) -\end{code} - %************************************************************************ %* * \subsection[flat-simultaneous]{Doing things simultaneously} @@ -606,6 +599,7 @@ mkHalfWord_HIADDR res arg let hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2) +# if WORDS_BIGENDIAN a_hw_mask1 = CMachOpStmt t_hw_mask1 MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing @@ -613,12 +607,11 @@ mkHalfWord_HIADDR res arg = CMachOpStmt t_hw_mask2 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing final -# if WORDS_BIGENDIAN = CSequential [ a_hw_mask1, a_hw_mask2, CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing ] # else - = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing + final = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing # endif in returnFlt final diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index bea6d67193..76b1f43f29 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -846,9 +846,7 @@ pprFCall call uniq args results vol_regs ] DNCall (DNCallSpec isStatic kind assem nm argTys resTy) -> let - target = StaticTarget (mkFastString nm) resultVar = "_ccall_result" - hasAssemArg = isStatic || kind == DNConstructor invokeOp = case kind of diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index de65b85984..cb08941c0c 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -17,10 +17,12 @@ module BasicTypes( Version, bumpVersion, initialVersion, bogusVersion, Arity, + + DeprecTxt, Unused, unused, - FixitySig(..), Fixity(..), FixityDirection(..), + Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, arrowFixity, negateFixity, negatePrecedence, compareFixity, @@ -29,11 +31,13 @@ module BasicTypes( NewOrData(..), - RecFlag(..), isRec, isNonRec, + RecFlag(..), isRec, isNonRec, boolToRecFlag, TopLevelFlag(..), isTopLevel, isNotTopLevel, - Boxity(..), isBoxed, tupleParens, + Boxity(..), isBoxed, + + TupCon(..), tupParens, tupleParens, OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, isDeadOcc, isLoopBreaker, @@ -53,8 +57,8 @@ module BasicTypes( #include "HsVersions.h" +import FastString( FastString ) import Outputable -import SrcLoc \end{code} %************************************************************************ @@ -96,15 +100,23 @@ type Version = Int bogusVersion :: Version -- Shouldn't look at these bogusVersion = error "bogusVersion" -bumpVersion :: Bool -> Version -> Version --- Bump if the predicate (typically equality between old and new) is false -bumpVersion False v = v+1 -bumpVersion True v = v +bumpVersion :: Version -> Version +bumpVersion v = v+1 initialVersion :: Version initialVersion = 1 \end{code} +%************************************************************************ +%* * + Deprecations +%* * +%************************************************************************ + + +\begin{code} +type DeprecTxt = FastString -- reason/explanation for deprecation +\end{code} %************************************************************************ %* * @@ -130,9 +142,13 @@ ipNameName (Linear n) = n mapIPName :: (a->b) -> IPName a -> IPName b mapIPName f (Dupable n) = Dupable (f n) mapIPName f (Linear n) = Linear (f n) + +instance Outputable name => Outputable (IPName name) where + ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters + ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters \end{code} - + %************************************************************************ %* * \subsection[Fixity]{Fixity info} @@ -141,15 +157,6 @@ mapIPName f (Linear n) = Linear (f n) \begin{code} ------------------------ -data FixitySig name = FixitySig name Fixity SrcLoc - -instance Eq name => Eq (FixitySig name) where - (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2 - -instance Outputable name => Outputable (FixitySig name) where - ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] - ------------------------- data Fixity = Fixity Int FixityDirection instance Outputable Fixity where @@ -219,6 +226,10 @@ data NewOrData = NewType -- "newtype Blah ..." | DataType -- "data Blah ..." deriving( Eq ) -- Needed because Demand derives Eq + +instance Outputable NewOrData where + ppr NewType = ptext SLIT("newtype") + ppr DataType = ptext SLIT("data") \end{code} @@ -240,8 +251,13 @@ isNotTopLevel TopLevel = False isTopLevel TopLevel = True isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = ptext SLIT("<TopLevel>") + ppr NotTopLevel = ptext SLIT("<NotTopLevel>") \end{code} + %************************************************************************ %* * \subsection[Top-level/local]{Top-level/not-top level flag} @@ -257,10 +273,6 @@ data Boxity isBoxed :: Boxity -> Bool isBoxed Boxed = True isBoxed Unboxed = False - -tupleParens :: Boxity -> SDoc -> SDoc -tupleParens Boxed p = parens p -tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \end{code} @@ -273,6 +285,7 @@ tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \begin{code} data RecFlag = Recursive | NonRecursive + deriving( Eq ) isRec :: RecFlag -> Bool isRec Recursive = True @@ -281,6 +294,34 @@ isRec NonRecursive = False isNonRec :: RecFlag -> Bool isNonRec Recursive = False isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = ptext SLIT("Recursive") + ppr NonRecursive = ptext SLIT("NonRecursive") +\end{code} + +%************************************************************************ +%* * + Tuples +%* * +%************************************************************************ + +\begin{code} +data TupCon = TupCon Boxity Arity + +instance Eq TupCon where + (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2 + +tupParens :: TupCon -> SDoc -> SDoc +tupParens (TupCon b _) p = tupleParens b p + +tupleParens :: Boxity -> SDoc -> SDoc +tupleParens Boxed p = parens p +tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \end{code} %************************************************************************ @@ -290,7 +331,7 @@ isNonRec NonRecursive = True %************************************************************************ This is the "Embedding-Projection pair" datatype, it contains -two pieces of code (normally either RenamedHsExpr's or Id's) +two pieces of code (normally either RenamedExpr's or Id's) If we have a such a pair (EP from to), the idea is that 'from' and 'to' represents functions of type @@ -400,12 +441,10 @@ The strictness annotations on types in data type declarations e.g. data T = MkT !Int !(Bool,Bool) \begin{code} -data StrictnessMark - = MarkedUserStrict -- "!" in a source decl - | MarkedUserUnboxed -- "!!" in a source decl - | MarkedStrict -- "!" in an interface decl: strict but not unboxed - | MarkedUnboxed -- "!!" in an interface decl: unboxed - | NotMarkedStrict -- No annotation at all +data StrictnessMark -- Used in interface decls only + = MarkedStrict + | MarkedUnboxed + | NotMarkedStrict deriving( Eq ) isMarkedUnboxed MarkedUnboxed = True @@ -415,10 +454,9 @@ isMarkedStrict NotMarkedStrict = False isMarkedStrict other = True -- All others are strict instance Outputable StrictnessMark where - ppr MarkedUserStrict = ptext SLIT("!u") ppr MarkedStrict = ptext SLIT("!") - ppr MarkedUnboxed = ptext SLIT("! !") - ppr NotMarkedStrict = empty + ppr MarkedUnboxed = ptext SLIT("!!") + ppr NotMarkedStrict = ptext SLIT("_") \end{code} diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index c2e51761d5..b9dcca2a62 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -5,16 +5,16 @@ \begin{code} module DataCon ( - DataCon, + DataCon, DataConIds(..), ConTag, fIRST_TAG, mkDataCon, dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon, dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys, dataConRepArgTys, dataConTheta, - dataConFieldLabels, dataConStrictMarks, + dataConFieldLabels, dataConStrictMarks, dataConExStricts, dataConSourceArity, dataConRepArity, dataConNumInstArgs, - dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, dataConRepStrictness, isNullaryDataCon, isTupleCon, isUnboxedTupleCon, isExistentialDataCon, classDataCon, dataConExistentialTyVars, @@ -29,11 +29,11 @@ import {-# SOURCE #-} PprType( pprType ) import Type ( Type, ThetaType, mkForAllTys, mkFunTys, mkTyConApp, - mkTyVarTys, splitTyConApp_maybe, repType, - mkPredTys, isStrictType + mkTyVarTys, splitTyConApp_maybe, + mkPredTys, isStrictPred ) import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) + isTupleTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique ) import Var ( TyVar, Id ) @@ -41,7 +41,6 @@ import FieldLabel ( FieldLabel ) import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) -import Maybes ( orElse ) import ListSetOps ( assoc ) import Util ( zipEqual, zipWithEqual, notNull ) \end{code} @@ -217,7 +216,7 @@ data DataCon -- "Stupid", because the dictionaries aren't used for anything. -- -- Indeed, [as of March 02] they are no - -- longer in the type of the dcWrapId, because + -- longer in the type of the wrapper Id, because -- that makes it harder to use the wrap-id to rebuild -- values after record selection or in generics. @@ -228,41 +227,59 @@ data DataCon -- (before unboxing and flattening of -- strict fields) - dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening, - -- and including existential dictionaries - - dcRepStrictness :: [StrictnessMark], -- One for each representation argument - - dcTyCon :: TyCon, -- Result tycon - -- Now the strictness annotations and field labels of the constructor dcStrictMarks :: [StrictnessMark], - -- Strictness annotations as deduced by the compiler. - -- Has no MarkedUserStrict; they have been changed to MarkedStrict - -- or MarkedUnboxed by the compiler. - -- *Includes the existential dictionaries* - -- length = length dcExTheta + dataConSourceArity dataCon + -- Strictness annotations as decided by the compiler. + -- Does *not* include the existential dictionaries + -- length = dataConSourceArity dataCon dcFields :: [FieldLabel], -- Field labels for this constructor, in the -- same order as the argument types; -- length = 0 (if not a record) or dataConSourceArity. + -- Constructor representation + dcRepArgTys :: [Type], -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* existential dictionaries + + dcRepStrictness :: [StrictnessMark], -- One for each representation argument + + dcTyCon :: TyCon, -- Result tycon + -- Finally, the curried worker function that corresponds to the constructor -- It doesn't have an unfolding; the code generator saturates these Ids -- and allocates a real constructor when it finds one. -- -- An entirely separate wrapper function is built in TcTyDecls - dcWorkId :: Id, -- The corresponding worker Id - -- Takes dcRepArgTys as its arguments - -- Perhaps this should be a 'Maybe'; not reqd for newtype constructors - - dcWrapId :: Maybe Id -- The wrapper Id, if it's necessary - -- It's deemed unnecessary if it performs the - -- identity function + dcIds :: DataConIds } +data DataConIds + = NewDC Id -- Newtypes have only a wrapper, but no worker + | AlgDC (Maybe Id) Id -- Algebraic data types always have a worker, and + -- may or may not have a wrapper, depending on whether + -- the wrapper does anything. + + -- *Neither* the worker *nor* the wrapper take the dcStupidTheta dicts as arguments + + -- The wrapper takes dcOrigArgTys as its arguments + -- The worker takes dcRepArgTys as its arguments + -- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys + + -- The 'Nothing' case of AlgDC is important + -- Not only is this efficient, + -- but it also ensures that the wrapper is replaced + -- by the worker (becuase it *is* the wroker) + -- even when there are no args. E.g. in + -- f (:) x + -- the (:) *is* the worker. + -- This is really important in rule matching, + -- (We could match on the wrappers, + -- but that makes it less likely that rules will match + -- when we bring bits of unfoldings together.) + type ConTag = Int fIRST_TAG :: ConTag @@ -330,15 +347,15 @@ mkDataCon :: Name -> [TyVar] -> ThetaType -> [TyVar] -> ThetaType -> [Type] -> TyCon - -> Id -> Maybe Id -- Worker and possible wrapper + -> DataConIds -> DataCon -- Can get the tag from the TyCon mkDataCon name - arg_stricts -- Use [] to mean 'all non-strict' + arg_stricts -- Must match orig_arg_tys 1-1 fields tyvars theta ex_tyvars ex_theta orig_arg_tys tycon - work_id wrap_id + ids = con where con = MkData {dcName = name, @@ -347,9 +364,9 @@ mkDataCon name dcOrigArgTys = orig_arg_tys, dcRepArgTys = rep_arg_tys, dcExTyVars = ex_tyvars, dcExTheta = ex_theta, - dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_stricts, + dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty, - dcWorkId = work_id, dcWrapId = wrap_id} + dcIds = ids} -- Strictness marks for source-args -- *after unboxing choices*, @@ -359,11 +376,8 @@ mkDataCon name -- source-language arguments. We add extra ones for the -- dictionary arguments right here. ex_dict_tys = mkPredTys ex_theta - real_stricts = map mk_dict_strict_mark ex_dict_tys ++ - zipWith (chooseBoxingStrategy tycon) - orig_arg_tys - (arg_stricts ++ repeat NotMarkedStrict) - real_arg_tys = ex_dict_tys ++ orig_arg_tys + real_arg_tys = ex_dict_tys ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark ex_theta ++ arg_stricts -- Representation arguments and demands (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys @@ -375,8 +389,8 @@ mkDataCon name result_ty = mkTyConApp tycon (mkTyVarTys tyvars) -mk_dict_strict_mark ty | isStrictType ty = MarkedStrict - | otherwise = NotMarkedStrict +mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict + | otherwise = NotMarkedStrict \end{code} \begin{code} @@ -393,16 +407,27 @@ dataConRepType :: DataCon -> Type dataConRepType = dcRepType dataConWorkId :: DataCon -> Id -dataConWorkId = dcWorkId +dataConWorkId dc = case dcIds dc of + AlgDC _ wrk_id -> wrk_id + NewDC _ -> pprPanic "dataConWorkId" (ppr dc) dataConWrapId_maybe :: DataCon -> Maybe Id -dataConWrapId_maybe = dcWrapId +dataConWrapId_maybe dc = case dcIds dc of + AlgDC mb_wrap _ -> mb_wrap + NewDC wrap -> Just wrap dataConWrapId :: DataCon -> Id -- Returns an Id which looks like the Haskell-source constructor --- If there is no dcWrapId it's because there is no need for a --- wrapper, so the worker is the Right Thing -dataConWrapId dc = dcWrapId dc `orElse` dcWorkId dc +dataConWrapId dc = case dcIds dc of + AlgDC (Just wrap) _ -> wrap + AlgDC Nothing wrk -> wrk -- worker=wrapper + NewDC wrap -> wrap + +dataConImplicitIds :: DataCon -> [Id] +dataConImplicitIds dc = case dcIds dc of + AlgDC (Just wrap) work -> [wrap,work] + AlgDC Nothing work -> [work] + NewDC wrap -> [wrap] dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields @@ -410,6 +435,11 @@ dataConFieldLabels = dcFields dataConStrictMarks :: DataCon -> [StrictnessMark] dataConStrictMarks = dcStrictMarks +dataConExStricts :: DataCon -> [StrictnessMark] +-- Strictness of *existential* arguments only +-- Usually empty, so we don't bother to cache this +dataConExStricts dc = map mk_dict_strict_mark (dcExTheta dc) + -- Number of type-instantiation arguments -- All the remaining arguments of the DataCon are (notionally) -- stored in the DataCon, and are matched in a case expression @@ -541,40 +571,8 @@ splitProductType str ty Just stuff -> stuff Nothing -> pprPanic (str ++ ": not a product") (pprType ty) --- We attempt to unbox/unpack a strict field when either: --- (i) The tycon is imported, and the field is marked '! !', or --- (ii) The tycon is defined in this module, the field is marked '!', --- and the -funbox-strict-fields flag is on. --- --- This ensures that if we compile some modules with -funbox-strict-fields and --- some without, the compiler doesn't get confused about the constructor --- representations. - -chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark - -- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict -chooseBoxingStrategy tycon arg_ty strict - = case strict of - MarkedUserStrict -> MarkedStrict - MarkedUserUnboxed - | can_unbox -> MarkedUnboxed - | otherwise -> MarkedStrict - other -> strict - where - can_unbox = unbox arg_ty - -- beware: repType will go into a loop if we try this on a recursive - -- type (for reasons unknown...), hence the check for recursion below. - unbox ty = - case splitTyConApp_maybe ty of - Nothing -> False - Just (arg_tycon, _) - | isRecursiveTyCon arg_tycon -> False - | otherwise -> - case splitTyConApp_maybe (repType ty) of - Nothing -> False - Just (arg_tycon, _) -> isProductTyCon arg_tycon computeRep :: [StrictnessMark] -- Original arg strictness - -- [after strategy choice; can't be MarkedUserStrict] -> [Type] -- and types -> ([StrictnessMark], -- Representation arg strictness [Type]) -- And type @@ -586,5 +584,5 @@ computeRep stricts tys unbox MarkedStrict ty = [(MarkedStrict, ty)] unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys where - (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty) + (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty \end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index b810376efa..3b36e58570 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -30,7 +30,6 @@ module Id ( isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, isDataConWorkId, isDataConWorkId_maybe, - isDataConWrapId, isDataConWrapId_maybe, isBottomingId, hasNoBinding, @@ -90,8 +89,7 @@ import Var ( Id, DictId, globalIdDetails, setGlobalIdDetails ) import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId ) -import Type ( Type, typePrimRep, addFreeTyVars, - seqType, splitTyConApp_maybe ) +import Type ( Type, typePrimRep, addFreeTyVars, seqType) import IdInfo @@ -238,6 +236,7 @@ Meanwhile, it is not discarded as dead code. recordSelectorFieldLabel :: Id -> FieldLabel recordSelectorFieldLabel id = case globalIdDetails id of RecordSelId lbl -> lbl + other -> panic "recordSelectorFieldLabel" isRecordSelector id = case globalIdDetails id of RecordSelId lbl -> True @@ -267,14 +266,6 @@ isDataConWorkId_maybe id = case globalIdDetails id of DataConWorkId con -> Just con other -> Nothing -isDataConWrapId_maybe id = case globalIdDetails id of - DataConWrapId con -> Just con - other -> Nothing - -isDataConWrapId id = case globalIdDetails id of - DataConWrapId con -> True - other -> False - -- hasNoBinding returns True of an Id which may not have a -- binding, even though it is defined in this module. -- Data constructor workers used to be things of this kind, but @@ -297,7 +288,6 @@ isImplicitId id FCallId _ -> True PrimOpId _ -> True ClassOpId _ -> True - GenericOpId _ -> True DataConWorkId _ -> True DataConWrapId _ -> True -- These are are implied by their type or class decl; diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index a0002d7c85..0b5b79ad93 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -77,7 +77,6 @@ module IdInfo ( import CoreSyn -import TyCon ( TyCon ) import Class ( Class ) import PrimOp ( PrimOp ) import Var ( Id ) @@ -231,7 +230,6 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported data GlobalIdDetails = VanillaGlobal -- Imported from elsewhere, a default method Id. - | GenericOpId TyCon -- The to/from operations of a | RecordSelId FieldLabel -- The Id for a record selector | DataConWorkId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* @@ -252,7 +250,6 @@ notGlobalId = NotGlobalId instance Outputable GlobalIdDetails where ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") ppr VanillaGlobal = ptext SLIT("[GlobalId]") - ppr (GenericOpId _) = ptext SLIT("[GenericOp]") ppr (DataConWorkId _) = ptext SLIT("[DataCon]") ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") ppr (ClassOpId _) = ptext SLIT("[ClassOp]") diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index edc77b7943..3781abefe9 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -30,16 +30,13 @@ import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy ) import PrimRep ( PrimRep(..) ) -import TcType ( Type, tcCmpType ) -import Type ( typePrimRep ) -import PprType ( pprParendType ) +import Type ( Type ) import CStrings ( pprFSInCStyle ) import Outputable import FastTypes import FastString import Binary -import Util ( thenCmp ) import Ratio ( numerator ) import FastString ( uniqueOfFS, lengthFS ) @@ -343,7 +340,7 @@ cmpLit (MachFloat a) (MachFloat b) = a `compare` b cmpLit (MachDouble a) (MachDouble b) = a `compare` b cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT - | otherwise = GT + | otherwise = GT litTag (MachChar _) = _ILIT(1) litTag (MachStr _) = _ILIT(2) diff --git a/ghc/compiler/basicTypes/MkId.hi-boot b/ghc/compiler/basicTypes/MkId.hi-boot index b4b0fe1a97..47b20fb9eb 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot +++ b/ghc/compiler/basicTypes/MkId.hi-boot @@ -1,5 +1,5 @@ _interface_ MkId 1 _exports_ -MkId mkDataConWorkId ; +MkId mkDataConIds ; _declarations_ -1 mkDataConWorkId _:_ Name.Name -> DataCon.DataCon -> Var.Id ;; +1 mkDataConIds _:_ Name.Name -> Name.Name -> DataCon.DataCon -> DataCon.DataConIds ;; diff --git a/ghc/compiler/basicTypes/MkId.hi-boot-5 b/ghc/compiler/basicTypes/MkId.hi-boot-5 index 95f2d9c53e..ff901a5840 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot-5 +++ b/ghc/compiler/basicTypes/MkId.hi-boot-5 @@ -1,4 +1,3 @@ __interface MkId 1 0 where -__export MkId mkDataConWorkId ; -1 mkDataConWorkId :: Name.Name -> DataCon.DataCon -> Var.Id ; - +__export MkId mkDataConIds ; +1 mkDataConIds :: Name.Name -> Name.Name -> DataCon.DataCon -> DataCon.DataConIds ; diff --git a/ghc/compiler/basicTypes/MkId.hi-boot-6 b/ghc/compiler/basicTypes/MkId.hi-boot-6 index 414a4ab100..d3f22527f3 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot-6 +++ b/ghc/compiler/basicTypes/MkId.hi-boot-6 @@ -1,4 +1,5 @@ module MkId where -mkDataConWorkId :: Name.Name -> DataCon.DataCon -> Var.Id +mkDataConIds :: Name.Name -> Name.Name -> DataCon.DataCon -> DataCon.DataConIds + diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 1da519af6f..b629f373b4 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -16,7 +16,7 @@ module MkId ( mkDictFunId, mkDefaultMethodId, mkDictSelId, - mkDataConWorkId, mkDataConWrapId, + mkDataConIds, mkRecordSelId, mkPrimOpId, mkFCallId, @@ -30,7 +30,7 @@ module MkId ( mkRuntimeErrorApp, rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID + pAT_ERROR_ID, eRROR_ID ) where #include "HsVersions.h" @@ -43,6 +43,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) import Rules ( addRule ) +import Type ( TyThing(..) ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred, mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, @@ -57,35 +58,35 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, import Class ( Class, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar, Var ) import VarSet ( isEmptyVarSet ) -import Name ( mkFCallName, Name ) -import PrimOp ( PrimOp, primOpSig, mkPrimOpIdName ) +import Name ( mkFCallName, mkWiredInName, Name ) +import OccName ( mkOccFS, varName ) +import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) import ForeignCall ( ForeignCall ) -import DataCon ( DataCon, - dataConFieldLabels, dataConRepArity, dataConTyCon, +import DataCon ( DataCon, DataConIds(..), + dataConFieldLabels, dataConRepArity, dataConArgTys, dataConRepType, - dataConOrigArgTys, - dataConTheta, - dataConSig, dataConStrictMarks, dataConWorkId, + dataConOrigArgTys, dataConTheta, + dataConSig, dataConStrictMarks, dataConExStricts, splitProductType ) import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId, mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported, - mkTemplateLocal, idNewStrictness, idName + mkTemplateLocal, idName ) import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo, setArityInfo, setSpecInfo, setCafInfo, setAllStrictnessInfo, vanillaIdInfo, GlobalIdDetails(..), CafInfo(..) ) -import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..), +import NewDemand ( mkStrictSig, DmdResult(..), mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR, Demand(..), Demands(..) ) -import FieldLabel ( mkFieldLabel, fieldLabelName, - firstFieldLabelTag, allFieldLabelTags, fieldLabelType +import FieldLabel ( fieldLabelName, firstFieldLabelTag, + allFieldLabelTags, fieldLabelType ) import DmdAnal ( dmdAnalTopRhs ) import CoreSyn -import Unique ( mkBuiltinUnique ) +import Unique ( mkBuiltinUnique, mkPrimOpIdUnique ) import Maybes import PrelNames import Maybe ( isJust ) @@ -147,57 +148,6 @@ ghcPrimIds %* * %************************************************************************ -\begin{code} -mkDataConWorkId :: Name -> DataCon -> Id - -- Makes the *worker* for the data constructor; that is, the function - -- that takes the reprsentation arguments and builds the constructor. -mkDataConWorkId wkr_name data_con - = mkGlobalId (DataConWorkId data_con) wkr_name - (dataConRepType data_con) info - where - info = noCafIdInfo - `setArityInfo` arity - `setAllStrictnessInfo` Just strict_sig - - arity = dataConRepArity data_con - strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info) - -- Notice that we do *not* say the worker is strict - -- even if the data constructor is declared strict - -- e.g. data T = MkT !(Int,Int) - -- Why? Because the *wrapper* is strict (and its unfolding has case - -- expresssions that do the evals) but the *worker* itself is not. - -- If we pretend it is strict then when we see - -- case x of y -> $wMkT y - -- the simplifier thinks that y is "sure to be evaluated" (because - -- $wMkT is strict) and drops the case. No, $wMkT is not strict. - -- - -- When the simplifer sees a pattern - -- case e of MkT x -> ... - -- it uses the dataConRepStrictness of MkT to mark x as evaluated; - -- but that's fine... dataConRepStrictness comes from the data con - -- not from the worker Id. - - tycon = dataConTyCon data_con - cpr_info | isProductTyCon tycon && - isDataTyCon tycon && - arity > 0 && - arity <= mAX_CPR_SIZE = retCPR - | otherwise = TopRes - -- RetCPR is only true for products that are real data types; - -- that is, not unboxed tuples or [non-recursive] newtypes - -mAX_CPR_SIZE :: Arity -mAX_CPR_SIZE = 10 --- We do not treat very big tuples as CPR-ish: --- a) for a start we get into trouble because there aren't --- "enough" unboxed tuple types (a tiresome restriction, --- but hard to fix), --- b) more importantly, big unboxed tuples get returned mainly --- on the stack, and are often then allocated in the heap --- by the caller. So doing CPR for them may in fact make --- things worse. -\end{code} - The wrapper for a constructor is an ordinary top-level binding that evaluates any strict args, unboxes any args that are going to be flattened, and calls the worker. @@ -235,45 +185,94 @@ Notice that Making an explicit case expression allows the simplifier to eliminate it in the (common) case where the constructor arg is already evaluated. + \begin{code} -mkDataConWrapId :: Name -> DataCon -> Maybe Id --- Only make a wrapper Id if necessary +mkDataConIds :: Name -> Name -> DataCon -> DataConIds + -- Makes the *worker* for the data constructor; that is, the function + -- that takes the reprsentation arguments and builds the constructor. +mkDataConIds wrap_name wkr_name data_con + | isNewTyCon tycon + = NewDC nt_wrap_id -mkDataConWrapId wrap_name data_con - | is_newtype || any isMarkedStrict strict_marks - = -- We need a wrapper function - Just (mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty info) + | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper + = AlgDC (Just alg_wrap_id) wrk_id - | otherwise - = Nothing -- The common case, where there is no point in - -- having a wrapper function. Not only is this efficient, - -- but it also ensures that the wrapper is replaced - -- by the worker (becuase it *is* the wroker) - -- even when there are no args. E.g. in - -- f (:) x - -- the (:) *is* the worker. - -- This is really important in rule matching, - -- (We could match on the wrappers, - -- but that makes it less likely that rules will match - -- when we bring bits of unfoldings together.) + | otherwise -- Algebraic, no wrapper + = AlgDC Nothing wrk_id where (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con - is_newtype = isNewTyCon tycon all_tyvars = tyvars ++ ex_tyvars - work_id = dataConWorkId data_con - common_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` arity - -- It's important to specify the arity, so that partial - -- applications are treated as values + ex_dict_tys = mkPredTys ex_theta + all_arg_tys = ex_dict_tys ++ orig_arg_tys + result_ty = mkTyConApp tycon (mkTyVarTys tyvars) - info | is_newtype = common_info `setUnfoldingInfo` newtype_unf - | otherwise = common_info `setUnfoldingInfo` data_unf - `setAllStrictnessInfo` Just wrap_sig + wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty) + -- We used to include the stupid theta in the wrapper's args + -- but now we don't. Instead the type checker just injects these + -- extra constraints where necessary. - wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info) - res_info = strictSigResInfo (idNewStrictness work_id) - arg_dmds = map mk_dmd strict_marks + ----------- Worker (algebraic data types only) -------------- + wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name + (dataConRepType data_con) wkr_info + + wkr_arity = dataConRepArity data_con + wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setAllStrictnessInfo` Just wkr_sig + + wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) + -- Notice that we do *not* say the worker is strict + -- even if the data constructor is declared strict + -- e.g. data T = MkT !(Int,Int) + -- Why? Because the *wrapper* is strict (and its unfolding has case + -- expresssions that do the evals) but the *worker* itself is not. + -- If we pretend it is strict then when we see + -- case x of y -> $wMkT y + -- the simplifier thinks that y is "sure to be evaluated" (because + -- $wMkT is strict) and drops the case. No, $wMkT is not strict. + -- + -- When the simplifer sees a pattern + -- case e of MkT x -> ... + -- it uses the dataConRepStrictness of MkT to mark x as evaluated; + -- but that's fine... dataConRepStrictness comes from the data con + -- not from the worker Id. + + cpr_info | isProductTyCon tycon && + isDataTyCon tycon && + wkr_arity > 0 && + wkr_arity <= mAX_CPR_SIZE = retCPR + | otherwise = TopRes + -- RetCPR is only true for products that are real data types; + -- that is, not unboxed tuples or [non-recursive] newtypes + + ----------- Wrappers for newtypes -------------- + nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info + nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setUnfoldingInfo` newtype_unf + newtype_unf = ASSERT( null ex_tyvars && null ex_theta && + isSingleton orig_arg_tys ) + -- No existentials on a newtype, but it can have a context + -- e.g. newtype Eq a => T a = MkT (...) + mkTopUnfolding $ Note InlineMe $ + mkLams tyvars $ Lam id_arg1 $ + mkNewTypeBody tycon result_ty (Var id_arg1) + + id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) + + ----------- Wrappers for algebraic data types -------------- + alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info + alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` alg_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setUnfoldingInfo` alg_unf + `setAllStrictnessInfo` Just wrap_sig + + all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con + wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info) + arg_dmds = map mk_dmd all_strict_marks mk_dmd str | isMarkedStrict str = evalDmd | otherwise = lazyDmd -- The Cpr info can be important inside INLINE rhss, where the @@ -285,42 +284,19 @@ mkDataConWrapId wrap_name data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - newtype_unf = ASSERT( null ex_tyvars && null ex_dict_args && - isSingleton orig_arg_tys ) - -- No existentials on a newtype, but it can have a context - -- e.g. newtype Eq a => T a = MkT (...) - mkTopUnfolding $ Note InlineMe $ - mkLams tyvars $ Lam id_arg1 $ - mkNewTypeBody tycon result_ty (Var id_arg1) - - data_unf = mkTopUnfolding $ Note InlineMe $ - mkLams all_tyvars $ - mkLams ex_dict_args $ mkLams id_args $ - foldr mk_case con_app - (zip (ex_dict_args++id_args) strict_marks) i3 [] - - con_app i rep_ids = mkApps (Var work_id) - (map varToCoreExpr (all_tyvars ++ reverse rep_ids)) - - ex_dict_tys = mkPredTys ex_theta - all_arg_tys = ex_dict_tys ++ orig_arg_tys - result_ty = mkTyConApp tycon (mkTyVarTys tyvars) + alg_unf = mkTopUnfolding $ Note InlineMe $ + mkLams all_tyvars $ + mkLams ex_dict_args $ mkLams id_args $ + foldr mk_case con_app + (zip (ex_dict_args ++ id_args) all_strict_marks) + i3 [] - wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty) - -- We used to include the stupid theta in the wrapper's args - -- but now we don't. Instead the type checker just injects these - -- extra constraints where necessary. - - mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) - where - n = length tys + con_app i rep_ids = mkApps (Var wrk_id) + (map varToCoreExpr (all_tyvars ++ reverse rep_ids)) (ex_dict_args,i2) = mkLocals 1 ex_dict_tys (id_args,i3) = mkLocals i2 orig_arg_tys - arity = i3-1 - (id_arg1:_) = id_args -- Used for newtype only - - strict_marks = dataConStrictMarks data_con + alg_arity = i3-1 mk_case :: (Id, StrictnessMark) -- Arg, strictness @@ -343,6 +319,21 @@ mkDataConWrapId wrap_name data_con body i' (reverse con_args ++ rep_args))] where (con_args, i') = mkLocals i tys + +mAX_CPR_SIZE :: Arity +mAX_CPR_SIZE = 10 +-- We do not treat very big tuples as CPR-ish: +-- a) for a start we get into trouble because there aren't +-- "enough" unboxed tuple types (a tiresome restriction, +-- but hard to fix), +-- b) more importantly, big unboxed tuples get returned mainly +-- on the stack, and are often then allocated in the heap +-- by the caller. So doing CPR for them may in fact make +-- things worse. + +mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) + where + n = length tys \end{code} @@ -393,9 +384,6 @@ Similarly for (recursive) newtypes \begin{code} mkRecordSelId tycon field_label -- Assumes that all fields with the same field label have the same type - -- - -- Annoyingly, we have to pass in the unpackCString# Id, because - -- we can't conjure it up out of thin air = sel_id where sel_id = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info @@ -505,6 +493,7 @@ mkRecordSelId tycon field_label where arg_ids = mkTemplateLocalsNum field_base (dataConOrigArgTys data_con) -- No need to instantiate; same tyvars in datacon as tycon + -- Records can't be existential, so no existential tyvars or dicts unpack_base = field_base + length arg_ids uniqs = map mkBuiltinUnique [unpack_base..] @@ -548,7 +537,7 @@ mkReboxingAlt us con args rhs (DataAlt con, args', mkLets binds rhs) where - stricts = dataConStrictMarks con + stricts = dataConExStricts con ++ dataConStrictMarks con go [] stricts us = ([], []) @@ -613,10 +602,9 @@ mkDictSelId name clas -- But it's type must expose the representation of the dictionary -- to gat (say) C a -> (a -> a) - field_lbl = mkFieldLabel name tycon sel_ty tag - tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name + tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name - info = noCafIdInfo + info = noCafIdInfo `setArityInfo` 1 `setUnfoldingInfo` mkTopUnfolding rhs `setAllStrictnessInfo` Just strict_sig @@ -673,7 +661,9 @@ mkPrimOpId prim_op where (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) - name = mkPrimOpIdName prim_op + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + Nothing (AnId id) id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo @@ -817,6 +807,29 @@ they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. \begin{code} +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccFS varName fs) uniq Nothing (AnId id) + +unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId +nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId +lazyIdName = mkWiredInIdName pREL_BASE FSLIT("lazy") lazyIdKey lazyId + +errorName = mkWiredInIdName pREL_ERR FSLIT("error") errorIdKey eRROR_ID +recSelErrorName = mkWiredInIdName pREL_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID +runtimeErrorName = mkWiredInIdName pREL_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = mkWiredInIdName pREL_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = mkWiredInIdName pREL_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = mkWiredInIdName pREL_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID +noMethodBindingErrorName = mkWiredInIdName pREL_ERR FSLIT("noMethodBindingError") + noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID +nonExhaustiveGuardsErrorName + = mkWiredInIdName pREL_ERR FSLIT("nonExhaustiveGuardsError") + nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID +\end{code} + +\begin{code} -- unsafeCoerce# :: forall a b. a -> b unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info @@ -930,9 +943,9 @@ rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName pAT_ERROR_ID = mkRuntimeErrorId patErrorName nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName -- The runtime error Ids take a UTF8-encoded string as argument mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy diff --git a/ghc/compiler/basicTypes/Module.hi-boot-5 b/ghc/compiler/basicTypes/Module.hi-boot-5 index cdc5fbf581..ebde9b7076 100644 --- a/ghc/compiler/basicTypes/Module.hi-boot-5 +++ b/ghc/compiler/basicTypes/Module.hi-boot-5 @@ -1,4 +1,4 @@ __interface Module 1 0 where -__export Module Module ; -1 data Module ; +__export Module ModuleName ; +1 data ModuleName ; diff --git a/ghc/compiler/basicTypes/Module.hi-boot-6 b/ghc/compiler/basicTypes/Module.hi-boot-6 index 7677859749..d26545c44f 100644 --- a/ghc/compiler/basicTypes/Module.hi-boot-6 +++ b/ghc/compiler/basicTypes/Module.hi-boot-6 @@ -1,4 +1,4 @@ module Module where -data Module +data ModuleName diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 4b59757c6a..ea4de1ed05 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -56,8 +56,8 @@ module Module , moduleString -- :: Module -> EncodedString , moduleUserString -- :: Module -> UserString + , mkModule , mkBasePkgModule -- :: UserString -> Module - , mkThPkgModule -- :: UserString -> Module , mkHomeModule -- :: ModuleName -> Module , isHomeModule -- :: Module -> Bool , mkPackageModule -- :: ModuleName -> Module @@ -83,9 +83,8 @@ module Module #include "HsVersions.h" import OccName import Outputable -import Packages ( PackageName, basePackage, thPackage ) +import Packages ( PackageName, basePackage ) import CmdLineOpts ( opt_InPackage ) -import FastString ( FastString ) import Unique ( Uniquable(..) ) import Maybes ( expectJust ) import UniqFM @@ -270,21 +269,16 @@ pprModule (Module mod p) = getPprStyle $ \ sty -> \begin{code} -mkBasePkgModule :: ModuleName -> Module -mkBasePkgModule mod_nm - = Module mod_nm pack_info +mkModule :: PackageName -> ModuleName -> Module +mkModule pkg_name mod_name + = Module mod_name pkg_info where - pack_info - | opt_InPackage == basePackage = ThisPackage - | otherwise = AnotherPackage + pkg_info + | opt_InPackage == pkg_name = ThisPackage + | otherwise = AnotherPackage -mkThPkgModule :: ModuleName -> Module -mkThPkgModule mod_nm - = Module mod_nm pack_info - where - pack_info - | opt_InPackage == thPackage = ThisPackage - | otherwise = AnotherPackage +mkBasePkgModule :: ModuleName -> Module +mkBasePkgModule mod_nm = mkModule basePackage mod_nm mkHomeModule :: ModuleName -> Module mkHomeModule mod_nm = Module mod_nm ThisPackage diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index acf518f9d3..3a68b58d1d 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -13,17 +13,18 @@ module Name ( mkInternalName, mkSystemName, mkSystemNameEncoded, mkSystemTvNameEncoded, mkFCallName, mkIPName, - mkExternalName, mkKnownKeyExternalName, mkWiredInName, + mkExternalName, mkWiredInName, nameUnique, setNameUnique, - nameOccName, nameModule, nameModule_maybe, - setNameOcc, setNameSrcLoc, - hashName, externaliseName, localiseName, + nameOccName, nameModule, nameModule_maybe, nameModuleName, + setNameOcc, + hashName, localiseName, - nameSrcLoc, eqNameByOcc, + nameSrcLoc, nameParent, nameParent_maybe, isSystemName, isInternalName, isExternalName, isTyVarName, isDllName, isWiredInName, + wiredInNameTyThing_maybe, nameIsLocalOrFrom, isHomePackageName, -- Class NamedThing and overloaded friends @@ -33,11 +34,14 @@ module Name ( #include "HsVersions.h" +import {-# SOURCE #-} TypeRep( TyThing ) + import OccName -- All of it -import Module ( Module, moduleName, isHomeModule ) +import Module ( Module, ModuleName, moduleName, isHomeModule ) import CmdLineOpts ( opt_Static ) -import SrcLoc ( noSrcLoc, isWiredInLoc, wiredInSrcLoc, SrcLoc ) +import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) import Unique ( Unique, Uniquable(..), getKey, pprUnique ) +import Maybes ( orElse ) import FastTypes import Outputable \end{code} @@ -61,10 +65,13 @@ data Name = Name { -- the SrcLoc in a Name all that often. data NameSort - = External Module -- (a) TyCon, Class, their derived Ids, dfun Id - -- (b) Imported Id - -- (c) Top-level Id in the original source, even if - -- locally defined + = External Module (Maybe Name) + -- (Just parent) => this Name is a subordinate name of 'parent' + -- e.g. data constructor of a data type, method of a class + -- Nothing => not a subordinate + + | WiredIn Module (Maybe Name) TyThing + -- A variant of External, for wired-in things | Internal -- A user-defined Id or TyVar -- defined in the module being compiled @@ -100,6 +107,7 @@ Notes about the NameSorts: nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module +nameModuleName :: Name -> ModuleName nameSrcLoc :: Name -> SrcLoc nameUnique name = n_uniq name @@ -115,24 +123,43 @@ isSystemName :: Name -> Bool isHomePackageName :: Name -> Bool isWiredInName :: Name -> Bool -isWiredInName name = isWiredInLoc (n_loc name) - -isExternalName (Name {n_sort = External _}) = True -isExternalName other = False +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName other = False -nameModule (Name { n_sort = External mod }) = mod -nameModule name = pprPanic "nameModule" (ppr name) +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ _ thing}) = Just thing +wiredInNameTyThing_maybe other = Nothing -nameModule_maybe (Name { n_sort = External mod }) = Just mod -nameModule_maybe name = Nothing +isExternalName (Name {n_sort = External _ _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName other = False isInternalName name = not (isExternalName name) -nameIsLocalOrFrom from (Name {n_sort = External mod}) = mod == from -nameIsLocalOrFrom from other = True +nameParent_maybe :: Name -> Maybe Name +nameParent_maybe (Name {n_sort = External _ p}) = p +nameParent_maybe (Name {n_sort = WiredIn _ p _}) = p +nameParent_maybe other = Nothing + +nameParent :: Name -> Name +nameParent name = case nameParent_maybe name of + Just parent -> parent + Nothing -> name + +nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) +nameModuleName name = moduleName (nameModule name) + +nameModule_maybe (Name { n_sort = External mod _}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe name = Nothing -isHomePackageName (Name {n_sort = External mod}) = isHomeModule mod -isHomePackageName other = True -- Internal and system names +nameIsLocalOrFrom from name + | isExternalName name = from == nameModule name + | otherwise = True + +isHomePackageName name + | isExternalName name = isHomeModule (nameModule name) + | otherwise = True -- Internal and system names isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? isDllName nm = not opt_Static && not (isHomePackageName nm) @@ -142,18 +169,6 @@ isTyVarName name = isTvOcc (nameOccName name) isSystemName (Name {n_sort = System}) = True isSystemName other = False - -eqNameByOcc :: Name -> Name -> Bool --- Compare using the strings, not the unique --- See notes with HsCore.eq_ufVar -eqNameByOcc (Name {n_sort = sort1, n_occ = occ1}) - (Name {n_sort = sort2, n_occ = occ2}) - = sort1 `eq_sort` sort2 && occ1 == occ2 - where - eq_sort (External m1) (External m2) = moduleName m1 == moduleName m2 - eq_sort (External _) _ = False - eq_sort _ (External _) = False - eq_sort _ _ = True \end{code} @@ -175,16 +190,16 @@ mkInternalName uniq occ loc = Name { n_uniq = uniq, n_sort = Internal, n_occ = o -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) -mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name -mkExternalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = External mod, - n_occ = occ, n_loc = loc } - -mkKnownKeyExternalName :: Module -> OccName -> Unique -> Name -mkKnownKeyExternalName mod occ uniq - = mkExternalName uniq mod occ noSrcLoc +mkExternalName :: Unique -> Module -> OccName -> Maybe Name -> SrcLoc -> Name +mkExternalName uniq mod occ mb_parent loc + = Name { n_uniq = uniq, n_sort = External mod mb_parent, + n_occ = occ, n_loc = loc } -mkWiredInName :: Module -> OccName -> Unique -> Name -mkWiredInName mod occ uniq = mkExternalName uniq mod occ wiredInSrcLoc +mkWiredInName :: Module -> OccName -> Unique -> Maybe Name -> TyThing -> Name +mkWiredInName mod occ uniq mb_parent thing + = Name { n_uniq = uniq, + n_sort = WiredIn mod mb_parent thing, + n_occ = occ, n_loc = wiredInSrcLoc } mkSystemName :: Unique -> UserFS -> Name mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System, @@ -224,14 +239,8 @@ setNameUnique name uniq = name {n_uniq = uniq} setNameOcc :: Name -> OccName -> Name setNameOcc name occ = name {n_occ = occ} -externaliseName :: Name -> Module -> Name -externaliseName n mod = n { n_sort = External mod } - localiseName :: Name -> Name localiseName n = n { n_sort = Internal } - -setNameSrcLoc :: Name -> SrcLoc -> Name -setNameSrcLoc name loc = name {n_loc = loc} \end{code} @@ -294,19 +303,29 @@ instance OutputableBndr Name where pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> case sort of - External mod -> pprExternal sty name uniq mod occ - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ + External mod mb_p -> pprExternal sty name uniq mod occ mb_p False + WiredIn mod mb_p thing -> pprExternal sty name uniq mod occ mb_p True + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ -pprExternal sty name uniq mod occ +pprExternal sty name uniq mod occ mb_p is_wired | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ - | debugStyle sty = ppr (moduleName mod) <> dot <> ppr_debug_occ uniq occ + | debugStyle sty = sep [ppr (moduleName mod) <> dot <> pprOccName occ, + hsep [text "{-", + if is_wired then ptext SLIT("(w)") else empty, + pprUnique uniq, + case mb_p of + Nothing -> empty + Just n -> brackets (ppr n), + text "-}"]] | unqualStyle sty name = pprOccName occ | otherwise = ppr (moduleName mod) <> dot <> pprOccName occ pprInternal sty uniq occ | codeStyle sty = pprUnique uniq - | debugStyle sty = ppr_debug_occ uniq occ + | debugStyle sty = hsep [pprOccName occ, text "{-", + text (briefOccNameFlavour occ), + pprUnique uniq, text "-}"] | otherwise = pprOccName occ -- User style -- Like Internal, except that we only omit the unique in Iface style @@ -316,10 +335,6 @@ pprSystem sty uniq occ -- If the tidy phase hasn't run, the OccName -- is unlikely to be informative (like 's'), -- so print the unique - -ppr_debug_occ uniq occ = hsep [pprOccName occ, text "{-", - text (briefOccNameFlavour occ), - pprUnique uniq, text "-}"] \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/NameSet.lhs b/ghc/compiler/basicTypes/NameSet.lhs index e75d3cd2cc..305e80d1ce 100644 --- a/ghc/compiler/basicTypes/NameSet.lhs +++ b/ghc/compiler/basicTypes/NameSet.lhs @@ -19,7 +19,7 @@ module NameSet ( -- Defs and uses Defs, Uses, DefUse, DefUses, emptyDUs, usesOnly, mkDUs, plusDU, - findUses, duDefs, duUses + findUses, duDefs, duUses, allUses ) where #include "HsVersions.h" @@ -120,9 +120,10 @@ delFVs ns s = delListFromNameSet s ns type Defs = NameSet type Uses = NameSet -type DefUse = (Maybe Defs, Uses) type DefUses = [DefUse] -- In dependency order: earlier Defs scope over later Uses + +type DefUse = (Maybe Defs, Uses) -- For items (Just ds, us), the use of any member -- of the ds implies that all the us are used too -- diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 4ff4c87c6b..2a242a0e85 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -15,6 +15,17 @@ module OccName ( OccName, -- Abstract, instance of Outputable pprOccName, + -- The OccEnv type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, + lookupOccEnv, mkOccEnv, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv_C, extendOccEnv_C, + + + -- The OccSet type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, + foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, + mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS, mkVarOcc, mkVarOccEncoded, mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, @@ -30,6 +41,8 @@ module OccName ( occNameFlavour, briefOccNameFlavour, setOccNameSpace, + mkTupleOcc, isTupleOcc_maybe, + -- Tidying up TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, @@ -47,8 +60,10 @@ module OccName ( import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt ) import Util ( thenCmp ) -import Unique ( Unique ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) +import Unique ( Unique, mkUnique, Uniquable(..) ) +import BasicTypes ( Boxity(..), Arity ) +import UniqFM +import UniqSet import FastString import Outputable import Binary @@ -173,7 +188,11 @@ instance Outputable OccName where ppr = pprOccName pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) = pprEncodedFS occ +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + pprEncodedFS occ <> if debugStyle sty then + braces (text (briefNameSpaceFlavour sp)) + else empty \end{code} @@ -227,6 +246,92 @@ mkVarOccEncoded fs = mkSysOccFS varName fs %************************************************************************ %* * + Environments +%* * +%************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, so we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char reprsenting the name space. This in turn makes it +easy to build an OccEnv. + +\begin{code} +instance Uniquable OccName where + getUnique (OccName ns fs) + = mkUnique char (I# (uniqueOfFS fs)) + where -- See notes above about this getUnique function + char = case ns of + VarName -> 'i' + DataName -> 'd' + TvName -> 'v' + TcClsName -> 't' + +type OccEnv a = UniqFM a + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a + +emptyOccEnv = emptyUFM +unitOccEnv = unitUFM +extendOccEnv = addToUFM +extendOccEnvList = addListToUFM +lookupOccEnv = lookupUFM +mkOccEnv = listToUFM +elemOccEnv = elemUFM +foldOccEnv = foldUFM +occEnvElts = eltsUFM +plusOccEnv_C = plusUFM_C +extendOccEnv_C = addToUFM_C + + +type OccSet = UniqFM OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +occSetElts :: OccSet -> [OccName] +foldOccSet :: (OccName -> b -> b) -> b -> OccSet -> b +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +intersectsOccSet :: OccSet -> OccSet -> Bool + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +occSetElts = uniqSetToList +foldOccSet = foldUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) +\end{code} + + +%************************************************************************ +%* * \subsection{Predicates and taking them apart} %* * %************************************************************************ @@ -256,10 +361,12 @@ occNameFlavour (OccName VarName s) = "Variable" -- briefOccNameFlavour is used in debug-printing of names briefOccNameFlavour :: OccName -> String -briefOccNameFlavour (OccName DataName _) = "d" -briefOccNameFlavour (OccName VarName _) = "v" -briefOccNameFlavour (OccName TvName _) = "tv" -briefOccNameFlavour (OccName TcClsName _) = "tc" +briefOccNameFlavour (OccName sp _) = briefNameSpaceFlavour sp + +briefNameSpaceFlavour DataName = "d" +briefNameSpaceFlavour VarName = "v" +briefNameSpaceFlavour TvName = "tv" +briefNameSpaceFlavour TcClsName = "tc" \end{code} \begin{code} @@ -289,6 +396,7 @@ isDataOcc other = False -- Pretty inefficient! isSymOcc (OccName DataName s) = isLexConSym (decodeFS s) isSymOcc (OccName VarName s) = isLexSym (decodeFS s) +isSymOcc other = False \end{code} @@ -448,31 +556,25 @@ because that isn't a single lexeme. So we encode it to 'lle' and *then* tack on the '1', if necessary. \begin{code} -type TidyOccEnv = FiniteMap FastString Int -- The in-scope OccNames -emptyTidyOccEnv = emptyFM +type TidyOccEnv = OccEnv Int -- The in-scope OccNames + -- Range gives a plausible starting point for new guesses + +emptyTidyOccEnv = emptyOccEnv initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl (\env (OccName _ fs) -> addToFM env fs 1) emptyTidyOccEnv +initTidyOccEnv = foldl (\env occ -> extendOccEnv env occ 1) emptyTidyOccEnv tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) tidyOccName in_scope occ@(OccName occ_sp fs) - | not (fs `elemFM` in_scope) - = (addToFM in_scope fs 1, occ) -- First occurrence - - | otherwise -- Already occurs - = go in_scope (unpackFS fs) - where - - go in_scope str = case lookupFM in_scope pk_str of - Just n -> go (addToFM in_scope pk_str (n+1)) (str ++ show n) - -- Need to go round again, just in case "t3" (say) - -- clashes with a "t3" that's already in scope - - Nothing -> (addToFM in_scope pk_str 1, mkSysOccFS occ_sp pk_str) - -- str is now unique - where - pk_str = mkFastString str + = case lookupOccEnv in_scope occ of + Nothing -> -- Not already used: make it used + (extendOccEnv in_scope occ 1, occ) + + Just n -> -- Already used: make a new guess, + -- change the guess base, and try again + tidyOccName (extendOccEnv in_scope occ (n+1)) + (mkSysOcc occ_sp (unpackFS fs ++ show n)) \end{code} @@ -544,20 +646,6 @@ encode cs = case maybe_tuple cs of go [] = [] go (c:cs) = encode_ch c ++ go cs -maybe_tuple "(# #)" = Just("Z1H") -maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") - other -> Nothing -maybe_tuple "()" = Just("Z0T") -maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") - other -> Nothing -maybe_tuple other = Nothing - -count_commas :: Int -> String -> (Int, String) -count_commas n (',' : cs) = count_commas (n+1) cs -count_commas n cs = (n,cs) - encodeFS :: UserFS -> EncodedFS encodeFS fast_str | all unencodedChar str = fast_str | otherwise = mkFastString (encode str) @@ -613,56 +701,120 @@ decodeFS fs = mkFastString (decode (unpackFS fs)) decode :: EncodedString -> UserString decode [] = [] -decode ('Z' : rest) = decode_escape rest -decode ('z' : rest) = decode_escape rest +decode ('Z' : d : rest) | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : decode rest +decode ('z' : d : rest) | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : decode rest decode (c : rest) = c : decode rest -decode_escape :: EncodedString -> UserString - -decode_escape ('L' : rest) = '(' : decode rest -decode_escape ('R' : rest) = ')' : decode rest -decode_escape ('M' : rest) = '[' : decode rest -decode_escape ('N' : rest) = ']' : decode rest -decode_escape ('C' : rest) = ':' : decode rest -decode_escape ('Z' : rest) = 'Z' : decode rest - -decode_escape ('z' : rest) = 'z' : decode rest -decode_escape ('a' : rest) = '&' : decode rest -decode_escape ('b' : rest) = '|' : decode rest -decode_escape ('c' : rest) = '^' : decode rest -decode_escape ('d' : rest) = '$' : decode rest -decode_escape ('e' : rest) = '=' : decode rest -decode_escape ('g' : rest) = '>' : decode rest -decode_escape ('h' : rest) = '#' : decode rest -decode_escape ('i' : rest) = '.' : decode rest -decode_escape ('l' : rest) = '<' : decode rest -decode_escape ('m' : rest) = '-' : decode rest -decode_escape ('n' : rest) = '!' : decode rest -decode_escape ('p' : rest) = '+' : decode rest -decode_escape ('q' : rest) = '\'' : decode rest -decode_escape ('r' : rest) = '\\' : decode rest -decode_escape ('s' : rest) = '/' : decode rest -decode_escape ('t' : rest) = '*' : decode rest -decode_escape ('u' : rest) = '_' : decode rest -decode_escape ('v' : rest) = '%' : decode rest - --- Tuples are coded as Z23T +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = pprTrace "decode_upper" (char ch) ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = pprTrace "decode_lower" (char ch) ch + -- Characters not having a specific code are coded as z224U -decode_escape (c : rest) - | isDigit c = go (digitToInt c) rest +decode_num_esc d rest + = go (digitToInt d) rest where go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest - go 0 ('T' : rest) = "()" ++ (decode rest) - go n ('T' : rest) = '(' : replicate (n-1) ',' ++ ')' : decode rest - go 1 ('H' : rest) = "(# #)" ++ (decode rest) - go n ('H' : rest) = '(' : '#' : replicate (n-1) ',' ++ '#' : ')' : decode rest go n ('U' : rest) = chr n : decode rest - go n other = pprPanic "decode_escape" (ppr n <+> text (c:rest)) + go n other = pprPanic "decode_num_esc" (ppr n <+> text other) +\end{code} + -decode_escape (c : rest) = pprTrace "decode_escape" (char c) (decode rest) -decode_escape [] = pprTrace "decode_escape" (text "empty") "" +%************************************************************************ +%* * + Stuff for dealing with tuples +%* * +%************************************************************************ + +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z<digit> + +* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) + There are no unboxed 0-tuples. + +* "()" is the tycon for a boxed 0-tuple. + There are no boxed 1-tuples. + + +\begin{code} +maybe_tuple :: UserString -> Maybe EncodedString + +maybe_tuple "(# #)" = Just("Z1H") +maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") + other -> Nothing +maybe_tuple "()" = Just("Z0T") +maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") + other -> Nothing +maybe_tuple other = Nothing + +count_commas :: Int -> String -> (Int, String) +count_commas n (',' : cs) = count_commas (n+1) cs +count_commas n cs = (n,cs) \end{code} +\begin{code} +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ['T'] = "()" + go n ['T'] = '(' : replicate (n-1) ',' ++ ")" + go 1 ['H'] = "(# #)" + go n ['H'] = '(' : '#' : replicate (n-1) ',' ++ "#)" + go n other = pprPanic "decode_tuple" (ppr n <+> text other) + +mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName +mkTupleOcc ns bx ar + = OccName ns (mkFastString ('Z' : (show ar ++ bx_char))) + where + bx_char = case bx of + Boxed -> "T" + Unboxed -> "H" + +isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity) +-- Tuples are special, because there are so many of them! +isTupleOcc_maybe (OccName ns fs) + = case unpackFS fs of + ('Z':d:rest) | isDigit d -> Just (decode_tup (digitToInt d) rest) + other -> Nothing + where + decode_tup n "H" = (ns, Unboxed, n) + decode_tup n "T" = (ns, Boxed, n) + decode_tup n (d:rest) = decode_tup (n*10 + digitToInt d) rest +\end{code} %************************************************************************ %* * @@ -718,8 +870,15 @@ isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neCh isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c \end{code} + +%************************************************************************ +%* * + Binary instance + Here rather than BinIface because OccName is abstract +%* * +%************************************************************************ + \begin{code} -{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} instance Binary NameSpace where put_ bh VarName = do putByte bh 0 @@ -745,7 +904,4 @@ instance Binary OccName where aa <- get bh ab <- get bh return (OccName aa ab) - --- Imported from other files :- - \end{code} diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 1c93ca1302..f743100fee 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -1,4 +1,3 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -7,45 +6,57 @@ \begin{code} module RdrName ( - RdrName, + RdrName(..), -- Constructors exported only to BinIface -- Construction mkRdrUnqual, mkRdrQual, - mkUnqual, mkQual, mkOrig, mkIfaceOrig, + mkUnqual, mkVarUnqual, mkQual, mkOrig, mkIfaceOrig, nameRdrName, getRdrName, - qualifyRdrName, unqualifyRdrName, mkRdrNameWkr, + qualifyRdrName, unqualifyRdrName, + mkDerivedRdrName, dummyRdrVarName, dummyRdrTcName, -- Destruction rdrNameModule, rdrNameOcc, setRdrNameSpace, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, - isOrig, isExact, isExact_maybe, - - -- Environment - RdrNameEnv, - emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, - extendRdrEnv, rdrEnvToList, elemRdrEnv, foldRdrEnv, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- Printing; instance Outputable RdrName - pprUnqualRdrName + pprUnqualRdrName, + + -- LocalRdrEnv + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, + lookupLocalRdrEnv, elemLocalRdrEnv, + + -- GlobalRdrEnv + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, + + -- GlobalRdrElt, Provenance, ImportSpec + GlobalRdrElt(..), Provenance(..), ImportSpec(..), + isLocalGRE, unQualOK, hasQual, + pprNameProvenance ) where #include "HsVersions.h" -import OccName ( NameSpace, tcName, +import OccName ( NameSpace, tcName, varName, OccName, UserFS, EncodedFS, mkSysOccFS, setOccNameSpace, mkOccFS, mkVarOcc, occNameFlavour, - isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc - ) -import Module ( ModuleName, - mkSysModuleNameFS, mkModuleNameFS + isDataOcc, isTvOcc, isTcOcc, + OccEnv, emptyOccEnv, extendOccEnvList, lookupOccEnv, + elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv, + occEnvElts ) -import Name ( Name, NamedThing(getName), nameModule, nameOccName ) -import Module ( moduleName ) -import FiniteMap +import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS ) +import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe, + nameOccName, isExternalName, nameSrcLoc ) +import Maybes ( seqMaybe ) +import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import BasicTypes( DeprecTxt ) import Outputable -import Binary import Util ( thenCmp ) \end{code} @@ -77,7 +88,10 @@ data RdrName -- We know exactly the Name. This is used -- (a) when the parser parses built-in syntax like "[]" -- and "(,)", but wants a RdrName from it - -- (b) possibly, by the meta-programming stuff + -- (b) when converting names to the RdrNames in IfaceTypes + -- Here an Exact RdrName always contains an External Name + -- (Internal Names are converted to simple Unquals) + -- (c) possibly, by the meta-programming stuff \end{code} @@ -91,7 +105,7 @@ data RdrName rdrNameModule :: RdrName -> ModuleName rdrNameModule (Qual m _) = m rdrNameModule (Orig m _) = m -rdrNameModule (Exact n) = moduleName (nameModule n) +rdrNameModule (Exact n) = nameModuleName n rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n) rdrNameOcc :: RdrName -> OccName @@ -112,7 +126,8 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns = Unqual (setOccNameSpace ns (nameOccName n)) +setRdrNameSpace (Exact n) ns = Orig (nameModuleName n) + (setOccNameSpace ns (nameOccName n)) \end{code} \begin{code} @@ -129,20 +144,31 @@ mkOrig mod occ = Orig mod occ mkIfaceOrig :: NameSpace -> EncodedFS -> EncodedFS -> RdrName mkIfaceOrig ns m n = Orig (mkSysModuleNameFS m) (mkSysOccFS ns n) +--------------- +mkDerivedRdrName :: Name -> (OccName -> OccName) -> (RdrName) +mkDerivedRdrName parent mk_occ + = mkOrig (nameModuleName parent) (mk_occ (nameOccName parent)) +--------------- -- These two are used when parsing source files -- They do encode the module and occurrence names mkUnqual :: NameSpace -> UserFS -> RdrName mkUnqual sp n = Unqual (mkOccFS sp n) +mkVarUnqual :: UserFS -> RdrName +mkVarUnqual n = Unqual (mkOccFS varName n) + mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccFS sp n) getRdrName :: NamedThing thing => thing -> RdrName -getRdrName name = Exact (getName name) +getRdrName name = nameRdrName (getName name) nameRdrName :: Name -> RdrName nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) qualifyRdrName :: ModuleName -> RdrName -> RdrName -- Sets the module name of a RdrName, even if it has one already @@ -151,12 +177,10 @@ qualifyRdrName mod rn = Qual mod (rdrNameOcc rn) unqualifyRdrName :: RdrName -> RdrName unqualifyRdrName rdr_name = Unqual (rdrNameOcc rdr_name) -mkRdrNameWkr :: RdrName -> RdrName -- Worker-ify it -mkRdrNameWkr rdr_name = Qual (rdrNameModule rdr_name) - (mkWorkerOcc (rdrNameOcc rdr_name)) - -origFromName :: Name -> RdrName -origFromName n = Orig (moduleName (nameModule n)) (nameOccName n) +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModuleName n) (nameOccName n) + | otherwise = Unqual (nameOccName n) \end{code} \begin{code} @@ -175,6 +199,10 @@ isRdrDataCon rn = isDataOcc (rdrNameOcc rn) isRdrTyVar rn = isTvOcc (rdrNameOcc rn) isRdrTc rn = isTcOcc (rdrNameOcc rn) +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + isUnqual (Unqual _) = True isUnqual other = False @@ -184,6 +212,9 @@ isQual _ = False isOrig (Orig _ _) = True isOrig _ = False +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + isExact (Exact _) = True isExact other = False @@ -215,8 +246,15 @@ instance OutputableBndr RdrName where pprUnqualRdrName rdr_name = ppr (rdrNameOcc rdr_name) instance Eq RdrName where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + r1 == r2 = False instance Ord RdrName where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } @@ -224,16 +262,18 @@ instance Ord RdrName where a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - -- Unqual < Qual < Orig < Exact - compare (Exact n1) (Exact n2) = n1 `compare` n2 + -- Unqual < Qual < Orig + -- We always convert Exact to Orig before comparing + compare (Exact n1) (Exact n2) | n1==n2 = EQ -- Short cut + | otherwise = nukeExact n1 `compare` nukeExact n2 + compare (Exact n1) n2 = nukeExact n1 `compare` n2 + compare n1 (Exact n2) = n1 `compare` nukeExact n2 + + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - -- Convert Exact to Orig - compare (Exact n1) n2 = origFromName n1 `compare` n2 - compare n1 (Exact n2) = n1 `compare` origFromName n2 - compare (Unqual _) _ = LT compare (Qual _ _) (Orig _ _) = LT compare _ _ = GT @@ -243,59 +283,228 @@ instance Ord RdrName where %************************************************************************ %* * -\subsection{Environment} + LocalRdrEnv +%* * +%************************************************************************ + +A LocalRdrEnv is used for local bindings (let, where, lambda, case) +It is keyed by OccName, because we never use it for qualified names. + +\begin{code} +type LocalRdrEnv = OccEnv Name + +emptyLocalRdrEnv = emptyOccEnv + +extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnv env names + = extendOccEnvList env [(nameOccName n, n) | n <- names] + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv env rdr_name + | isUnqual rdr_name = lookupOccEnv env (rdrNameOcc rdr_name) + | otherwise = Nothing + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name env + | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env + | otherwise = False +\end{code} + + +%************************************************************************ +%* * + GlobalRdrEnv +%* * +%************************************************************************ + +\begin{code} +type GlobalRdrEnv = OccEnv [GlobalRdrElt] + -- Keyed by OccName; when looking up a qualified name + -- we look up the OccName part, and then check the Provenance + -- to see if the appropriate qualification is valid. This + -- saves routinely doubling the size of the env by adding both + -- qualified and unqualified names to the domain. + -- + -- The list in the range is reqd because there may be name clashes + -- These only get reported on lookup, not on construction + + -- INVARIANT: All the members of the list have distinct + -- gre_name fields; that is, no duplicate Names + +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] +globalRdrEnvElts env = foldOccEnv (++) [] env + +data GlobalRdrElt + = GRE { gre_name :: Name, + gre_prov :: Provenance, -- Why it's in scope + gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated + } + +instance Outputable GlobalRdrElt where + ppr gre = ppr name <+> pp_parent (nameParent_maybe name) + <+> parens (pprNameProvenance gre) + where + name = gre_name gre + pp_parent (Just p) = brackets (text "parent:" <+> ppr p) + pp_parent Nothing = empty + +pprGlobalRdrEnv :: GlobalRdrEnv -> SDoc +pprGlobalRdrEnv env + = vcat (map pp (occEnvElts env)) + where + pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+> + vcat [ ppr (gre_name gre) <+> pprNameProvenance gre + | gre <- gres] +\end{code} + +\begin{code} +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env rdr_name = case lookupOccEnv env rdr_name of + Nothing -> [] + Just gres -> gres + +lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +lookupGRE_RdrName rdr_name env + = case lookupOccEnv env occ of + Nothing -> [] + Just gres | isUnqual rdr_name -> filter unQualOK gres + | otherwise -> filter (hasQual mod) gres + where + mod = rdrNameModule rdr_name + occ = rdrNameOcc rdr_name + +lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt] +lookupGRE_Name env name + = [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name), + gre_name gre == name ] + + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_prov = LocalDef _}) = True +isLocalGRE other = False + +unQualOK :: GlobalRdrElt -> Bool +-- An unqualifed version of this thing is in scope +unQualOK (GRE {gre_prov = LocalDef _}) = True +unQualOK (GRE {gre_prov = Imported is _}) = not (all is_qual is) + +hasQual :: ModuleName -> GlobalRdrElt -> Bool +-- A qualified version of this thing is in scope +hasQual mod (GRE {gre_prov = LocalDef m}) = m == mod +hasQual mod (GRE {gre_prov = Imported is _}) = any ((== mod) . is_as) is + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_C (foldr insertGRE) env + (nameOccName (gre_name gre)) + [gre] + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1, + gre_prov = gre_prov g1 `plusProv` gre_prov g2, + gre_deprec = gre_deprec g1 `seqMaybe` gre_deprec g2 } + -- Could the deprecs be different? If we re-export + -- something deprecated, is it propagated? I forget. +\end{code} + + +%************************************************************************ +%* * + Provenance %* * %************************************************************************ +The "provenance" of something says how it came to be in scope. + \begin{code} -type RdrNameEnv a = FiniteMap RdrName a - -emptyRdrEnv :: RdrNameEnv a -lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a -addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a -extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a -rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] -rdrEnvElts :: RdrNameEnv a -> [a] -elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool -foldRdrEnv :: (RdrName -> a -> b -> b) -> b -> RdrNameEnv a -> b - -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM -addListToRdrEnv = addListToFM -rdrEnvElts = eltsFM -extendRdrEnv = addToFM -rdrEnvToList = fmToList -elemRdrEnv = elemFM -foldRdrEnv = foldFM +data Provenance + = LocalDef -- Defined locally + ModuleName + + | Imported -- Imported + [ImportSpec] -- INVARIANT: non-empty + Bool -- True iff the thing was named *explicitly* + -- in *any* of the import specs rather than being + -- imported as part of a group; + -- e.g. + -- import B + -- import C( T(..) ) + -- Here, everything imported by B, and the constructors of T + -- are not named explicitly; only T is named explicitly. + -- This info is used when warning of unused names. + +data ImportSpec -- Describes a particular import declaration + -- Shared among all the Provenaces for a particular + -- import declaration + = ImportSpec { + is_mod :: ModuleName, -- 'import Muggle' + -- Note the Muggle may well not be + -- the defining module for this thing! + is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause) + is_qual :: Bool, -- True <=> qualified (only) + is_loc :: SrcLoc } -- Location of import statment + +-- Comparison of provenance is just used for grouping +-- error messages (in RnEnv.warnUnusedBinds) +instance Eq Provenance where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Eq ImportSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Ord Provenance where + compare (LocalDef _) (LocalDef _) = EQ + compare (LocalDef _) (Imported _ _) = LT + compare (Imported _ _) (LocalDef _) = GT + compare (Imported is1 _) (Imported is2 _) = compare (head is1) (head is2) + +instance Ord ImportSpec where + compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` + (is_loc is1 `compare` is_loc is2) \end{code} \begin{code} -instance Binary RdrName where - put_ bh (Unqual aa) = do - putByte bh 0 - put_ bh aa - - put_ bh (Qual aa ab) = do - putByte bh 1 - put_ bh aa - put_ bh ab - - put_ bh (Orig aa ab) = do - putByte bh 2 - put_ bh aa - put_ bh ab - - put_ bh (Exact n) = pprPanic "No Binary instance for RdrName.Exact" (ppr n) - - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Unqual aa) - 1 -> do aa <- get bh - ab <- get bh - return (Qual aa ab) - _ -> do aa <- get bh - ab <- get bh - return (Orig aa ab) +plusProv :: Provenance -> Provenance -> Provenance +-- Choose LocalDef over Imported +-- There is an obscure bug lurking here, in the presence +-- of recursive modules, something can be imported *and* locally +-- defined, and one might refer to it with a qualified name from +-- the import -- but I'm going to ignore that because it makes +-- the isLocalGRE predicate so much nicer this way +plusProv (LocalDef m1) (LocalDef m2) + = pprPanic "plusProv" (ppr m1 <+> ppr m2) +plusProv p1@(LocalDef _) p2 = p1 +plusProv p1 p2@(LocalDef _) = p2 +plusProv (Imported is1 ex1) (Imported is2 ex2) + = Imported (is1++is2) (ex1 || ex2) + +pprNameProvenance :: GlobalRdrElt -> SDoc +pprNameProvenance (GRE {gre_name = name, gre_prov = LocalDef _}) + = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) +pprNameProvenance (GRE {gre_name = name, gre_prov = Imported (why:whys) _}) + = sep [ppr_reason why, nest 2 (ppr_defn (nameSrcLoc name))] + +ppr_reason imp_spec + = ptext SLIT("imported from") <+> ppr (is_mod imp_spec) + <+> ptext SLIT("at") <+> ppr (is_loc imp_spec) + +ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("defined at") <+> ppr loc) + | otherwise = empty \end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 377a8c872d..cd3513568c 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -11,13 +11,14 @@ module SrcLoc ( SrcLoc, -- Abstract - mkSrcLoc, isGoodSrcLoc, isWiredInLoc, + mkSrcLoc, isGoodSrcLoc, mkGeneralSrcLoc, noSrcLoc, -- "I'm sorry, I haven't a clue" advanceSrcLoc, importedSrcLoc, -- Unknown place in an interface wiredInSrcLoc, -- Something wired into the compiler generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session srcLocFile, -- return the file name part srcLocLine, -- return the line part @@ -28,7 +29,6 @@ module SrcLoc ( import Util ( thenCmp ) import Outputable -import FastString ( unpackFS ) import FastTypes import FastString @@ -45,17 +45,13 @@ We keep information about the {\em definition} point for each entity; this is the obvious stuff: \begin{code} data SrcLoc - = WiredInLoc -- Used exclusively for Ids and TyCons - -- that are totally wired in to the - -- compiler. That supports the - -- occasionally-useful predicate - -- isWiredInName - - | SrcLoc FastString -- A precise location (file name) + = SrcLoc FastString -- A precise location (file name) FastInt -- line FastInt -- column - | UnhelpfulSrcLoc FastString -- Just a general indication + | ImportedLoc String -- Module name + + | UnhelpfulLoc FastString -- Just a general indication {- data SrcSpan @@ -86,30 +82,37 @@ rare case. Things to make 'em: \begin{code} mkSrcLoc x line col = SrcLoc x (iUnbox line) (iUnbox col) -wiredInSrcLoc = WiredInLoc -noSrcLoc = UnhelpfulSrcLoc FSLIT("<No locn>") -importedSrcLoc = UnhelpfulSrcLoc FSLIT("<imported>") -generatedSrcLoc = UnhelpfulSrcLoc FSLIT("<compiler-generated-code>") +noSrcLoc = UnhelpfulLoc FSLIT("<no locn>") +generatedSrcLoc = UnhelpfulLoc FSLIT("<compiler-generated code>") +wiredInSrcLoc = UnhelpfulLoc FSLIT("<wired into compiler>") +interactiveSrcLoc = UnhelpfulLoc FSLIT("<interactive session>") -isGoodSrcLoc (SrcLoc _ _ _) = True -isGoodSrcLoc other = False +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc -isWiredInLoc WiredInLoc = True -isWiredInLoc other = False +importedSrcLoc :: String -> SrcLoc +importedSrcLoc mod_name = ImportedLoc mod_name + +isGoodSrcLoc (SrcLoc _ _ _) = True +isGoodSrcLoc other = False srcLocFile :: SrcLoc -> FastString srcLocFile (SrcLoc fname _ _) = fname +srcLocFile other = FSLIT("<unknown file") srcLocLine :: SrcLoc -> Int srcLocLine (SrcLoc _ l c) = iBox l +srcLocLine other = panic "srcLocLine: unknown line" srcLocCol :: SrcLoc -> Int srcLocCol (SrcLoc _ l c) = iBox c +srcLocCol other = panic "srcLocCol: unknown col" advanceSrcLoc :: SrcLoc -> Char -> SrcLoc advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (tab c) advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l +# 1#) 0# advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c +# 1#) +advanceSrcLoc loc _ = loc -- Better than nothing -- Advance to the next tab stop. Tabs are at column positions 0, 8, 16, etc. tab :: FastInt -> FastInt @@ -132,21 +135,21 @@ instance Eq SrcLoc where instance Ord SrcLoc where compare = cmpSrcLoc -cmpSrcLoc WiredInLoc WiredInLoc = EQ -cmpSrcLoc WiredInLoc other = LT +cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 +cmpSrcLoc (UnhelpfulLoc _) other = LT -cmpSrcLoc (UnhelpfulSrcLoc s1) (UnhelpfulSrcLoc s2) = s1 `compare` s2 -cmpSrcLoc (UnhelpfulSrcLoc s1) other = GT +cmpSrcLoc (ImportedLoc _) (UnhelpfulLoc _) = GT +cmpSrcLoc (ImportedLoc m1) (ImportedLoc m2) = m1 `compare` m2 +cmpSrcLoc (ImportedLoc _) other = LT -cmpSrcLoc (SrcLoc _ _ _) WiredInLoc = GT -cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulSrcLoc _) = LT cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) `thenCmp` (c1 `cmpline` c2) where l1 `cmpline` l2 | l1 <# l2 = LT | l1 ==# l2 = EQ | otherwise = GT - +cmpSrcLoc (SrcLoc _ _ _) other = GT + instance Outputable SrcLoc where ppr (SrcLoc src_path src_line src_col) = getPprStyle $ \ sty -> @@ -158,10 +161,7 @@ instance Outputable SrcLoc where else hcat [text "{-# LINE ", int (iBox src_line), space, char '\"', ftext src_path, text " #-}"] - where - src_file = unpackFS src_path -- Leave the directory prefix intact, - -- so emacs can find the file - ppr (UnhelpfulSrcLoc s) = ftext s - ppr WiredInLoc = ptext SLIT("<Wired in>") + ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> quotes (text mod) + ppr (UnhelpfulLoc s) = ftext s \end{code} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 6752a3b79b..47ac572ddf 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -26,30 +26,27 @@ import CgBindery ( getArgAmodes, bindNewToNode, idInfoToAmode, stableAmodeIdInfo, heapIdInfo, CgIdInfo, bindNewToStack ) -import CgStackery ( mkVirtStkOffsets, freeStackSlots, updateFrameSize ) -import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp, - getSpRelOffset ) +import CgStackery ( mkVirtStkOffsets, freeStackSlots ) +import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp ) import CgRetConv ( assignRegs ) -import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE, - mIN_UPD_SIZE ) +import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE ) import CgHeapery ( allocDynClosure ) import CgTailCall ( performReturn, mkStaticAlgReturnCode, returnUnboxedTuple ) import CLabel ( mkClosureLabel ) import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynConstr, - layOutStaticConstr, closureSize, mkStaticClosure + layOutStaticConstr, mkStaticClosure ) import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) import DataCon ( DataCon, dataConTag, - isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, + isUnboxedTupleCon, dataConWorkId, dataConName, dataConRepArity ) import Id ( Id, idName, idPrimRep, isDeadBinder ) import Literal ( Literal(..) ) import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) import PrimRep ( PrimRep(..), isFollowableRep ) -import Unique ( Uniquable(..) ) import Util import Outputable diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 825d748c05..ecf7d52ae9 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP Project, Glasgow University, 1992-1998 % -% $Id: CgRetConv.lhs,v 1.33 2002/09/13 15:02:28 simonpj Exp $ +% $Id: CgRetConv.lhs,v 1.34 2003/10/09 11:58:46 simonpj Exp $ % \section[CgRetConv]{Return conventions for the code generator} @@ -26,7 +26,7 @@ import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, mAX_Real_Double_REG, mAX_Real_Long_REG ) import CmdLineOpts ( opt_Unregisterised ) -import Maybes ( catMaybes ) +import Maybes ( mapCatMaybes ) import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep ) import TyCon ( TyCon, tyConFamilySize ) import Util ( isn'tIn ) @@ -224,10 +224,10 @@ mkRegTbl_allRegs regs_in_use mkRegTbl' regs_in_use vanillas floats doubles longs = (ok_vanilla, ok_float, ok_double, ok_long) where - ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) vanillas) - ok_float = catMaybes (map (select FloatReg) floats) - ok_double = catMaybes (map (select DoubleReg) doubles) - ok_long = catMaybes (map (select (LongReg Int64Rep)) longs) + ok_vanilla = mapCatMaybes (select (VanillaReg VoidRep)) vanillas + ok_float = mapCatMaybes (select FloatReg) floats + ok_double = mapCatMaybes (select DoubleReg) doubles + ok_long = mapCatMaybes (select (LongReg Int64Rep)) longs -- rep isn't looked at, hence we can use any old rep. select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 16639d4a16..89678d5e87 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.58 2003/06/09 13:17:38 matthewc Exp $ +% $Id: ClosureInfo.lhs,v 1.59 2003/10/09 11:58:46 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -89,6 +89,8 @@ import Bitmap import Maybe ( isJust ) import DATA_BITS + +import TypeRep -- TEMP \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 5b01138cd8..4ac0eaa557 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -300,7 +300,7 @@ maybeExternaliseId id | opt_EnsureSplittableC, -- Externalise the name for -split-objs isInternalName name = moduleName `thenFC` \ mod -> - returnFC (setIdName id (mkExternalName uniq mod new_occ (nameSrcLoc name))) + returnFC (setIdName id (mkExternalName uniq mod new_occ Nothing (nameSrcLoc name))) | otherwise = returnFC id where diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 1722ddcd47..149e225efb 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -8,9 +8,9 @@ module CompManager ( ModuleGraph, ModSummary(..), - CmState, emptyCmState, -- abstract + CmState, -- abstract - cmInit, -- :: GhciMode -> IO CmState + cmInit, -- :: GhciMode -> DynFlags -> IO CmState cmDepAnal, -- :: CmState -> DynFlags -> [FilePath] -> IO ModuleGraph @@ -46,6 +46,7 @@ module CompManager ( cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable) findModuleLinkable_maybe, -- Exported to InteractiveUI + cmSetDFlags, cmGetBindings, -- :: CmState -> [TyThing] cmGetPrintUnqual, -- :: CmState -> PrintUnqualified @@ -57,13 +58,11 @@ where #include "HsVersions.h" import DriverPipeline ( CompResult(..), preprocess, compile, link ) +import HscMain ( newHscEnv ) import DriverState ( v_Output_file, v_NoHsMain ) import DriverPhases -import DriverUtil import Finder -import HscMain ( initPersistentCompilerState ) -import HscTypes hiding ( moduleNameToModule ) -import NameEnv +import HscTypes import PrelNames ( gHC_PRIM_Name ) import Module ( Module, ModuleName, moduleName, mkModuleName, isHomeModule, ModuleEnv, lookupModuleEnvByName, mkModuleEnv, moduleEnvElts, @@ -80,19 +79,20 @@ import Util import Outputable import Panic import CmdLineOpts ( DynFlags(..), getDynFlags ) -import Maybes ( expectJust, orElse ) +import Maybes ( expectJust, orElse, mapCatMaybes ) import DATA_IOREF ( readIORef ) #ifdef GHCI import HscMain ( hscThing, hscStmt, hscTcExpr ) -import Module ( moduleUserString ) -import TcRnDriver ( mkGlobalContext, getModuleContents ) -import Name ( Name, NamedThing(..), isExternalName, nameModule ) +import TcRnDriver ( mkExportEnv, getModuleContents ) +import IfaceSyn ( IfaceDecl ) +import Name ( Name ) +import NameEnv import Id ( idType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) -import BasicTypes ( Fixity, FixitySig(..), defaultFixity ) +import BasicTypes ( Fixity ) import Linker ( HValue, unload, extendLinkEnv ) import GHC.Exts ( unsafeCoerce# ) import Foreign @@ -115,31 +115,31 @@ import Time ( ClockTime ) -- Persistent state for the entire system data CmState = CmState { - gmode :: GhciMode, -- NEVER CHANGES - - hpt :: HomePackageTable, -- Info about home package module - mg :: ModuleGraph, -- the module graph - ic :: InteractiveContext, -- command-line binding info - - pcs :: PersistentCompilerState -- compile's persistent state + cm_hsc :: HscEnv, -- Includes the home-package table + cm_mg :: ModuleGraph, -- The module graph + cm_ic :: InteractiveContext -- Command-line binding info } -cmGetModInfo cmstate = (mg cmstate, hpt cmstate) -cmGetBindings cmstate = nameEnvElts (ic_type_env (ic cmstate)) -cmGetPrintUnqual cmstate = icPrintUnqual (ic cmstate) - -emptyCmState :: GhciMode -> IO CmState -emptyCmState gmode - = do pcs <- initPersistentCompilerState - return (CmState { hpt = emptyHomePackageTable, - mg = emptyMG, - gmode = gmode, - ic = emptyInteractiveContext, - pcs = pcs }) +#ifdef GHCI +cmGetModInfo cmstate = (cm_mg cmstate, hsc_HPT (cm_hsc cmstate)) +cmGetBindings cmstate = nameEnvElts (ic_type_env (cm_ic cmstate)) +cmGetPrintUnqual cmstate = icPrintUnqual (cm_ic cmstate) +cmHPT cmstate = hsc_HPT (cm_hsc cmstate) +#endif -cmInit :: GhciMode -> IO CmState -cmInit mode = emptyCmState mode +cmInit :: GhciMode -> DynFlags -> IO CmState +cmInit ghci_mode dflags + = do { hsc_env <- newHscEnv ghci_mode dflags + ; return (CmState { cm_hsc = hsc_env, + cm_mg = emptyMG, + cm_ic = emptyInteractiveContext })} +discardCMInfo :: CmState -> CmState +-- Forget the compilation manager's state, including the home package table +-- but retain the persistent info in HscEnv +discardCMInfo cm_state + = cm_state { cm_mg = emptyMG, cm_ic = emptyInteractiveContext, + cm_hsc = (cm_hsc cm_state) { hsc_HPT = emptyHomePackageTable } } ------------------------------------------------------------------- -- The unlinked image @@ -150,8 +150,6 @@ cmInit mode = emptyCmState mode -- recompiling. type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) -emptyUI :: UnlinkedImage -emptyUI = [] findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable findModuleLinkable_maybe lis mod @@ -159,21 +157,6 @@ findModuleLinkable_maybe lis mod [] -> Nothing [li] -> Just li many -> pprPanic "findModuleLinkable" (ppr mod) - -filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] -filterModuleLinkables p [] = [] -filterModuleLinkables p (li:lis) - = case li of - LM _ modnm _ -> if p modnm then retain else dump - where - dump = filterModuleLinkables p lis - retain = li : dump - -linkableInSet :: Linkable -> [Linkable] -> Bool -linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModName l) of - Nothing -> False - Just m -> linkableTime l == linkableTime m \end{code} @@ -191,106 +174,54 @@ linkableInSet l objs_loaded = -- module. They always shadow anything in scope in the current context. cmSetContext - :: CmState -> DynFlags + :: CmState -> [String] -- take the top-level scopes of these modules -> [String] -- and the just the exports from these -> IO CmState -cmSetContext cmstate dflags toplevs exports = do - let CmState{ hpt=hpt, pcs=pcs, ic=old_ic } = cmstate - hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags, - hsc_HPT = hpt } - - toplev_mods <- mapM (getTopLevModule hpt) (map mkModuleName toplevs) - export_mods <- mapM (moduleNameToModule hpt) (map mkModuleName exports) - - (new_pcs, maybe_env) - <- mkGlobalContext hsc_env pcs toplev_mods export_mods - - case maybe_env of - Nothing -> return cmstate - Just env -> return cmstate{ pcs = new_pcs, - ic = old_ic{ ic_toplev_scope = toplev_mods, - ic_exports = export_mods, - ic_rn_gbl_env = env } } - -getTopLevModule hpt mn = - case lookupModuleEnvByName hpt mn of - - Just mod_info - | isJust (mi_globals iface) -> return (mi_module iface) - where - iface = hm_iface mod_info - - _other -> throwDyn (CmdLineError ( - "cannot enter the top-level scope of a compiled module (module `" ++ - moduleNameUserString mn ++ "')")) - -moduleNameToModule :: HomePackageTable -> ModuleName -> IO Module -moduleNameToModule hpt mn = do - case lookupModuleEnvByName hpt mn of - Just mod_info -> return (mi_module (hm_iface mod_info)) - _not_a_home_module -> do - maybe_stuff <- findModule mn - case maybe_stuff of - Left _ -> throwDyn (CmdLineError ("can't find module `" - ++ moduleNameUserString mn ++ "'")) - Right (m,_) -> return m +cmSetContext cmstate toplevs exports = do + let old_ic = cm_ic cmstate + + export_env <- mkExportEnv (cm_hsc cmstate) + (map mkModuleName exports) + + putStrLn (showSDoc (text "export env" $$ ppr export_env)) + return cmstate{ cm_ic = old_ic { ic_toplev_scope = toplevs, + ic_exports = exports, + ic_rn_gbl_env = export_env } } cmGetContext :: CmState -> IO ([String],[String]) -cmGetContext CmState{ic=ic} = - return (map moduleUserString (ic_toplev_scope ic), - map moduleUserString (ic_exports ic)) +cmGetContext CmState{cm_ic=ic} = + return (ic_toplev_scope ic, ic_exports ic) cmModuleIsInterpreted :: CmState -> String -> IO Bool cmModuleIsInterpreted cmstate str - = case lookupModuleEnvByName (hpt cmstate) (mkModuleName str) of - Just details -> return (isJust (mi_globals (hm_iface details))) + = case lookupModuleEnvByName (cmHPT cmstate) (mkModuleName str) of + Just details -> return (isJust (hm_globals details)) _not_a_home_module -> return False ----------------------------------------------------------------------------- +cmSetDFlags :: CmState -> DynFlags -> CmState +cmSetDFlags cm_state dflags + = cm_state { cm_hsc = (cm_hsc cm_state) { hsc_dflags = dflags } } + +----------------------------------------------------------------------------- -- cmInfoThing: convert a String to a TyThing -- A string may refer to more than one TyThing (eg. a constructor, -- and type constructor), so we return a list of all the possible TyThings. -cmInfoThing :: CmState -> DynFlags -> String -> IO (CmState, [(TyThing,Fixity)]) -cmInfoThing cmstate dflags id - = do (new_pcs, things) <- hscThing hsc_env pcs icontext id - let new_pit = eps_PIT (pcs_EPS new_pcs) - pairs = map (\x -> (x, getFixity new_pit (getName x))) things - return (cmstate{ pcs=new_pcs }, pairs) - where - CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate - hsc_env = HscEnv { hsc_mode = Interactive, - hsc_dflags = dflags, - hsc_HPT = hpt } - - getFixity :: PackageIfaceTable -> Name -> Fixity - getFixity pit name - | isExternalName name, - Just iface <- lookupIface hpt pit (nameModule name), - Just (FixitySig _ fixity _) <- lookupNameEnv (mi_fixities iface) name - = fixity - | otherwise - = defaultFixity +cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity)] +cmInfoThing cmstate id + = hscThing (cm_hsc cmstate) (cm_ic cmstate) id -- --------------------------------------------------------------------------- -- cmBrowseModule: get all the TyThings defined in a module -cmBrowseModule :: CmState -> DynFlags -> String -> Bool - -> IO (CmState, [TyThing]) -cmBrowseModule cmstate dflags str exports_only = do - let mn = mkModuleName str - mod <- moduleNameToModule hpt mn - (pcs1, maybe_ty_things) - <- getModuleContents hsc_env pcs mod exports_only - case maybe_ty_things of - Nothing -> return (cmstate{pcs=pcs1}, []) - Just ty_things -> return (cmstate{pcs=pcs1}, ty_things) - where - hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags, - hsc_HPT = hpt } - CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate +cmBrowseModule :: CmState -> String -> Bool -> IO [IfaceDecl] +cmBrowseModule cmstate str exports_only + = getModuleContents (cm_hsc cmstate) (cm_ic cmstate) + (mkModuleName str) exports_only + ----------------------------------------------------------------------------- -- cmRunStmt: Run a statement/expr. @@ -300,19 +231,13 @@ data CmRunResult | CmRunFailed | CmRunException Exception -- statement raised an exception -cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult) -cmRunStmt cmstate@CmState{ hpt=hpt, pcs=pcs, ic=icontext } - dflags expr +cmRunStmt :: CmState -> String -> IO (CmState, CmRunResult) +cmRunStmt cmstate@CmState{ cm_hsc=hsc_env, cm_ic=icontext } expr = do - let hsc_env = HscEnv { hsc_mode = Interactive, - hsc_dflags = dflags, - hsc_HPT = hpt } - - (new_pcs, maybe_stuff) - <- hscStmt hsc_env pcs icontext expr + maybe_stuff <- hscStmt hsc_env icontext expr case maybe_stuff of - Nothing -> return (cmstate{ pcs=new_pcs }, CmRunFailed) + Nothing -> return (cmstate, CmRunFailed) Just (new_ic, names, hval) -> do let thing_to_run = unsafeCoerce# hval :: IO [HValue] @@ -323,7 +248,7 @@ cmRunStmt cmstate@CmState{ hpt=hpt, pcs=pcs, ic=icontext } -- on error, keep the *old* interactive context, -- so that 'it' is not bound to something -- that doesn't exist. - return ( cmstate{ pcs=new_pcs }, CmRunException e ) + return ( cmstate, CmRunException e ) Right hvals -> do -- Get the newly bound things, and bind them. @@ -331,7 +256,7 @@ cmRunStmt cmstate@CmState{ hpt=hpt, pcs=pcs, ic=icontext } -- the new ones override the old ones. extendLinkEnv (zip names hvals) - return (cmstate{ pcs=new_pcs, ic=new_ic }, + return (cmstate{ cm_ic=new_ic }, CmRunOk names) @@ -373,36 +298,28 @@ foreign import "rts_evalStableIO" {- safe -} ----------------------------------------------------------------------------- -- cmTypeOfExpr: returns a string representing the type of an expression -cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String) -cmTypeOfExpr cmstate dflags expr - = do (new_pcs, maybe_stuff) <- hscTcExpr hsc_env pcs ic expr - - let new_cmstate = cmstate{pcs = new_pcs} +cmTypeOfExpr :: CmState -> String -> IO (Maybe String) +cmTypeOfExpr cmstate expr + = do maybe_stuff <- hscTcExpr (cm_hsc cmstate) (cm_ic cmstate) expr case maybe_stuff of - Nothing -> return (new_cmstate, Nothing) - Just ty -> return (new_cmstate, Just str) + Nothing -> return Nothing + Just ty -> return (Just str) where str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty) - unqual = icPrintUnqual ic + unqual = icPrintUnqual (cm_ic cmstate) tidy_ty = tidyType emptyTidyEnv ty - where - CmState{ hpt=hpt, pcs=pcs, ic=ic } = cmstate - hsc_env = HscEnv { hsc_mode = Interactive, - hsc_dflags = dflags, - hsc_HPT = hpt } - ----------------------------------------------------------------------------- -- cmTypeOfName: returns a string representing the type of a name. cmTypeOfName :: CmState -> Name -> IO (Maybe String) -cmTypeOfName CmState{ pcs=pcs, ic=ic } name +cmTypeOfName CmState{ cm_ic=ic } name = do hPutStrLn stderr ("cmTypeOfName: " ++ showSDoc (ppr name)) case lookupNameEnv (ic_type_env ic) name of - Nothing -> return Nothing + Nothing -> return Nothing Just (AnId id) -> return (Just str) where unqual = icPrintUnqual ic @@ -414,30 +331,24 @@ cmTypeOfName CmState{ pcs=pcs, ic=ic } name ----------------------------------------------------------------------------- -- cmCompileExpr: compile an expression and deliver an HValue -cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue) -cmCompileExpr cmstate dflags expr +cmCompileExpr :: CmState -> String -> IO (Maybe HValue) +cmCompileExpr cmstate expr = do - let hsc_env = HscEnv { hsc_mode = Interactive, - hsc_dflags = dflags, - hsc_HPT = hpt } - - (new_pcs, maybe_stuff) - <- hscStmt hsc_env pcs icontext + maybe_stuff + <- hscStmt (cm_hsc cmstate) (cm_ic cmstate) ("let __cmCompileExpr = "++expr) case maybe_stuff of - Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) + Nothing -> return Nothing Just (new_ic, names, hval) -> do -- Run it! hvals <- (unsafeCoerce# hval) :: IO [HValue] case (names,hvals) of - ([n],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv) + ([n],[hv]) -> return (Just hv) _ -> panic "cmCompileExpr" - where - CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate #endif /* GHCI */ \end{code} @@ -453,26 +364,26 @@ cmCompileExpr cmstate dflags expr -- Unload the compilation manager's state: everything it knows about the -- current collection of modules in the Home package. -cmUnload :: CmState -> DynFlags -> IO CmState -cmUnload state@CmState{ gmode=mode, pcs=pcs } dflags +cmUnload :: CmState -> IO CmState +cmUnload state@CmState{ cm_hsc = hsc_env } = do -- Throw away the old home dir cache flushFinderCache -- Unload everything the linker knows about - cm_unload mode dflags [] + cm_unload hsc_env [] -- Start with a fresh CmState, but keep the PersistentCompilerState - new_state <- cmInit mode - return new_state{ pcs=pcs } - -cm_unload Batch dflags linkables = return () + return (discardCMInfo state) +cm_unload hsc_env linkables + = case hsc_mode hsc_env of + Batch -> return () #ifdef GHCI -cm_unload Interactive dflags linkables = Linker.unload dflags linkables + Interactive -> Linker.unload (hsc_dflags hsc_env) linkables #else -cm_unload Interactive dflags linkables = panic "unload: no interpreter" + Interactive -> panic "unload: no interpreter" #endif - + ----------------------------------------------------------------------------- -- Trace dependency graph @@ -485,14 +396,18 @@ cm_unload Interactive dflags linkables = panic "unload: no interpreter" -- He wants to do the dependency analysis before the unload, so that -- if the former fails he can use the later -cmDepAnal :: CmState -> DynFlags -> [FilePath] -> IO ModuleGraph -cmDepAnal cmstate dflags rootnames +cmDepAnal :: CmState -> [FilePath] -> IO ModuleGraph +cmDepAnal cmstate rootnames = do showPass dflags "Chasing dependencies" - when (verbosity dflags >= 1 && gmode cmstate == Batch) $ + when (verbosity dflags >= 1 && gmode == Batch) $ hPutStrLn stderr (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map text rootnames))])) - downsweep rootnames (mg cmstate) + downsweep rootnames (cm_mg cmstate) + where + hsc_env = cm_hsc cmstate + dflags = hsc_dflags hsc_env + gmode = hsc_mode hsc_env ----------------------------------------------------------------------------- -- The real business of the compilation manager: given a system state and @@ -500,18 +415,17 @@ cmDepAnal cmstate dflags rootnames -- the system state at the same time. cmLoadModules :: CmState -- The HPT may not be as up to date - -> DynFlags -- as the ModuleGraph -> ModuleGraph -- Bang up to date -> IO (CmState, -- new state SuccessFlag, -- was successful [String]) -- list of modules loaded -cmLoadModules cmstate1 dflags mg2unsorted +cmLoadModules cmstate1 mg2unsorted = do -- version 1's are the original, before downsweep - let pcs1 = pcs cmstate1 - let hpt1 = hpt cmstate1 - - let ghci_mode = gmode cmstate1 -- this never changes + let hsc_env = cm_hsc cmstate1 + let hpt1 = hsc_HPT hsc_env + let ghci_mode = hsc_mode hsc_env -- this never changes + let dflags = hsc_dflags hsc_env -- this never changes -- Do the downsweep to reestablish the module graph let verb = verbosity dflags @@ -545,6 +459,7 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Uniq of ModuleName is the same as Module, fortunately... let hpt2 = delListFromUFM hpt1 (map linkableModName new_linkables) + hsc_env2 = hsc_env { hsc_HPT = hpt2 } -- When (verb >= 2) $ -- putStrLn (showSDoc (text "Valid linkables:" @@ -576,7 +491,7 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Unload any modules which are going to be re-linked this -- time around. - cm_unload ghci_mode dflags stable_linkables + cm_unload hsc_env2 stable_linkables -- we can now glom together our linkable sets let valid_linkables = valid_old_linkables ++ new_linkables @@ -601,17 +516,13 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Now do the upsweep, calling compile for each module in -- turn. Final result is version 3 of everything. - let threaded2 = CmThreaded pcs1 hpt2 - -- clean up between compilations let cleanup = cleanTempFilesExcept verb (ppFilesFromSummaries (flattenSCCs mg2)) - (upsweep_ok, threaded3, modsUpswept) - <- upsweep_mods ghci_mode dflags valid_linkables reachable_from - threaded2 cleanup upsweep_these - - let (CmThreaded pcs3 hpt3) = threaded3 + (upsweep_ok, hsc_env3, modsUpswept) + <- upsweep_mods hsc_env2 valid_linkables reachable_from + cleanup upsweep_these -- At this point, modsUpswept and newLis should have the same -- length, so there is one new (or old) linkable for each @@ -653,10 +564,10 @@ cmLoadModules cmstate1 dflags mg2unsorted hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module." -- link everything together - linkresult <- link ghci_mode dflags do_linking hpt3 + linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3) - cmLoadFinish Succeeded linkresult - hpt3 modsDone ghci_mode pcs3 + let cmstate3 = cmstate1 { cm_mg = modsDone, cm_hsc = hsc_env3 } + cmLoadFinish Succeeded linkresult cmstate3 else -- Tricky. We need to back out the effects of compiling any @@ -674,7 +585,8 @@ cmLoadModules cmstate1 dflags mg2unsorted = filter ((`notElem` mods_to_zap_names).modSummaryName) modsDone - let hpt4 = retainInTopLevelEnvs (map modSummaryName mods_to_keep) hpt3 + let hpt4 = retainInTopLevelEnvs (map modSummaryName mods_to_keep) + (hsc_HPT hsc_env3) -- Clean up after ourselves cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep) @@ -682,26 +594,24 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Link everything together linkresult <- link ghci_mode dflags False hpt4 - cmLoadFinish Failed linkresult - hpt4 mods_to_keep ghci_mode pcs3 + let cmstate3 = cmstate1 { cm_mg = mods_to_keep, + cm_hsc = hsc_env3 { hsc_HPT = hpt4 } } + cmLoadFinish Failed linkresult cmstate3 -- Finish up after a cmLoad. -- If the link failed, unload everything and return. -cmLoadFinish ok Failed hpt mods ghci_mode pcs = do - dflags <- getDynFlags - cm_unload ghci_mode dflags [] - new_state <- cmInit ghci_mode - return (new_state{ pcs=pcs }, Failed, []) +cmLoadFinish ok Failed cmstate + = do cm_unload (cm_hsc cmstate) [] + return (discardCMInfo cmstate, Failed, []) -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. -cmLoadFinish ok Succeeded hpt mods ghci_mode pcs - = do let new_cmstate = CmState{ hpt=hpt, mg=mods, - gmode=ghci_mode, pcs=pcs, - ic = emptyInteractiveContext } - mods_loaded = map (moduleNameUserString.modSummaryName) mods +cmLoadFinish ok Succeeded cmstate + = do let new_cmstate = cmstate { cm_ic = emptyInteractiveContext } + mods_loaded = map (moduleNameUserString.modSummaryName) + (cm_mg cmstate) return (new_cmstate, ok, mods_loaded) @@ -928,72 +838,62 @@ findPartiallyCompletedCycles modsDone theGraph else chewed_rest -data CmThreaded -- stuff threaded through individual module compilations - = CmThreaded PersistentCompilerState HomePackageTable - - -- Compile multiple modules, stopping as soon as an error appears. -- There better had not be any cyclic groups here -- we check for them. -upsweep_mods :: GhciMode - -> DynFlags +upsweep_mods :: HscEnv -- Includes up-to-date HPT -> [Linkable] -- Valid linkables -> (ModuleName -> [ModuleName]) -- to construct downward closures - -> CmThreaded -- PCS & HPT -> IO () -- how to clean up unwanted tmp files -> [SCC ModSummary] -- mods to do (the worklist) -- ...... RETURNING ...... -> IO (SuccessFlag, - CmThreaded, -- Includes linkables + HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup +upsweep_mods hsc_env oldUI reachable_from cleanup [] - = return (Succeeded, threaded, []) + = return (Succeeded, hsc_env, []) -upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup +upsweep_mods hsc_env oldUI reachable_from cleanup ((CyclicSCC ms):_) = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ unwords (map (moduleNameUserString.modSummaryName) ms)) - return (Failed, threaded, []) + return (Failed, hsc_env, []) -upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup +upsweep_mods hsc_env oldUI reachable_from cleanup ((AcyclicSCC mod):mods) - = do --case threaded of - -- CmThreaded pcsz hptz - -- -> putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleNameUserString.moduleName.mi_module.hm_iface) (eltsUFM hptz))) + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleNameUserString.moduleName.mi_module.hm_iface) (eltsUFM (hsc_HPT hsc_env))) - (ok_flag, threaded1) <- upsweep_mod ghci_mode dflags oldUI threaded mod + (ok_flag, hsc_env1) <- upsweep_mod hsc_env oldUI mod (reachable_from (modSummaryName mod)) cleanup -- Remove unwanted tmp files between compilations if failed ok_flag then - return (Failed, threaded1, []) + return (Failed, hsc_env1, []) else do - (restOK, threaded2, modOKs) - <- upsweep_mods ghci_mode dflags oldUI reachable_from - threaded1 cleanup mods - return (restOK, threaded2, mod:modOKs) + (restOK, hsc_env2, modOKs) + <- upsweep_mods hsc_env1 oldUI reachable_from cleanup mods + return (restOK, hsc_env2, mod:modOKs) -- Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: GhciMode - -> DynFlags +upsweep_mod :: HscEnv -> UnlinkedImage - -> CmThreaded -> ModSummary -> [ModuleName] - -> IO (SuccessFlag, CmThreaded) + -> IO (SuccessFlag, + HscEnv) -- With updated HPT -upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me +upsweep_mod hsc_env oldUI summary1 reachable_inc_me = do let this_mod = ms_mod summary1 location = ms_location summary1 mod_name = moduleName this_mod + hpt1 = hsc_HPT hsc_env - let (CmThreaded pcs1 hpt1) = threaded1 let mb_old_iface = case lookupModuleEnvByName hpt1 mod_name of Just mod_info -> Just (hm_iface mod_info) Nothing -> Nothing @@ -1007,8 +907,9 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me -- interface in the HPT. We never demand-load home interfaces in -- interactive mode. hpt1_strictDC - = ASSERT(ghci_mode == Batch || all (`elemUFM` hpt1) reachable_only) + = ASSERT(hsc_mode hsc_env == Batch || all (`elemUFM` hpt1) reachable_only) retainInTopLevelEnvs reachable_only hpt1 + hsc_env_strictDC = hsc_env { hsc_HPT = hpt1_strictDC } old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable @@ -1016,26 +917,27 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me | Just l <- maybe_old_linkable, isObjectLinkable l = True | otherwise = False - compresult <- compile ghci_mode this_mod location source_unchanged - have_object mb_old_iface hpt1_strictDC pcs1 + compresult <- compile hsc_env_strictDC this_mod location + source_unchanged have_object mb_old_iface case compresult of -- Compilation "succeeded", and may or may not have returned a new -- linkable (depending on whether compilation was actually performed -- or not). - CompOK pcs2 new_details new_iface maybe_new_linkable + CompOK new_details new_globals new_iface maybe_new_linkable -> do let new_linkable = maybe_new_linkable `orElse` old_linkable new_info = HomeModInfo { hm_iface = new_iface, + hm_globals = new_globals, hm_details = new_details, hm_linkable = new_linkable } hpt2 = extendModuleEnv hpt1 this_mod new_info - return (Succeeded, CmThreaded pcs2 hpt2) + return (Succeeded, hsc_env { hsc_HPT = hpt2 }) -- Compilation failed. Compile may still have updated the PCS, tho. - CompErrs pcs2 -> return (Failed, CmThreaded pcs2 hpt1) + CompErrs -> return (Failed, hsc_env) -- Filter modules in the HPT retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable @@ -1089,7 +991,7 @@ topological_sort include_source_imports summaries Nothing -> panic "reverse_topological_sort" Just mk -> (summ, mk, -- ignore imports not from the home package - catMaybes (map (flip lookup key_map) m_imports)) + mapCatMaybes (flip lookup key_map) m_imports) edges = map toEdge summaries key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)] diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 18444b6892..1602a07b86 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -16,7 +16,6 @@ import CoreLint ( endPass ) import CoreSyn import Type ( Type, applyTy, splitFunTy_maybe, isUnLiftedType, isUnboxedTupleType, seqType ) -import TcType ( TyThing( AnId ) ) import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) ) import Var ( Var, Id, setVarUnique ) import VarSet @@ -26,7 +25,7 @@ import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, isLocalId, hasNoBinding, idNewStrictness, idUnfolding, isDataConWorkId_maybe ) -import HscTypes ( TypeEnv, typeEnvElts ) +import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -579,9 +578,6 @@ mkLocalNonRec bndr dem floats rhs = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') -> returnUs (addFloat floats' (FloatLet (NonRec bndr rhs'))) - where - bndr_ty = idType bndr - mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr mkBinds (Floats _ binds) body diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 b/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 index db6c7550ac..38dc8c7f7e 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 @@ -3,4 +3,3 @@ module CoreSyn where -- Needed by Var.lhs data Expr b type CoreExpr = Expr Var.Var - diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 01d7925741..baf76c7225 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -42,8 +42,7 @@ import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) import Id ( Id, idType, isId, - idUnfolding, - isFCallId_maybe, globalIdDetails + idUnfolding, globalIdDetails ) import DataCon ( isUnboxedTupleCon ) import Literal ( litSize ) @@ -137,7 +136,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr | not inline -> UnfoldNever -- A big function with an INLINE pragma must -- have an UnfoldIfGoodArgs guidance - | inline -> UnfoldIfGoodArgs n_val_binders + | otherwise -> UnfoldIfGoodArgs n_val_binders (map (const 0) val_binders) max_inline_size 0 diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 7921b3cfcf..5a82fdda3b 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -47,7 +47,7 @@ import Name ( hashName, isDllName ) import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit ) import DataCon ( DataCon, dataConRepArity, dataConArgTys, - isExistentialDataCon, dataConTyCon, dataConName ) + isExistentialDataCon, dataConTyCon ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, mkWildId, idArity, idName, idUnfolding, idInfo, @@ -59,7 +59,7 @@ import NewDemand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy, applyTys, isUnLiftedType, seqType, mkTyVarTy, - splitForAllTy_maybe, isForAllTy, splitNewType_maybe, + splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, splitTyConApp_maybe, eqType, funResultTy, applyTy, funResultTy, applyTy ) @@ -932,13 +932,15 @@ eta_expand n us expr ty ; Nothing -> -- Given this: - -- newtype T = MkT (Int -> Int) + -- newtype T = MkT ([T] -> Int) -- Consider eta-expanding this -- eta_expand 1 e T -- We want to get - -- coerce T (\x::Int -> (coerce (Int->Int) e) x) + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + -- Only try this for recursive newtypes; the non-recursive kind + -- are transparent anyway - case splitNewType_maybe ty of { + case splitRecNewType_maybe ty of { Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr }}} diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs index 06cf07940b..d7eb45579a 100644 --- a/ghc/compiler/coreSyn/ExternalCore.lhs +++ b/ghc/compiler/coreSyn/ExternalCore.lhs @@ -14,13 +14,13 @@ data Tdef | Newtype (Qual Tcon) [Tbind] (Maybe Ty) data Cdef - = Constr (Qual Dcon) [Tbind] [Ty] + = Constr Dcon [Tbind] [Ty] data Vdefg = Rec [Vdef] | Nonrec Vdef -type Vdef = (Qual Var,Ty,Exp) +type Vdef = (Var,Ty,Exp) -- Top level bindings are unqualified now data Exp = Var (Qual Var) diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index 86c77da144..66fa9711e3 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -18,6 +18,7 @@ import TyCon import Class import TypeRep import Type +import PprExternalCore -- Instances import DataCon ( DataCon, dataConExistentialTyVars, dataConRepArgTys, dataConName, dataConWrapId_maybe ) import CoreSyn @@ -28,12 +29,10 @@ import CoreTidy ( tidyExpr ) import VarEnv ( emptyTidyEnv ) import Literal import Name -import CostCentre import Outputable import ForeignCall -import PprExternalCore import CmdLineOpts -import Maybes ( orElse, catMaybes ) +import Maybes ( mapCatMaybes ) import IO import FastString @@ -73,11 +72,11 @@ mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = bin other_implicit_binds = map get_defn (concatMap other_implicit_ids (typeEnvElts type_env)) implicit_con_ids :: TyThing -> [Id] -implicit_con_ids (ATyCon tc) | isAlgTyCon tc = catMaybes (map dataConWrapId_maybe (tyConDataCons tc)) +implicit_con_ids (ATyCon tc) | isAlgTyCon tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) implicit_con_ids other = [] other_implicit_ids :: TyThing -> [Id] -other_implicit_ids (ATyCon tc) = tyConSelIds tc ++ tyConGenIds tc +other_implicit_ids (ATyCon tc) = tyConSelIds tc other_implicit_ids (AClass cl) = classSelIds cl other_implicit_ids other = [] @@ -110,7 +109,7 @@ collect_tdefs _ tdefs = tdefs make_cdef :: DataCon -> C.Cdef make_cdef dcon = C.Constr dcon_name existentials tys where - dcon_name = make_con_qid (dataConName dcon) + dcon_name = make_var_id (dataConName dcon) existentials = map make_tbind ex_tyvars ex_tyvars = dataConExistentialTyVars dcon tys = map make_ty (dataConRepArgTys dcon) @@ -126,7 +125,8 @@ make_vdef b = case b of NonRec v e -> C.Nonrec (f (v,e)) Rec ves -> C.Rec (map f ves) - where f (v,e) = (make_var_qid (Var.varName v), make_ty (varType v),make_exp e) + where f (v,e) = (make_var_id (Var.varName v), make_ty (varType v),make_exp e) + -- Top level bindings are unqualified now make_exp :: CoreExpr -> C.Exp make_exp (Var v) = @@ -187,7 +187,7 @@ make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t) make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts) -- The special case for newtypes says "do not expand newtypes". --- Reason: sourceTypeRep does substitution and, while substitution deals +-- Reason: predTypeRep does substitution and, while substitution deals -- correctly with name capture, it's only correct if you see the uniques! -- If you just see occurrence names, name capture may occur. -- Example: newtype A a = A (forall b. b -> a) @@ -198,11 +198,11 @@ make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) -- expose the representation in interface files, which definitely isn't right. -- Maybe CoreTidy should know whether to expand newtypes or not? -make_ty (SourceTy (NType tc ts)) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) +make_ty (NewTcApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts) -make_ty (SourceTy p) = make_ty (sourceTypeRep p) -make_ty (NoteTy _ t) = make_ty t +make_ty (PredTy p) = make_ty (predTypeRep p) +make_ty (NoteTy _ t) = make_ty t diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 2d62772859..09bb56e092 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -258,8 +258,6 @@ ppr_case_pat con args pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty pprArg expr = pprParendExpr expr - -arrow = ptext SLIT("->") \end{code} Other printing bits-and-bobs used with the general @pprCoreBinding@ diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs index 73536fa99d..357780d295 100644 --- a/ghc/compiler/coreSyn/PprExternalCore.lhs +++ b/ghc/compiler/coreSyn/PprExternalCore.lhs @@ -55,12 +55,12 @@ ptdef (Newtype tcon tbinds rep ) = Nothing -> empty pcdef (Constr dcon tbinds tys) = - (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) + (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) pname id = text id pqname ("",id) = pname id -pqname (m,id) = pname m <> char '.' <> pname id +pqname (m,id) = pname m <> char '.' <> pname id ptbind (t,Klifted) = pname t ptbind (t,k) = parens (pname t <> text "::" <> pkind k) @@ -96,7 +96,7 @@ pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t pvdefg (Rec vtes) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvte vtes)))) pvdefg (Nonrec vte) = pvte vte -pvte (v,t,e) = sep [pqname v <+> text "::" <+> pty t <+> char '=', +pvte (v,t,e) = sep [pname v <+> text "::" <+> pty t <+> char '=', indent (pexp e)] paexp (Var x) = pqname x diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index c406f926e0..1994caa358 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -44,7 +44,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, ) import CoreFVs ( exprFreeVars ) import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( ThetaType, SourceType(..), PredType, +import Type ( ThetaType, PredType(..), tyVarsOfType, tyVarsOfTypes, mkAppTy, ) import VarSet @@ -58,8 +58,7 @@ import IdInfo ( IdInfo, vanillaIdInfo, specInfo, setSpecInfo, setArityInfo, unknownArity, arityInfo, unfoldingInfo, setUnfoldingInfo, - WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo, - lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo + WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo ) import BasicTypes ( OccInfo(..) ) import Unique ( Unique, Uniquable(..), deriveUnique ) @@ -427,11 +426,8 @@ substTheta subst theta | otherwise = map (substPred subst) theta substPred :: TyVarSubst -> PredType -> PredType -substPred = substSourceType - -substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty) -substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) -substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys) +substPred subst (IParam n ty) = IParam n (subst_ty subst ty) +substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) subst_ty subst ty = go ty @@ -439,7 +435,10 @@ subst_ty subst ty go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args - go (SourceTy p) = SourceTy $! (substSourceType subst p) + go (NewTcApp tc tys) = let args = map go tys + in args `seqList` NewTcApp tc args + + go (PredTy p) = PredTy $! (substPred subst p) go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2) go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note @@ -632,8 +631,7 @@ simplIdInfo subst old_info \begin{code} -- substBndr and friends are used when doing expression substitution only -- In this case we can *preserve* occurrence information, and indeed we *want* --- to do so else lose useful occ info in rules. Hence the calls to --- simpl_id with keepOccInfo +-- to do so else lose useful occ info in rules. substBndr :: Subst -> Var -> (Subst, Var) substBndr subst bndr @@ -651,8 +649,6 @@ substRecBndrs subst bndrs -- Here's the reason we need to pass rec_subst to subst_id (new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst) subst bndrs - -keepOccInfo occ = False -- Never fragile \end{code} @@ -747,7 +743,6 @@ substIdInfo :: Bool -- True <=> keep even fragile info -- Substitute the -- rules -- worker info --- LBVar info -- Zap the unfolding -- If keep_fragile then -- keep OccInfo diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 5b93642612..67c6261ebe 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -9,9 +9,9 @@ module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn ) -import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), ExternalPackageState(..), - PersistentCompilerState(..), Dependencies(..), TypeEnv, GlobalRdrEnv, - lookupType, unQualInScope ) +import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), + Dependencies(..), TypeEnv, + unQualInScope ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) @@ -27,9 +27,10 @@ import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. -import Module ( Module, moduleEnvElts ) +import Module ( Module, moduleEnvElts, emptyModuleEnv ) import Id ( Id ) -import NameEnv ( lookupNameEnv ) +import RdrName ( GlobalRdrEnv ) +import NameSet import VarEnv import VarSet import Bag ( isEmptyBag, mapBag, emptyBag ) @@ -39,10 +40,9 @@ import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, import Outputable import qualified Pretty import UniqSupply ( mkSplitUniqSupply ) -import Maybes ( orElse ) import SrcLoc ( SrcLoc ) -import FastString import DATA_IOREF ( readIORef ) +import FastString \end{code} %************************************************************************ @@ -52,36 +52,36 @@ import DATA_IOREF ( readIORef ) %************************************************************************ \begin{code} -deSugar :: HscEnv -> PersistentCompilerState - -> TcGblEnv -> IO (Maybe ModGuts) - -deSugar hsc_env pcs - (TcGblEnv { tcg_mod = mod, - tcg_type_env = type_env, - tcg_usages = usage_var, - tcg_imports = imports, - tcg_exports = exports, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_deprecs = deprecs, - tcg_insts = insts, - tcg_binds = binds, - tcg_fords = fords, - tcg_rules = rules }) +deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts) +-- Can modify PCS by faulting in more declarations + +deSugar hsc_env + (TcGblEnv { tcg_mod = mod, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_dus = dus, + tcg_inst_uses = dfun_uses_var, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_deprecs = deprecs, + tcg_insts = insts, + tcg_binds = binds, + tcg_fords = fords, + tcg_rules = rules }) = do { showPass dflags "Desugar" - ; us <- mkSplitUniqSupply 'd' - ; usages <- readIORef usage_var -- Do desugaring - ; let ((ds_binds, ds_rules, ds_fords), ds_warns) - = initDs dflags us lookup mod - (dsProgram binds rules fords) - - warns = mapBag mk_warn ds_warns - warn_doc = pprBagOfWarnings warns + ; let { is_boot = imp_dep_mods imports } + ; (results, warnings) <- initDs hsc_env mod type_env is_boot $ + dsProgram binds rules fords + + ; let { (ds_binds, ds_rules, ds_fords) = results + ; warns = mapBag mk_warn warnings + ; warn_doc = pprBagOfWarnings warns } -- Display any warnings - ; doIfSet (not (isEmptyBag ds_warns)) + ; doIfSet (not (isEmptyBag warnings)) (printErrs warn_doc) -- if warnings are considered errors, leave. @@ -96,6 +96,9 @@ deSugar hsc_env pcs ; doIfSet (dopt Opt_D_dump_ds dflags) (printDump (ppr_ds_rules ds_rules)) + ; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used + ; let used_names = allUses dus emptyNameSet `unionNameSets` dfun_uses + ; usages <- mkUsageInfo hsc_env imports used_names ; let deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports), dep_pkgs = imp_dep_pkgs imports, @@ -104,7 +107,7 @@ deSugar hsc_env pcs mg_module = mod, mg_exports = exports, mg_deps = deps, - mg_usages = mkUsageInfo hsc_env eps imports usages, + mg_usages = usages, mg_dir_imps = [m | (m,_) <- moduleEnvElts (imp_mods imports)], mg_rdr_env = rdr_env, mg_fix_env = fix_env, @@ -127,38 +130,25 @@ deSugar hsc_env pcs mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc) mk_warn (loc, sdoc) = addShortWarnLocLine loc print_unqual sdoc - -- The lookup function passed to initDs is used for well-known Ids, - -- such as fold, build, cons etc, so the chances are - -- it'll be found in the package symbol table. That's - -- why we don't merge all these tables - eps = pcs_EPS pcs - pte = eps_PTE eps - hpt = hsc_HPT hsc_env - lookup n = case lookupType hpt pte n of { - Just v -> v ; - other -> - case lookupNameEnv type_env n of - Just v -> v ; - other -> pprPanic "Desugar: lookup:" (ppr n) - } deSugarExpr :: HscEnv - -> PersistentCompilerState -> Module -> GlobalRdrEnv -> TypeEnv -> TypecheckedHsExpr -> IO CoreExpr -deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr +deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do { showPass dflags "Desugar" ; us <- mkSplitUniqSupply 'd' -- Do desugaring - ; let (core_expr, ds_warns) = initDs dflags us lookup this_mod (dsExpr tc_expr) - warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns) + ; let { is_boot = emptyModuleEnv } -- Assume no hi-boot files when + -- doing stuff from the command line + ; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env is_boot $ + dsExpr tc_expr -- Display any warnings -- Note: if -Werror is used, we don't signal an error here. ; doIfSet (not (isEmptyBag ds_warns)) - (printErrs warn_doc) + (printErrs (pprBagOfWarnings (mapBag mk_warn ds_warns))) -- Dump output ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr) @@ -166,18 +156,12 @@ deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr ; return core_expr } where - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - pte = eps_PTE (pcs_EPS pcs) - lookup n = lookupNameEnv type_env n `orElse` -- Look in the type env of the - -- current module first - lookupType hpt pte n `orElse` -- Then other modules - pprPanic "Desugar: lookup:" (ppr n) + dflags = hsc_dflags hsc_env + print_unqual = unQualInScope rdr_env mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc) mk_warn (loc,sdoc) = addShortWarnLocLine loc print_unqual sdoc - print_unqual = unQualInScope rdr_env dsProgram all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> @@ -192,7 +176,7 @@ dsProgram all_binds rules fo_decls local_binders = mkVarSet (bindersOfBinds ds_binds) in - mapDs (dsRule local_binders) rules `thenDs` \ ds_rules -> + mappM (dsRule local_binders) rules `thenDs` \ ds_rules -> returnDs (ds_binds, ds_rules, ds_fords) where auto_scc | opt_SccProfilingOn = TopLevel @@ -214,9 +198,6 @@ ppr_ds_rules rules \begin{code} dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule) -dsRule in_scope (IfaceRuleOut fun rule) -- Built-in rules come this way - = returnDs (fun, rule) - dsRule in_scope (HsRule name act vars lhs rhs loc) = putSrcLocDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index b1714b81bb..c04c9ee766 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/ghc/compiler/deSugar/DsArrows.lhs @@ -201,7 +201,7 @@ matchEnvStack :: [Id] -- x1..xn -> CoreExpr -- e -> DsM CoreExpr matchEnvStack env_ids stack_ids body - = getUniqSupplyDs `thenDs` \ uniqs -> + = newUniqueSupply `thenDs` \ uniqs -> newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var -> matchVarStack tup_var stack_ids (coreCaseTuple uniqs tup_var env_ids body) @@ -358,7 +358,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) in dsfixCmd ids local_vars stack' res_ty cmd `thenDs` \ (core_cmd, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> newSysLocalDs arg_ty `thenDs` \ arg_id -> -- push the argument expression onto the stack let @@ -392,7 +392,7 @@ dsCmd ids local_vars env_ids stack res_ty in dsfixCmd ids local_vars' stack' res_ty body `thenDs` \ (core_body, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- the expression is built from the inside out, so the actions -- are presented in reverse order @@ -433,7 +433,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd _loc) `thenDs` \ (core_then, fvs_then, then_ids) -> dsfixCmd ids local_vars stack res_ty else_cmd `thenDs` \ (core_else, fvs_else, else_ids) -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> dsLookupTyCon eitherTyConName `thenDs` \ either_con -> dsLookupDataCon leftDataConName `thenDs` \ left_con -> dsLookupDataCon rightDataConName `thenDs` \ right_con -> @@ -487,7 +487,7 @@ case bodies, containing the following fields: \begin{code} dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) = dsExpr exp `thenDs` \ core_exp -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- Extract and desugar the leaf commands in the case, building tuple -- expressions that will (after tagging) replace these leaves @@ -502,7 +502,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) envStackType leaf_ids stack, core_leaf) in - mapDs make_branch leaves `thenDs` \ branches -> + mappM make_branch leaves `thenDs` \ branches -> dsLookupTyCon eitherTyConName `thenDs` \ either_con -> dsLookupDataCon leftDataConName `thenDs` \ left_con -> dsLookupDataCon rightDataConName `thenDs` \ right_con -> @@ -536,7 +536,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) matchEnvStack env_ids stack_ids core_body `thenDs` \ core_matches -> returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, - fvs_exp `unionVarSet` fvs_alts) + fvs_exp `unionVarSet` fvs_alts) -- A | ys |- c :: [ts] t -- ---------------------------------- @@ -551,7 +551,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) in dsfixCmd ids local_vars' stack res_ty body `thenDs` \ (core_body, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- build a new environment, plus the stack, using the let bindings dsLet binds (buildEnvStack env_ids' stack_ids) `thenDs` \ core_binds -> @@ -598,7 +598,7 @@ dsTrimCmdArg local_vars env_ids (HsCmdTop cmd stack cmd_ty ids) = mkCmdEnv ids `thenDs` \ meth_ids -> dsfixCmd meth_ids local_vars stack cmd_ty cmd `thenDs` \ (core_cmd, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids) `thenDs` \ trim_code -> let @@ -751,7 +751,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc) selectMatchVar pat `thenDs` \ pat_id -> newSysLocalDs env_ty2 `thenDs` \ env_id -> - getUniqSupplyDs `thenDs` \ uniqs -> + newUniqueSupply `thenDs` \ uniqs -> let after_c_ty = mkCorePairTy pat_ty env_ty2 out_ty = mkTupleType out_ids @@ -818,7 +818,7 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss) -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - getUniqSupplyDs `thenDs` \ uniqs -> + newUniqueSupply `thenDs` \ uniqs -> newSysLocalDs env2_ty `thenDs` \ env2_id -> let later_ty = mkTupleType later_ids @@ -874,7 +874,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss)) - mapDs dsExpr rhss `thenDs` \ core_rhss -> + mappM dsExpr rhss `thenDs` \ core_rhss -> let later_tuple = mkTupleExpr later_ids later_ty = mkTupleType later_ids diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 97c844ed45..ff2403e6f4 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -83,7 +83,7 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest = putSrcLocDs locn $ dsGuarded grhss `thenDs` \ body_expr -> mkSelectorBinds pat body_expr `thenDs` \ sel_binds -> - mapDs (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> + mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> returnDs (sel_binds ++ rest) -- Common special case: no type or dictionary abstraction @@ -134,7 +134,7 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest let dict_args = map Var dicts - mk_bind (tyvars, global, local) n -- locals !! n == local + mk_bind ((tyvars, global, local), n) -- locals !! n == local = -- Need to make fresh locals to bind in the selector, because -- some of the tyvars will be bound to voidTy newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' -> @@ -148,7 +148,7 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest ty_args = map mk_ty_arg all_tyvars substitute = substTyWith all_tyvars ty_args in - zipWithDs mk_bind exports [0..] `thenDs` \ export_binds -> + mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds -> -- don't scc (auto-)annotate the tuple itself. returnDs ((poly_tup_id, poly_tup_expr) : (export_binds ++ rest)) \end{code} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 71f3324adf..e643772323 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -14,6 +14,7 @@ module DsCCall #include "HsVersions.h" + import CoreSyn import DsMonad @@ -30,7 +31,7 @@ import TcType ( tcSplitTyConApp_maybe ) import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy, tyVarsOfType, mkForAllTys, mkTyConApp, isPrimitiveType, splitTyConApp_maybe, - splitNewType_maybe, splitForAllTy_maybe, + splitRecNewType_maybe, splitForAllTy_maybe, isUnboxedTupleType ) @@ -62,6 +63,11 @@ import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey, import VarSet ( varSetElems ) import Constants ( wORD_SIZE) import Outputable + +#ifdef DEBUG +import TypeRep +#endif + \end{code} Desugaring of @ccall@s consists of adding some state manipulation, @@ -109,7 +115,7 @@ dsCCall :: CLabelString -- C routine to invoke dsCCall lbl args may_gc result_ty = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> - getUniqueDs `thenDs` \ uniq -> + newUnique `thenDs` \ uniq -> let target = StaticTarget lbl the_fcall = CCall (CCallSpec target CCallConv may_gc) @@ -155,7 +161,7 @@ unboxArg arg = returnDs (arg, \body -> body) -- Recursive newtypes - | Just rep_ty <- splitNewType_maybe arg_ty + | Just rep_ty <- splitRecNewType_maybe arg_ty = unboxArg (mkCoerce2 rep_ty arg_ty arg) -- Booleans @@ -172,7 +178,8 @@ unboxArg arg -- Data types with a single constructor, which has a single, primitive-typed arg -- This deals with Int, Float etc; also Ptr, ForeignPtr | is_product_type && data_con_arity == 1 - = ASSERT(isUnLiftedType data_con_arg_ty1 ) -- Typechecker ensures this + = ASSERT2(isUnLiftedType data_con_arg_ty1, crudePprType arg_ty) + -- Typechecker ensures this newSysLocalDs arg_ty `thenDs` \ case_bndr -> newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg -> returnDs (Var prim_arg, @@ -335,10 +342,10 @@ boxResult arg_ids augment mbTopCon result_ty -- The ccall returns a non-() value | isUnboxedTupleType prim_res_ty = let - (Just (_, ls@(prim_res_ty1:extras))) = splitTyConApp_maybe prim_res_ty + Just (_, ls) = splitTyConApp_maybe prim_res_ty arity = 1 + length ls in - mapDs newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) -> + mappM newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) -> newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> let the_rhs = return_result (Var state_id) @@ -352,8 +359,7 @@ boxResult arg_ids augment mbTopCon result_ty in returnDs (ccall_res_ty, the_alt) | otherwise - = - newSysLocalDs prim_res_ty `thenDs` \ result_id -> + = newSysLocalDs prim_res_ty `thenDs` \ result_id -> newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> let the_rhs = return_result (Var state_id) @@ -385,7 +391,7 @@ resultWrapper result_ty (LitAlt (mkMachInt 0),[],Var falseDataConId)]) -- Recursive newtypes - | Just rep_ty <- splitNewType_maybe result_ty + | Just rep_ty <- splitRecNewType_maybe result_ty = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) -> returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e)) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index a26d5a752e..1e9c6e1cc6 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,7 +13,6 @@ import Match ( matchWrapper, matchSimply ) import MatchLit ( dsLit ) import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsGRHSs ( dsGuarded ) -import DsCCall ( dsCCall ) import DsListComp ( dsListComp, dsPArrComp ) import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, mkCoreTupTy, selectMatchVar, @@ -346,7 +345,7 @@ dsExpr (ExplicitPArr ty xs) returnDs (mkApps (Var toP) [Type ty, coreList]) dsExpr (ExplicitTuple expr_list boxity) - = mapDs dsExpr expr_list `thenDs` \ core_exprs -> + = mappM dsExpr expr_list `thenDs` \ core_exprs -> returnDs (mkConApp (tupleCon boxity (length expr_list)) (map (Type . exprType) core_exprs ++ core_exprs)) @@ -434,8 +433,8 @@ dsExpr (RecordConOut data_con con_expr rbinds) in (if null labels - then mapDs unlabelled_bottom arg_tys - else mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)) + then mappM unlabelled_bottom arg_tys + else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)) `thenDs` \ con_args -> returnDs (mkApps con_expr' con_args) @@ -506,7 +505,7 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) -- and the right hand sides with applications of the wrapper Id -- so that everything works when we are doing fancy unboxing on the -- constructor aguments. - mapDs mk_alt cons_to_upd `thenDs` \ alts -> + mappM mk_alt cons_to_upd `thenDs` \ alts -> matchWrapper RecUpd alts `thenDs` \ ([discrim_var], matching_code) -> returnDs (bindNonRec discrim_var record_expr' matching_code) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 22c8569aae..a832499181 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -9,6 +9,7 @@ Expanding out @foreign import@ and @foreign export@ declarations. module DsForeign ( dsForeigns ) where #include "HsVersions.h" +import TcRnMonad -- temp import CoreSyn @@ -76,8 +77,10 @@ dsForeigns fos where combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) (ForeignImport id _ spec depr loc) - = dsFImport id spec `thenDs` \ (bs, h, c, mbhd) -> + = traceIf (text "fi start" <+> ppr id) `thenDs` \ _ -> + dsFImport id spec `thenDs` \ (bs, h, c, mbhd) -> warnDepr depr loc `thenDs` \ _ -> + traceIf (text "fi end" <+> ppr id) `thenDs` \ _ -> returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) (addH mbhd acc_hdrs) @@ -234,8 +237,8 @@ dsFCall fn_id fcall no_hdrs topConDs `thenDs` \ topCon -> boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> - getUniqueDs `thenDs` \ ccall_uniq -> - getUniqueDs `thenDs` \ work_uniq -> + newUnique `thenDs` \ ccall_uniq -> + newUnique `thenDs` \ work_uniq -> let -- Build the worker worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) @@ -290,7 +293,7 @@ dsFExport :: Id -- Either the exported Id, dsFExport fn_id ty ext_name cconv isDyn = let - (tvs,sans_foralls) = tcSplitForAllTys ty + (_tvs,sans_foralls) = tcSplitForAllTys ty (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls -- We must use tcSplits here, because we want to see -- the (IO t) in the corner of the type! diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 0aef3a6e4d..75c76d6209 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -52,7 +52,7 @@ dsGRHSs :: TypecheckedMatchContext -> [TypecheckedPat] -- These are to build a M -> DsM (Type, MatchResult) dsGRHSs kind pats (GRHSs grhss binds ty) - = mapDs (dsGRHS kind pats) grhss `thenDs` \ match_results -> + = mappM (dsGRHS kind pats) grhss `thenDs` \ match_results -> let match_result1 = foldr1 combineMatchResults match_results match_result2 = adjustMatchResultDs (dsLet binds) match_result1 diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 9a77075d96..fc3a689773 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -11,7 +11,6 @@ module DsListComp ( dsListComp, dsPArrComp ) where import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import BasicTypes ( Boxity(..) ) -import TyCon ( tyConName ) import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsMatchContext(..), HsStmtContext(..), collectHsBinders ) @@ -30,10 +29,10 @@ import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type, splitTyConApp_maybe ) import TysPrim ( alphaTyVar ) import TysWiredIn ( nilDataCon, consDataCon, trueDataConId, falseDataConId, - unitDataConId, unitTy, mkListTy ) + unitDataConId, unitTy, mkListTy, parrTyCon ) import Match ( matchSimply ) import PrelNames ( foldrName, buildName, replicatePName, mapPName, - filterPName, zipPName, crossPName, parrTyConName ) + filterPName, zipPName, crossPName ) import PrelInfo ( pAT_ERROR_ID ) import SrcLoc ( noSrcLoc ) import Panic ( panic ) @@ -147,7 +146,7 @@ with the Unboxed variety. deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr deListComp (ParStmt stmtss_w_bndrs : quals) list - = mapDs do_list_comp stmtss_w_bndrs `thenDs` \ exps -> + = mappM do_list_comp stmtss_w_bndrs `thenDs` \ exps -> mkZipBind qual_tys `thenDs` \ (zip_fn, zip_rhs) -> -- Deal with [e | pat <- zip l1 .. ln] in example above @@ -233,9 +232,9 @@ mkZipBind :: [Type] -> DsM (Id, CoreExpr) -- (a2:as'2) -> (a2,a2) : zip as'1 as'2)] mkZipBind elt_tys - = mapDs newSysLocalDs list_tys `thenDs` \ ass -> - mapDs newSysLocalDs elt_tys `thenDs` \ as' -> - mapDs newSysLocalDs list_tys `thenDs` \ as's -> + = mappM newSysLocalDs list_tys `thenDs` \ ass -> + mappM newSysLocalDs elt_tys `thenDs` \ as' -> + mappM newSysLocalDs list_tys `thenDs` \ as's -> newSysLocalDs zip_fn_ty `thenDs` \ zip_fn -> let inner_rhs = mkConsExpr ret_elt_ty @@ -473,7 +472,7 @@ deLambda ty p e = parrElemType :: CoreExpr -> Type parrElemType e = case splitTyConApp_maybe (exprType e) of - Just (tycon, [ty]) | tyConName tycon == parrTyConName -> ty + Just (tycon, [ty]) | tycon == parrTyCon -> ty _ -> panic "DsListComp.parrElemType: not a parallel array type" \end{code} diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index f92af145d5..ffb6b13b21 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -30,21 +30,18 @@ import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), Match(..), GRHSs(..), GRHS(..), HsBracket(..), HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..), HsBinds(..), MonoBinds(..), HsConDetails(..), - TyClDecl(..), HsGroup(..), + TyClDecl(..), HsGroup(..), HsBang(..), HsReify(..), ReifyFlavour(..), - HsType(..), HsContext(..), HsPred(..), HsTyOp(..), + HsType(..), HsContext(..), HsPred(..), HsTyVarBndr(..), Sig(..), ForeignDecl(..), InstDecl(..), ConDecl(..), BangType(..), PendingSplice, splitHsInstDeclTy, placeHolderType, tyClDeclNames, collectHsBinders, collectPatBinders, collectPatsBinders, - hsTyVarName, hsConArgs, getBangType, - toHsType + hsTyVarName, hsConArgs ) -import PrelNames ( mETA_META_Name, rationalTyConName, negateName, - parrTyConName ) -import MkIface ( ifaceTyThing ) +import PrelNames ( mETA_META_Name, rationalTyConName, integerTyConName, negateName ) import Name ( Name, nameOccName, nameModule, getSrcLoc ) import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName @@ -53,16 +50,16 @@ import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- ws previously used in this file. import qualified OccName( varName, tcName ) -import Module ( Module, mkThPkgModule, moduleUserString ) +import Module ( Module, mkModule, moduleUserString ) import Id ( Id, idType ) -import Name ( mkKnownKeyExternalName ) +import Name ( mkExternalName ) import OccName ( mkOccFS ) import NameEnv import NameSet import Type ( Type, mkGenTyConApp ) -import TcType ( TyThing(..), tcTyConAppArgs ) -import TyCon ( DataConDetails(..) ) -import TysWiredIn ( stringTy ) +import TcType ( tcTyConAppArgs ) +import TyCon ( DataConDetails(..), tyConName ) +import TysWiredIn ( stringTy, parrTyCon ) import CoreSyn import CoreUtils ( exprType ) import SrcLoc ( noSrcLoc ) @@ -72,7 +69,7 @@ import Panic ( panic ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique ) import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) import SrcLoc ( SrcLoc ) - +import Packages ( thPackage ) import Outputable import FastString ( mkFastString ) @@ -97,9 +94,12 @@ dsBracket brack splices ----------------------------------------------------------------------------- dsReify :: HsReify Id -> DsM CoreExpr +dsReify r = panic "dsReify" -- To be re-done + -- Returns a CoreExpr of type reifyType --> M.TypeQ -- reifyDecl --> M.DecQ -- reifyFixty --> Q M.Fix +{- dsReify (ReifyOut ReifyType name) = do { thing <- dsLookupGlobal name ; -- By deferring the lookup until now (rather than doing it @@ -118,7 +118,7 @@ dsReify r@(ReifyOut ReifyDecl name) Just (MkC d) -> return d Nothing -> pprPanic "dsReify" (ppr r) } - +-} {- -------------- Examples -------------------- [| \x -> x |] @@ -207,9 +207,9 @@ repTyClD decl = do x <- repTyClD' decl repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ)) repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, - tcdName = tc, tcdTyVars = tvs, - tcdCons = DataCons cons, tcdDerivs = mb_derivs, - tcdLoc = loc}) + tcdName = tc, tcdTyVars = tvs, + tcdCons = cons, tcdDerivs = mb_derivs, + tcdLoc = loc}) = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repContext cxt ; @@ -220,9 +220,9 @@ repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, return $ Just (loc, dec) } repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt, - tcdName = tc, tcdTyVars = tvs, - tcdCons = DataCons [con], tcdDerivs = mb_derivs, - tcdLoc = loc}) + tcdName = tc, tcdTyVars = tvs, + tcdCons = [con], tcdDerivs = mb_derivs, + tcdLoc = loc}) = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repContext cxt ; @@ -242,7 +242,7 @@ repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty, repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, tcdTyVars = tvs, tcdFDs = [], -- We don't understand functional dependencies - tcdSigs = sigs, tcdMeths = mb_meth_binds, + tcdSigs = sigs, tcdMeths = meth_binds, tcdLoc = loc}) = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { @@ -252,11 +252,6 @@ repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, decls1 <- coreList decQTyConName (sigs1 ++ binds1) ; repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ; return $ Just (loc, dec) } - where - -- If the user quotes a class decl, it'll have default-method - -- bindings; but if we (reifyDecl C) where C is a class, we - -- won't be given the default methods (a definite infelicity). - meth_binds = mb_meth_binds `orElse` EmptyMonoBinds -- Un-handled cases repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ; @@ -265,7 +260,7 @@ repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ; where msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") -repInstD' (InstDecl ty binds _ _ loc) +repInstD' (InstDecl ty binds _ loc) -- Ignore user pragmas for now = do { cxt1 <- repContext cxt ; inst_ty1 <- repPred (HsClassP cls tys) ; @@ -291,8 +286,8 @@ repBangTy (BangType str ty) = do MkC s <- rep2 strName [] MkC t <- repTy ty rep2 strictTypeName [s, t] where strName = case str of - NotMarkedStrict -> notStrictName - _ -> isStrictName + HsNoBang -> notStrictName + other -> isStrictName ------------------------------------------------------- -- Deriving clause @@ -326,9 +321,8 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (ClassOpSig nm _ ty loc) = rep_proto nm ty loc -rep_sig (Sig nm ty loc) = rep_proto nm ty loc -rep_sig other = return [] +rep_sig (Sig nm ty loc) = rep_proto nm ty loc +rep_sig other = return [] rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)] rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; @@ -411,14 +405,13 @@ repTy (HsListTy t) = do repTapp tcon t1 repTy (HsPArrTy t) = do t1 <- repTy t - tcon <- repTy (HsTyVar parrTyConName) + tcon <- repTy (HsTyVar (tyConName parrTyCon)) repTapp tcon t1 repTy (HsTupleTy tc tys) = do tys1 <- repTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2) -repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) +repTy (HsOpTy ty1 n ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2) repTy (HsParTy t) = repTy t repTy (HsNumTy i) = @@ -1129,18 +1122,16 @@ repListTyCon = rep2 listTName [] repLiteral :: HsLit -> DsM (Core M.Lit) repLiteral lit = do lit' <- case lit of - HsIntPrim i -> return $ HsInteger i - HsInt i -> return $ HsInteger i - HsFloatPrim r -> do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty - HsDoublePrim r -> do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty + HsIntPrim i -> mk_integer i + HsInt i -> mk_integer i + HsFloatPrim r -> mk_rational r + HsDoublePrim r -> mk_rational r _ -> return lit lit_expr <- dsLit lit' rep2 lit_name [lit_expr] where lit_name = case lit of - HsInteger _ -> integerLName + HsInteger _ _ -> integerLName HsInt _ -> integerLName HsIntPrim _ -> intPrimLName HsFloatPrim _ -> floatPrimLName @@ -1152,10 +1143,14 @@ repLiteral lit uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal" (ppr lit) +mk_integer i = do integer_ty <- lookupType integerTyConName + return $ HsInteger i integer_ty +mk_rational r = do rat_ty <- lookupType rationalTyConName + return $ HsRat r rat_ty + repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit) -repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i) -repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ; - repLiteral (HsRat f rat_ty) } +repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit } +repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit } -- The type Rational will be in the environment, becuase -- the smart constructor 'THSyntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used @@ -1218,11 +1213,11 @@ coreVar id = MkC (Var id) -- 2) Make a "Name" -- 3) Add the name to knownKeyNames -templateHaskellNames :: NameSet +templateHaskellNames :: [Name] -- The names that are implicitly mentioned by ``bracket'' -- Should stay in sync with the import list of DsMeta -templateHaskellNames = mkNameSet [ +templateHaskellNames = [ returnQName, bindQName, sequenceQName, gensymName, liftName, -- Lit charLName, stringLName, integerLName, intPrimLName, @@ -1277,10 +1272,11 @@ tcQual = mk_known_key_name OccName.tcName thModule :: Module -- NB: the THSyntax module comes from the "haskell-src" package -thModule = mkThPkgModule mETA_META_Name +thModule = mkModule thPackage mETA_META_Name mk_known_key_name space str uniq - = mkKnownKeyExternalName thModule (mkOccFS space str) uniq + = mkExternalName uniq thModule (mkOccFS space str) + Nothing noSrcLoc returnQName = varQual FSLIT("returnQ") returnQIdKey bindQName = varQual FSLIT("bindQ") bindQIdKey @@ -1323,9 +1319,9 @@ conEName = varQual FSLIT("conE") conEIdKey litEName = varQual FSLIT("litE") litEIdKey appEName = varQual FSLIT("appE") appEIdKey infixEName = varQual FSLIT("infixE") infixEIdKey -infixAppName = varQual FSLIT("infixApp") infixAppIdKey -sectionLName = varQual FSLIT("sectionL") sectionLIdKey -sectionRName = varQual FSLIT("sectionR") sectionRIdKey +infixAppName = varQual FSLIT("infixApp") infixAppIdKey +sectionLName = varQual FSLIT("sectionL") sectionLIdKey +sectionRName = varQual FSLIT("sectionR") sectionRIdKey lamEName = varQual FSLIT("lamE") lamEIdKey tupEName = varQual FSLIT("tupE") tupEIdKey condEName = varQual FSLIT("condE") condEIdKey diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 0889109049..c916626e8b 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -5,49 +5,52 @@ \begin{code} module DsMonad ( - DsM, - initDs, returnDs, thenDs, mapDs, listDs, fixDs, - mapAndUnzipDs, zipWithDs, foldlDs, - uniqSMtoDsM, - newTyVarsDs, cloneTyVarsDs, + DsM, mappM, + initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs, + + newTyVarsDs, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, newFailLocalDs, getSrcLocDs, putSrcLocDs, getModuleDs, - getUniqueDs, getUniquesDs, - UniqSupply, getUniqSupplyDs, + newUnique, + UniqSupply, newUniqueSupply, getDOptsDs, dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, dsWarn, - DsWarnings, + DsWarning, DsMatchContext(..) ) where #include "HsVersions.h" import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr ) -import HscTypes ( TyThing(..) ) +import TcRnMonad +import IfaceEnv ( tcIfaceGlobal ) +import HscTypes ( TyThing(..), TypeEnv, HscEnv, + IsBootInterface, + tyThingId, tyThingTyCon, tyThingDataCon ) import Bag ( emptyBag, snocBag, Bag ) import DataCon ( DataCon ) import TyCon ( TyCon ) import DataCon ( DataCon ) import Id ( mkSysLocal, setIdUnique, Id ) -import Module ( Module ) +import Module ( Module, ModuleName, ModuleEnv ) import Var ( TyVar, setTyVarUnique ) import Outputable import SrcLoc ( noSrcLoc, SrcLoc ) import Type ( Type ) -import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs, - fixUs, UniqSM, UniqSupply, getUs ) -import Unique ( Unique ) +import UniqSupply ( UniqSupply, uniqsFromSupply ) import Name ( Name, nameOccName ) import NameEnv import OccName ( occNameFS ) import CmdLineOpts ( DynFlags ) +import DATA_IOREF ( newIORef, readIORef ) + infixr 9 `thenDs` \end{code} @@ -55,17 +58,29 @@ Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around a @UniqueSupply@ and some annotations, which presumably include source-file location information: \begin{code} -newtype DsM result - = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings)) +type DsM result = TcRnIf DsGblEnv DsLclEnv result -unDsM (DsM x) = x +-- Compatibility functions +fixDs = fixM +thenDs = thenM +returnDs = returnM +listDs = sequenceM +foldlDs = foldlM +mapAndUnzipDs = mapAndUnzipM -data DsEnv = DsEnv { - ds_dflags :: DynFlags, - ds_globals :: Name -> TyThing, -- Lookup well-known Ids + +type DsWarning = (SrcLoc, SDoc) + +data DsGblEnv = DsGblEnv { + ds_mod :: Module, -- For SCC profiling + ds_warns :: IORef (Bag DsWarning), -- Warning messages + ds_if_env :: IfGblEnv -- Used for looking up global, + -- possibly-imported things + } + +data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings - ds_loc :: SrcLoc, -- to put in pattern-matching error msgs - ds_mod :: Module -- module: for SCC profiling + ds_loc :: SrcLoc -- to put in pattern-matching error msgs } -- Inside [| |] brackets, the desugarer looks @@ -80,81 +95,29 @@ data DsMetaVal | Splice TypecheckedHsExpr -- These bindings are introduced by -- the PendingSplices on a HsBracketOut -instance Monad DsM where - return = returnDs - (>>=) = thenDs - -type DsWarnings = Bag DsWarning -- The desugarer reports matches which are - -- completely shadowed or incomplete patterns -type DsWarning = (SrcLoc, SDoc) - -{-# INLINE thenDs #-} -{-# INLINE returnDs #-} - -- initDs returns the UniqSupply out the end (not just the result) -initDs :: DynFlags - -> UniqSupply - -> (Name -> TyThing) - -> Module -- module name: for profiling +initDs :: HscEnv + -> Module -> TypeEnv + -> ModuleEnv (ModuleName,IsBootInterface) -> DsM a - -> (a, DsWarnings) - -initDs dflags init_us lookup mod (DsM action) - = initUs_ init_us (action ds_env emptyBag) - where - ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup, - ds_loc = noSrcLoc, ds_mod = mod, - ds_meta = emptyNameEnv } - -thenDs :: DsM a -> (a -> DsM b) -> DsM b - -thenDs (DsM m1) m2 = DsM( \ env warns -> - m1 env warns `thenUs` \ (result, warns1) -> - unDsM (m2 result) env warns1) - -returnDs :: a -> DsM a -returnDs result = DsM (\ env warns -> returnUs (result, warns)) - -fixDs :: (a -> DsM a) -> DsM a -fixDs f = DsM (\env warns -> fixUs (\ ~(a, _warns') -> unDsM (f a) env warns)) - -listDs :: [DsM a] -> DsM [a] -listDs [] = returnDs [] -listDs (x:xs) - = x `thenDs` \ r -> - listDs xs `thenDs` \ rs -> - returnDs (r:rs) - -mapDs :: (a -> DsM b) -> [a] -> DsM [b] - -mapDs f [] = returnDs [] -mapDs f (x:xs) - = f x `thenDs` \ r -> - mapDs f xs `thenDs` \ rs -> - returnDs (r:rs) - -foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a - -foldlDs k z [] = returnDs z -foldlDs k z (x:xs) = k z x `thenDs` \ r -> - foldlDs k r xs - -mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c]) - -mapAndUnzipDs f [] = returnDs ([], []) -mapAndUnzipDs f (x:xs) - = f x `thenDs` \ (r1, r2) -> - mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) -> - returnDs (r1:rs1, r2:rs2) - -zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c] - -zipWithDs f [] ys = returnDs [] -zipWithDs f (x:xs) (y:ys) - = f x y `thenDs` \ r -> - zipWithDs f xs ys `thenDs` \ rs -> - returnDs (r:rs) + -> IO (a, Bag DsWarning) + +initDs hsc_env mod type_env is_boot thing_inside + = do { warn_var <- newIORef emptyBag + ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env), + if_is_boot = is_boot } + ; gbl_env = DsGblEnv { ds_mod = mod, + ds_if_env = if_env, + ds_warns = warn_var } + ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, + ds_loc = noSrcLoc } } + + ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside + + ; warns <- readIORef warn_var + ; return (res, warns) + } \end{code} And all this mysterious stuff is so we can occasionally reach out and @@ -163,61 +126,35 @@ functions are defined with it. The difference in name-strings makes it easier to read debugging output. \begin{code} -uniqSMtoDsM :: UniqSM a -> DsM a -uniqSMtoDsM u_action = DsM(\ env warns -> - u_action `thenUs` \ res -> - returnUs (res, warns)) - - -getUniqueDs :: DsM Unique -getUniqueDs = DsM (\ env warns -> - getUniqueUs `thenUs` \ uniq -> - returnUs (uniq, warns)) - -getUniquesDs :: DsM [Unique] -getUniquesDs = DsM(\ env warns -> - getUniquesUs `thenUs` \ uniqs -> - returnUs (uniqs, warns)) - -getUniqSupplyDs :: DsM UniqSupply -getUniqSupplyDs = DsM(\ env warns -> - getUs `thenUs` \ uniqs -> - returnUs (uniqs, warns)) - -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Name -> Type -> DsM Id newUniqueId id ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (setIdUnique old_local uniq) newSysLocalDs, newFailLocalDs :: Type -> DsM Id newSysLocalDs ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal FSLIT("ds") uniq ty) -newSysLocalsDs tys = mapDs newSysLocalDs tys +newSysLocalsDs tys = mappM newSysLocalDs tys newFailLocalDs ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal FSLIT("fail") uniq ty) -- The UserLocal bit just helps make the code a little clearer \end{code} \begin{code} -cloneTyVarsDs :: [TyVar] -> DsM [TyVar] -cloneTyVarsDs tyvars - = getUniquesDs `thenDs` \ uniqs -> - returnDs (zipWith setTyVarUnique tyvars uniqs) - newTyVarsDs :: [TyVar] -> DsM [TyVar] newTyVarsDs tyvar_tmpls - = getUniquesDs `thenDs` \ uniqs -> - returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs) + = newUniqueSupply `thenDs` \ uniqs -> + returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs)) \end{code} We can also reach out and either set/grab location information from @@ -225,56 +162,52 @@ the @SrcLoc@ being carried around. \begin{code} getDOptsDs :: DsM DynFlags -getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns)) +getDOptsDs = getDOpts getModuleDs :: DsM Module -getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns)) +getModuleDs = do { env <- getGblEnv; return (ds_mod env) } getSrcLocDs :: DsM SrcLoc -getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns)) +getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) } putSrcLocDs :: SrcLoc -> DsM a -> DsM a -putSrcLocDs new_loc (DsM expr) = DsM(\ env warns -> - expr (env { ds_loc = new_loc }) warns) +putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside dsWarn :: DsWarning -> DsM () -dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn)) +dsWarn warn = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` warn) } \end{code} \begin{code} dsLookupGlobal :: Name -> DsM TyThing +-- Very like TcEnv.tcLookupGlobal dsLookupGlobal name - = DsM(\ env warns -> returnUs (ds_globals env name, warns)) + = do { env <- getGblEnv + ; setEnvs (ds_if_env env, ()) + (tcIfaceGlobal name) } dsLookupGlobalId :: Name -> DsM Id dsLookupGlobalId name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - AnId id -> id - other -> pprPanic "dsLookupGlobalId" (ppr name) + returnDs (tyThingId thing) dsLookupTyCon :: Name -> DsM TyCon dsLookupTyCon name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - ATyCon tc -> tc - other -> pprPanic "dsLookupTyCon" (ppr name) + returnDs (tyThingTyCon thing) dsLookupDataCon :: Name -> DsM DataCon dsLookupDataCon name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - ADataCon dc -> dc - other -> pprPanic "dsLookupDataCon" (ppr name) + returnDs (tyThingDataCon thing) \end{code} \begin{code} dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) -dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns)) +dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) } dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a -dsExtendMetaEnv menv (DsM m) - = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns) +dsExtendMetaEnv menv thing_inside + = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index d7b55f5ad3..e7f88fe690 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -58,15 +58,15 @@ import TysWiredIn ( nilDataCon, consDataCon, tupleCon, mkTupleTy, unitDataConId, unitTy, charTy, charDataCon, - intTy, intDataCon, smallIntegerDataCon, + intTy, intDataCon, floatDataCon, doubleDataCon, stringTy, isPArrFakeCon ) import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) -import UniqSupply ( splitUniqSupply, uniqFromSupply ) +import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply ) import PrelNames ( unpackCStringName, unpackCStringUtf8Name, - plusIntegerName, timesIntegerName, + plusIntegerName, timesIntegerName, smallIntegerDataConName, lengthPName, indexPName ) import Outputable import UnicodeUtil ( intsToUtf8, stringToUtf8 ) @@ -134,13 +134,13 @@ tidyNPat lit lit_ty default_pat | otherwise = default_pat where - mk_int (HsInteger i) = HsIntPrim i + mk_int (HsInteger i _) = HsIntPrim i - mk_float (HsInteger i) = HsFloatPrim (fromInteger i) - mk_float (HsRat f _) = HsFloatPrim f + mk_float (HsInteger i _) = HsFloatPrim (fromInteger i) + mk_float (HsRat f _) = HsFloatPrim f - mk_double (HsInteger i) = HsDoublePrim (fromInteger i) - mk_double (HsRat f _) = HsDoublePrim f + mk_double (HsInteger i _) = HsDoublePrim (fromInteger i) + mk_double (HsRat f _) = HsDoublePrim f \end{code} @@ -287,7 +287,7 @@ mkCoPrimCaseMatchResult var match_alts = MatchResult CanFail mk_case where mk_case fail - = mapDs (mk_alt fail) match_alts `thenDs` \ alts -> + = mappM (mk_alt fail) match_alts `thenDs` \ alts -> returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts)) mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> @@ -328,13 +328,13 @@ mkCoAlgCaseMatchResult var match_alts = CanFail wild_var = mkWildId (idType var) - mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts -> + mk_case fail = mappM (mk_alt fail) match_alts `thenDs` \ alts -> returnDs (Case (Var var) wild_var (mk_default fail ++ alts)) mk_alt fail (con, args, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> - getUniquesDs `thenDs` \ us -> - returnDs (mkReboxingAlt us con args body) + newUniqueSupply `thenDs` \ us -> + returnDs (mkReboxingAlt (uniqsFromSupply us) con args body) mk_default fail | exhaustive_case = [] | otherwise = [(DEFAULT, [], fail)] @@ -387,7 +387,7 @@ mkCoAlgCaseMatchResult var match_alts unboxAlt = newSysLocalDs intPrimTy `thenDs` \l -> dsLookupGlobalId indexPName `thenDs` \indexP -> - mapDs (mkAlt indexP) match_alts `thenDs` \alts -> + mappM (mkAlt indexP) match_alts `thenDs` \alts -> returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts))) where wild = mkWildId intPrimTy @@ -450,7 +450,8 @@ mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)] mkIntegerExpr i | inIntRange i -- Small enough, so start from an Int - = returnDs (mkSmallIntegerLit i) + = dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc -> + returnDs (mkSmallIntegerLit integer_dc i) -- Special case for integral literals with a large magnitude: -- They are transformed into an expression involving only smaller @@ -458,25 +459,27 @@ mkIntegerExpr i | otherwise -- Big, so start from a string = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id -> - dsLookupGlobalId timesIntegerName `thenDs` \ times_id -> + dsLookupGlobalId timesIntegerName `thenDs` \ times_id -> + dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc -> let + lit i = mkSmallIntegerLit integer_dc i plus a b = Var plus_id `App` a `App` b times a b = Var times_id `App` a `App` b -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b horner :: Integer -> Integer -> CoreExpr horner b i | abs q <= 1 = if r == 0 || r == i - then mkSmallIntegerLit i - else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r) - | r == 0 = horner b q `times` mkSmallIntegerLit b - | otherwise = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b) + then lit i + else lit r `plus` lit (i-r) + | r == 0 = horner b q `times` lit b + | otherwise = lit r `plus` (horner b q `times` lit b) where (q,r) = i `quotRem` b in returnDs (horner tARGET_MAX_INT i) -mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i] +mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i] mkStringLit str = mkStringLitFS (mkFastString str) @@ -547,7 +550,7 @@ mkSelectorBinds pat val_expr -- This does not matter after desugaring, but there's a subtle -- issue with implicit parameters. Consider -- (x,y) = ?i - -- Then, ?i is given type {?i :: Int}, a SourceType, which is opaque + -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque -- to the desugarer. (Why opaque? Because newtypes have to be. Why -- does it get that type? So that when we abstract over it we get the -- right top-level type (?i::Int) => ...) @@ -561,7 +564,7 @@ mkSelectorBinds pat val_expr mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr -> newSysLocalDs unitTy `thenDs` \ err_var -> - mapDs (mk_bind val_var err_var) binders `thenDs` \ binds -> + mappM (mk_bind val_var err_var) binders `thenDs` \ binds -> returnDs ( (val_var, val_expr) : (err_var, err_expr) : binds ) diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 282ba80464..88868e6b1c 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -266,11 +266,11 @@ corresponds roughly to @matchVarCon@. \begin{code} match vars@(v:vs) eqns_info - = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info -> + = mappM (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info -> let tidy_eqns_blks = unmix_eqns tidy_eqns_info in - mapDs (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results -> + mappM (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results -> returnDs (foldr1 combineMatchResults match_results) where unmix_eqns [] = [] @@ -712,7 +712,7 @@ matchWrapper ctxt matches EqnInfo _ _ arg_pats _ : _ = eqns_info error_string = matchContextErrString ctxt in - mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> + mappM selectMatchVar arg_pats `thenDs` \ new_vars -> match_fun dflags new_vars eqns_info `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 141f6a7e3d..a874218982 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -86,7 +86,7 @@ matchConFamily (var:vars) eqns_info get_uniq (EqnInfo _ _ (ConPatOut data_con _ _ _ _ : _) _) = getUnique data_con in -- Now make a case alternative out of each group - mapDs (match_con vars) eqn_groups `thenDs` \ alts -> + mappM (match_con vars) eqn_groups `thenDs` \ alts -> returnDs (mkCoAlgCaseMatchResult var alts) \end{code} @@ -99,7 +99,7 @@ Wadler's chapter in SLPJ. match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _) : other_eqns) = -- Make new vars for the con arguments; avoid new locals where possible - mapDs selectMatchVar arg_pats `thenDs` \ arg_vars -> + mappM selectMatchVar arg_pats `thenDs` \ arg_vars -> -- Now do the business to make the alt for _this_ ConPat ... match (arg_vars ++ vars) diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 2be6e259d6..e260e0cd58 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -19,14 +19,14 @@ import TcHsSyn ( TypecheckedPat ) import Id ( Id ) import CoreSyn import TyCon ( tyConDataCons ) -import TcType ( tcSplitTyConApp, isIntegerTy ) - +import TcType ( tcSplitTyConApp, isIntegerTy ) import PrelNames ( ratioTyConKey ) import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) import Panic ( panic, assertPanic ) import Ratio ( numerator, denominator ) +import Outputable \end{code} %************************************************************************ @@ -56,7 +56,7 @@ dsLit (HsChar c) = returnDs (mkCharExpr c) dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c)) dsLit (HsString str) = mkStringLitFS str dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s)) -dsLit (HsInteger i) = mkIntegerExpr i +dsLit (HsInteger i _) = mkIntegerExpr i dsLit (HsInt i) = returnDs (mkIntExpr i) dsLit (HsIntPrim i) = returnDs (mkIntLit i) dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f)) diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs index f0678402ec..928d5e3fdd 100644 --- a/ghc/compiler/ghci/ByteCodeAsm.lhs +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -28,18 +28,18 @@ import TyCon ( TyCon ) import PrimOp ( PrimOp ) import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep ) import Constants ( wORD_SIZE ) -import FastString ( FastString(..), unpackFS ) +import FastString ( FastString(..) ) import SMRep ( StgWord ) import FiniteMap import Outputable -import Control.Monad ( foldM, zipWithM ) -import Control.Monad.ST ( ST, runST ) +import Control.Monad ( foldM ) +import Control.Monad.ST ( runST ) import GHC.Word ( Word(..) ) import Data.Array.MArray import Data.Array.Unboxed ( listArray ) -import Data.Array.Base ( STUArray, UArray(..), unsafeWrite ) +import Data.Array.Base ( UArray(..) ) import Data.Array.ST ( castSTUArray ) import Foreign ( Word16, free ) import Data.Int ( Int64 ) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 6d1aa58f47..49a5b1cbac 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.160 2003/09/23 14:32:58 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.161 2003/10/09 11:58:53 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -19,7 +19,7 @@ import CompManager import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, isObjectLinkable, GhciMode(..) ) import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) ) -import MkIface ( ifaceTyThing ) +import IfaceSyn ( IfaceDecl( ifName ) ) import DriverFlags import DriverState import DriverUtil ( remove_spaces ) @@ -159,20 +159,20 @@ interactiveUI :: [FilePath] -> Maybe String -> IO () interactiveUI srcs maybe_expr = do dflags <- getDynFlags - cmstate <- cmInit Interactive; + cmstate <- cmInit Interactive dflags; hFlush stdout hSetBuffering stdout NoBuffering -- Initialise buffering for the *interpreted* I/O system - cmstate <- initInterpBuffering cmstate dflags + initInterpBuffering cmstate -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering -- initial context is just the Prelude - cmstate <- cmSetContext cmstate dflags [] ["Prelude"] + cmstate <- cmSetContext cmstate [] ["Prelude"] #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS Readline.initialize @@ -381,10 +381,11 @@ runStmt stmt | otherwise = do st <- getGHCiState dflags <- io getDynFlags - let dflags' = dopt_unset dflags Opt_WarnUnusedBinds + let cm_state' = cmSetDFlags (cmstate st) + (dopt_unset dflags Opt_WarnUnusedBinds) (new_cmstate, result) <- io $ withProgName (progname st) $ withArgs (args st) $ - cmRunStmt (cmstate st) dflags' stmt + cmRunStmt cm_state' stmt setGHCiState st{cmstate = new_cmstate} case result of CmRunFailed -> return [] @@ -438,22 +439,22 @@ no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++ " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr" -initInterpBuffering :: CmState -> DynFlags -> IO CmState -initInterpBuffering cmstate dflags - = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd +initInterpBuffering :: CmState -> IO () +initInterpBuffering cmstate + = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd case maybe_hval of Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) other -> panic "interactiveUI:setBuffering" - (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd + maybe_hval <- cmCompileExpr cmstate flush_cmd case maybe_hval of Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) _ -> panic "interactiveUI:flush" turnOffBuffering -- Turn it off right now - return cmstate + return () flushInterpBuffers :: GHCi () @@ -477,11 +478,10 @@ info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'") info s = do let names = words s init_cms <- getCmState - dflags <- io getDynFlags let infoThings cms [] = return cms infoThings cms (name:names) = do - (cms, stuff) <- io (cmInfoThing cms dflags name) + stuff <- io (cmInfoThing cms name) io (putStrLn (showSDocForUser unqual ( vcat (intersperse (text "") (map showThing stuff)))) ) @@ -489,18 +489,21 @@ info s = do unqual = cmGetPrintUnqual init_cms - showThing (ty_thing, fixity) - = vcat [ text "-- " <> showTyThing ty_thing, - showFixity fixity (getName ty_thing), - ppr (ifaceTyThing True{-omit prags-} ty_thing) ] + showThing (decl, fixity) + = vcat [ text "-- " <> showTyThing decl, + showFixity fixity (ifName decl), + showTyThing decl ] showFixity fix name | fix == defaultFixity = empty | otherwise = ppr fix <+> - (if isSymOcc (nameOccName name) + (if isSymOcc name then ppr name else char '`' <> ppr name <> char '`') + showTyThing decl = ppr decl + +{- showTyThing (AClass cl) = hcat [ppr cl, text " is a class", showSrcLoc (className cl)] showTyThing (ADataCon dc) @@ -526,22 +529,22 @@ info s = do | otherwise = empty where loc = nameSrcLoc name +-} - cms <- infoThings init_cms names - setCmState cms + infoThings init_cms names return () addModule :: [FilePath] -> GHCi () addModule files = do state <- getGHCiState - dflags <- io (getDynFlags) io (revertCAFs) -- always revert CAFs on load/add. files <- mapM expandPath files let new_targets = files ++ targets state - graph <- io (cmDepAnal (cmstate state) dflags new_targets) - (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph) + graph <- io (cmDepAnal (cmstate state) new_targets) + (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph) setGHCiState state{ cmstate = cmstate1, targets = new_targets } setContextAfterLoad mods + dflags <- io getDynFlags modulesLoadedMsg ok mods dflags changeDirectory :: String -> GHCi () @@ -550,8 +553,7 @@ changeDirectory dir = do when (targets state /= []) $ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\ \because the search path has changed.\n" - dflags <- io getDynFlags - cmstate1 <- io (cmUnload (cmstate state) dflags) + cmstate1 <- io (cmUnload (cmstate state)) setGHCiState state{ cmstate = cmstate1, targets = [] } setContextAfterLoad [] dir <- expandPath dir @@ -575,9 +577,7 @@ defineMacro s = do -- compile the expression cms <- getCmState - dflags <- io getDynFlags - (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr) - setCmState new_cmstate + maybe_hv <- io (cmCompileExpr cms new_expr) case maybe_hv of Nothing -> return () Just hv -> io (writeIORef commands -- @@ -608,43 +608,43 @@ loadModule fs = timeIt (loadModule' fs) loadModule' :: [FilePath] -> GHCi () loadModule' files = do state <- getGHCiState - dflags <- io getDynFlags -- expand tildes files <- mapM expandPath files -- do the dependency anal first, so that if it fails we don't throw -- away the current set of modules. - graph <- io (cmDepAnal (cmstate state) dflags files) + graph <- io (cmDepAnal (cmstate state) files) -- Dependency anal ok, now unload everything - cmstate1 <- io (cmUnload (cmstate state) dflags) + cmstate1 <- io (cmUnload (cmstate state)) setGHCiState state{ cmstate = cmstate1, targets = [] } io (revertCAFs) -- always revert CAFs on load. - (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph) + (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph) setGHCiState state{ cmstate = cmstate2, targets = files } setContextAfterLoad mods + dflags <- io (getDynFlags) modulesLoadedMsg ok mods dflags reloadModule :: String -> GHCi () reloadModule "" = do state <- getGHCiState - dflags <- io getDynFlags case targets state of [] -> io (putStr "no current target\n") paths -> do -- do the dependency anal first, so that if it fails we don't throw -- away the current set of modules. - graph <- io (cmDepAnal (cmstate state) dflags paths) + graph <- io (cmDepAnal (cmstate state) paths) io (revertCAFs) -- always revert CAFs on reload. (cmstate1, ok, mods) - <- io (cmLoadModules (cmstate state) dflags graph) + <- io (cmLoadModules (cmstate state) graph) setGHCiState state{ cmstate=cmstate1 } setContextAfterLoad mods + dflags <- io getDynFlags modulesLoadedMsg ok mods dflags reloadModule _ = noArgs ":reload" @@ -671,9 +671,7 @@ modulesLoadedMsg ok mods dflags = typeOfExpr :: String -> GHCi () typeOfExpr str = do cms <- getCmState - dflags <- io getDynFlags - (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str) - setCmState new_cmstate + maybe_tystr <- io (cmTypeOfExpr cms str) case maybe_tystr of Nothing -> return () Just tystr -> io (putStrLn tystr) @@ -696,56 +694,25 @@ browseCmd m = browseModule m exports_only = do cms <- getCmState - dflags <- io getDynFlags is_interpreted <- io (cmModuleIsInterpreted cms m) when (not is_interpreted && not exports_only) $ throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted")) - -- temporarily set the context to the module we're interested in, + -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified (as,bs) <- io (cmGetContext cms) - cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m] - else cmSetContext cms dflags [m] []) - cms2 <- io (cmSetContext cms1 dflags as bs) - - (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only) + cms1 <- io (if exports_only then cmSetContext cms [] [prel,m] + else cmSetContext cms [m] []) + cms2 <- io (cmSetContext cms1 as bs) - setCmState cms3 + things <- io (cmBrowseModule cms2 m exports_only) let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context - things' = filter wantToSee things - - wantToSee (AnId id) = not (isImplicitId id) - wantToSee (ADataCon _) = False -- They'll come via their TyCon - wantToSee _ = True - - thing_names = map getName things - - thingDecl thing@(AnId id) = ifaceTyThing True{-omit prags-} thing - - thingDecl thing@(AClass c) = - let rn_decl = ifaceTyThing True{-omit prags-} thing in - case rn_decl of - ClassDecl { tcdSigs = cons } -> - rn_decl{ tcdSigs = filter methodIsVisible cons } - other -> other - where - methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names - - thingDecl thing@(ATyCon t) = - let rn_decl = ifaceTyThing True{-omit prags-} thing in - case rn_decl of - TyData { tcdCons = DataCons cons } -> - rn_decl{ tcdCons = DataCons (filter conIsVisible cons) } - other -> other - where - conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names - io (putStrLn (showSDocForUser unqual ( - vcat (map (ppr . thingDecl) things'))) - ) + vcat (map ppr things) + ))) ----------------------------------------------------------------------------- -- Setting the module context @@ -764,10 +731,9 @@ setContext str newContext mods = do cms <- getCmState - dflags <- io getDynFlags (as,bs) <- separate cms mods [] [] let bs' = if null as && prel `notElem` bs then prel:bs else bs - cms' <- io (cmSetContext cms dflags as bs') + cms' <- io (cmSetContext cms as bs') setCmState cms' separate cmstate [] as bs = return (as,bs) @@ -782,7 +748,6 @@ prel = "Prelude" addToContext mods = do cms <- getCmState - dflags <- io getDynFlags (as,bs) <- io (cmGetContext cms) (as',bs') <- separate cms mods [] [] @@ -790,14 +755,13 @@ addToContext mods = do let as_to_add = as' \\ (as ++ bs) bs_to_add = bs' \\ (as ++ bs) - cms' <- io (cmSetContext cms dflags + cms' <- io (cmSetContext cms (as ++ as_to_add) (bs ++ bs_to_add)) setCmState cms' removeFromContext mods = do cms <- getCmState - dflags <- io getDynFlags (as,bs) <- io (cmGetContext cms) (as_to_remove,bs_to_remove) <- separate cms mods [] [] @@ -805,7 +769,7 @@ removeFromContext mods = do let as' = as \\ (as_to_remove ++ bs_to_remove) bs' = bs \\ (as_to_remove ++ bs_to_remove) - cms' <- io (cmSetContext cms dflags as' bs') + cms' <- io (cmSetContext cms as' bs') setCmState cms' ---------------------------------------------------------------------------- @@ -924,9 +888,9 @@ optToStr RevertCAFs = "r" newPackages new_pkgs = do -- The new packages are already in v_Packages state <- getGHCiState - dflags <- io getDynFlags - cmstate1 <- io (cmUnload (cmstate state) dflags) + cmstate1 <- io (cmUnload (cmstate state)) setGHCiState state{ cmstate = cmstate1, targets = [] } + dflags <- io getDynFlags io (linkPackages dflags new_pkgs) setContextAfterLoad [] @@ -961,7 +925,8 @@ showBindings = do cms <- getCmState let unqual = cmGetPrintUnqual cms - showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing True{-omit prags-} b))) +-- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b))) + showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b))) io (mapM_ showBinding (cmGetBindings cms)) return () diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 8f9fa34b22..008c0b2e93 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -36,11 +36,10 @@ import DriverState ( v_Cmdline_frameworks, v_Framework_paths ) #endif import Finder ( findModule, findLinkable ) import HscTypes -import Name ( Name, nameModule, isExternalName, isWiredInName ) +import Name ( Name, nameModule, nameModuleName, isExternalName, isWiredInName ) import NameEnv import NameSet ( nameSetToList ) import Module -import FastString ( FastString(..), unpackFS ) import ListSetOps ( minusList ) import CmdLineOpts ( DynFlags(verbosity), getDynFlags ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) @@ -144,7 +143,7 @@ filterNameMap mods env = filterNameEnv keep_elt env where keep_elt (n,_) = isExternalName n - && (moduleName (nameModule n) `elem` mods) + && (nameModuleName n `elem` mods) \end{code} @@ -308,8 +307,7 @@ preloadLib dflags lib_paths framework_paths lib_spec %************************************************************************ \begin{code} -linkExpr :: HscEnv -> PersistentCompilerState - -> UnlinkedBCO -> IO HValue +linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue -- Link a single expression, *including* first linking packages and -- modules that this expression depends on. @@ -317,13 +315,14 @@ linkExpr :: HscEnv -> PersistentCompilerState -- Raises an IO exception if it can't find a compiled version of the -- dependents to link. -linkExpr hsc_env pcs root_ul_bco +linkExpr hsc_env root_ul_bco = do { -- Initialise the linker (if it's not been done already) initDynLinker -- Find what packages and linkables are required - ; (lnks, pkgs) <- getLinkDeps hpt pit needed_mods + ; eps <- readIORef (hsc_EPS hsc_env) + ; (lnks, pkgs) <- getLinkDeps hpt (eps_PIT eps) needed_mods -- Link the packages and modules required ; linkPackages dflags pkgs @@ -342,7 +341,6 @@ linkExpr hsc_env pcs root_ul_bco ; return root_hval }} where - pit = eps_PIT (pcs_EPS pcs) hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env free_names = nameSetToList (bcoFreeNames root_ul_bco) @@ -473,9 +471,6 @@ findModuleLinkable_maybe lis mod [li] -> Just li many -> pprPanic "findModuleLinkable" (ppr mod) -filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] -filterModuleLinkables p ls = filter (p . linkableModName) ls - linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = case findModuleLinkable_maybe objs_loaded (linkableModName l) of @@ -650,8 +645,7 @@ unload_wkr dflags linkables pls objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) - let objs_retained = map linkableModName objs_loaded' - bcos_retained = map linkableModName bcos_loaded' + let bcos_retained = map linkableModName bcos_loaded' itbl_env' = filterNameMap bcos_retained (itbl_env pls) closure_env' = filterNameMap bcos_retained (closure_env pls) new_pls = pls { itbl_env = itbl_env', diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index ddc11adb13..fa48574bf2 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -14,12 +14,12 @@ import Language.Haskell.THSyntax as Meta import HsSyn as Hs ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsStmtContext(..), TyClDecl(..), + HsStmtContext(..), TyClDecl(..), HsBang(..), Match(..), GRHSs(..), GRHS(..), HsPred(..), HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..), Stmt(..), HsBinds(..), MonoBinds(..), Sig(..), Pat(..), HsConDetails(..), HsOverLit, BangType(..), - placeHolderType, HsType(..), HsTupCon(..), + placeHolderType, HsType(..), HsTyVarBndr(..), HsContext, mkSimpleMatch, mkHsForAllTy ) @@ -29,10 +29,8 @@ import Module ( mkModuleName ) import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData ) import OccName import SrcLoc ( SrcLoc, generatedSrcLoc ) -import TyCon ( DataConDetails(..) ) import Type ( Type ) -import BasicTypes( Boxity(..), RecFlag(Recursive), - NewOrData(..), StrictnessMark(..) ) +import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..) ) import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), CExportSpec(..)) import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..), @@ -59,13 +57,13 @@ mk_con con = case con of -> ConDecl (cName c) noExistentials noContext (InfixCon (mk_arg st1) (mk_arg st2)) loc0 where - mk_arg (IsStrict, ty) = BangType MarkedUserStrict (cvtType ty) - mk_arg (NotStrict, ty) = BangType NotMarkedStrict (cvtType ty) + mk_arg (IsStrict, ty) = BangType HsStrict (cvtType ty) + mk_arg (NotStrict, ty) = BangType HsNoBang (cvtType ty) mk_id_arg (i, IsStrict, ty) - = (vName i, BangType MarkedUserStrict (cvtType ty)) + = (vName i, BangType HsStrict (cvtType ty)) mk_id_arg (i, NotStrict, ty) - = (vName i, BangType NotMarkedStrict (cvtType ty)) + = (vName i, BangType HsNoBang (cvtType ty)) mk_derivs [] = Nothing mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] @@ -80,24 +78,24 @@ cvt_top (TySynD tc tvs rhs) cvt_top (DataD ctxt tc tvs constrs derivs) = Left $ TyClD (mkTyData DataType (cvt_context ctxt, tconName tc, cvt_tvs tvs) - (DataCons (map mk_con constrs)) + (map mk_con constrs) (mk_derivs derivs) loc0) cvt_top (NewtypeD ctxt tc tvs constr derivs) = Left $ TyClD (mkTyData NewType (cvt_context ctxt, tconName tc, cvt_tvs tvs) - (DataCons [mk_con constr]) + [mk_con constr] (mk_derivs derivs) loc0) cvt_top (ClassD ctxt cl tvs decs) = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs) noFunDeps sigs - (Just binds) loc0) + binds loc0) where (binds,sigs) = cvtBindsAndSigs decs cvt_top (InstanceD tys ty decs) - = Left $ InstD (InstDecl inst_ty binds sigs Nothing loc0) + = Left $ InstD (InstDecl inst_ty binds sigs loc0) where (binds, sigs) = cvtBindsAndSigs decs inst_ty = HsForAllTy Nothing @@ -314,7 +312,7 @@ cvtType ty = trans (root ty []) root t zs = (t,zs) trans (TupleT n,args) - | length args == n = HsTupleTy (HsTupCon Boxed n) args + | length args == n = HsTupleTy Boxed args | n == 0 = foldl HsAppTy (HsTyVar (tconName "()")) args | otherwise = foldl HsAppTy (HsTyVar (tconName ("(" ++ replicate (n-1) ',' ++ ")"))) args trans (ArrowT, [x,y]) = HsFunTy x y diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index b00b3e9776..34ebac6526 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -15,20 +15,16 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, GRHSs, pprPatBind ) -- friends: -import HsImpExp ( pprHsVar ) import HsPat ( Pat ) import HsTypes ( HsType ) -import PprCore ( {- instance Outputable (Expr a) -} ) --others: import Name ( Name ) -import PrelNames ( isUnboundName ) import NameSet ( NameSet, elemNameSet, nameSetToList ) -import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..), IPName ) +import BasicTypes ( RecFlag(..), Activation(..), Fixity, IPName ) import Outputable import SrcLoc ( SrcLoc ) import Var ( TyVar ) -import Class ( DefMeth (..) ) \end{code} %************************************************************************ @@ -248,12 +244,6 @@ data Sig name (HsType name) SrcLoc - | ClassOpSig name -- Selector name - (DefMeth name) -- Default-method info - -- See "THE NAMING STORY" in HsDecls - (HsType name) - SrcLoc - | SpecSig name -- specialise a function or datatype ... (HsType name) -- ... to these types SrcLoc @@ -268,15 +258,15 @@ data Sig name SrcLoc | FixSig (FixitySig name) -- Fixity declaration + +data FixitySig name = FixitySig name Fixity SrcLoc \end{code} \begin{code} okBindSig :: NameSet -> Sig Name -> Bool -okBindSig ns (ClassOpSig _ _ _ _) = False okBindSig ns sig = sigForThisGroup ns sig okClsDclSig :: Sig Name -> Bool -okClsDclSig (Sig _ _ _) = False okClsDclSig (SpecInstSig _ _) = False okClsDclSig sig = True -- All others OK @@ -286,39 +276,38 @@ okInstDclSig ns (FixSig _) = False okInstDclSig ns (SpecInstSig _ _) = True okInstDclSig ns sig = sigForThisGroup ns sig +sigForThisGroup :: NameSet -> Sig Name -> Bool sigForThisGroup ns sig = case sigName sig of - Nothing -> False - Just n | isUnboundName n -> True -- Don't complain about an unbound name again - | otherwise -> n `elemNameSet` ns + Nothing -> False + Just n -> n `elemNameSet` ns sigName :: Sig name -> Maybe name sigName (Sig n _ _) = Just n -sigName (ClassOpSig n _ _ _) = Just n sigName (SpecSig n _ _) = Just n sigName (InlineSig _ n _ _) = Just n sigName (FixSig (FixitySig n _ _)) = Just n sigName other = Nothing +sigLoc :: Sig name -> SrcLoc +sigLoc (Sig _ _ loc) = loc +sigLoc (SpecSig _ _ loc) = loc +sigLoc (InlineSig _ _ _ loc) = loc +sigLoc (FixSig (FixitySig n _ loc)) = loc +sigLoc (SpecInstSig _ loc) = loc + isFixitySig :: Sig name -> Bool isFixitySig (FixSig _) = True isFixitySig _ = False -isClassOpSig :: Sig name -> Bool -isClassOpSig (ClassOpSig _ _ _ _) = True -isClassOpSig _ = False - isPragSig :: Sig name -> Bool -- Identifies pragmas isPragSig (SpecSig _ _ _) = True isPragSig (InlineSig _ _ _ _) = True isPragSig (SpecInstSig _ _) = True isPragSig other = False -\end{code} -\begin{code} hsSigDoc (Sig _ _ loc) = (ptext SLIT("type signature"),loc) -hsSigDoc (ClassOpSig _ _ _ loc) = (ptext SLIT("class-method type signature"), loc) hsSigDoc (SpecSig _ _ loc) = (ptext SLIT("SPECIALISE pragma"),loc) hsSigDoc (InlineSig True _ _ loc) = (ptext SLIT("INLINE pragma"),loc) hsSigDoc (InlineSig False _ _ loc) = (ptext SLIT("NOINLINE pragma"),loc) @@ -326,6 +315,19 @@ hsSigDoc (SpecInstSig _ loc) = (ptext SLIT("SPECIALISE instance pragma"),l hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc) \end{code} +Signature equality is used when checking for duplicate signatures + +\begin{code} +eqHsSig :: Sig Name -> Sig Name -> Bool +eqHsSig (FixSig (FixitySig n1 _ _)) (FixSig (FixitySig n2 _ _)) = n1 == n2 +eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 +eqHsSig (InlineSig b1 n1 _ _) (InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2 + -- For specialisations, we don't have equality over + -- HsType, so it's not convenient to spot duplicate + -- specialisations here. Check for this later, when we're in Type land +eqHsSig _other1 _other2 = False +\end{code} + \begin{code} instance (Outputable name) => Outputable (Sig name) where ppr sig = ppr_sig sig @@ -334,20 +336,6 @@ ppr_sig :: Outputable name => Sig name -> SDoc ppr_sig (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] -ppr_sig (ClassOpSig var dm ty _) - = sep [ pprHsVar var <+> dcolon, - nest 4 (ppr ty), - nest 4 (pp_dm_comment) ] - where - pp_dm = case dm of - DefMeth _ -> equals -- Default method indicator - GenDefMeth -> semi -- Generic method indicator - NoDefMeth -> empty -- No Method at all - pp_dm_comment = case dm of - DefMeth _ -> text "{- has default method -}" - GenDefMeth -> text "{- has generic method -}" - NoDefMeth -> empty -- No Method at all - ppr_sig (SpecSig var ty _) = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], nest 4 (ppr ty <+> text "#-}") @@ -363,21 +351,7 @@ ppr_sig (SpecInstSig ty _) = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] ppr_sig (FixSig fix_sig) = ppr fix_sig -\end{code} - -Checking for distinct signatures; oh, so boring - -\begin{code} -eqHsSig :: Sig Name -> Sig Name -> Bool -eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 -eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2 - -eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2 -eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) = - -- may have many specialisations for one value; - -- but not ones that are exactly the same... - (n1 == n2) && (ty1 == ty2) - -eqHsSig _other1 _other2 = False +instance Outputable name => Outputable (FixitySig name) where + ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index d5e9c07f13..547da2738b 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -12,15 +12,14 @@ module HsDecls ( DefaultDecl(..), HsGroup(..), SpliceDecl(..), ForeignDecl(..), ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), - ConDecl(..), CoreDecl(..), - BangType(..), getBangType, getBangStrictness, unbangedType, - DeprecDecl(..), DeprecTxt, + ConDecl(..), + BangType(..), HsBang(..), getBangType, getBangStrictness, unbangedType, + DeprecDecl(..), tyClDeclName, tyClDeclNames, tyClDeclTyVars, - isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, - isTypeOrClassDecl, countTyClDecls, - isSourceInstDecl, instDeclDFun, ifaceRuleDeclName, + isClassDecl, isSynDecl, isDataDecl, + countTyClDecls, conDetailsTys, - collectRuleBndrSigTys, isSrcRule + collectRuleBndrSigTys, ) where #include "HsVersions.h" @@ -29,31 +28,24 @@ module HsDecls ( import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) -- Because Expr imports Decls via HsBracket -import HsBinds ( HsBinds, MonoBinds, Sig(..) ) +import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig ) import HsPat ( HsConDetails(..), hsConArgs ) import HsImpExp ( pprHsVar ) import HsTypes -import PprCore ( pprCoreRule ) -import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, - eq_ufBinders, eq_ufExpr, pprUfExpr - ) -import CoreSyn ( CoreRule(..), RuleName ) -import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..), FixitySig(..) ) +import HscTypes ( DeprecTxt ) +import CoreSyn ( RuleName ) +import BasicTypes ( NewOrData(..), Activation(..) ) import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, CExportSpec(..)) -- others: -import Name ( NamedThing ) import FunDeps ( pprFundeps ) -import TyCon ( DataConDetails(..), visibleDataCons ) -import Class ( FunDep, DefMeth(..) ) +import Class ( FunDep ) import CStrings ( CLabelString ) import Outputable -import Util ( eqListBy, count ) +import Util ( count ) import SrcLoc ( SrcLoc ) import FastString - -import Maybe ( isNothing, fromJust ) \end{code} @@ -73,7 +65,6 @@ data HsDecl id | ForD (ForeignDecl id) | DeprecD (DeprecDecl id) | RuleD (RuleDecl id) - | CoreD (CoreDecl id) | SpliceD (SpliceDecl id) -- NB: all top-level fixity decls are contained EITHER @@ -109,8 +100,7 @@ data HsGroup id hs_defds :: [DefaultDecl id], hs_fords :: [ForeignDecl id], hs_depds :: [DeprecDecl id], - hs_ruleds :: [RuleDecl id], - hs_coreds :: [CoreDecl id] + hs_ruleds :: [RuleDecl id] } \end{code} @@ -124,7 +114,6 @@ instance OutputableBndr name => Outputable (HsDecl name) where ppr (SigD sd) = ppr sd ppr (RuleD rd) = ppr rd ppr (DeprecD dd) = ppr dd - ppr (CoreD dd) = ppr dd ppr (SpliceD dd) = ppr dd instance OutputableBndr name => Outputable (HsGroup name) where @@ -135,13 +124,12 @@ instance OutputableBndr name => Outputable (HsGroup name) where hs_depds = deprec_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_coreds = core_decls }) + hs_ruleds = rule_decls }) = vcat [ppr_ds fix_decls, ppr_ds default_decls, ppr_ds deprec_decls, ppr_ds rule_decls, ppr val_decls, ppr_ds tycl_decls, ppr_ds inst_decls, - ppr_ds foreign_decls, ppr_ds core_decls] + ppr_ds foreign_decls] where ppr_ds [] = empty ppr_ds ds = text "" $$ vcat (map ppr ds) @@ -298,13 +286,7 @@ Interface file code: -- are both in TyClDecl data TyClDecl name - = IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature - tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. - tcdIdInfo :: [HsIdInfo name], - tcdLoc :: SrcLoc - } - - | ForeignType { tcdName :: name, -- See remarks about IfaceSig above + = ForeignType { tcdName :: name, tcdExtName :: Maybe FastString, tcdFoType :: FoType, tcdLoc :: SrcLoc } @@ -313,19 +295,13 @@ data TyClDecl name tcdCtxt :: HsContext name, -- Context tcdName :: name, -- Type constructor tcdTyVars :: [HsTyVarBndr name], -- Type variables - tcdCons :: DataConDetails (ConDecl name), -- Data constructors + tcdCons :: [ConDecl name], -- Data constructors tcdDerivs :: Maybe (HsContext name), -- Derivings; Nothing => not specified -- Just [] => derive exactly what is asked - tcdGeneric :: Maybe Bool, -- Nothing <=> source decl - -- Just x <=> interface-file decl; - -- x=True <=> generic converter functions available - -- We need this for imported data decls, since the - -- imported modules may have been compiled with - -- different flags to the current compilation unit tcdLoc :: SrcLoc } - | TySynonym { tcdName :: name, -- type constructor + | TySynonym { tcdName :: name, -- type constructor tcdTyVars :: [HsTyVarBndr name], -- type variables tcdSynRhs :: HsType name, -- synonym expansion tcdLoc :: SrcLoc @@ -336,20 +312,15 @@ data TyClDecl name tcdTyVars :: [HsTyVarBndr name], -- The class type variables tcdFDs :: [FunDep name], -- Functional dependencies tcdSigs :: [Sig name], -- Methods' signatures - tcdMeths :: Maybe (MonoBinds name), -- Default methods - -- Nothing for imported class decls - -- Just bs for source class decls - tcdLoc :: SrcLoc + tcdMeths :: MonoBinds name, -- Default methods + tcdLoc :: SrcLoc } \end{code} Simple classifiers \begin{code} -isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool - -isIfaceSigDecl (IfaceSig {}) = True -isIfaceSigDecl other = False +isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool isSynDecl (TySynonym {}) = True isSynDecl other = False @@ -359,12 +330,6 @@ isDataDecl other = False isClassDecl (ClassDecl {}) = True isClassDecl other = False - -isTypeOrClassDecl (ClassDecl {}) = True -isTypeOrClassDecl (TyData {}) = True -isTypeOrClassDecl (TySynonym {}) = True -isTypeOrClassDecl (ForeignType {}) = True -isTypeOrClassDecl other = False \end{code} Dealing with names @@ -382,87 +347,26 @@ tyClDeclNames :: Eq name => TyClDecl name -> [(name, SrcLoc)] -- We use the equality to filter out duplicate field names tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)] -tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc}) - = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs] + = (cls_name,loc) : [(n,loc) | Sig n _ loc <- sigs] tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc}) = (tc_name,loc) : conDeclsNames cons - tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs tyClDeclTyVars (ForeignType {}) = [] -tyClDeclTyVars (IfaceSig {}) = [] -\end{code} - -\begin{code} -instance (NamedThing name, Ord name) => Eq (TyClDecl name) where - -- Used only when building interface files - (==) d1@(IfaceSig {}) d2@(IfaceSig {}) - = tcdName d1 == tcdName d2 && - tcdType d1 == tcdType d2 && - tcdIdInfo d1 == tcdIdInfo d2 - - (==) d1@(ForeignType {}) d2@(ForeignType {}) - = tcdName d1 == tcdName d2 && - tcdFoType d1 == tcdFoType d2 - - (==) d1@(TyData {}) d2@(TyData {}) - = tcdName d1 == tcdName d2 && - tcdND d1 == tcdND d2 && - eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> - eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) && - eq_hsCD env (tcdCons d1) (tcdCons d2) - ) - - (==) d1@(TySynonym {}) d2@(TySynonym {}) - = tcdName d1 == tcdName d2 && - eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> - eq_hsType env (tcdSynRhs d1) (tcdSynRhs d2) - ) - - (==) d1@(ClassDecl {}) d2@(ClassDecl {}) - = tcdName d1 == tcdName d2 && - eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> - eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) && - eqListBy (eq_hsFD env) (tcdFDs d1) (tcdFDs d2) && - eqListBy (eq_cls_sig env) (tcdSigs d1) (tcdSigs d2) - ) - - (==) _ _ = False -- default case - -eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2 -eq_hsCD env Unknown Unknown = True -eq_hsCD env (HasCons n1) (HasCons n2) = n1 == n2 -eq_hsCD env d1 d2 = False - -eq_hsFD env (ns1,ms1) (ns2,ms2) - = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2 - -eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) - = n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2 - where - -- Ignore the name of the default method for (DefMeth id) - -- This is used for comparing declarations before putting - -- them into interface files, and the name of the default - -- method isn't relevant - NoDefMeth `eq_dm` NoDefMeth = True - GenDefMeth `eq_dm` GenDefMeth = True - DefMeth _ `eq_dm` DefMeth _ = True - dm1 `eq_dm` dm2 = False \end{code} \begin{code} -countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, - count isIfaceSigDecl decls, count isDataTy decls, count isNewTy decls) where @@ -477,10 +381,6 @@ countTyClDecls decls instance OutputableBndr name => Outputable (TyClDecl name) where - ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info}) - = getPprStyle $ \ sty -> - hsep [ pprHsVar var, dcolon, ppr ty, pprHsIdInfo info ] - ppr (ForeignType {tcdName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] @@ -491,13 +391,9 @@ instance OutputableBndr name ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings}) - = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars) + = pp_tydecl (ppr new_or_data <+> pp_decl_head context tycon tyvars) (pp_condecls condecls) derivings - where - keyword = case new_or_data of - NewType -> SLIT("newtype") - DataType -> SLIT("data") ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods}) @@ -506,21 +402,15 @@ instance OutputableBndr name | otherwise -- Laid out = sep [hsep [top_matter, ptext SLIT("where {")], - nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])] + nest 4 (sep [sep (map ppr_sig sigs), ppr methods, char '}'])] where top_matter = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds ppr_sig sig = ppr sig <> semi - pp_methods = if isNothing methods - then empty - else ppr (fromJust methods) - pp_decl_head :: OutputableBndr name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars] -pp_condecls Unknown = ptext SLIT("{- abstract -}") -pp_condecls (HasCons n) = ptext SLIT("{- abstract with") <+> int n <+> ptext SLIT("constructors -}") -pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) +pp_condecls cs = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) pp_tydecl pp_head pp_decl_rhs derivings = hang pp_head 4 (sep [ @@ -552,12 +442,12 @@ data ConDecl name \end{code} \begin{code} -conDeclsNames :: Eq name => DataConDetails (ConDecl name) -> [(name,SrcLoc)] +conDeclsNames :: Eq name => [ConDecl name] -> [(name,SrcLoc)] -- See tyClDeclNames for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful conDeclsNames cons - = snd (foldl do_one ([], []) (visibleDataCons cons)) + = snd (foldl do_one ([], []) cons) where do_one (flds_seen, acc) (ConDecl name _ _ (RecCon flds) loc) = (new_flds ++ flds_seen, (name,loc) : [(f,loc) | f <- new_flds] ++ acc) @@ -566,38 +456,21 @@ conDeclsNames cons do_one (flds_seen, acc) (ConDecl name _ _ _ loc) = (flds_seen, (name,loc):acc) -\end{code} -\begin{code} conDetailsTys details = map getBangType (hsConArgs details) - -eq_ConDecl env (ConDecl n1 tvs1 cxt1 cds1 _) - (ConDecl n2 tvs2 cxt2 cds2 _) - = n1 == n2 && - (eq_hsTyVars env tvs1 tvs2 $ \ env -> - eq_hsContext env cxt1 cxt2 && - eq_ConDetails env cds1 cds2) - -eq_ConDetails env (PrefixCon bts1) (PrefixCon bts2) - = eqListBy (eq_btype env) bts1 bts2 -eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2) - = eq_btype env bta1 bta2 && eq_btype env btb1 btb2 -eq_ConDetails env (RecCon fs1) (RecCon fs2) - = eqListBy (eq_fld env) fs1 fs2 -eq_ConDetails env _ _ = False - -eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2 \end{code} \begin{code} -data BangType name = BangType StrictnessMark (HsType name) +data BangType name = BangType HsBang (HsType name) + +data HsBang = HsNoBang + | HsStrict -- ! + | HsUnbox -- !! (GHC extension, meaning "unbox") getBangType (BangType _ ty) = ty getBangStrictness (BangType s _) = s -unbangedType ty = BangType NotMarkedStrict ty - -eq_btype env (BangType s1 t1) (BangType s2 t2) = s1==s2 && eq_hsType env t1 t2 +unbangedType ty = BangType HsNoBang ty \end{code} \begin{code} @@ -606,24 +479,28 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where = sep [pprHsForAll tvs cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) - = hsep [ppr_bang ty1, ppr con, ppr_bang ty2] + = hsep [ppr ty1, ppr con, ppr ty2] -- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even -- if the constructor is an infix one. This is because in an interface file -- we don't distinguish between the two. Hence when printing these for the -- user, we need to parenthesise infix constructor names. ppr_con_details con (PrefixCon tys) - = hsep (pprHsVar con : map ppr_bang tys) + = hsep (pprHsVar con : map ppr tys) ppr_con_details con (RecCon fields) = ppr con <+> braces (sep (punctuate comma (map ppr_field fields))) where - ppr_field (n, ty) = ppr n <+> dcolon <+> ppr_bang ty + ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty instance OutputableBndr name => Outputable (BangType name) where - ppr = ppr_bang - -ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty + ppr (BangType is_strict ty) + = bang <> pprParendHsType ty + where + bang = case is_strict of + HsNoBang -> empty + HsStrict -> char '!' + HsUnbox -> ptext SLIT("!!") \end{code} @@ -638,44 +515,18 @@ data InstDecl name = InstDecl (HsType name) -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - (MonoBinds name) - [Sig name] -- User-supplied pragmatic info - - (Maybe name) -- Name for the dictionary function - -- Nothing for source-file instance decls - SrcLoc -isSourceInstDecl :: InstDecl name -> Bool -isSourceInstDecl (InstDecl _ _ _ maybe_dfun _) = isNothing maybe_dfun - -instDeclDFun :: InstDecl name -> Maybe name -instDeclDFun (InstDecl _ _ _ df _) = df -- A Maybe, but that's ok -\end{code} - -\begin{code} instance (OutputableBndr name) => Outputable (InstDecl name) where - ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc) + ppr (InstDecl inst_ty binds uprags src_loc) = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], nest 4 (ppr uprags), nest 4 (ppr binds) ] - where - pp_dfun = case maybe_dfun_name of - Just df -> ppr df - Nothing -> empty -\end{code} - -\begin{code} -instance Ord name => Eq (InstDecl name) where - -- Used for interface comparison only, so don't compare bindings - (==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _) - = inst_ty1 == inst_ty2 && dfun1 == dfun2 \end{code} - %************************************************************************ %* * \subsection[DefaultDecl]{A @default@ declaration} @@ -716,12 +567,6 @@ data ForeignDecl name = ForeignImport name (HsType name) ForeignImport Bool SrcLoc -- defines name | ForeignExport name (HsType name) ForeignExport Bool SrcLoc -- uses name --- yield the Haskell name defined or used in a foreign declaration --- -foreignDeclName :: ForeignDecl name -> name -foreignDeclName (ForeignImport n _ _ _ _) = n -foreignDeclName (ForeignExport n _ _ _ _) = n - -- specification of an imported external entity in dependence on the calling -- convention -- @@ -826,28 +671,6 @@ data RuleDecl name (HsExpr name) -- RHS SrcLoc - | IfaceRule -- One that's come in from an interface file; pre-typecheck - RuleName - Activation - [UfBinder name] -- Tyvars and term vars - name -- Head of lhs - [UfExpr name] -- Args of LHS - (UfExpr name) -- Pre typecheck - SrcLoc - - | IfaceRuleOut -- Post typecheck - name -- Head of LHS - CoreRule - -isSrcRule :: RuleDecl name -> Bool -isSrcRule (HsRule _ _ _ _ _ _) = True -isSrcRule other = False - -ifaceRuleDeclName :: RuleDecl name -> name -ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n -ifaceRuleDeclName (IfaceRuleOut n r) = n -ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs) - data RuleBndr name = RuleBndr name | RuleBndrSig name (HsType name) @@ -855,31 +678,15 @@ data RuleBndr name collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] -instance (NamedThing name, Ord name) => Eq (RuleDecl name) where - -- Works for IfaceRules only; used when comparing interface file versions - (IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _) - = n1==n2 && f1 == f2 && a1==a2 && - eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> - eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2)) - instance OutputableBndr name => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs rhs loc) = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act, - pp_forall, pprExpr lhs, equals <+> pprExpr rhs, - text "#-}" ] + nest 4 (pp_forall <+> pprExpr lhs), + nest 4 (equals <+> pprExpr rhs <+> text "#-}") ] where pp_forall | null ns = empty | otherwise = text "forall" <+> fsep (map ppr ns) <> dot - ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc) - = hsep [ doubleQuotes (ftext name), ppr act, - ptext SLIT("__forall") <+> braces (interppSP tpl_vars), - ppr fn <+> sep (map (pprUfExpr parens) tpl_args), - ptext SLIT("=") <+> ppr rhs - ] <+> semi - - ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule - instance OutputableBndr name => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty @@ -897,29 +704,7 @@ We use exported entities for things to deprecate. \begin{code} data DeprecDecl name = Deprecation name DeprecTxt SrcLoc -type DeprecTxt = FastString -- reason/explanation for deprecation - instance OutputableBndr name => Outputable (DeprecDecl name) where ppr (Deprecation thing txt _) = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] \end{code} - - -%************************************************************************ -%* * - External-core declarations -%* * -%************************************************************************ - -\begin{code} -data CoreDecl name -- a Core value binding (from 'external Core' input) - = CoreDecl name - (HsType name) - (UfExpr name) - SrcLoc - -instance OutputableBndr name => Outputable (CoreDecl name) where - ppr (CoreDecl var ty rhs loc) - = getPprStyle $ \ sty -> - hsep [ pprHsVar var, dcolon, ppr ty, ppr rhs ] -\end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 9b2b64fc87..bc17aed3ba 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -11,9 +11,9 @@ module HsExpr where -- friends: import HsDecls ( HsGroup ) import HsBinds ( HsBinds(..), nullBinds ) -import HsPat ( Pat ) -import HsLit ( HsLit, HsOverLit ) -import HsTypes ( HsType, PostTcType, SyntaxName ) +import HsPat ( Pat(..), HsConDetails(..) ) +import HsLit ( HsLit(..), HsOverLit ) +import HsTypes ( HsType, PostTcType, SyntaxName, placeHolderType ) import HsImpExp ( isOperator, pprHsVar ) -- others: @@ -23,11 +23,47 @@ import Var ( TyVar, Id ) import Name ( Name ) import DataCon ( DataCon ) import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, generatedSrcLoc ) import Outputable import FastString \end{code} + +%************************************************************************ +%* * + Some useful helpers for constructing expressions +%* * +%************************************************************************ + +\begin{code} +mkHsApps f xs = foldl HsApp (HsVar f) xs +mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs) + +mkHsIntLit n = HsLit (HsInt n) +mkHsString s = HsString (mkFastString s) + +mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars)) +mkNullaryConPat con = ConPatIn con (PrefixCon []) + +mkSimpleHsAlt :: Pat id -> HsExpr id -> Match id +-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking +mkSimpleHsAlt pat expr + = mkSimpleMatch [pat] expr placeHolderType generatedSrcLoc + +mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id +mkSimpleMatch pats rhs rhs_ty locn + = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) + +unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id] +unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] + +glueBindsOnGRHSs :: HsBinds id -> GRHSs id -> GRHSs id +glueBindsOnGRHSs EmptyBinds grhss = grhss +glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty) + = GRHSs grhss (binds1 `ThenBinds` binds2) ty +\end{code} + + %************************************************************************ %* * \subsection{Expressions proper} @@ -597,18 +633,6 @@ data GRHSs id data GRHS id = GRHS [Stmt id] -- The RHS is the final ResultStmt SrcLoc - -mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id -mkSimpleMatch pats rhs rhs_ty locn - = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) - -unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id] -unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] - -glueBindsOnGRHSs :: HsBinds id -> GRHSs id -> GRHSs id -glueBindsOnGRHSs EmptyBinds grhss = grhss -glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty) - = GRHSs grhss (binds1 `ThenBinds` binds2) ty \end{code} @getMatchLoc@ takes a @Match@ and returns the diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs index 8eb18e278e..a41d323a47 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -9,7 +9,7 @@ module HsLit where #include "HsVersions.h" import Type ( Type ) -import HsTypes ( SyntaxName, PostTcType ) +import HsTypes ( SyntaxName ) import Outputable import FastString import Ratio ( Rational ) @@ -32,7 +32,7 @@ data HsLit | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION | HsIntPrim Integer -- Unboxed Int - | HsInteger Integer -- Genuinely an integer; arises only from TRANSLATION + | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) @@ -46,7 +46,7 @@ instance Eq HsLit where (HsStringPrim x1) == (HsStringPrim x2) = x1==x2 (HsInt x1) == (HsInt x2) = x1==x2 (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 - (HsInteger x1) == (HsInteger x2) = x1==x2 + (HsInteger x1 _) == (HsInteger x2 _) = x1==x2 (HsRat x1 _) == (HsRat x2 _) = x1==x2 (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 @@ -58,9 +58,12 @@ data HsOverLit -- An overloaded literal | HsFractional Rational SyntaxName -- Frac-looking literals -- The name is fromRational +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) instance Eq HsOverLit where (HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2 (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2 + l1 == l2 = False instance Ord HsOverLit where compare (HsIntegral i1 _) (HsIntegral i2 _) = i1 `compare` i2 @@ -77,7 +80,7 @@ instance Outputable HsLit where ppr (HsString s) = pprHsString s ppr (HsStringPrim s) = pprHsString s <> char '#' ppr (HsInt i) = integer i - ppr (HsInteger i) = integer i + ppr (HsInteger i _) = integer i ppr (HsRat f _) = rational f ppr (HsFloatPrim f) = rational f <> char '#' ppr (HsDoublePrim d) = rational d <> text "##" diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 373a240a33..c996f22772 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -9,9 +9,6 @@ therefore, is almost nothing but re-exporting. \begin{code} module HsSyn ( - -- NB: don't reexport HsCore - -- this module tells about "real Haskell" - module HsBinds, module HsDecls, module HsExpr, @@ -21,7 +18,7 @@ module HsSyn ( module HsTypes, Fixity, NewOrData, - HsModule(..), + HsModule(..), HsExtCore(..), collectStmtsBinders, collectStmtBinders, collectHsBinders, collectLocatedHsBinders, collectMonoBinders, collectLocatedMonoBinders, @@ -38,10 +35,11 @@ import HsImpExp import HsLit import HsPat import HsTypes -import BasicTypes ( Fixity, Version, NewOrData ) +import HscTypes ( DeprecTxt ) +import BasicTypes ( Fixity, NewOrData ) -- others: -import Name ( NamedThing ) +import IfaceSyn ( IfaceBinding ) import Outputable import SrcLoc ( SrcLoc ) import Module ( Module ) @@ -63,10 +61,17 @@ data HsModule name [HsDecl name] -- Type, class, value, and interface signature decls (Maybe DeprecTxt) -- reason/explanation for deprecation of this module SrcLoc + +data HsExtCore name -- Read from Foo.hcr + = HsExtCore + Module + [TyClDecl name] -- Type declarations only; just as in Haskell source, + -- so that we can infer kinds etc + [IfaceBinding] -- And the bindings \end{code} \begin{code} -instance (NamedThing name, OutputableBndr name) +instance (OutputableBndr name) => Outputable (HsModule name) where ppr (HsModule Nothing _ imports decls _ src_loc) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 61321a4a52..79b662fab6 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -1,13 +1,12 @@ -% +]% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsTypes]{Abstract syntax: user-defined types} \begin{code} module HsTypes ( - HsType(..), HsTyVarBndr(..), HsTyOp(..), + HsType(..), HsTyVarBndr(..), , HsContext, HsPred(..) - , HsTupCon(..), hsTupParens, mkHsTupCon, , mkHsForAllTy, mkHsDictTy, mkHsIParamTy , hsTyVarName, hsTyVarNames, replaceTyVarName @@ -21,35 +20,18 @@ module HsTypes ( -- Printing , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr - - -- Equality over Hs things - , EqHsEnv, emptyEqHsEnv, extendEqHsEnv, - , eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsTyVars, eq_hsType, eq_hsContext, eqListBy - - -- Converting from Type to HsType - , toHsType, toHsTyVar, toHsTyVars, toHsContext, toHsFDs ) where #include "HsVersions.h" -import Class ( FunDep ) -import TcType ( Type, Kind, ThetaType, SourceType(..), - tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType - ) -import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation -import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn ) -import RdrName ( mkUnqual ) -import Name ( Name, getName, mkInternalName ) -import OccName ( NameSpace, mkVarOcc, tvName ) -import Var ( TyVar, tyVarKind ) -import Subst ( substTyWith ) +import TcType ( Type, Kind, liftedTypeKind, eqKind ) +import TypeRep ( Type ) +import Name ( Name, mkInternalName ) +import OccName ( mkVarOcc ) import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind ) -import BasicTypes ( Boxity(..), Arity, IPName, tupleParens ) -import PrelNames ( listTyConKey, parrTyConKey, - hasKey, unboundKey ) +import BasicTypes ( IPName, Boxity, tupleParens ) +import PrelNames ( unboundKey ) import SrcLoc ( noSrcLoc ) -import Util ( eqListBy, lengthIs ) -import FiniteMap import Outputable \end{code} @@ -114,10 +96,10 @@ data HsType name | HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:] - | HsTupleTy HsTupCon + | HsTupleTy Boxity [HsType name] -- Element types (length gives arity) - | HsOpTy (HsType name) (HsTyOp name) (HsType name) + | HsOpTy (HsType name) name (HsType name) | HsParTy (HsType name) -- Parenthesis preserved for the precedence re-arrangement in RnTypes @@ -136,23 +118,6 @@ data HsType name Kind -- A type with a kind signature -data HsTyOp name = HsArrow | HsTyOp name - -- Function arrows from *source* get read in as HsOpTy t1 HsArrow t2 - -- But when we generate or parse interface files, we use HsFunTy. - -- This keeps interfaces a bit smaller, because there are a lot of arrows - ------------------------ -data HsTupCon = HsTupCon Boxity Arity - -instance Eq HsTupCon where - (HsTupCon b1 a1) == (HsTupCon b2 a2) = b1==b2 && a1==a2 - -mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon -mkHsTupCon space boxity args = HsTupCon boxity (length args) - -hsTupParens :: HsTupCon -> SDoc -> SDoc -hsTupParens (HsTupCon b _) p = tupleParens b p - ----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: @@ -181,19 +146,19 @@ mkHsIParamTy v ty = HsPredTy (HsIParam v ty) data HsTyVarBndr name = UserTyVar name - | IfaceTyVar name Kind + | KindedTyVar name Kind -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. -hsTyVarName (UserTyVar n) = n -hsTyVarName (IfaceTyVar n _) = n +hsTyVarName (UserTyVar n) = n +hsTyVarName (KindedTyVar n _) = n hsTyVarNames tvs = map hsTyVarName tvs replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 -replaceTyVarName (UserTyVar n) n' = UserTyVar n' -replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k +replaceTyVarName (UserTyVar n) n' = UserTyVar n' +replaceTyVarName (KindedTyVar n k) n' = KindedTyVar n' k \end{code} @@ -249,13 +214,9 @@ NB: these types get printed into interface files, so instance (Outputable name) => Outputable (HsType name) where ppr ty = pprHsType ty -instance (Outputable name) => Outputable (HsTyOp name) where - ppr HsArrow = ftext FSLIT("->") - ppr (HsTyOp n) = ppr n - instance (Outputable name) => Outputable (HsTyVarBndr name) where - ppr (UserTyVar name) = ppr name - ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind + ppr (UserTyVar name) = ppr name + ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind instance Outputable name => Outputable (HsPred name) where ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys) @@ -324,7 +285,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 -ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys) +ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys) ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_ty pREC_TOP ty <+> dcolon <+> pprKind kind) ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty) @@ -335,9 +296,6 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty] -ppr_mono_ty ctxt_prec (HsOpTy ty1 HsArrow ty2) - = ppr_fun_ty ctxt_prec ty1 ty2 - ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = maybeParen ctxt_prec pREC_OP $ ppr_mono_ty pREC_OP ty1 <+> ppr op <+> ppr_mono_ty pREC_OP ty2 @@ -361,197 +319,3 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} -%************************************************************************ -%* * -\subsection{Converting from Type to HsType} -%* * -%************************************************************************ - -@toHsType@ converts from a Type to a HsType, making the latter look as -user-friendly as possible. Notably, it uses synonyms where possible, and -expresses overloaded functions using the '=>' context part of a HsForAllTy. - -\begin{code} -toHsTyVar :: TyVar -> HsTyVarBndr Name -toHsTyVar tv = IfaceTyVar (getName tv) (tyVarKind tv) - -toHsTyVars tvs = map toHsTyVar tvs - -toHsType :: Type -> HsType Name --- This function knows the representation of types -toHsType (TyVarTy tv) = HsTyVar (getName tv) -toHsType (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res) -toHsType (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) - -toHsType (NoteTy (SynNote ty@(TyConApp tycon tyargs)) real_ty) - | isNewTyCon tycon = toHsType ty - | syn_matches = toHsType ty -- Use synonyms if possible!! - | otherwise = -#ifdef DEBUG - pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $ -#endif - toHsType real_ty -- but drop it if not. - where - syn_matches = ty_from_syn `tcEqType` real_ty - (tyvars,syn_ty) = getSynTyConDefn tycon - ty_from_syn = substTyWith tyvars tyargs syn_ty - - -- We only use the type synonym in the file if this doesn't cause - -- us to lose important information. This matters for usage - -- annotations. It's an issue if some of the args to the synonym - -- have arrows in them, or if the synonym's RHS has an arrow; for - -- example, with nofib/real/ebnf2ps/ in Parsers.using. - - -- **! It would be nice if when this test fails we could still - -- write the synonym in as a Note, so we don't lose the info for - -- error messages, but it's too much work for right now. - -- KSW 2000-07. - -toHsType (NoteTy _ ty) = toHsType ty - -toHsType (SourceTy (NType tc tys)) = foldl HsAppTy (HsTyVar (getName tc)) (map toHsType tys) -toHsType (SourceTy pred) = HsPredTy (toHsPred pred) - -toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * - | not saturated = generic_case - | isTupleTyCon tc = HsTupleTy (HsTupCon (tupleTyConBoxity tc) (tyConArity tc)) tys' - | tc `hasKey` listTyConKey = HsListTy (head tys') - | tc `hasKey` parrTyConKey = HsPArrTy (head tys') - | otherwise = generic_case - where - generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys' - tys' = map toHsType tys - saturated = tys `lengthIs` tyConArity tc - -toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of - (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs)) - (map toHsPred preds) - (toHsType tau) - -toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys) -toHsPred (IParam n ty) = HsIParam n (toHsType ty) - -toHsContext :: ThetaType -> HsContext Name -toHsContext theta = map toHsPred theta - -toHsFDs :: [FunDep TyVar] -> [FunDep Name] -toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds] -\end{code} - - -%************************************************************************ -%* * -\subsection{Comparison} -%* * -%************************************************************************ - -\begin{code} -instance Ord a => Eq (HsType a) where - -- The Ord is needed because we keep a - -- finite map of variables to variables - (==) a b = eq_hsType emptyEqHsEnv a b - -instance Ord a => Eq (HsPred a) where - (==) a b = eq_hsPred emptyEqHsEnv a b - -eqWithHsTyVars :: Ord name => - [HsTyVarBndr name] -> [HsTyVarBndr name] - -> (EqHsEnv name -> Bool) -> Bool -eqWithHsTyVars = eq_hsTyVars emptyEqHsEnv -\end{code} - -\begin{code} -type EqHsEnv n = FiniteMap n n --- Tracks the mapping from L-variables to R-variables - -eq_hsVar :: Ord n => EqHsEnv n -> n -> n -> Bool -eq_hsVar env n1 n2 = case lookupFM env n1 of - Just n1 -> n1 == n2 - Nothing -> n1 == n2 - -extendEqHsEnv env n1 n2 - | n1 == n2 = env - | otherwise = addToFM env n1 n2 - -emptyEqHsEnv :: EqHsEnv n -emptyEqHsEnv = emptyFM -\end{code} - -We do define a specialised equality for these \tr{*Type} types; used -in checking interfaces. - -\begin{code} -------------------- -eq_hsTyVars env [] [] k = k env -eq_hsTyVars env (tv1:tvs1) (tv2:tvs2) k = eq_hsTyVar env tv1 tv2 $ \ env -> - eq_hsTyVars env tvs1 tvs2 k -eq_hsTyVars env _ _ _ = False - -eq_hsTyVar env (UserTyVar v1) (UserTyVar v2) k = k (extendEqHsEnv env v1 v2) -eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 `eqKind` k2 && k (extendEqHsEnv env v1 v2) -eq_hsTyVar env _ _ _ = False - -eq_hsVars env [] [] k = k env -eq_hsVars env (v1:bs1) (v2:bs2) k = eq_hsVars (extendEqHsEnv env v1 v2) bs1 bs2 k -eq_hsVars env _ _ _ = False -\end{code} - -\begin{code} -------------------- -eq_hsTypes env = eqListBy (eq_hsType env) - -------------------- -eq_hsType env (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) - = eq_tvs tvs1 tvs2 $ \env -> - eq_hsContext env c1 c2 && - eq_hsType env t1 t2 - where - eq_tvs Nothing (Just _) k = False - eq_tvs Nothing Nothing k = k env - eq_tvs (Just _) Nothing k = False - eq_tvs (Just tvs1) (Just tvs2) k = eq_hsTyVars env tvs1 tvs2 k - -eq_hsType env (HsTyVar n1) (HsTyVar n2) - = eq_hsVar env n1 n2 - -eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2) - = (c1 == c2) && eq_hsTypes env tys1 tys2 - -eq_hsType env (HsListTy ty1) (HsListTy ty2) - = eq_hsType env ty1 ty2 - -eq_hsType env (HsKindSig ty1 k1) (HsKindSig ty2 k2) - = eq_hsType env ty1 ty2 && k1 `eqKind` k2 - -eq_hsType env (HsPArrTy ty1) (HsPArrTy ty2) - = eq_hsType env ty1 ty2 - -eq_hsType env (HsAppTy fun_ty1 arg_ty1) (HsAppTy fun_ty2 arg_ty2) - = eq_hsType env fun_ty1 fun_ty2 && eq_hsType env arg_ty1 arg_ty2 - -eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2) - = eq_hsType env a1 a2 && eq_hsType env b1 b2 - -eq_hsType env (HsPredTy p1) (HsPredTy p2) - = eq_hsPred env p1 p2 - -eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2) - = eq_hsOp env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2 - -eq_hsType env ty1 ty2 = False - - -eq_hsOp env (HsTyOp n1) (HsTyOp n2) = eq_hsVar env n1 n2 -eq_hsOp env HsArrow HsArrow = True -eq_hsOp env op1 op2 = False - -------------------- -eq_hsContext env a b = eqListBy (eq_hsPred env) a b - -------------------- -eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2) - = c1 == c2 && eq_hsTypes env tys1 tys2 -eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2) - = n1 == n2 && eq_hsType env ty1 ty2 -eq_hsPred env _ _ = False -\end{code} diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index a4a7b7cb9a..2c0ea39478 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -16,7 +16,7 @@ import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity ) import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, - isUnLiftedType, isTyVarTy, mkTyVarTy, sourceTypeRep, + isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes ) import TypeRep ( Type(..) ) @@ -1119,7 +1119,6 @@ pushLit env (MachWord w) = text "ldc.i4" <+> integer w <+> text "conv.u4" pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8" pushLit env (MachFloat f) = text "ldc.r4" <+> rational f pushLit env (MachDouble f) = text "ldc.r8" <+> rational f -pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!! Not valid in ILX!!") pushLit env (MachNullAddr) = text "ldc.i4 0" pushLit env (MachLabel l _) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!! Not valid in ILX!!") @@ -1169,7 +1168,7 @@ deepIlxRepType ty@(TyConApp tc tys) deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty) deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty -deepIlxRepType (SourceTy p) = deepIlxRepType (sourceTypeRep p) +deepIlxRepType (PredTy p) = deepIlxRepType (predTypeRep p) deepIlxRepType ty@(TyVarTy tv) = ty idIlxRepType id = deepIlxRepType (idType id) diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs deleted file mode 100644 index c507f2e4dc..0000000000 --- a/ghc/compiler/main/BinIface.hs +++ /dev/null @@ -1,1051 +0,0 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} --- --- (c) The University of Glasgow 2002 --- --- Binary interface file support. - -module BinIface ( writeBinIface, readBinIface, v_IgnoreHiVersion ) where - -#include "HsVersions.h" - -import HscTypes -import BasicTypes -import NewDemand -import HsTypes -import HsCore -import HsDecls -import HsBinds -import HsPat ( HsConDetails(..) ) -import TyCon -import Class -import VarEnv -import CostCentre -import RdrName ( mkRdrUnqual, mkRdrQual ) -import Name ( Name, nameOccName, nameModule_maybe ) -import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts ) -import Module ( moduleName ) -import OccName ( OccName ) -import RnHsSyn -import DriverState ( v_Build_tag ) -import CmdLineOpts ( opt_HiVersion ) -import Panic -import SrcLoc -import Binary -import Util - -import DATA_IOREF -import EXCEPTION ( throwDyn ) -import Monad ( when ) - -#include "HsVersions.h" - --- --------------------------------------------------------------------------- --- We write out a ModIface, but read it in as a ParsedIface. --- There are some big differences, and some subtle ones. We do most --- of the conversion on the way out, so there is minimal fuss when we --- read it back in again (see RnMonad.lhs) - --- The main difference is that all Names in a ModIface are RdrNames in --- a ParsedIface, so when writing out a Name in binary we make sure it --- is binary-compatible with a RdrName. - --- Other subtle differences: --- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put --- Modules as ModuleNames. --- - pi_exports and pi_usages, Names have --- to be converted to OccNames. --- - pi_fixity is a NameEnv in ModIface, --- but a list of (Name,Fixity) pairs in ParsedIface. --- - versioning is totally different. --- - deprecations are different. - -writeBinIface :: FilePath -> ModIface -> IO () -writeBinIface hi_path mod_iface - = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface - -readBinIface :: FilePath -> IO ParsedIface -readBinIface hi_path = getBinFileWithDict hi_path - - --- %********************************************************* --- %* * --- All the Binary instances --- %* * --- %********************************************************* - --- BasicTypes -{-! for IPName derive: Binary !-} -{-! for Fixity derive: Binary !-} -{-! for FixityDirection derive: Binary !-} -{-! for NewOrData derive: Binary !-} -{-! for Boxity derive: Binary !-} -{-! for StrictnessMark derive: Binary !-} -{-! for Activation derive: Binary !-} - -instance Binary Name where - -- we must print these as RdrNames, because that's how they will be read in - put_ bh name - = case nameModule_maybe name of - Just mod - | this_mod == mod -> put_ bh (mkRdrUnqual occ) - | otherwise -> put_ bh (mkRdrQual (moduleName mod) occ) - _ -> put_ bh (mkRdrUnqual occ) - where - occ = nameOccName name - (this_mod,_,_,_) = getUserData bh - - get bh = error "can't Binary.get a Name" - --- NewDemand -{-! for Demand derive: Binary !-} -{-! for Demands derive: Binary !-} -{-! for DmdResult derive: Binary !-} -{-! for StrictSig derive: Binary !-} - -instance Binary DmdType where - -- ignore DmdEnv when spitting out the DmdType - put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p) - get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr) - --- TyCon -{-! for DataConDetails derive: Binary !-} - --- Class -{-! for DefMeth derive: Binary !-} - --- HsTypes -{-! for HsPred derive: Binary !-} -{-! for HsType derive: Binary !-} -{-! for HsTupCon derive: Binary !-} -{-! for HsTyVarBndr derive: Binary !-} - --- HsCore -{-! for UfExpr derive: Binary !-} -{-! for UfConAlt derive: Binary !-} -{-! for UfBinding derive: Binary !-} -{-! for UfBinder derive: Binary !-} -{-! for HsIdInfo derive: Binary !-} -{-! for UfNote derive: Binary !-} - --- HsDecls -{-! for ConDetails derive: Binary !-} -{-! for BangType derive: Binary !-} - -instance (Binary name) => Binary (TyClDecl name) where - put_ bh (IfaceSig name ty idinfo _) = do - putByte bh 0 - put_ bh name - lazyPut bh ty - lazyPut bh idinfo - put_ bh (ForeignType ae af ag ah) = - error "Binary.put_(TyClDecl): ForeignType" - put_ bh (TyData ai aj ak al am _ (Just generics) _) = do - putByte bh 2 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh al - put_ bh am - -- ignore Derivs - put_ bh generics -- Record whether generics needed or not - put_ bh (TySynonym aq ar as _) = do - putByte bh 3 - put_ bh aq - put_ bh ar - put_ bh as - put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do - putByte bh 4 - put_ bh ctxt - put_ bh nm - put_ bh tyvars - put_ bh fds - put_ bh sigs - -- ignore methods (there should be none) - -- ignore SrcLoc - get bh = do - h <- getByte bh - case h of - 0 -> do - name <- get bh - ty <- lazyGet bh - idinfo <- lazyGet bh - return (IfaceSig name ty idinfo noSrcLoc) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do - n_or_d <- get bh - ctx <- get bh - nm <- get bh - tyvars <- get bh - cons <- get bh - generics <- get bh - return (TyData n_or_d ctx nm tyvars cons - Nothing (Just generics) noSrcLoc) - 3 -> do - aq <- get bh - ar <- get bh - as <- get bh - return (TySynonym aq ar as noSrcLoc) - _ -> do - ctxt <- get bh - nm <- get bh - tyvars <- get bh - fds <- get bh - sigs <- get bh - return (ClassDecl ctxt nm tyvars fds sigs - Nothing noSrcLoc) - -instance (Binary name) => Binary (ConDecl name) where - put_ bh (ConDecl aa ac ad ae _) = do - put_ bh aa - put_ bh ac - put_ bh ad - put_ bh ae - -- ignore SrcLoc - get bh = do - aa <- get bh - ac <- get bh - ad <- get bh - ae <- get bh - return (ConDecl aa ac ad ae noSrcLoc) - -instance (Binary name) => Binary (InstDecl name) where - put_ bh (InstDecl aa _ _ ad _) = do - put_ bh aa - -- ignore MonoBinds - -- ignore Sigs - put_ bh ad - -- ignore SrcLoc - get bh = do - aa <- get bh - ad <- get bh - return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc) - -instance (Binary name) => Binary (RuleDecl name) where - put_ bh (IfaceRule ag ah ai aj ak al _) = do - put_ bh ag - put_ bh ah - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh al - -- ignore SrcLoc - get bh = do ag <- get bh - ah <- get bh - ai <- get bh - aj <- get bh - ak <- get bh - al <- get bh - return (IfaceRule ag ah ai aj ak al noSrcLoc) - -instance (Binary name) => Binary (DeprecDecl name) where - put_ bh (Deprecation aa ab _) = do - put_ bh aa - put_ bh ab - -- ignore SrcLoc - get bh = do - aa <- get bh - ab <- get bh - return (Deprecation aa ab noSrcLoc) - --- HsBinds -instance Binary name => Binary (Sig name) where - put_ bh (ClassOpSig n def ty _) = do put_ bh n; put_ bh def; put_ bh ty - get bh = do - n <- get bh - def <- get bh - ty <- get bh - return (ClassOpSig n def ty noSrcLoc) - --- CostCentre -{-! for IsCafCC derive: Binary !-} -{-! for IsDupdCC derive: Binary !-} -{-! for CostCentre derive: Binary !-} - - - -instance Binary ModIface where - put_ bh iface = do - build_tag <- readIORef v_Build_tag - put_ bh (show opt_HiVersion ++ build_tag) - p <- put_ bh (moduleName (mi_module iface)) - put_ bh (mi_package iface) - put_ bh (vers_module (mi_version iface)) - put_ bh (mi_orphan iface) - -- no: mi_boot - lazyPut bh (mi_deps iface) - lazyPut bh (map usageToOccName (mi_usages iface)) - put_ bh (vers_exports (mi_version iface), - map exportItemToRdrExportItem (mi_exports iface)) - put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface)) - (vers_decls (mi_version iface))) - -- no: mi_globals - put_ bh (collectFixities (mi_fixities iface) - (dcl_tycl (mi_decls iface))) - put_ bh (dcl_insts (mi_decls iface)) - lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface)) - lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface)) - - -- Read in as a ParsedIface, not a ModIface. See above. - get bh = error "Binary.get: ModIface" - -declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version - -> [(Version, RenamedTyClDecl)] -declsToVersionedDecls decls env - = map add_vers decls - where add_vers d = - case lookupNameEnv env (tyClDeclName d) of - Nothing -> (initialVersion, d) - Just v -> (v, d) - - ---NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs -deprecsToIfaceDeprecs NoDeprecs = Nothing -deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt) -deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env)) - - -{-! for GenAvailInfo derive: Binary !-} -{-! for WhatsImported derive: Binary !-} - --- For binary interfaces we need to convert the ImportVersion Names to OccNames -usageToOccName :: Usage Name -> Usage OccName -usageToOccName usg - = usg { usg_entities = [ (nameOccName n, v) | (n,v) <- usg_entities usg ] } - -exportItemToRdrExportItem (mn, avails) - = (mn, map availInfoToRdrAvailInfo avails) - -availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo -availInfoToRdrAvailInfo (Avail n) - = Avail (nameOccName n) -availInfoToRdrAvailInfo (AvailTC n ns) - = AvailTC (nameOccName n) (map nameOccName ns) - --- --------------------------------------------------------------------------- --- Reading a binary interface into ParsedIface - -instance Binary ParsedIface where - put_ bh ParsedIface{ - pi_mod = module_name, - pi_pkg = pkg_name, - pi_vers = module_ver, - pi_orphan = orphan, - pi_usages = usages, - pi_exports = exports, - pi_decls = tycl_decls, - pi_fixity = fixities, - pi_insts = insts, - pi_rules = rules, - pi_deprecs = deprecs } = do - build_tag <- readIORef v_Build_tag - put_ bh (show opt_HiVersion ++ build_tag) - put_ bh module_name - put_ bh pkg_name - put_ bh module_ver - put_ bh orphan - lazyPut bh usages - put_ bh exports - put_ bh tycl_decls - put_ bh fixities - put_ bh insts - lazyPut bh rules - lazyPut bh deprecs - get bh = do - check_ver <- get bh - ignore_ver <- readIORef v_IgnoreHiVersion - build_tag <- readIORef v_Build_tag - let our_ver = show opt_HiVersion ++ build_tag - when (check_ver /= our_ver && not ignore_ver) $ - -- use userError because this will be caught by readIface - -- which will emit an error msg containing the iface module name. - throwDyn (ProgramError ( - "mismatched interface file versions: expected " - ++ our_ver ++ ", found " ++ check_ver)) - module_name <- get bh -- same rep. as Module, so that's ok - pkg_name <- get bh - module_ver <- get bh - orphan <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - tycl_decls <- {-# SCC "bin_tycldecls" #-} get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - insts <- {-# SCC "bin_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh - return (ParsedIface { - pi_mod = module_name, - pi_pkg = pkg_name, - pi_vers = module_ver, - pi_orphan = orphan, - pi_deps = deps, - pi_usages = usages, - pi_exports = exports, - pi_decls = tycl_decls, - pi_fixity = fixities, - pi_insts = reverse insts, - pi_rules = rules, - pi_deprecs = deprecs }) - -GLOBAL_VAR(v_IgnoreHiVersion, False, Bool) - --- ---------------------------------------------------------------------------- -{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} - --- Imported from other files :- - -instance Binary Dependencies where - put_ bh deps = do put_ bh (dep_mods deps) - put_ bh (dep_pkgs deps) - put_ bh (dep_orphs deps) - - get bh = do ms <- get bh - ps <- get bh - os <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os }) - -instance (Binary name) => Binary (GenAvailInfo name) where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - return (AvailTC ab ac) - -instance (Binary name) => Binary (Usage name) where - put_ bh usg = do - put_ bh (usg_name usg) - put_ bh (usg_mod usg) - put_ bh (usg_exports usg) - put_ bh (usg_entities usg) - put_ bh (usg_rules usg) - - get bh = do - nm <- get bh - mod <- get bh - exps <- get bh - ents <- get bh - rules <- get bh - return (Usage { usg_name = nm, usg_mod = mod, - usg_exports = exps, usg_entities = ents, - usg_rules = rules }) - -instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore aa) = do - putByte bh 2 - put_ bh aa - put_ bh (ActiveAfter ab) = do - putByte bh 3 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return NeverActive - 1 -> do return AlwaysActive - 2 -> do aa <- get bh - return (ActiveBefore aa) - _ -> do ab <- get bh - return (ActiveAfter ab) - -instance Binary StrictnessMark where - put_ bh MarkedUserStrict = do - putByte bh 0 - put_ bh MarkedStrict = do - putByte bh 1 - put_ bh MarkedUnboxed = do - putByte bh 2 - put_ bh NotMarkedStrict = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return MarkedUserStrict - 1 -> do return MarkedStrict - 2 -> do return MarkedUnboxed - _ -> do return NotMarkedStrict - -instance Binary Boxity where - put_ bh Boxed = do - putByte bh 0 - put_ bh Unboxed = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Boxed - _ -> do return Unboxed - -instance Binary NewOrData where - put_ bh NewType = do - putByte bh 0 - put_ bh DataType = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return NewType - _ -> do return DataType - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (Fixity aa ab) - -instance (Binary name) => Binary (FixitySig name) where - put_ bh (FixitySig aa ab _) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (FixitySig aa ab noSrcLoc) - -instance (Binary name) => Binary (IPName name) where - put_ bh (Dupable aa) = do - putByte bh 0 - put_ bh aa - put_ bh (Linear ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Dupable aa) - _ -> do ab <- get bh - return (Linear ab) - -instance Binary Demand where - put_ bh Top = do - putByte bh 0 - put_ bh Abs = do - putByte bh 1 - put_ bh (Call aa) = do - putByte bh 2 - put_ bh aa - put_ bh (Eval ab) = do - putByte bh 3 - put_ bh ab - put_ bh (Defer ac) = do - putByte bh 4 - put_ bh ac - put_ bh (Box ad) = do - putByte bh 5 - put_ bh ad - put_ bh Bot = do - putByte bh 6 - get bh = do - h <- getByte bh - case h of - 0 -> do return Top - 1 -> do return Abs - 2 -> do aa <- get bh - return (Call aa) - 3 -> do ab <- get bh - return (Eval ab) - 4 -> do ac <- get bh - return (Defer ac) - 5 -> do ad <- get bh - return (Box ad) - _ -> do return Bot - -instance Binary Demands where - put_ bh (Poly aa) = do - putByte bh 0 - put_ bh aa - put_ bh (Prod ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Poly aa) - _ -> do ab <- get bh - return (Prod ab) - -instance Binary DmdResult where - put_ bh TopRes = do - putByte bh 0 - put_ bh RetCPR = do - putByte bh 1 - put_ bh BotRes = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return TopRes - 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off - -- The wrapper was generated for CPR in - -- the imported module! - _ -> do return BotRes - -instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh - return (StrictSig aa) - -instance (Binary name) => Binary (HsTyVarBndr name) where - put_ bh (UserTyVar aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceTyVar ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UserTyVar aa) - _ -> do ab <- get bh - ac <- get bh - return (IfaceTyVar ab ac) - -instance Binary HsTupCon where - put_ bh (HsTupCon ab ac) = do - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - return (HsTupCon ab ac) - -instance (Binary name) => Binary (HsTyOp name) where - put_ bh HsArrow = putByte bh 0 - put_ bh (HsTyOp n) = do putByte bh 1 - put_ bh n - - get bh = do h <- getByte bh - case h of - 0 -> return HsArrow - 1 -> do a <- get bh - return (HsTyOp a) - -instance (Binary name) => Binary (HsType name) where - put_ bh (HsForAllTy aa ab ac) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh (HsTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (HsAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (HsFunTy ag ah) = do - putByte bh 3 - put_ bh ag - put_ bh ah - put_ bh (HsListTy ai) = do - putByte bh 4 - put_ bh ai - put_ bh (HsPArrTy aj) = do - putByte bh 5 - put_ bh aj - put_ bh (HsTupleTy ak al) = do - putByte bh 6 - put_ bh ak - put_ bh al - put_ bh (HsOpTy am an ao) = do - putByte bh 7 - put_ bh am - put_ bh an - put_ bh ao - put_ bh (HsNumTy ap) = do - putByte bh 8 - put_ bh ap - put_ bh (HsPredTy aq) = do - putByte bh 9 - put_ bh aq - put_ bh (HsKindSig ar as) = do - putByte bh 10 - put_ bh ar - put_ bh as - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - return (HsForAllTy aa ab ac) - 1 -> do ad <- get bh - return (HsTyVar ad) - 2 -> do ae <- get bh - af <- get bh - return (HsAppTy ae af) - 3 -> do ag <- get bh - ah <- get bh - return (HsFunTy ag ah) - 4 -> do ai <- get bh - return (HsListTy ai) - 5 -> do aj <- get bh - return (HsPArrTy aj) - 6 -> do ak <- get bh - al <- get bh - return (HsTupleTy ak al) - 7 -> do am <- get bh - an <- get bh - ao <- get bh - return (HsOpTy am an ao) - 8 -> do ap <- get bh - return (HsNumTy ap) - 9 -> do aq <- get bh - return (HsPredTy aq) - _ -> do ar <- get bh - as <- get bh - return (HsKindSig ar as) - -instance (Binary name) => Binary (HsPred name) where - put_ bh (HsClassP aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (HsIParam ac ad) = do - putByte bh 1 - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (HsClassP aa ab) - _ -> do ac <- get bh - ad <- get bh - return (HsIParam ac ad) - -instance (Binary name) => Binary (UfExpr name) where - put_ bh (UfVar aa) = do - putByte bh 0 - put_ bh aa - put_ bh (UfType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (UfTuple ac ad) = do - putByte bh 2 - put_ bh ac - put_ bh ad - put_ bh (UfLam ae af) = do - putByte bh 3 - put_ bh ae - put_ bh af - put_ bh (UfApp ag ah) = do - putByte bh 4 - put_ bh ag - put_ bh ah - put_ bh (UfCase ai aj ak) = do - putByte bh 5 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (UfLet al am) = do - putByte bh 6 - put_ bh al - put_ bh am - put_ bh (UfNote an ao) = do - putByte bh 7 - put_ bh an - put_ bh ao - put_ bh (UfLit ap) = do - putByte bh 8 - put_ bh ap - put_ bh (UfFCall as at) = do - putByte bh 9 - put_ bh as - put_ bh at - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UfVar aa) - 1 -> do ab <- get bh - return (UfType ab) - 2 -> do ac <- get bh - ad <- get bh - return (UfTuple ac ad) - 3 -> do ae <- get bh - af <- get bh - return (UfLam ae af) - 4 -> do ag <- get bh - ah <- get bh - return (UfApp ag ah) - 5 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (UfCase ai aj ak) - 6 -> do al <- get bh - am <- get bh - return (UfLet al am) - 7 -> do an <- get bh - ao <- get bh - return (UfNote an ao) - 8 -> do ap <- get bh - return (UfLit ap) - _ -> do as <- get bh - at <- get bh - return (UfFCall as at) - -instance (Binary name) => Binary (UfConAlt name) where - put_ bh UfDefault = do - putByte bh 0 - put_ bh (UfDataAlt aa) = do - putByte bh 1 - put_ bh aa - put_ bh (UfTupleAlt ab) = do - putByte bh 2 - put_ bh ab - put_ bh (UfLitAlt ac) = do - putByte bh 3 - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do return UfDefault - 1 -> do aa <- get bh - return (UfDataAlt aa) - 2 -> do ab <- get bh - return (UfTupleAlt ab) - _ -> do ac <- get bh - return (UfLitAlt ac) - -instance (Binary name) => Binary (UfBinding name) where - put_ bh (UfNonRec aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (UfRec ac) = do - putByte bh 1 - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (UfNonRec aa ab) - _ -> do ac <- get bh - return (UfRec ac) - -instance (Binary name) => Binary (UfBinder name) where - put_ bh (UfValBinder aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (UfTyBinder ac ad) = do - putByte bh 1 - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (UfValBinder aa ab) - _ -> do ac <- get bh - ad <- get bh - return (UfTyBinder ac ad) - -instance (Binary name) => Binary (HsIdInfo name) where - put_ bh (HsArity aa) = do - putByte bh 0 - put_ bh aa - put_ bh (HsStrictness ab) = do - putByte bh 1 - put_ bh ab - put_ bh (HsUnfold ac ad) = do - putByte bh 2 - put_ bh ac - put_ bh ad - put_ bh HsNoCafRefs = do - putByte bh 3 - put_ bh (HsWorker ae af) = do - putByte bh 4 - put_ bh ae - put_ bh af - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (HsArity aa) - 1 -> do ab <- get bh - return (HsStrictness ab) - 2 -> do ac <- get bh - ad <- get bh - return (HsUnfold ac ad) - 3 -> do return HsNoCafRefs - _ -> do ae <- get bh - af <- get bh - return (HsWorker ae af) - -instance (Binary name) => Binary (UfNote name) where - put_ bh (UfSCC aa) = do - putByte bh 0 - put_ bh aa - put_ bh (UfCoerce ab) = do - putByte bh 1 - put_ bh ab - put_ bh UfInlineCall = do - putByte bh 2 - put_ bh UfInlineMe = do - putByte bh 3 - put_ bh (UfCoreNote s) = do - putByte bh 4 - put_ bh s - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UfSCC aa) - 1 -> do ab <- get bh - return (UfCoerce ab) - 2 -> do return UfInlineCall - 3 -> do return UfInlineMe - _ -> do ac <- get bh - return (UfCoreNote ac) - -instance (Binary name) => Binary (BangType name) where - put_ bh (BangType aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (BangType aa ab) - -instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where - put_ bh (PrefixCon aa) = do - putByte bh 0 - put_ bh aa - put_ bh (InfixCon ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - put_ bh (RecCon ad) = do - putByte bh 2 - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (PrefixCon aa) - 1 -> do ab <- get bh - ac <- get bh - return (InfixCon ab ac) - _ -> do ad <- get bh - return (RecCon ad) - -instance (Binary datacon) => Binary (DataConDetails datacon) where - put_ bh (DataCons aa) = do - putByte bh 0 - put_ bh aa - put_ bh Unknown = do - putByte bh 1 - put_ bh (HasCons ab) = do - putByte bh 2 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (DataCons aa) - 1 -> do return Unknown - _ -> do ab <- get bh - return (HasCons ab) - -instance (Binary id) => Binary (DefMeth id) where - put_ bh NoDefMeth = do - putByte bh 0 - put_ bh (DefMeth aa) = do - putByte bh 1 - put_ bh aa - put_ bh GenDefMeth = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return NoDefMeth - 1 -> do aa <- get bh - return (DefMeth aa) - _ -> do return GenDefMeth - -instance Binary IsCafCC where - put_ bh CafCC = do - putByte bh 0 - put_ bh NotCafCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - _ -> do return NotCafCC - -instance Binary IsDupdCC where - put_ bh OriginalCC = do - putByte bh 0 - put_ bh DupdCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return OriginalCC - _ -> do return DupdCC - -instance Binary CostCentre where - put_ bh NoCostCentre = do - putByte bh 0 - put_ bh (NormalCC aa ab ac ad) = do - putByte bh 1 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh ad - put_ bh (AllCafsCC ae) = do - putByte bh 2 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do return NoCostCentre - 1 -> do aa <- get bh - ab <- get bh - ac <- get bh - ad <- get bh - return (NormalCC aa ab ac ad) - _ -> do ae <- get bh - return (AllCafsCC ae) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 153c058c02..7a4799bc5b 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -246,6 +246,7 @@ data DynFlag | Opt_D_dump_stix | Opt_D_dump_simpl_stats | Opt_D_dump_tc_trace + | Opt_D_dump_if_trace | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 28bb2857a9..701f2ba586 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.126 2003/09/24 13:04:50 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.127 2003/10/09 11:58:56 simonpj Exp $ -- -- Driver flags -- @@ -371,6 +371,7 @@ dynamic_flags = [ , ( "ddump-worker-wrapper", NoArg (setDynFlag Opt_D_dump_worker_wrapper) ) , ( "dshow-passes", NoArg (setVerbosity "2") ) , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace) ) + , ( "ddump-if-trace", NoArg (setDynFlag Opt_D_dump_if_trace) ) , ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) ) , ( "ddump-splices", NoArg (setDynFlag Opt_D_dump_splices) ) , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) ) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 87977cb1f7..e889a72845 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -41,6 +41,7 @@ import Module import ErrUtils import CmdLineOpts import Config +import RdrName ( GlobalRdrEnv ) import Panic import Util import BasicTypes ( SuccessFlag(..) ) @@ -95,29 +96,29 @@ preprocess filename = -- NB. No old interface can also mean that the source has changed. -compile :: GhciMode -- distinguish batch from interactive +compile :: HscEnv -> Module -> ModLocation -> Bool -- True <=> source unchanged -> Bool -- True <=> have object -> Maybe ModIface -- old interface, if available - -> HomePackageTable -- For home-module stuff - -> PersistentCompilerState -- persistent compiler state -> IO CompResult data CompResult - = CompOK PersistentCompilerState -- Updated PCS - ModDetails -- New details + = CompOK ModDetails -- New details + (Maybe GlobalRdrEnv) -- Lexical environment for the module + -- (Maybe because we may have loaded it from + -- its precompiled interface) ModIface -- New iface (Maybe Linkable) -- New code; Nothing => compilation was not reqd -- (old code is still valid) - | CompErrs PersistentCompilerState -- Updated PCS + | CompErrs -compile ghci_mode this_mod location +compile hsc_env this_mod location source_unchanged have_object - old_iface hpt pcs = do + old_iface = do dyn_flags <- restoreDynFlags -- Restore to the state of the last save @@ -154,20 +155,18 @@ compile ghci_mode this_mod location -- -no-recomp should also work with --make do_recomp <- readIORef v_Recomp let source_unchanged' = source_unchanged && do_recomp - hsc_env = HscEnv { hsc_mode = ghci_mode, - hsc_dflags = dyn_flags', - hsc_HPT = hpt } + hsc_env' = hsc_env { hsc_dflags = dyn_flags' } -- run the compiler - hsc_result <- hscMain hsc_env pcs this_mod location + hsc_result <- hscMain hsc_env' this_mod location source_unchanged' have_object old_iface case hsc_result of - HscFail pcs -> return (CompErrs pcs) + HscFail -> return CompErrs - HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing) + HscNoRecomp details iface -> return (CompOK details Nothing iface Nothing) - HscRecomp pcs details iface + HscRecomp details rdr_env iface stub_h_exists stub_c_exists maybe_interpreted_code -> do let maybe_stub_o <- compileStub dyn_flags' stub_c_exists @@ -202,7 +201,7 @@ compile ghci_mode this_mod location let linkable = LM unlinked_time mod_name (hs_unlinked ++ stub_unlinked) - return (CompOK pcs details iface (Just linkable)) + return (CompOK details rdr_env iface (Just linkable)) ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) @@ -620,14 +619,10 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } - hsc_env = HscEnv { hsc_mode = OneShot, - hsc_dflags = dyn_flags', - hsc_HPT = emptyHomePackageTable } - + hsc_env <- newHscEnv OneShot dyn_flags' -- run the compiler! - pcs <- initPersistentCompilerState - result <- hscMain hsc_env pcs mod + result <- hscMain hsc_env mod location{ ml_hspp_file=Just input_fn } source_unchanged False @@ -635,13 +630,14 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do case result of - HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) + HscFail -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) - HscNoRecomp pcs details iface -> do + HscNoRecomp details iface -> do SysTools.touch "Touching object file" o_file return (Nothing, Just location, output_fn) - HscRecomp _pcs _details _iface stub_h_exists stub_c_exists + HscRecomp _details _rdr_env _iface + stub_h_exists stub_c_exists _maybe_interpreted_code -> do -- deal with stubs diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 9b42afcc60..4de831c58c 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,7 +6,7 @@ \begin{code} module HscMain ( - HscResult(..), hscMain, initPersistentCompilerState + HscResult(..), hscMain, newHscEnv #ifdef GHCI , hscStmt, hscTcExpr, hscThing, , compileExpr @@ -16,7 +16,9 @@ module HscMain ( #include "HsVersions.h" #ifdef GHCI +import HsSyn ( Stmt(..) ) import TcHsSyn ( TypecheckedHsExpr ) +import IfaceSyn ( IfaceDecl ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) @@ -25,51 +27,49 @@ import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing ) import RdrHsSyn ( RdrNameStmt ) +import RdrName ( GlobalRdrEnv ) import Type ( Type ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) import SrcLoc ( noSrcLoc ) import Name ( Name ) import CoreLint ( lintUnfolding ) +import DsMeta ( templateHaskellNames ) +import BasicTypes ( Fixity ) #endif -import HsSyn - -import RdrName ( nameRdrName ) import StringBuffer ( hGetStringBuffer ) import Parser import Lexer ( P(..), ParseResult(..), mkPState, showPFailed ) import SrcLoc ( mkSrcLoc ) -import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface ) -import RnEnv ( extendOrigNameCache ) -import PrelInfo ( wiredInThingEnv, knownKeyNames ) -import PrelRules ( builtinRules ) -import MkIface ( mkIface ) +import TcRnDriver ( tcRnModule, tcRnExtCore, tcRnIface ) +import IfaceEnv ( initNameCache ) +import LoadIface ( ifaceStats, initExternalPackageState ) +import PrelInfo ( wiredInThings, basicKnownKeyNames ) +import RdrName ( GlobalRdrEnv ) +import MkIface ( checkOldIface, mkIface ) import Desugar import Flattening ( flatten ) import SimplCore import TidyPgm ( tidyCorePgm ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) +import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) -import Module ( emptyModuleEnv ) import CmdLineOpts import DriverPhases ( isExtCore_file ) -import ErrUtils ( dumpIfSet_dyn, showPass ) +import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import UniqSupply ( mkSplitUniqSupply ) -import Bag ( consBag, emptyBag ) import Outputable import HscStats ( ppSourceStats ) import HscTypes import MkExternalCore ( emitExternalCore ) import ParserCore import ParserCoreUtils -import FiniteMap ( emptyFM ) -import Name ( nameModule ) import Module ( Module, ModLocation(..), showModMsg ) import FastString import Maybes ( expectJust ) @@ -77,27 +77,58 @@ import Maybes ( expectJust ) import Monad ( when ) import Maybe ( isJust, fromJust ) import IO +import DATA_IOREF ( newIORef, readIORef ) \end{code} %************************************************************************ %* * -\subsection{The main compiler pipeline} + Initialisation +%* * +%************************************************************************ + +\begin{code} +newHscEnv :: GhciMode -> DynFlags -> IO HscEnv +newHscEnv ghci_mode dflags + = do { eps_var <- newIORef initExternalPackageState + ; us <- mkSplitUniqSupply 'r' + ; nc_var <- newIORef (initNameCache us knownKeyNames) + ; return (HscEnv { hsc_mode = ghci_mode, + hsc_dflags = dflags, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var } ) } + + +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, + -- where templateHaskellNames are defined +knownKeyNames = map getName wiredInThings + ++ basicKnownKeyNames +#ifdef GHCI + ++ templateHaskellNames +#endif +\end{code} + + +%************************************************************************ +%* * + The main compiler pipeline %* * %************************************************************************ \begin{code} data HscResult - -- compilation failed - = HscFail PersistentCompilerState -- updated PCS - -- concluded that it wasn't necessary - | HscNoRecomp PersistentCompilerState -- updated PCS - ModDetails -- new details (HomeSymbolTable additions) + -- Compilation failed + = HscFail + + -- Concluded that it wasn't necessary + | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) ModIface -- new iface (if any compilation was done) - -- did recompilation - | HscRecomp PersistentCompilerState -- updated PCS - ModDetails -- new details (HomeSymbolTable additions) - ModIface -- new iface (if any compilation was done) + + -- Did recompilation + | HscRecomp ModDetails -- new details (HomeSymbolTable additions) + (Maybe GlobalRdrEnv) + ModIface -- new iface (if any compilation was done) Bool -- stub_h exists Bool -- stub_c exists (Maybe CompiledByteCode) @@ -107,7 +138,6 @@ data HscResult hscMain :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> Module -> ModLocation -- location info -> Bool -- True <=> source unchanged @@ -115,35 +145,35 @@ hscMain -> Maybe ModIface -- old interface, if available -> IO HscResult -hscMain hsc_env pcs mod location +hscMain hsc_env mod location source_unchanged have_object maybe_old_iface = do { - (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface" - checkOldIface hsc_env pcs mod - (ml_hi_file location) - source_unchanged maybe_old_iface; - case maybe_chk_result of { - Nothing -> return (HscFail pcs_ch) ; - Just (recomp_reqd, maybe_checked_iface) -> do { + (recomp_reqd, maybe_checked_iface) <- + _scc_ "checkOldIface" + checkOldIface hsc_env mod + (ml_hi_file location) + source_unchanged maybe_old_iface; let no_old_iface = not (isJust maybe_checked_iface) what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp - ; what_next hsc_env pcs_ch have_object + ; what_next hsc_env have_object mod location maybe_checked_iface - }}} + } -- hscNoRecomp definitely expects to have the old interface available -hscNoRecomp hsc_env pcs_ch have_object +hscNoRecomp hsc_env have_object mod location (Just old_iface) | hsc_mode hsc_env == OneShot = do { when (verbosity (hsc_dflags hsc_env) > 0) $ hPutStrLn stderr "compilation IS NOT required"; + dumpIfaceStats hsc_env ; + let { bomb = panic "hscNoRecomp:OneShot" }; - return (HscNoRecomp pcs_ch bomb bomb) + return (HscNoRecomp bomb bomb) } | otherwise = do { @@ -151,18 +181,14 @@ hscNoRecomp hsc_env pcs_ch have_object hPutStrLn stderr ("Skipping " ++ showModMsg have_object mod location); - -- Typecheck - (pcs_tc, maybe_tc_result) <- _scc_ "tcRnIface" - tcRnIface hsc_env pcs_ch old_iface ; - - case maybe_tc_result of { - Nothing -> return (HscFail pcs_tc); - Just new_details -> + new_details <- _scc_ "tcRnIface" + tcRnIface hsc_env old_iface ; + dumpIfaceStats hsc_env ; - return (HscNoRecomp pcs_tc new_details old_iface) - }} + return (HscNoRecomp new_details old_iface) + } -hscRecomp hsc_env pcs_ch have_object +hscRecomp hsc_env have_object mod location maybe_checked_iface = do { -- what target are we shooting for? @@ -177,13 +203,13 @@ hscRecomp hsc_env pcs_ch have_object showModMsg (not toInterp) mod location); ; front_res <- if toCore then - hscCoreFrontEnd hsc_env pcs_ch location + hscCoreFrontEnd hsc_env location else - hscFrontEnd hsc_env pcs_ch location + hscFrontEnd hsc_env location ; case front_res of Left flure -> return flure; - Right (pcs_tc, ds_result) -> do { + Right ds_result -> do { -- OMITTED: @@ -193,11 +219,15 @@ hscRecomp hsc_env pcs_ch have_object -- FLATTENING ------------------- ; flat_result <- _scc_ "Flattening" - flatten hsc_env pcs_tc ds_result + flatten hsc_env ds_result + +{- TEMP: need to review space-leak fixing here + NB: even the code generator can force one of the + thunks for constructor arguments, for newtypes in particular ; let -- Rule-base accumulated from imported packages - pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc) + pkg_rule_base = eps_rule_base (hsc_EPS hsc_env) -- In one-shot mode, ZAP the external package state at -- this point, because we aren't going to need it from @@ -208,6 +238,7 @@ hscRecomp hsc_env pcs_ch have_object | otherwise = pcs_tc ; pkg_rule_base `seq` pcs_middle `seq` return () +-} -- alive at this point: -- pcs_middle @@ -217,21 +248,16 @@ hscRecomp hsc_env pcs_ch have_object ------------------- -- SIMPLIFY ------------------- - ; simpl_result <- _scc_ "Core2Core" - core2core hsc_env pkg_rule_base flat_result + ; simpl_result <- _scc_ "Core2Core" + core2core hsc_env flat_result ------------------- -- TIDY ------------------- - ; (pcs_simpl, tidy_result) - <- _scc_ "CoreTidy" - tidyCorePgm dflags pcs_middle simpl_result - - -- ZAP the persistent compiler state altogether now if we're - -- in one-shot mode, to save space. - ; pcs_final <- if one_shot then return (error "pcs_final missing") - else return pcs_simpl + ; tidy_result <- _scc_ "CoreTidy" + tidyCorePgm hsc_env simpl_result + -- Emit external core ; emitExternalCore dflags tidy_result -- Alive at this point: @@ -255,6 +281,9 @@ hscRecomp hsc_env pcs_ch have_object ; final_iface <- if one_shot then return (error "no final iface") else return new_iface + ; let { final_globals | one_shot = Nothing + | otherwise = Just $! (mg_rdr_env tidy_result) } + ; final_globals `seq` return () -- Build the final ModDetails (except in one-shot mode, where -- we won't need this information after compilation). @@ -270,36 +299,38 @@ hscRecomp hsc_env pcs_ch have_object ; (stub_h_exists, stub_c_exists, maybe_bcos) <- hscBackEnd dflags tidy_result - -- and the answer is ... - ; return (HscRecomp pcs_final - final_details + -- And the answer is ... + ; dumpIfaceStats hsc_env + + ; return (HscRecomp final_details + final_globals final_iface stub_h_exists stub_c_exists maybe_bcos) }} -hscCoreFrontEnd hsc_env pcs_ch location = do { +hscCoreFrontEnd hsc_env location = do { ------------------- -- PARSE ------------------- ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location)) ; case parseCore inp 1 of - FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch)); + FailP s -> hPutStrLn stderr s >> return (Left HscFail); OkP rdr_module -> do { ------------------- -- RENAME and TYPECHECK ------------------- - ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck" - tcRnExtCore hsc_env pcs_ch rdr_module + ; maybe_tc_result <- _scc_ "TypeCheck" + tcRnExtCore hsc_env rdr_module ; case maybe_tc_result of { - Nothing -> return (Left (HscFail pcs_tc)); - Just mod_guts -> return (Right (pcs_tc, mod_guts)) + Nothing -> return (Left HscFail); + Just mod_guts -> return (Right mod_guts) -- No desugaring to do! }}} -hscFrontEnd hsc_env pcs_ch location = do { +hscFrontEnd hsc_env location = do { ------------------- -- PARSE ------------------- @@ -307,26 +338,26 @@ hscFrontEnd hsc_env pcs_ch location = do { (expectJust "hscFrontEnd:hspp" (ml_hspp_file location)) ; case maybe_parsed of { - Nothing -> return (Left (HscFail pcs_ch)); + Nothing -> return (Left HscFail); Just rdr_module -> do { ------------------- -- RENAME and TYPECHECK ------------------- - ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename" - tcRnModule hsc_env pcs_ch rdr_module + ; maybe_tc_result <- _scc_ "Typecheck-Rename" + tcRnModule hsc_env rdr_module ; case maybe_tc_result of { - Nothing -> return (Left (HscFail pcs_ch)); + Nothing -> return (Left HscFail); Just tc_result -> do { ------------------- -- DESUGAR ------------------- ; maybe_ds_result <- _scc_ "DeSugar" - deSugar hsc_env pcs_tc tc_result + deSugar hsc_env tc_result ; case maybe_ds_result of - Nothing -> return (Left (HscFail pcs_ch)); - Just ds_result -> return (Right (pcs_tc, ds_result)); + Nothing -> return (Left HscFail); + Just ds_result -> return (Right ds_result); }}}}} @@ -393,7 +424,7 @@ myParseModule dflags src_filename case unP parseModule (mkPState buf loc dflags) of { - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing }; POk _ rdr_module -> do { @@ -456,50 +487,47 @@ A naked expression returns a singleton Name [it]. #ifdef GHCI hscStmt -- Compile a stmt all the way to an HValue, but don't run it :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The statement - -> IO ( PersistentCompilerState, - Maybe (InteractiveContext, [Name], HValue) ) + -> IO (Maybe (InteractiveContext, [Name], HValue)) -hscStmt hsc_env pcs icontext stmt +hscStmt hsc_env icontext stmt = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt ; case maybe_stmt of { - Nothing -> return (pcs, Nothing) ; + Nothing -> return Nothing ; Just parsed_stmt -> do { -- Rename and typecheck it - (pcs1, maybe_tc_result) - <- tcRnStmt hsc_env pcs icontext parsed_stmt + maybe_tc_result + <- tcRnStmt hsc_env icontext parsed_stmt ; case maybe_tc_result of { - Nothing -> return (pcs1, Nothing) ; + Nothing -> return Nothing ; Just (new_ic, bound_names, tc_expr) -> do { -- Then desugar, code gen, and link it - ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE + ; hval <- compileExpr hsc_env iNTERACTIVE (ic_rn_gbl_env new_ic) (ic_type_env new_ic) tc_expr - ; return (pcs1, Just (new_ic, bound_names, hval)) + ; return (Just (new_ic, bound_names, hval)) }}}}} hscTcExpr -- Typecheck an expression (but don't run it) :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The expression - -> IO (PersistentCompilerState, Maybe Type) + -> IO (Maybe Type) -hscTcExpr hsc_env pcs icontext expr +hscTcExpr hsc_env icontext expr = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr ; case maybe_stmt of { Just (ExprStmt expr _ _) - -> tcRnExpr hsc_env pcs icontext expr ; + -> tcRnExpr hsc_env icontext expr ; Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ; - return (pcs, Nothing) } ; - Nothing -> return (pcs, Nothing) } } + return Nothing } ; + Nothing -> return Nothing } } \end{code} \begin{code} @@ -514,7 +542,7 @@ hscParseStmt dflags str case unP parseStmt (mkPState buf loc dflags) of { - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing }; -- no stmt: the line consisted of just space or comments @@ -540,26 +568,21 @@ hscParseStmt dflags str #ifdef GHCI hscThing -- like hscStmt, but deals with a single identifier :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The identifier - -> IO ( PersistentCompilerState, - [TyThing] ) - -hscThing hsc_env pcs0 ic str - = do let dflags = hsc_dflags hsc_env + -> IO [(IfaceDecl, Fixity)] - maybe_rdr_name <- myParseIdentifier dflags str +hscThing hsc_env ic str + = do maybe_rdr_name <- myParseIdentifier (hsc_dflags hsc_env) str case maybe_rdr_name of { - Nothing -> return (pcs0, []); + Nothing -> return []; Just rdr_name -> do - (pcs1, maybe_tc_result) <- - tcRnThing hsc_env pcs0 ic rdr_name + maybe_tc_result <- tcRnThing hsc_env ic rdr_name case maybe_tc_result of { - Nothing -> return (pcs1, []) ; - Just things -> return (pcs1, things) + Nothing -> return [] ; + Just things -> return things }} myParseIdentifier dflags str @@ -568,7 +591,7 @@ myParseIdentifier dflags str let loc = mkSrcLoc FSLIT("<interactive>") 1 0 case unP parseIdentifier (mkPState buf loc dflags) of - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing } POk _ rdr_name -> return (Just rdr_name) @@ -584,20 +607,19 @@ myParseIdentifier dflags str \begin{code} #ifdef GHCI compileExpr :: HscEnv - -> PersistentCompilerState -> Module -> GlobalRdrEnv -> TypeEnv -> TypecheckedHsExpr -> IO HValue -compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr +compileExpr hsc_env this_mod rdr_env type_env tc_expr = do { let { dflags = hsc_dflags hsc_env ; lint_on = dopt Opt_DoCoreLinting dflags } -- Desugar it - ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr + ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr -- Flatten it - ; flat_expr <- flattenExpr hsc_env pcs ds_expr + ; flat_expr <- flattenExpr hsc_env ds_expr -- Simplify it ; simpl_expr <- simplifyExpr dflags flat_expr @@ -621,7 +643,7 @@ compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr ; bcos <- coreExprToBCOs dflags prepd_expr -- link it - ; hval <- linkExpr hsc_env pcs bcos + ; hval <- linkExpr hsc_env bcos ; return hval } @@ -631,40 +653,19 @@ compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr %************************************************************************ %* * -\subsection{Initial persistent state} + Statistics on reading interfaces %* * %************************************************************************ \begin{code} -initPersistentCompilerState :: IO PersistentCompilerState -initPersistentCompilerState - = do nc <- initNameCache - return ( - PCS { pcs_EPS = initExternalPackageState, - pcs_nc = nc }) - -initNameCache :: IO NameCache - = do us <- mkSplitUniqSupply 'r' - return (NameCache { nsUniqs = us, - nsNames = initOrigNames, - nsIPs = emptyFM }) - -initExternalPackageState :: ExternalPackageState -initExternalPackageState - = emptyExternalPackageState { - eps_rules = foldr add_rule (emptyBag, 0) builtinRules, - eps_PTE = wiredInThingEnv, - } +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env + = do { eps <- readIORef (hsc_EPS hsc_env) + ; dumpIfSet (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) } where - add_rule (name,rule) (rules, n_slurped) - = (gated_decl `consBag` rules, n_slurped) - where - gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule)) - mod = nameModule name - rdr_name = nameRdrName name -- Seems a bit of a hack to go back - -- to the RdrName - gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible - -initOrigNames :: OrigNameCache -initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags \end{code} diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 8e59f3c16f..e830170f58 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -9,7 +9,6 @@ module HscStats ( ppSourceStats ) where #include "HsVersions.h" import HsSyn -import TyCon ( DataConDetails(..) ) import Outputable import Char ( isSpace ) import Util ( count ) @@ -64,13 +63,13 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - (fixity_sigs, bind_tys, _, bind_specs, bind_inlines) + (fixity_sigs, bind_tys, bind_specs, bind_inlines) = count_sigs [d | SigD d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, data_ds, newt_ds, type_ds, _) = countTyClDecls tycl_decls + (class_ds, type_ds, data_ds, newt_ds) = countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] inst_ds = length inst_decls @@ -102,17 +101,13 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) count_monobinds (PatMonoBind p r _) = (0,1) count_monobinds (FunMonoBind f _ m _) = (0,1) - count_mb_monobinds (Just mbs) = count_monobinds mbs - count_mb_monobinds Nothing = (0,0) + count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) - count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) - - sig_info (FixSig _) = (1,0,0,0,0) - sig_info (Sig _ _ _) = (0,1,0,0,0) - sig_info (ClassOpSig _ _ _ _) = (0,0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,0,1,0) - sig_info (InlineSig _ _ _ _) = (0,0,0,0,1) - sig_info _ = (0,0,0,0,0) + sig_info (FixSig _) = (1,0,0,0) + sig_info (Sig _ _ _) = (0,1,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0) + sig_info (InlineSig _ _ _ _) = (0,0,0,1) + sig_info _ = (0,0,0,0) import_info (ImportDecl _ _ qual as spec _) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) @@ -124,35 +119,31 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) spec_info (Just (False, _)) = (0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,1) - data_info (TyData {tcdCons = DataCons cs, tcdDerivs = derivs}) + data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) = (length cs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) class_info decl@(ClassDecl {}) = case count_sigs (tcdSigs decl) of - (_,_,classops,_,_) -> - (classops, addpr (count_mb_monobinds (tcdMeths decl))) + (_,classops,_,_) -> + (classops, addpr (count_monobinds (tcdMeths decl))) class_info other = (0,0) - inst_info (InstDecl _ inst_meths inst_sigs _ _) + inst_info (InstDecl _ inst_meths inst_sigs _) = case count_sigs inst_sigs of - (_,_,_,ss,is) -> + (_,_,ss,is) -> (addpr (count_monobinds inst_meths), ss, is) addpr :: (Int,Int) -> Int - add1 :: Int -> Int -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) add3 :: (Int,Int,Int) -> (Int,Int,Int) -> (Int, Int, Int) add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int) - add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int) addpr (x,y) = x+y - add1 x1 y1 = x1+y1 add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4) - add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6) \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 88fd6b9562..7cb86bfb42 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -1,64 +1,59 @@ -% + % (c) The University of Glasgow, 2000 % \section[HscTypes]{Types for the per-module compiler} \begin{code} module HscTypes ( - HscEnv(..), + HscEnv(..), hscEPS, GhciMode(..), - ModDetails(..), ModIface(..), + ModDetails(..), ModGuts(..), ModImports(..), ForeignStubs(..), - ParsedIface(..), IfaceDeprecs, HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - ExternalPackageState(..), emptyExternalPackageState, + ExternalPackageState(..), PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, lookupIface, lookupIfaceByModName, moduleNameToModule, emptyModIface, - InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, unQualInScope, + + ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, + emptyIfaceDepCache, - IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, + Deprecs(..), IfaceDeprecs, - VersionInfo(..), initialVersionInfo, lookupVersion, - FixityEnv, lookupFixity, collectFixities, emptyFixityEnv, + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - TyThing(..), implicitTyThings, + implicitTyThings, isImplicitTyThing, + TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, - extendTypeEnvList, extendTypeEnvWithIds, + extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, - WhetherHasOrphans, IsBootInterface, DeclsMap, Usage(..), + WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, + Pool(..), emptyPool, DeclPool, InstPool, + Gated, + RulePool, addRuleToPool, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, - ExportItem, RdrExportItem, + IfaceExport, - PersistentCompilerState(..), + Deprecations, DeprecTxt, lookupDeprec, plusDeprecs, - Deprecations(..), lookupDeprec, plusDeprecs, - - InstEnv, ClsInstEnv, DFunId, + InstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, GlobalRdrElt(..), emptyGlobalRdrEnv, pprGlobalRdrEnv, - LocalRdrEnv, extendLocalRdrEnv, isLocalGRE, unQualInScope, - -- Linker stuff Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, - isObject, nameOfObject, isInterpretable, byteCodeOfObject, - - -- Provenance - Provenance(..), ImportReason(..), - pprNameProvenance, hasBetterProv - + isObject, nameOfObject, isInterpretable, byteCodeOfObject ) where #include "HsVersions.h" @@ -67,48 +62,43 @@ module HscTypes ( import ByteCodeAsm ( CompiledByteCode ) #endif -import RdrName ( RdrName, mkRdrUnqual, - RdrNameEnv, addListToRdrEnv, foldRdrEnv, isUnqual, - rdrEnvToList, emptyRdrEnv ) -import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) +import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, + LocalRdrEnv, emptyLocalRdrEnv, + GlobalRdrElt(..), unQualOK ) +import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet -import OccName ( OccName ) +import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, + extendOccEnv, foldOccEnv ) import Module -import InstEnv ( InstEnv, ClsInstEnv, DFunId ) +import InstEnv ( InstEnv, DFunId ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) -import Id ( Id, idName ) +import Id ( Id, isImplicitId ) +import Type ( TyThing(..) ) + import Class ( Class, classSelIds, classTyCon ) -import TyCon ( TyCon, tyConName, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons ) -import TcType ( TyThing(..) ) -import DataCon ( dataConWorkId, dataConWrapId, dataConWrapId_maybe ) -import Packages ( PackageName, basePackage ) +import TyCon ( TyCon, isClassTyCon, tyConSelIds, tyConDataCons ) +import DataCon ( dataConImplicitIds ) +import Packages ( PackageName ) import CmdLineOpts ( DynFlags ) -import BasicTypes ( Version, initialVersion, IPName, - Fixity, FixitySig(..), defaultFixity ) +import BasicTypes ( Version, initialVersion, IPName, + Fixity, defaultFixity, DeprecTxt ) -import HsSyn ( DeprecTxt, TyClDecl, InstDecl, RuleDecl, - tyClDeclName, ifaceRuleDeclName, tyClDeclNames, - instDeclDFun ) -import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) +import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) +import FiniteMap ( FiniteMap ) import CoreSyn ( IdCoreRule ) import PrelNames ( isBuiltInSyntaxName ) -import InstEnv ( emptyInstEnv ) -import Rules ( emptyRuleBase ) - -import FiniteMap -import Bag ( Bag, emptyBag ) import Maybes ( orElse ) import Outputable -import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import Util ( thenCmp, sortLt ) +import SrcLoc ( SrcLoc ) import UniqSupply ( UniqSupply ) import Maybe ( fromJust ) import FastString ( FastString ) +import DATA_IOREF ( IORef, readIORef ) import Time ( ClockTime ) \end{code} @@ -122,9 +112,28 @@ import Time ( ClockTime ) The HscEnv gives the environment in which to compile a chunk of code. \begin{code} -data HscEnv = HscEnv { hsc_mode :: GhciMode, - hsc_dflags :: DynFlags, - hsc_HPT :: HomePackageTable } +data HscEnv + = HscEnv { hsc_mode :: GhciMode, + hsc_dflags :: DynFlags, + + hsc_HPT :: HomePackageTable, + -- The home package table describes already-compiled + -- home-packge modules, *excluding* the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as "external-package" modules.) + -- hsc_HPT is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded by the compilation manager. + + -- The next two are side-effected by compiling + -- to reflect sucking in interface files + hsc_EPS :: IORef ExternalPackageState, + hsc_NC :: IORef NameCache } + +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) \end{code} The GhciMode is self-explanatory: @@ -141,9 +150,12 @@ type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported emptyHomePackageTable = emptyModuleEnv emptyPackageIfaceTable = emptyModuleEnv -data HomeModInfo = HomeModInfo { hm_iface :: ModIface, - hm_details :: ModDetails, - hm_linkable :: Linkable } +data HomeModInfo + = HomeModInfo { hm_iface :: ModIface, + hm_globals :: Maybe GlobalRdrEnv, -- Its top level environment + -- Nothing <-> compiled module + hm_details :: ModDetails, + hm_linkable :: Linkable } \end{code} Simple lookups in the symbol table. @@ -192,38 +204,58 @@ the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface = ModIface { - mi_module :: !Module, mi_package :: !PackageName, -- Which package the module comes from - mi_version :: !VersionInfo, -- Version info for everything in this module + mi_module :: !Module, + mi_mod_vers :: !Version, -- Module version: changes when anything changes + mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans mi_boot :: !IsBootInterface, -- Read from an hi-boot file? mi_deps :: Dependencies, - -- This is consulted for directly-imported modules, but - -- not for anything else + -- This is consulted for directly-imported modules, + -- but not for anything else (hence lazy) - mi_usages :: [Usage Name], -- Usages; kept sorted so that it's easy to decide -- whether to write a new iface file (changing usages -- doesn't affect the version of this module) + mi_usages :: [Usage], -- NOT STRICT! we read this field lazily from the interface file -- It is *only* consulted by the recompilation checker - mi_exports :: ![ExportItem], - -- What it exports Kept sorted by (mod,occ), to make - -- version comparisons easier + -- Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + mi_exports :: ![IfaceExport], + mi_exp_vers :: !Version, -- Version number of export list - mi_globals :: !(Maybe GlobalRdrEnv), - -- Its top level environment or Nothing if we read this - -- interface from an interface file. (We need the source - -- file to figure out the top-level environment.) + -- Fixities + mi_fixities :: [(OccName,Fixity)], + -- NOT STRICT! we read this field lazily from the interface file - mi_fixities :: !FixityEnv, -- Fixities - mi_deprecs :: Deprecations, -- Deprecations - -- NOT STRICT! we read this field lazilly from the interface file + -- Deprecations + mi_deprecs :: Deprecs [(OccName,DeprecTxt)], + -- NOT STRICT! we read this field lazily from the interface file - mi_decls :: IfaceDecls -- The RnDecls form of ModDetails - -- NOT STRICT! we fill this field with _|_ sometimes + -- Type, class and variable declarations + -- The version of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the version of the parent class/tycon changes + mi_decls :: [(Version,IfaceDecl)], -- Sorted + + -- Instance declarations and rules + mi_insts :: [IfaceInst], -- Sorted + mi_rules :: [IfaceRule], -- Sorted + mi_rule_vers :: !Version, -- Version number for rules and instances combined + + -- Cached environments for easy lookup + -- These are computed (lazily) from other fields + -- and are not put into the interface file + mi_dep_fn :: Name -> Maybe DeprecTxt, -- Cached lookup for mi_deprecs + mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities + mi_ver_fn :: OccName -> Maybe Version -- Cached lookup for mi_decls + -- The Nothing in mi_ver_fn means that the thing + -- isn't in decls. It's useful to know that when + -- seeing if we are up to date wrt the old interface } -- Should be able to construct ModDetails from mi_decls in ModIface @@ -247,7 +279,7 @@ data ModGuts mg_deps :: !Dependencies, -- What is below it, directly or otherwise mg_dir_imps :: ![Module], -- Directly-imported modules; used to -- generate initialisation code - mg_usages :: ![Usage Name], -- Version info for what it needed + mg_usages :: ![Usage], -- Version info for what it needed mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module @@ -305,76 +337,35 @@ data ForeignStubs = NoStubs [Id] -- Foreign-exported binders -- we have to generate code to register these - -data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted - dcl_rules :: [RenamedRuleDecl], -- Sorted - dcl_insts :: [RenamedInstDecl] } -- Unsorted - -mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls --- Sort to put them in canonical order for version comparison -mkIfaceDecls tycls rules insts - = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls, - dcl_rules = sortLt lt_rule rules, - dcl_insts = sortLt lt_inst insts } - where - d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2 - r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2 - i1 `lt_inst` i2 = instDeclDFun i1 < instDeclDFun i2 \end{code} \begin{code} -emptyModIface :: Module -> ModIface -emptyModIface mod - = ModIface { mi_module = mod, - mi_package = basePackage, -- XXX fully bogus - mi_version = initialVersionInfo, - mi_usages = [], - mi_deps = noDependencies, +emptyModIface :: PackageName -> ModuleName -> ModIface +emptyModIface pkg mod + = ModIface { mi_package = pkg, + mi_module = mkModule pkg mod, + mi_mod_vers = initialVersion, mi_orphan = False, mi_boot = False, + mi_deps = noDependencies, + mi_usages = [], mi_exports = [], - mi_fixities = emptyNameEnv, - mi_globals = Nothing, + mi_exp_vers = initialVersion, + mi_fixities = [], mi_deprecs = NoDeprecs, - mi_decls = panic "emptyModIface: decls" + mi_insts = [], + mi_rules = [], + mi_decls = [], + mi_rule_vers = initialVersion, + mi_dep_fn = emptyIfaceDepCache, + mi_fix_fn = emptyIfaceFixCache, + mi_ver_fn = emptyIfaceVerCache } \end{code} %************************************************************************ %* * - Parsed interface files -%* * -%************************************************************************ - -A ParsedIface is exactly as read from an interface file. - -\begin{code} -type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)]) - -- Nothing => NoDeprecs - -- Just (Left t) => DeprecAll - -- Just (Right p) => DeprecSome - -data ParsedIface - = ParsedIface { - pi_mod :: ModuleName, - pi_pkg :: PackageName, - pi_vers :: Version, -- Module version number - pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans - pi_deps :: Dependencies, -- What it depends on - pi_usages :: [Usage OccName], -- Usages - pi_exports :: (Version, [RdrExportItem]), -- Exports - pi_decls :: [(Version, TyClDecl RdrName)], -- Local definitions - pi_fixity :: [FixitySig RdrName], -- Local fixity declarations, - pi_insts :: [InstDecl RdrName], -- Local instance declarations - pi_rules :: (Version, [RuleDecl RdrName]), -- Rules, with their version - pi_deprecs :: IfaceDeprecs -- Deprecations - } -\end{code} - - -%************************************************************************ -%* * \subsection{The interactive context} %* * %************************************************************************ @@ -382,10 +373,10 @@ data ParsedIface \begin{code} data InteractiveContext = InteractiveContext { - ic_toplev_scope :: [Module], -- Include the "top-level" scope of + ic_toplev_scope :: [String], -- Include the "top-level" scope of -- these modules - ic_exports :: [Module], -- Include just the exports of these + ic_exports :: [String], -- Include just the exports of these -- modules ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from @@ -400,86 +391,111 @@ data InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], ic_exports = [], - ic_rn_gbl_env = emptyRdrEnv, - ic_rn_local_env = emptyRdrEnv, + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_rn_local_env = emptyLocalRdrEnv, ic_type_env = emptyTypeEnv } icPrintUnqual :: InteractiveContext -> PrintUnqualified icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt) \end{code} +@unQualInScope@ returns a function that takes a @Name@ and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the @Name@'s provenance to guide whether or not to print the name qualified +in error messages. + +\begin{code} +unQualInScope :: GlobalRdrEnv -> Name -> Bool +-- True if 'f' is in scope, and has only one binding, +-- and the thing it is bound to is the name we are looking for +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') +-- +-- Also checks for built-in syntax, which is always 'in scope' +-- +-- This fn is only efficient if the shared +-- partial application is used a lot. +unQualInScope env + = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n + where + unqual_names :: NameSet + unqual_names = foldOccEnv add emptyNameSet env + add [gre] unquals | unQualOK gre = addOneToNameSet unquals (gre_name gre) + add _ unquals = unquals +\end{code} + %************************************************************************ %* * -\subsection{Type environment stuff} + TyThing %* * %************************************************************************ \begin{code} +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (ADataCon dc) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isClassTyCon tc +isImplicitTyThing other = False + +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId id) = [] + + -- For type constructors, add the data cons (and their extras), + -- and the selectors and generic-programming Ids too + -- + -- Newtypes don't have a worker Id, so don't generate that? +implicitTyThings (ATyCon tc) = map AnId (tyConSelIds tc) ++ + concatMap (extras_plus . ADataCon) (tyConDataCons tc) + + -- For classes, add the class TyCon too (and its extras) + -- and the class selector Ids +implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ + extras_plus (ATyCon (classTyCon cl)) + + + -- For data cons add the worker and wrapper (if any) +implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) + +extras_plus thing = thing : implicitTyThings thing + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] +\end{code} + +%************************************************************************ +%* * + TypeEnv +%* * +%************************************************************************ + +\begin{code} +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv typeEnvElts :: TypeEnv -> [TyThing] typeEnvClasses :: TypeEnv -> [Class] typeEnvTyCons :: TypeEnv -> [TyCon] typeEnvIds :: TypeEnv -> [Id] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing +emptyTypeEnv = emptyNameEnv typeEnvElts env = nameEnvElts env typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] -\end{code} - - -\begin{code} -type TypeEnv = NameEnv TyThing - -emptyTypeEnv = emptyNameEnv mkTypeEnv :: [TyThing] -> TypeEnv mkTypeEnv things = extendTypeEnvList emptyTypeEnv things +lookupTypeEnv = lookupNameEnv + extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv -- Extend the type environment extendTypeEnvList env things = foldl extend env things where extend env thing = extendNameEnv env (getName thing) thing - -implicitTyThings :: [TyThing] -> [TyThing] -implicitTyThings things - = concatMap extras things - where - extras_plus thing = thing : extras thing - - extras (AnId id) = [] - - -- For type constructors, add the data cons (and their extras), - -- and the selectors and generic-programming Ids too - -- - -- Newtypes don't have a worker Id, so don't generate that - extras (ATyCon tc) = map AnId (tyConGenIds tc ++ tyConSelIds tc) ++ data_con_stuff - where - data_con_stuff | isNewTyCon tc = (if (null dcs) then [] else [ADataCon dc1, AnId (dataConWrapId dc1)]) - | otherwise = concatMap (extras_plus . ADataCon) dcs - dcs = tyConDataCons tc - dc1 = head dcs - - -- For classes, add the class TyCon too (and its extras) - -- and the class selector Ids - extras (AClass cl) = map AnId (classSelIds cl) ++ - extras_plus (ATyCon (classTyCon cl)) - - - -- For data cons add the worker and wrapper (if any) - extras (ADataCon dc) - = AnId (dataConWorkId dc) : wrap_id_stuff - where - -- May or may not have a wrapper - wrap_id_stuff = case dataConWrapId_maybe dc of - Just id -> [AnId id] - Nothing -> [] - -extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv -extendTypeEnvWithIds env ids - = extendNameEnvList env [(getName id, AnId id) | id <- ids] \end{code} \begin{code} @@ -490,6 +506,21 @@ lookupType hpt pte name Nothing -> lookupNameEnv pte name \end{code} + +\begin{code} +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +tyThingClass (AClass cls) = cls +tyThingClass other = pprPanic "tyThingClass" (ppr other) + +tyThingDataCon (ADataCon dc) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +tyThingId (AnId id) = id +tyThingId other = pprPanic "tyThingId" (ppr other) +\end{code} + %************************************************************************ %* * \subsection{Auxiliary types} @@ -500,35 +531,33 @@ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere \begin{code} -data VersionInfo - = VersionInfo { - vers_module :: Version, -- Changes when anything changes - vers_exports :: Version, -- Changes when export list changes - vers_rules :: Version, -- Changes when any rule changes - vers_decls :: NameEnv Version - -- Versions for "big" names only (not data constructors, class ops) - -- The version of an Id changes if its fixity changes - -- Ditto data constructors, class operations, except that the version of - -- the parent class/tycon changes - -- - -- If a name isn't in the map, it means 'initialVersion' - } +mkIfaceVerCache :: [(Version,IfaceDecl)] -> OccName -> Maybe Version +mkIfaceVerCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl add emptyOccEnv pairs + add env (v,d) = extendOccEnv env (ifName d) v + +emptyIfaceVerCache :: OccName -> Maybe Version +emptyIfaceVerCache occ = Nothing + +------------------ Deprecations ------------------------- +data Deprecs a + = NoDeprecs + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome a -- Some specific things deprecated + deriving( Eq ) -initialVersionInfo :: VersionInfo -initialVersionInfo = VersionInfo { vers_module = initialVersion, - vers_exports = initialVersion, - vers_rules = initialVersion, - vers_decls = emptyNameEnv - } +type IfaceDeprecs = Deprecs [(OccName,DeprecTxt)] +type Deprecations = Deprecs (NameEnv (OccName,DeprecTxt)) -lookupVersion :: NameEnv Version -> Name -> Version -lookupVersion env name = lookupNameEnv env name `orElse` initialVersion +mkIfaceDepCache:: IfaceDeprecs -> Name -> Maybe DeprecTxt +mkIfaceDepCache NoDeprecs = \n -> Nothing +mkIfaceDepCache (DeprecAll t) = \n -> Just t +mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName -data Deprecations = NoDeprecs - | DeprecAll DeprecTxt -- Whole module deprecated - | DeprecSome (NameEnv (Name,DeprecTxt)) -- Some things deprecated - -- Just "big" names - -- We keep the Name in the range, so we can print them out +emptyIfaceDepCache :: Name -> Maybe DeprecTxt +emptyIfaceDepCache n = Nothing lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt lookupDeprec NoDeprecs name = Nothing @@ -543,13 +572,6 @@ plusDeprecs NoDeprecs d = d plusDeprecs d (DeprecAll t) = DeprecAll t plusDeprecs (DeprecAll t) d = DeprecAll t plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) - -instance Eq Deprecations where - -- Used when checking whether we need write a new interface - NoDeprecs == NoDeprecs = True - (DeprecAll t1) == (DeprecAll t2) = t1 == t2 - (DeprecSome e1) == (DeprecSome e2) = nameEnvElts e1 == nameEnvElts e2 - d1 == d2 = False \end{code} @@ -567,8 +589,7 @@ data GenAvailInfo name = Avail name -- An ordinary identifier deriving( Eq ) -- Equality used when deciding if the interface has changed -type RdrExportItem = (ModuleName, [RdrAvailInfo]) -type ExportItem = (ModuleName, [AvailInfo]) +type IfaceExport = (ModuleName, [GenAvailInfo OccName]) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl add emptyNameSet avails @@ -595,26 +616,31 @@ pprAvail (Avail n) = ppr n \end{code} \begin{code} -type FixityEnv = NameEnv (FixitySig Name) - -- We keep the whole fixity sig so that we - -- can report line-number info when there is a duplicate - -- fixity declaration +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n `orElse` defaultFixity + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Fixity +emptyIfaceFixCache n = defaultFixity + +-- This fixity environment is for source code only +type FixityEnv = NameEnv FixItem + +-- We keep the OccName in the range so that we can generate an interface from it +data FixItem = FixItem OccName Fixity SrcLoc + +instance Outputable FixItem where + ppr (FixItem occ fix loc) = ppr fix <+> ppr occ <+> parens (ppr loc) emptyFixityEnv :: FixityEnv emptyFixityEnv = emptyNameEnv lookupFixity :: FixityEnv -> Name -> Fixity lookupFixity env n = case lookupNameEnv env n of - Just (FixitySig _ fix _) -> fix - Nothing -> defaultFixity - -collectFixities :: FixityEnv -> [TyClDecl Name] -> [FixitySig Name] --- Collect fixities for the specified declarations -collectFixities env decls - = [ fix - | d <- decls, (n,_) <- tyClDeclNames d, - Just fix <- [lookupNameEnv env n] - ] + Just (FixItem _ fix _) -> fix + Nothing -> defaultFixity \end{code} @@ -646,12 +672,13 @@ data Dependencies noDependencies :: Dependencies noDependencies = Deps [] [] [] -data Usage name - = Usage { usg_name :: ModuleName, -- Name of the module - usg_mod :: Version, -- Module version - usg_exports :: Maybe Version, -- Export-list version, if we depend on it - usg_entities :: [(name,Version)], -- Sorted by occurrence name - usg_rules :: Version -- Rules version +data Usage + = Usage { usg_name :: ModuleName, -- Name of the module + usg_mod :: Version, -- Module version + usg_entities :: [(OccName,Version)], -- Sorted by occurrence name + usg_exports :: Maybe Version, -- Export-list version, if we depend on it + usg_rules :: Version -- Orphan-rules version (for non-orphan + -- modules this will always be initialVersion) } deriving( Eq ) -- This type doesn't let you say "I imported f but none of the rules in -- the module". If you use anything in the module you get its rule version @@ -668,23 +695,10 @@ data Usage name %************************************************************************ %* * -\subsection{The persistent compiler state} + The External Package State %* * %************************************************************************ -The @PersistentCompilerState@ persists across successive calls to the -compiler. - -\begin{code} -data PersistentCompilerState - = PCS { - pcs_nc :: !NameCache, - pcs_EPS :: ExternalPackageState - -- non-strict because we fill it with error in HscMain - } -\end{code} - - \begin{code} type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase @@ -714,35 +728,26 @@ data ExternalPackageState -- Holding pens for stuff that has been read in from file, -- but not yet slurped into the renamer - eps_decls :: !DeclsMap, + eps_decls :: !DeclPool, -- A single, global map of Names to unslurped decls - eps_insts :: !IfaceInsts, - -- The as-yet un-slurped instance decls; this bag is depleted when we - -- slurp an instance decl so that we don't slurp the same one twice. - -- Each is 'gated' by the names that must be available before - -- this instance decl is needed. - eps_rules :: !IfaceRules, - -- Similar to instance decls, only for rules - - eps_inst_gates :: !NameSet -- Gates for instance decls - -- The instance gates must accumulate across - -- all invocations of the renamer; - -- see "the gating story" in RnIfaces.lhs - -- These names should all be from other packages; - -- for the home package we have all the instance - -- declarations anyhow + -- Decls move from here to eps_PTE + + eps_insts :: !InstPool, + -- The as-yet un-slurped instance decls + -- Decls move from here to eps_inst_env + -- Each instance is 'gated' by the names that must be + -- available before this instance decl is needed. + + eps_rules :: !RulePool + -- Rules move from here to eps_rule_base when + -- all their LHS free vars are in the eps_PTE + -- To maintain this invariant, we need to check the pool + -- a) when adding to the rule pool by loading an interface + -- (some of the new rules may alrady have all their + -- gates in the eps_PTE) + -- b) when extending the eps_PTE when we load a decl + -- from the eps_decls pool } - -emptyExternalPackageState = EPS { - eps_decls = (emptyNameEnv, 0), - eps_insts = (emptyBag, 0), - eps_inst_gates = emptyNameSet, - eps_rules = (emptyBag, 0), - eps_PIT = emptyPackageIfaceTable, - eps_PTE = emptyTypeEnv, - eps_inst_env = emptyInstEnv, - eps_rule_base = emptyRuleBase - } \end{code} The NameCache makes sure that there is just one Unique assigned for @@ -767,31 +772,43 @@ data NameCache -- Ensures that one implicit parameter name gets one unique } -type OrigNameCache = ModuleEnv (Module, OccNameCache) - -- Maps a module *name* to a Module, - -- plus the OccNameEnv fot that module -type OccNameCache = FiniteMap OccName Name - -- Maps the OccName to a Name - -- A FiniteMap because OccNames have a Namespace/Faststring pair - -type OrigIParamCache = FiniteMap (IPName RdrName) (IPName Name) +type OrigNameCache = ModuleEnv (OccEnv Name) +type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) \end{code} -A DeclsMap contains a binding for each Name in the declaration -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, TyClDecl RdrName)), Int) - -- The Int says how many have been sucked in - -type IfaceInsts = GatedDecls (InstDecl RdrName) -type IfaceRules = GatedDecls (RuleDecl RdrName) - -type GatedDecls d = (Bag (GatedDecl d), Int) -- The Int says how many have been sucked in -type GatedDecl d = (GateFn, (Module, d)) -type GateFn = (Name -> Bool) -> Bool -- Returns True <=> gate is open - -- The (Name -> Bool) fn returns True for visible Names +data Pool p = Pool (NameEnv p) -- The pool itself, indexed by some primary key + Int -- Number of decls slurped into the map + Int -- Number of decls slurped out of the map + +emptyPool = Pool emptyNameEnv 0 0 + +instance Outputable p => Outputable (Pool p) where + ppr (Pool p n_in n_out) -- Debug printing only + = vcat [ptext SLIT("Pool") <+> int n_in <+> int n_out, + nest 2 (ppr p)] + +type DeclPool = Pool IfaceDecl + +------------------------- +type Gated d = ([Name], (ModuleName, d)) -- The [Name] 'gate' the declaration + -- ModuleName records which iface file this + -- decl came from + +type RulePool = Pool [Gated IfaceRule] + +addRuleToPool :: NameEnv [Gated IfaceRule] + -> (ModuleName, IfaceRule) + -> [Name] -- Free vars of rule; always non-empty + -> NameEnv [Gated IfaceRule] +addRuleToPool rules rule (fv:fvs) = extendNameEnv_C combine rules fv [(fvs,rule)] + where + combine old _ = (fvs,rule) : old + +------------------------- +type InstPool = Pool [Gated IfaceInst] + -- The key of the Pool is the Class + -- The Names are the TyCons in the instance head -- For example, suppose this is in an interface file -- instance C T where ... -- We want to slurp this decl if both C and T are "visible" in @@ -861,156 +878,4 @@ byteCodeOfObject (BCOs bc) = bc \end{code} -%************************************************************************ -%* * -\subsection{Provenance and export info} -%* * -%************************************************************************ - -A LocalRdrEnv is used for local bindings (let, where, lambda, case) -Also used in - -\begin{code} -type LocalRdrEnv = RdrNameEnv Name - -extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnv env names - = addListToRdrEnv env [(mkRdrUnqual (nameOccName n), n) | n <- names] -\end{code} - -The GlobalRdrEnv gives maps RdrNames to Names. There is a separate -one for each module, corresponding to that module's top-level scope. - -\begin{code} -type GlobalRdrEnv = RdrNameEnv [GlobalRdrElt] - -- The list is because there may be name clashes - -- These only get reported on lookup, not on construction - -emptyGlobalRdrEnv = emptyRdrEnv - -data GlobalRdrElt - = GRE { gre_name :: Name, - gre_parent :: Maybe Name, -- Name of the "parent" structure, for - -- * the tycon of a data con - -- * the class of a class op - -- For others it's Nothing - -- Invariant: gre_name g /= gre_parent g - -- when the latter is a Just - - gre_prov :: Provenance, -- Why it's in scope - gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated - } - -instance Outputable GlobalRdrElt where - ppr gre = ppr (gre_name gre) <+> - parens (pp_parent (gre_parent gre) <+> pprNameProvenance gre) - where - pp_parent (Just p) = text "parent:" <+> ppr p <> comma - pp_parent Nothing = empty - -pprGlobalRdrEnv env - = vcat (map pp (rdrEnvToList env)) - where - pp (rn, gres) = ppr rn <> colon <+> - vcat [ ppr (gre_name gre) <+> pprNameProvenance gre - | gre <- gres] - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_prov = LocalDef}) = True -isLocalGRE other = False -\end{code} - -@unQualInScope@ returns a function that takes a @Name@ and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the @Name@'s provenance to guide whether or not to print the name qualified -in error messages. -\begin{code} -unQualInScope :: GlobalRdrEnv -> Name -> Bool --- True if 'f' is in scope, and has only one binding, --- and the thing it is bound to is the name we are looking for --- (i.e. false if A.f and B.f are both in scope as unqualified 'f') --- --- Also checks for built-in syntax, which is always 'in scope' --- --- This fn is only efficient if the shared --- partial application is used a lot. -unQualInScope env - = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n - where - unqual_names :: NameSet - unqual_names = foldRdrEnv add emptyNameSet env - add rdr_name [gre] unquals | isUnqual rdr_name = addOneToNameSet unquals (gre_name gre) - add _ _ unquals = unquals -\end{code} - -The "provenance" of something says how it came to be in scope. - -\begin{code} -data Provenance - = LocalDef -- Defined locally - - | NonLocalDef -- Defined non-locally - ImportReason - --- Just used for grouping error messages (in RnEnv.warnUnusedBinds) -instance Eq Provenance where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Eq ImportReason where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Ord Provenance where - compare LocalDef LocalDef = EQ - compare LocalDef (NonLocalDef _) = LT - compare (NonLocalDef _) LocalDef = GT - - compare (NonLocalDef reason1) (NonLocalDef reason2) - = compare reason1 reason2 - -instance Ord ImportReason where - compare ImplicitImport ImplicitImport = EQ - compare ImplicitImport (UserImport _ _ _) = LT - compare (UserImport _ _ _) ImplicitImport = GT - compare (UserImport m1 loc1 _) (UserImport m2 loc2 _) - = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) - - -data ImportReason - = UserImport Module SrcLoc Bool -- Imported from module M on line L - -- Note the M may well not be the defining module - -- for this thing! - -- The Bool is true iff the thing was named *explicitly* in the import spec, - -- rather than being imported as part of a group; e.g. - -- import B - -- import C( T(..) ) - -- Here, everything imported by B, and the constructors of T - -- are not named explicitly; only T is named explicitly. - -- This info is used when warning of unused names. - - | ImplicitImport -- Imported implicitly for some other reason -\end{code} - -\begin{code} -hasBetterProv :: Provenance -> Provenance -> Bool --- Choose --- a local thing over an imported thing --- a user-imported thing over a non-user-imported thing --- an explicitly-imported thing over an implicitly imported thing -hasBetterProv LocalDef _ = True -hasBetterProv (NonLocalDef (UserImport _ _ _ )) (NonLocalDef ImplicitImport) = True -hasBetterProv _ _ = False - -pprNameProvenance :: GlobalRdrElt -> SDoc -pprNameProvenance (GRE {gre_name = name, gre_prov = prov}) - = case prov of - LocalDef -> ptext SLIT("defined at") <+> ppr (nameSrcLoc name) - NonLocalDef why -> sep [ppr_reason why, - nest 2 (ppr_defn (nameSrcLoc name))] - -ppr_reason ImplicitImport = ptext SLIT("implicitly imported") -ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc - -ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("defined at") <+> ppr loc) - | otherwise = empty -\end{code} diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 1731fa54a8..535cbe41a5 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.133 2003/09/23 14:33:00 simonmar Exp $ +-- $Id: Main.hs,v 1.134 2003/10/09 11:58:57 simonpj Exp $ -- -- GHC Driver program -- @@ -332,9 +332,9 @@ doMake :: [String] -> IO () doMake [] = throwDyn (UsageError "no input files") doMake srcs = do dflags <- getDynFlags - state <- cmInit Batch - graph <- cmDepAnal state dflags srcs - (_, ok_flag, _) <- cmLoadModules state dflags graph + state <- cmInit Batch dflags + graph <- cmDepAnal state srcs + (_, ok_flag, _) <- cmLoadModules state graph when (failed ok_flag) (exitWith (ExitFailure 1)) return () diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs deleted file mode 100644 index 9f31e7019b..0000000000 --- a/ghc/compiler/main/MkIface.lhs +++ /dev/null @@ -1,870 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% - -\section[MkIface]{Print an interface for a module} - -\begin{code} -module MkIface ( - showIface, mkIface, mkUsageInfo, - pprIface, - ifaceTyThing, - ) where - -#include "HsVersions.h" - -import HsSyn -import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr ) -import HsTypes ( toHsTyVars ) -import TysPrim ( alphaTyVars ) -import BasicTypes ( NewOrData(..), Activation(..), FixitySig(..), - Version, initialVersion, bumpVersion - ) -import NewDemand ( isTopSig ) -import TcRnMonad -import TcRnTypes ( ImportAvails(..) ) -import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) -import HscTypes ( VersionInfo(..), ModIface(..), - ModGuts(..), ModGuts, - GhciMode(..), HscEnv(..), Dependencies(..), - FixityEnv, lookupFixity, collectFixities, - IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - TyThing(..), DFunId, - Avails, AvailInfo, GenAvailInfo(..), availName, - ExternalPackageState(..), - ParsedIface(..), Usage(..), - Deprecations(..), initialVersionInfo, - lookupVersion, lookupIfaceByModName - ) - -import CmdLineOpts -import Id ( idType, idInfo, isImplicitId, idCafInfo ) -import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks ) -import IdInfo -- Lots -import CoreSyn ( CoreRule(..), IdCoreRule ) -import CoreFVs ( ruleLhsFreeNames ) -import CoreUnfold ( neverUnfold, unfoldingTemplate ) -import Name ( getName, nameModule, nameModule_maybe, nameOccName, - nameIsLocalOrFrom, Name, NamedThing(..) ) -import NameEnv -import NameSet -import OccName ( OccName, pprOccName ) -import TyCon ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta, - isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon, - isSynTyCon, isAlgTyCon, isForeignTyCon, - getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity ) -import Class ( classExtraBigSig, classTyCon ) -import FieldLabel ( fieldLabelType ) -import TcType ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead, - mkSigmaTy, mkFunTys, mkTyConApp, mkTyVarTys ) -import SrcLoc ( noSrcLoc ) -import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, - ModLocation(..), mkSysModuleNameFS, - ModuleEnv, emptyModuleEnv, lookupModuleEnv, - extendModuleEnv_C, moduleEnvElts - ) -import Outputable -import DriverUtil ( createDirectoryHierarchy, directoryOf ) -import Util ( sortLt, dropList, seqList ) -import Binary ( getBinFileWithDict ) -import BinIface ( writeBinIface, v_IgnoreHiVersion ) -import ErrUtils ( dumpIfSet_dyn ) -import FiniteMap -import FastString - -import DATA_IOREF ( writeIORef ) -import Monad ( when ) -import Maybe ( catMaybes, isJust, isNothing ) -import Maybes ( orElse ) -import IO ( putStrLn ) -\end{code} - - -%************************************************************************ -%* * -\subsection{Print out the contents of a binary interface} -%* * -%************************************************************************ - -\begin{code} -showIface :: FilePath -> IO () -showIface filename = do - -- skip the version check; we don't want to worry about profiled vs. - -- non-profiled interfaces, for example. - writeIORef v_IgnoreHiVersion True - parsed_iface <- Binary.getBinFileWithDict filename - let ParsedIface{ - pi_mod=pi_mod, pi_pkg=pi_pkg, pi_vers=pi_vers, - pi_deps=pi_deps, - pi_orphan=pi_orphan, pi_usages=pi_usages, - pi_exports=pi_exports, pi_decls=pi_decls, - pi_fixity=pi_fixity, pi_insts=pi_insts, - pi_rules=pi_rules, pi_deprecs=pi_deprecs } = parsed_iface - putStrLn (showSDoc (vcat [ - text "__interface" <+> doubleQuotes (ppr pi_pkg) - <+> ppr pi_mod <+> ppr pi_vers - <+> (if pi_orphan then char '!' else empty) - <+> ptext SLIT("where"), - -- no instance Outputable (WhatsImported): - pprExports id (snd pi_exports), - pprDeps pi_deps, - pprUsages id pi_usages, - hsep (map ppr_fix pi_fixity) <> semi, - vcat (map ppr_inst pi_insts), - vcat (map ppr_decl pi_decls), - ppr pi_rules - -- no instance Outputable (Either): - -- ppr pi_deprecs - ])) - where - ppr_fix (FixitySig n f _) = ppr f <+> ppr n - ppr_inst i = ppr i <+> semi - ppr_decl (v,d) = int v <+> ppr d <> semi -\end{code} - -%************************************************************************ -%* * -\subsection{Completing an interface} -%* * -%************************************************************************ - -\begin{code} -mkIface :: HscEnv - -> ModLocation - -> Maybe ModIface -- The old interface, if we have it - -> ModGuts -- The compiled, tidied module - -> IO ModIface -- The new one, complete with decls and versions --- mkFinalIface --- a) completes the interface --- b) writes it out to a file if necessary - -mkIface hsc_env location maybe_old_iface - impl@ModGuts{ mg_module = this_mod, - mg_usages = usages, - mg_deps = deps, - mg_exports = exports, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = deprecs, - mg_insts = insts, - mg_rules = rules, - mg_types = types } - = do { -- Sort the exports to make them easier to compare for versions - let { my_exports = groupAvails this_mod exports ; - - iface_w_decls = ModIface { mi_module = this_mod, - mi_package = opt_InPackage, - mi_version = initialVersionInfo, - mi_deps = deps, - mi_usages = usages, - mi_exports = my_exports, - mi_decls = new_decls, - mi_orphan = orphan_mod, - mi_boot = False, - mi_fixities = fix_env, - mi_globals = Just rdr_env, - mi_deprecs = deprecs } } - - -- Add version information - ; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls - - -- Write the interface file, if necessary - ; when (must_write_hi_file maybe_diffs) $ do - createDirectoryHierarchy (directoryOf hi_file_path) - writeBinIface hi_file_path final_iface - - -- Debug printing - ; write_diffs dflags final_iface maybe_diffs - - ; orphan_mod `seq` - return final_iface } - - where - dflags = hsc_dflags hsc_env - ghci_mode = hsc_mode hsc_env - omit_pragmas = dopt Opt_OmitInterfacePragmas dflags - - must_write_hi_file Nothing = False - must_write_hi_file (Just _diffs) = ghci_mode /= Interactive - -- We must write a new .hi file if there are some changes - -- and we're not in interactive mode - -- maybe_diffs = 'Nothing' means that even the usages havn't changed, - -- so there's no need to write a new interface file. But even if - -- the usages have changed, the module version may not have. - - hi_file_path = ml_hi_file location - new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls - inst_dcls = map ifaceInstance insts - ty_cls_dcls = foldNameEnv (ifaceTyThing_acc omit_pragmas) [] types - rule_dcls = map ifaceRule rules - orphan_mod = isOrphanModule impl - -write_diffs :: DynFlags -> ModIface -> Maybe SDoc -> IO () -write_diffs dflags new_iface Nothing - = do when (dopt Opt_D_dump_hi_diffs dflags) (printDump (text "INTERFACE UNCHANGED")) - dumpIfSet_dyn dflags Opt_D_dump_hi "UNCHANGED FINAL INTERFACE" (pprIface new_iface) - -write_diffs dflags new_iface (Just sdoc_diffs) - = do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs - dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface) -\end{code} - -\begin{code} -isOrphanModule :: ModGuts -> Bool -isOrphanModule (ModGuts {mg_module = this_mod, mg_insts = insts, mg_rules = rules}) - = any orphan_inst insts || any orphan_rule rules - where - -- A rule is an orphan if the LHS mentions nothing defined locally - orphan_inst dfun_id = no_locals (tyClsNamesOfDFunHead (idType dfun_id)) - -- A instance is an orphan if its head mentions nothing defined locally - orphan_rule rule = no_locals (ruleLhsFreeNames rule) - - no_locals names = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names) -\end{code} - -Implicit Ids and class tycons aren't included in interface files, so -we miss them out of the accumulating parameter here. - -\begin{code} -ifaceTyThing_acc :: Bool -> TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] --- Don't put implicit things into the result -ifaceTyThing_acc omit_pragmas (ADataCon dc) so_far = so_far -ifaceTyThing_acc omit_pragmas (AnId id) so_far | isImplicitId id = so_far -ifaceTyThing_acc omit_pragmas (ATyCon id) so_far | isClassTyCon id = so_far -ifaceTyThing_acc omit_pragmas other so_far - = ifaceTyThing omit_pragmas other : so_far -\end{code} - -Convert *any* TyThing into a RenamedTyClDecl. Used both for -generating interface files and for the ':info' command in GHCi. - -\begin{code} -ifaceTyThing :: Bool -> TyThing -> RenamedTyClDecl -ifaceTyThing omit_pragmas (AClass clas) = cls_decl - where - cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta, - tcdName = getName clas, - tcdTyVars = toHsTyVars clas_tyvars, - tcdFDs = toHsFDs clas_fds, - tcdSigs = map toClassOpSig op_stuff, - tcdMeths = Nothing, - tcdLoc = noSrcLoc } - - (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas - tycon = classTyCon clas - data_con = head (tyConDataCons tycon) - - toClassOpSig (sel_id, def_meth) - = ASSERT(sel_tyvars == clas_tyvars) - ClassOpSig (getName sel_id) def_meth (toHsType op_ty) noSrcLoc - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id) - op_ty = tcFunResultTy rho_ty - -ifaceTyThing omit_pragmas (ATyCon tycon) = ty_decl - where - ty_decl | isSynTyCon tycon - = TySynonym { tcdName = getName tycon, - tcdTyVars = toHsTyVars tyvars, - tcdSynRhs = toHsType syn_ty, - tcdLoc = noSrcLoc } - - | isAlgTyCon tycon - = TyData { tcdND = new_or_data, - tcdCtxt = toHsContext (tyConTheta tycon), - tcdName = getName tycon, - tcdTyVars = toHsTyVars tyvars, - tcdCons = ifaceConDecls (tyConDataConDetails tycon), - tcdDerivs = Nothing, - tcdGeneric = Just (isJust (tyConGenInfo tycon)), - -- Just True <=> has generic stuff - tcdLoc = noSrcLoc } - - | isForeignTyCon tycon - = ForeignType { tcdName = getName tycon, - tcdExtName = Nothing, - tcdFoType = DNType, -- The only case at present - tcdLoc = noSrcLoc } - - | isPrimTyCon tycon || isFunTyCon tycon - -- needed in GHCi for ':info Int#', for example - = TyData { tcdND = DataType, - tcdCtxt = [], - tcdName = getName tycon, - tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars), - tcdCons = Unknown, - tcdDerivs = Nothing, - tcdGeneric = Just False, - tcdLoc = noSrcLoc } - - | otherwise = pprPanic "ifaceTyThing" (ppr tycon) - - tyvars = tyConTyVars tycon - (_, syn_ty) = getSynTyConDefn tycon - new_or_data | isNewTyCon tycon = NewType - | otherwise = DataType - - ifaceConDecls Unknown = Unknown - ifaceConDecls (HasCons n) = HasCons n - ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) - - ifaceConDecl data_con - = ConDecl (dataConName data_con) - (toHsTyVars ex_tyvars) - (toHsContext ex_theta) - details noSrcLoc - where - (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con - field_labels = dataConFieldLabels data_con - strict_marks = dropList ex_theta (dataConStrictMarks data_con) - -- The 'drop' is because dataConStrictMarks - -- includes the existential dictionaries - details | null field_labels - = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) - PrefixCon (zipWith BangType strict_marks (map toHsType arg_tys)) - - | otherwise - = RecCon (zipWith mk_field strict_marks field_labels) - - mk_field strict_mark field_label - = (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label))) - -ifaceTyThing omit_pragmas (AnId id) = iface_sig - where - iface_sig = IfaceSig { tcdName = getName id, - tcdType = toHsType id_type, - tcdIdInfo = hs_idinfo, - tcdLoc = noSrcLoc } - - id_type = idType id - id_info = idInfo id - arity_info = arityInfo id_info - caf_info = idCafInfo id - - hs_idinfo | omit_pragmas - = [] - | otherwise - = catMaybes [arity_hsinfo, caf_hsinfo, - strict_hsinfo, wrkr_hsinfo, - unfold_hsinfo] - - ------------ Arity -------------- - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of - Just sig | not (isTopSig sig) -> Just (HsStrictness sig) - _other -> Nothing - - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = case work_info of { HasWorker _ _ -> True; other -> False } - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker (getName work_id) wrap_arity) - NoWorker -> Nothing - - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - inline_prag = inlinePragInfo id_info - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing - | otherwise = Just (HsUnfold inline_prag (toUfExpr rhs)) - - -ifaceTyThing omit_pragmas (ADataCon dc) - -- This case only happens in the call to ifaceThing in InteractiveUI - -- Otherwise DataCons are filtered out in ifaceThing_acc - = IfaceSig { tcdName = getName dc, - tcdType = toHsType full_ty, - tcdIdInfo = [], - tcdLoc = noSrcLoc } - where - (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc - - -- The "stupid context" isn't part of the wrapper-Id type - -- (for better or worse -- see note in DataCon.lhs), so we - -- have to make it up here - full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) - (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs))) -\end{code} - -\begin{code} -ifaceInstance :: DFunId -> RenamedInstDecl -ifaceInstance dfun_id - = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc - where - tidy_ty = tidyTopType (deNoteType (idType dfun_id)) - -- The deNoteType is very important. It removes all type - -- synonyms from the instance type in interface files. - -- That in turn makes sure that when reading in instance decls - -- from interface files that the 'gating' mechanism works properly. - -- Otherwise you could have - -- type Tibble = T Int - -- instance Foo Tibble where ... - -- and this instance decl wouldn't get imported into a module - -- that mentioned T but not Tibble. - -ifaceRule :: IdCoreRule -> RuleDecl Name -ifaceRule (id, BuiltinRule _ _) - = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) - -ifaceRule (id, Rule name act bndrs args rhs) - = IfaceRule name act (map toUfBndr bndrs) (getName id) - (map toUfExpr args) (toUfExpr rhs) noSrcLoc - -bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name -bogusIfaceRule id - = IfaceRule FSLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc -\end{code} - - -%********************************************************* -%* * -\subsection{Keeping track of what we've slurped, and version numbers} -%* * -%********************************************************* - -mkUsageInfo figures out what the ``usage information'' for this -moudule is; that is, what it must record in its interface file as the -things it uses. - -We produce a line for every module B below the module, A, currently being -compiled: - import B <n> ; -to record the fact that A does import B indirectly. This is used to decide -to look to look for B.hi rather than B.hi-boot when compiling a module that -imports A. This line says that A imports B, but uses nothing in it. -So we'll get an early bale-out when compiling A if B's version changes. - -The usage information records: - -\begin{itemize} -\item (a) anything reachable from its body code -\item (b) any module exported with a @module Foo@ -\item (c) anything reachable from an exported item -\end{itemize} - -Why (b)? Because if @Foo@ changes then this module's export list -will change, so we must recompile this module at least as far as -making a new interface file --- but in practice that means complete -recompilation. - -Why (c)? Consider this: -\begin{verbatim} - module A( f, g ) where | module B( f ) where - import B( f ) | f = h 3 - g = ... | h = ... -\end{verbatim} - -Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in -@A@'s usages? Our idea is that we aren't going to touch A.hi if it is -*identical* to what it was before. If anything about @B.f@ changes -than anyone who imports @A@ should be recompiled in case they use -@B.f@ (they'll get an early exit if they don't). So, if anything -about @B.f@ changes we'd better make sure that something in A.hi -changes, and the convenient way to do that is to record the version -number @B.f@ in A.hi in the usage list. If B.f changes that'll force a -complete recompiation of A, which is overkill but it's the only way to -write a new, slightly different, A.hi. - -But the example is tricker. Even if @B.f@ doesn't change at all, -@B.h@ may do so, and this change may not be reflected in @f@'s version -number. But with -O, a module that imports A must be recompiled if -@B.h@ changes! So A must record a dependency on @B.h@. So we treat -the occurrence of @B.f@ in the export list *just as if* it were in the -code of A, and thereby haul in all the stuff reachable from it. - - *** Conclusion: if A mentions B.f in its export list, - behave just as if A mentioned B.f in its source code, - and slurp in B.f and all its transitive closure *** - -[NB: If B was compiled with -O, but A isn't, we should really *still* -haul in all the unfoldings for B, in case the module that imports A *is* -compiled with -O. I think this is the case.] - -\begin{code} -mkUsageInfo :: HscEnv -> ExternalPackageState - -> ImportAvails -> EntityUsage - -> [Usage Name] - -mkUsageInfo hsc_env eps - (ImportAvails { imp_mods = dir_imp_mods, - imp_dep_mods = dep_mods }) - used_names - = -- seq the list of Usages returned: occasionally these - -- don't get evaluated for a while and we can end up hanging on to - -- the entire collection of Ifaces. - usages `seqList` usages - where - usages = catMaybes [ mkUsage mod_name - | (mod_name,_) <- moduleEnvElts dep_mods] - -- ToDo: do we need to sort into canonical order? - - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - - import_all mod = case lookupModuleEnv dir_imp_mods mod of - Just (_, Nothing) -> True - _ -> False - - -- ent_map groups together all the things imported and used - -- from a particular module in this package - ent_map :: ModuleEnv [Name] - ent_map = foldNameSet add_mv emptyModuleEnv used_names - add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name] - where - mod = nameModule name - add_item names _ = name:names - - -- We want to create a Usage for a home module if - -- a) we used something from; has something in used_names - -- b) we imported all of it, even if we used nothing from it - -- (need to recompile if its export list changes: export_vers) - -- c) is a home-package orphan module (need to recompile if its - -- instance decls change: rules_vers) - mkUsage :: ModuleName -> Maybe (Usage Name) - mkUsage mod_name - | isNothing maybe_iface -- We can't depend on it if we didn't - || not (isHomeModule mod) -- even open the interface! - || (null used_names - && not all_imported - && not orphan_mod) - = Nothing -- Record no usage info - - | otherwise - = Just (Usage { usg_name = moduleName mod, - usg_mod = mod_vers, - usg_exports = export_vers, - usg_entities = ent_vers, - usg_rules = rules_vers }) - where - maybe_iface = lookupIfaceByModName hpt pit mod_name - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - Just iface = maybe_iface - mod = mi_module iface - version_info = mi_version iface - orphan_mod = mi_orphan iface - version_env = vers_decls version_info - mod_vers = vers_module version_info - rules_vers = vers_rules version_info - all_imported = import_all mod - export_vers | all_imported = Just (vers_exports version_info) - | otherwise = Nothing - - -- The sort is to put them into canonical order - used_names = lookupModuleEnv ent_map mod `orElse` [] - ent_vers = [(n, lookupVersion version_env n) - | n <- sortLt lt_occ used_names ] - lt_occ n1 n2 = nameOccName n1 < nameOccName n2 - -- ToDo: is '<' on OccNames the right thing; may differ between runs? -\end{code} - -\begin{code} -groupAvails :: Module -> Avails -> [(ModuleName, Avails)] - -- Group by module and sort by occurrence - -- This keeps the list in canonical order -groupAvails this_mod avails - = [ (mkSysModuleNameFS fs, sortLt lt avails) - | (fs,avails) <- fmToList groupFM - ] - where - groupFM :: FiniteMap FastString Avails - -- Deliberately use the FastString so we - -- get a canonical ordering - groupFM = foldl add emptyFM avails - - add env avail = addToFM_C combine env mod_fs [avail'] - where - mod_fs = moduleNameFS (moduleName avail_mod) - avail_mod = case nameModule_maybe (availName avail) of - Just m -> m - Nothing -> this_mod - combine old _ = avail':old - avail' = sortAvail avail - - a1 `lt` a2 = occ1 < occ2 - where - occ1 = nameOccName (availName a1) - occ2 = nameOccName (availName a2) - -sortAvail :: AvailInfo -> AvailInfo --- Sort the sub-names into canonical order. --- The canonical order has the "main name" at the beginning --- (if it's there at all) -sortAvail (Avail n) = Avail n -sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns)) - | otherwise = AvailTC n ( sortLt lt ns) - where - n1 `lt` n2 = nameOccName n1 < nameOccName n2 -\end{code} - -%************************************************************************ -%* * -\subsection{Checking if the new interface is up to date -%* * -%************************************************************************ - -\begin{code} -addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi - -> ModIface -- The new interface decls - -> (ModIface, Maybe SDoc) -- Nothing => no change; no need to write new Iface - -- Just mi => Here is the new interface to write - -- with correct version numbers - --- NB: the fixities, declarations, rules are all assumed --- to be sorted by increasing order of hsDeclName, so that --- we can compare for equality - -addVersionInfo Nothing new_iface --- No old interface, so definitely write a new one! - = (new_iface, Just (text "No old interface available")) - -addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, - mi_decls = old_decls, - mi_fixities = old_fixities, - mi_deprecs = old_deprecs })) - new_iface@(ModIface { mi_decls = new_decls, - mi_fixities = new_fixities, - mi_deprecs = new_deprecs }) - - | no_output_change && no_usage_change - = (new_iface, Nothing) - -- don't return the old iface because it may not have an - -- mi_globals field set to anything reasonable. - - | otherwise -- Add updated version numbers - = --pprTrace "completeIface" (ppr (dcl_tycl old_decls)) - (final_iface, Just pp_diffs) - - where - final_iface = new_iface { mi_version = new_version } - old_mod_vers = vers_module old_version - new_version = VersionInfo { vers_module = bumpVersion no_output_change old_mod_vers, - vers_exports = bumpVersion no_export_change (vers_exports old_version), - vers_rules = bumpVersion no_rule_change (vers_rules old_version), - vers_decls = tc_vers } - - no_output_change = no_tc_change && no_rule_change && no_export_change && no_deprec_change - no_usage_change = mi_usages old_iface == mi_usages new_iface - - no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted - no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto - && dcl_insts old_decls == dcl_insts new_decls - no_deprec_change = old_deprecs == new_deprecs - - -- Fill in the version number on the new declarations by looking at the old declarations. - -- Set the flag if anything changes. - -- Assumes that the decls are sorted by hsDeclName. - (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_version old_fixities new_fixities - (dcl_tycl old_decls) (dcl_tycl new_decls) - pp_diffs = vcat [pp_tc_diffs, - pp_change no_export_change "Export list", - pp_change no_rule_change "Rules", - pp_change no_deprec_change "Deprecations", - pp_change no_usage_change "Usages"] - pp_change True what = empty - pp_change False what = text what <+> ptext SLIT("changed") - -diffDecls :: VersionInfo -- Old version - -> FixityEnv -> FixityEnv -- Old and new fixities - -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls - -> (Bool, -- True <=> no change - SDoc, -- Record of differences - NameEnv Version) -- New version map - -diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers }) - old_fixities new_fixities old new - = diff True empty emptyNameEnv old new - where - -- When seeing if two decls are the same, - -- remember to check whether any relevant fixity has changed - eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1) - same_fixity n = lookupFixity old_fixities n == lookupFixity new_fixities n - - diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers) - diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods [] - diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers_with_new [] nds - where - new_vers_with_new = extendNameEnv new_vers (tyClDeclName nd) (bumpVersion False old_mod_vers) - -- When adding a new item, start from the old module version - -- This way, if you have version 4 of f, then delete f, then add f again, - -- you'll get version 6 of f, which will (correctly) force recompilation of - -- clients - - diff ok_so_far pp new_vers (od:ods) (nd:nds) - = case od_name `compare` nd_name of - LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds) - GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds - EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds - | otherwise -> diff False (pp $$ changed od nd) new_vers_with_diff ods nds - where - od_name = tyClDeclName od - nd_name = tyClDeclName nd - new_vers_with_diff = extendNameEnv new_vers nd_name (bumpVersion False old_version) - old_version = lookupVersion old_decls_vers od_name - - only_old d = ptext SLIT("Only in old iface:") <+> ppr d - only_new d = ptext SLIT("Only in new iface:") <+> ppr d - changed od nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr od) $$ - (ptext SLIT("New:") <+> ppr nd)) -\end{code} - - -b%************************************************************************ -%* * -\subsection{Writing an interface file} -%* * -%************************************************************************ - -\begin{code} -pprIface :: ModIface -> SDoc -pprIface iface - = vcat [ ptext SLIT("__interface") - <+> doubleQuotes (ftext (mi_package iface)) - <+> ppr (mi_module iface) <+> ppr (vers_module version_info) - <+> pp_sub_vers - <+> (if mi_orphan iface then char '!' else empty) - <+> int opt_HiVersion - <+> ptext SLIT("where") - - , pprExports nameOccName (mi_exports iface) - , pprDeps (mi_deps iface) - , pprUsages nameOccName (mi_usages iface) - - , pprFixities (mi_fixities iface) (dcl_tycl decls) - , pprIfaceDecls (vers_decls version_info) decls - , pprRulesAndDeprecs (dcl_rules decls) (mi_deprecs iface) - ] - where - version_info = mi_version iface - decls = mi_decls iface - exp_vers = vers_exports version_info - - rule_vers = vers_rules version_info - - pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty - | otherwise = brackets (ppr exp_vers <+> ppr rule_vers) -\end{code} - -When printing export lists, we print like this: - Avail f f - AvailTC C [C, x, y] C(x,y) - AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C - -\begin{code} -pprExports :: Eq a => (a -> OccName) -> [(ModuleName, [GenAvailInfo a])] -> SDoc -pprExports getOcc exports = vcat (map (pprExport getOcc) exports) - -pprExport :: Eq a => (a -> OccName) -> (ModuleName, [GenAvailInfo a]) -> SDoc -pprExport getOcc (mod, items) - = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi - where - --pp_avail :: GenAvailInfo a -> SDoc - pp_avail (Avail name) = ppr (getOcc name) - pp_avail (AvailTC _ []) = empty - pp_avail (AvailTC n (n':ns)) - | n==n' = ppr (getOcc n) <> pp_export ns - | otherwise = ppr (getOcc n) <> char '|' <> pp_export (n':ns) - - pp_export [] = empty - pp_export names = braces (hsep (map (ppr.getOcc) names)) - -pprOcc :: Name -> SDoc -- Print the occurrence name only -pprOcc n = pprOccName (nameOccName n) -\end{code} - - -\begin{code} -pprUsages :: (a -> OccName) -> [Usage a] -> SDoc -pprUsages getOcc usages = vcat (map (pprUsage getOcc) usages) - -pprUsage :: (a -> OccName) -> Usage a -> SDoc -pprUsage getOcc usage - = hsep [ptext SLIT("import"), ppr (usg_name usage), - int (usg_mod usage), - pp_export_version (usg_exports usage), - int (usg_rules usage), - pp_versions (usg_entities usage) - ] <> semi - where - pp_versions nvs = hsep [ ppr (getOcc n) <+> int v | (n,v) <- nvs ] - - pp_export_version Nothing = empty - pp_export_version (Just v) = int v - - -pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) - = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), - ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), - ptext SLIT("orphans:") <+> fsep (map ppr orphs) - ] - where - ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot - - ppr_boot True = text "[boot]" - ppr_boot False = empty -\end{code} - -\begin{code} -pprIfaceDecls :: NameEnv Int -> IfaceDecls -> SDoc -pprIfaceDecls version_map decls - = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls] - , vcat (map ppr_decl (dcl_tycl decls)) - ] - where - ppr_decl d = ppr_vers d <+> ppr d <> semi - - -- Print the version for the decl - ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of - Nothing -> empty - Just v -> int v -\end{code} - -\begin{code} -pprFixities :: FixityEnv - -> [TyClDecl Name] - -> SDoc -pprFixities fixity_map decls - = hsep [ ppr fix <+> ppr n - | FixitySig n fix _ <- collectFixities fixity_map decls ] <> semi - --- Disgusting to print these two together, but that's --- the way the interface parser currently expects them. -pprRulesAndDeprecs :: (Outputable a) => [a] -> Deprecations -> SDoc -pprRulesAndDeprecs [] NoDeprecs = empty -pprRulesAndDeprecs rules deprecs - = ptext SLIT("{-##") <+> (pp_rules rules $$ pp_deprecs deprecs) <+> ptext SLIT("##-}") - where - pp_rules [] = empty - pp_rules rules = ptext SLIT("__R") <+> vcat (map ppr rules) - - pp_deprecs NoDeprecs = empty - pp_deprecs deprecs = ptext SLIT("__D") <+> guts - where - guts = case deprecs of - DeprecAll txt -> doubleQuotes (ftext txt) - DeprecSome env -> ppr_deprec_env env - -ppr_deprec_env :: NameEnv (Name, FastString) -> SDoc -ppr_deprec_env env = vcat (punctuate semi (map pp_deprec (nameEnvElts env))) - where - pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ftext txt) -\end{code} diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index cfecbca2a6..abbbcea1eb 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -98,8 +98,8 @@ loadPackageConfig conf_filename = do buf <- hGetStringBuffer conf_filename let loc = mkSrcLoc (mkFastString conf_filename) 1 0 case unP parse (mkPState buf loc defaultDynFlags) of - PFailed l1 l2 err -> do - throwDyn (InstallationError (showPFailed l1 l2 err)) + PFailed l1 l2 err -> + throwDyn (InstallationError (showSDoc (showPFailed l1 l2 err))) POk _ pkg_details -> do return pkg_details diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 61b5b8ecc4..aaedea479b 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,7 +8,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) +import CmdLineOpts ( DynFlag(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) @@ -26,16 +26,15 @@ import Id ( idType, idInfo, idName, idCoreRules, import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( Arity, isNeverActive ) -import Name ( getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc +import Name ( Name, getOccName, nameOccName, mkInternalName, + localiseName, isExternalName, nameSrcLoc, nameParent_maybe ) -import RnEnv ( lookupOrigNameCache, newExternalName ) +import IfaceEnv ( allocateGlobalBinder ) import NameEnv ( lookupNameEnv, filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType ) import Module ( Module ) -import HscTypes ( PersistentCompilerState( pcs_nc ), - NameCache( nsNames, nsUniqs ), +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), TypeEnv, extendTypeEnvList, typeEnvIds, ModGuts(..), ModGuts, TyThing(..) ) @@ -44,9 +43,9 @@ import ErrUtils ( showPass, dumpIfSet_core ) import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) -import Util ( mapAccumL ) import Maybe ( isJust ) import Outputable +import DATA_IOREF ( IORef, readIORef, writeIORef ) import FastTypes hiding ( fastOr ) \end{code} @@ -86,7 +85,7 @@ binder [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.] - We use the NameCache kept in the PersistentCompilerState as the + We use the NameCache kept in the HscEnv as the source of such system-wide uniques. For external Ids, use the original-name cache in the NameCache @@ -118,16 +117,15 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -tidyCorePgm :: DynFlags - -> PersistentCompilerState - -> ModGuts - -> IO (PersistentCompilerState, ModGuts) +tidyCorePgm :: HscEnv -> ModGuts -> IO ModGuts -tidyCorePgm dflags pcs +tidyCorePgm hsc_env mod_impl@(ModGuts { mg_module = mod, mg_types = env_tc, mg_insts = insts_tc, mg_binds = binds_in, mg_rules = orphans_in }) - = do { showPass dflags "Tidy Core" + = do { let { dflags = hsc_dflags hsc_env + ; nc_var = hsc_NC hsc_env } + ; showPass dflags "Tidy Core" ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_in @@ -146,9 +144,8 @@ tidyCorePgm dflags pcs -- The second exported decl must 'get' the name 'f', so we -- have to put 'f' in the avoids list before we get to the first -- decl. tidyTopId then does a no-op on exported binders. - ; let orig_ns = pcs_nc pcs - init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName name | bndr <- typeEnvIds env_tc, + ; let init_env = (initTidyOccEnv avoids, emptyVarEnv) + avoids = [getOccName name | bndr <- typeEnvIds env_tc, let name = idName bndr, isExternalName name] -- In computing our "avoids" list, we must include @@ -158,13 +155,10 @@ tidyCorePgm dflags pcs -- since their names are "taken". -- The type environment is a convenient source of such things. - ; let ((orig_ns', occ_env, subst_env), tidy_binds) - = mapAccumL (tidyTopBind mod ext_ids) - init_tidy_env binds_in + ; (final_env, tidy_binds) + <- tidyTopBinds mod nc_var ext_ids init_env binds_in - ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules - - ; let pcs' = pcs { pcs_nc = orig_ns' } + ; let tidy_rules = tidyIdRules final_env ext_rules ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds @@ -173,7 +167,8 @@ tidyCorePgm dflags pcs -- to lookup the id in the TypeEnv too, because -- those Ids have had their IdInfo stripped if -- necessary. - ; let lookup_dfun_id id = + ; let (_, subst_env ) = final_env + lookup_dfun_id id = case lookupVarEnv subst_env id of Nothing -> dfun_panic Just id -> @@ -195,7 +190,7 @@ tidyCorePgm dflags pcs "Tidy Core Rules" (pprIdRules tidy_rules) - ; return (pcs', tidy_result) + ; return tidy_result } tidyCoreExpr :: CoreExpr -> IO CoreExpr @@ -220,7 +215,7 @@ mkFinalTypeEnv :: Bool -- Omit interface pragmas -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings --- From (c) we keep only those Ids with Global names; +-- From (c) we keep only those Ids with External names; -- the CoreTidy pass makes sure these are all and only -- the externally-accessible ones -- This truncates the type environment to include only the @@ -397,10 +392,8 @@ addExternal omit_iface_prags (id,rhs) needed \begin{code} -type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) - -- TopTidyEnv: when tidying we need to know --- * ns: The NameCache, containing a unique supply and any pre-ordained Names. +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. -- These may have arisen because the -- renamer read in an interface file mentioning M.$wf, say, -- and assigned it unique r77. If, on this compilation, we've @@ -412,91 +405,151 @@ type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -\end{code} +tidyTopBinds :: Module + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too + -> TidyEnv -> [CoreBind] + -> IO (TidyEnv, [CoreBind]) +tidyTopBinds mod nc_var ext_ids tidy_env [] + = return (tidy_env, []) -\begin{code} +tidyTopBinds mod nc_var ext_ids tidy_env (b:bs) + = do { (tidy_env1, b') <- tidyTopBind mod nc_var ext_ids tidy_env b + ; (tidy_env2, bs') <- tidyTopBinds mod nc_var ext_ids tidy_env1 bs + ; return (tidy_env2, b':bs') } + +------------------------ tidyTopBind :: Module - -> IdEnv Bool -- Domain = Ids that should be external + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> TopTidyEnv -> CoreBind - -> (TopTidyEnv, CoreBind) - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs) - = ((orig,occ,subst) , NonRec bndr' rhs') + -> TidyEnv -> CoreBind + -> IO (TidyEnv, CoreBind) + +tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) + = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr + ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs) + ; subst2 = extendVarEnv subst1 bndr bndr' + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, NonRec bndr' rhs') } where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - rec_tidy_env = (occ,subst) - rhs' = tidyExpr rec_tidy_env rhs - caf_info = hasCafRefs subst1 (idArity bndr') rhs' - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs) - = (final_env, Rec prs') + caf_info = hasCafRefs subst1 (idArity bndr) rhs + +tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) + = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs + ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info) + names' prs + ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, Rec prs') } where - (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs - rec_tidy_env = (occ,subst) - - do_one top_tidy_env (bndr,rhs) - = ((orig,occ,subst), (bndr',rhs')) - where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - - rhs' = tidyExpr rec_tidy_env rhs + bndrs = map fst prs -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info | or [ mayHaveCafRefs (hasCafRefs subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - -tidyTopBinder :: Module -> IdEnv Bool -> CafInfo - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -> CoreExpr -- RHS *before* tidying - -> CoreExpr -- RHS *after* tidying - -- The TidyEnv and the after-tidying RHS are - -- both are knot-tied: don't look at them! - -> TopTidyEnv -> Id -> (TopTidyEnv, Id) - -- NB: tidyTopBinder doesn't affect the unique supply - -tidyTopBinder mod ext_ids caf_info rec_tidy_env rhs tidy_rhs - env@(ns2, occ_env2, subst_env2) id + | otherwise = NoCafRefs + +-------------------------------------------------------------------- +-- tidyTopName +-- This is where we set names to local/global based on whether they really are +-- externally visible (see comment at the top of this module). If the name +-- was previously local, we have to give it a unique occurrence name if +-- we intend to externalise it. +tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, []) +tidyTopNames mod nc_var ext_ids occ_env (id:ids) + = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id + ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids + ; return (occ_env2, name:names) } + +tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var ext_ids occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { nc <- readIORef nc_var + ; let (nc', new_local_name) = mk_new_local nc + ; writeIORef nc_var nc' + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { nc <- readIORef nc_var + ; let (nc', new_external_name) = mk_new_external nc + ; writeIORef nc_var nc' + ; return (occ_env', new_external_name) } + where + name = idName id + external = id `elemVarEnv` ext_ids + global = isExternalName name + local = not global + internal = not external + mb_parent = nameParent_maybe name + loc = nameSrcLoc name + + (occ_env', occ') = tidyOccName occ_env (nameOccName name) + + mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc) + where + (us1, us2) = splitUniqSupply (nsUniqs nc) + uniq = uniqFromSupply us1 + + mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we want to + -- use the same name for externally-visible things as we did before. + + +----------------------------------------------------------- +tidyTopPair :: VarEnv Bool + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) -- This function is the heart of Step 2 -- The rec_tidy_env is the one to use for the IdInfo -- It's necessary because when we are dealing with a recursive -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group - -- The rhs is already tidied - - = ASSERT(isLocalId id) -- "all Ids defined in this module are local - -- until the CoreTidy phase" --GHC comentary - ((orig_env', occ_env', subst_env'), id') +tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) + = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local + -- until the CoreTidy phase" --GHC comentary + (bndr', rhs') where - (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2 - is_external - (idName id) - ty' = tidyTopType (idType id) - idinfo = tidyTopIdInfo rec_tidy_env is_external - (idInfo id) unfold_info arity - caf_info - - id' = mkVanillaGlobal name' ty' idinfo - - subst_env' = extendVarEnv subst_env2 id id' - - maybe_external = lookupVarEnv ext_ids id - is_external = isJust maybe_external + bndr' = mkVanillaGlobal name' ty' idinfo' + ty' = tidyTopType (idType bndr) + rhs' = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external) + (idInfo bndr) unfold_info arity + caf_info -- Expose an unfolding if ext_ids tells us to -- Remember that ext_ids maps an Id to a Bool: -- True to show the unfolding, False to hide it + maybe_external = lookupVarEnv ext_ids bndr show_unfold = maybe_external `orElse` False - unfold_info | show_unfold = mkTopUnfolding tidy_rhs + unfold_info | show_unfold = mkTopUnfolding rhs' | otherwise = noUnfolding -- Usually the Id will have an accurate arity on it, because @@ -542,50 +595,6 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info -- They have already been extracted by findExternalRules --- This is where we set names to local/global based on whether they really are --- externally visible (see comment at the top of this module). If the name --- was previously local, we have to give it a unique occurrence name if --- we intend to externalise it. -tidyTopName mod ns occ_env external name - | global && internal = (ns, occ_env, localiseName name) - - | global && external = (ns, occ_env, name) - -- Global names are assumed to have been allocated by the renamer, - -- so they already have the "right" unique - -- And it's a system-wide unique too - - | local && internal = (ns_w_local, occ_env', new_local_name) - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table - - | local && external = case lookupOrigNameCache ns_names mod occ' of - Just orig -> (ns, occ_env', orig) - Nothing -> (ns_w_global, occ_env', new_external_name) - -- If we want to externalise a currently-local name, check - -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table (ns_w_global). - -- This is needed when *re*-compiling a module in GHCi; we want to - -- use the same name for externally-visible things as we did before. - - where - global = isExternalName name - local = not global - internal = not external - loc = nameSrcLoc name - - (occ_env', occ') = tidyOccName occ_env (nameOccName name) - - ns_names = nsNames ns - (us1, us2) = splitUniqSupply (nsUniqs ns) - uniq = uniqFromSupply us1 - new_local_name = mkInternalName uniq occ' loc - ns_w_local = ns { nsUniqs = us2 } - - (ns_w_global, new_external_name) = newExternalName ns mod occ' loc - ------------ Worker -------------- tidyWorker tidy_env (HasWorker work_id wrap_arity) diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index e58821036a..63379cba32 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -65,7 +65,7 @@ import FastString import GLAEXTS import TRACE ( trace ) -import Maybe ( catMaybes ) +import Maybes ( mapCatMaybes ) \end{code} \begin{code} @@ -116,7 +116,7 @@ save_cands = [BaseReg,Sp,SpLim,Hp,HpLim] restore_cands = save_cands volatileSavesOrRestores do_saves vols - = catMaybes (map mkCode vols) + = mapCatMaybes mkCode vols where mkCode mid | case mid of { BaseReg -> True; _ -> False } diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 8c3dafbbe8..be32d651a1 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -12,7 +12,6 @@ import {-# SOURCE #-} StixPrim ( amodeToStix ) import MachRegs import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) -import SMRep ( fixedHdrSize ) import Constants ( uF_RET, uF_UPDATEE, uF_SIZE ) import ForeignCall ( CCallConv(..) ) import MachOp ( MachOp(..) ) @@ -21,7 +20,6 @@ import Stix import Panic ( panic ) import UniqSupply ( returnUs, thenUs, UniqSM ) import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, - mkBlackHoleBQInfoTableLabel, mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel ) \end{code} -------------------------------------------------------------------------------- @@ -145,12 +143,10 @@ Let's make sure that these CAFs are lifted out, shall we? \begin{code} -- Some common labels -bh_info, ind_static_info, ind_info :: StixExpr +bh_info, ind_static_info :: StixExpr bh_info = StCLbl mkBlackHoleInfoTableLabel -bq_info = StCLbl mkBlackHoleBQInfoTableLabel ind_static_info = StCLbl mkIndStaticInfoLabel -ind_info = StCLbl mkIndInfoLabel upd_frame_info = StCLbl mkUpdInfoLabel -- Some common call trees diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index d1edcc022c..ed6d9da074 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -19,10 +19,9 @@ import Literal ( Literal(..), word2IntLit ) import MachOp ( MachOp(..) ) import PrimRep ( PrimRep(..), getPrimRepSizeInBytes ) import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) -import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, +import Constants ( mIN_INTLIKE, mIN_CHARLIKE, bLOCK_SIZE, rESERVED_STACK_WORDS ) import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel, - mkMAP_FROZEN_infoLabel, mkForeignLabel ) import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), CCallConv(..), playSafe, playThreadSafe ) @@ -230,8 +229,6 @@ iNTLIKE_closure = StCLbl mkIntlikeClosureLabel cHARLIKE_closure :: StixExpr cHARLIKE_closure = StCLbl mkCharlikeClosureLabel -mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel - -- these are the sizes of charLike and intLike closures, in _bytes_. charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep) intLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep) diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs index b8a2114ac0..4bca818dd3 100644 --- a/ghc/compiler/ndpFlatten/FlattenMonad.hs +++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs @@ -74,18 +74,16 @@ import Name (Name) import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems ) import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv, elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList) -import TyCon (tyConName) import Type (Type, tyConAppTyCon) -import HscTypes (HomePackageTable, PersistentCompilerState(pcs_EPS), +import HscTypes (HomePackageTable, ExternalPackageState(eps_PTE), HscEnv(hsc_HPT), TyThing(..), lookupType) -import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName, - doublePrimTyConName, fstName, andName, orName, +import PrelNames ( fstName, andName, orName, lengthPName, replicatePName, mapPName, bpermutePName, bpermuteDftPName, indexOfPName) -import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName, - neqIntName) - -- neqCharName, neqFloatName,neqDoubleName, +import TysPrim ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) +import PrimOp ( PrimOp(..) ) +import PrelInfo ( primOpId ) import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps) import CoreUtils (exprType) @@ -130,11 +128,11 @@ data FlattenState = FlattenState { -- initial value of the flattening state -- -initialFlattenState :: PersistentCompilerState +initialFlattenState :: ExternalPackageState -> HomePackageTable -> UniqSupply -> FlattenState -initialFlattenState pcs hpt us = +initialFlattenState eps hpt us = FlattenState { us = us, env = lookup, @@ -144,7 +142,7 @@ initialFlattenState pcs hpt us = } where lookup n = - case lookupType hpt (eps_PTE (pcs_EPS pcs)) n of + case lookupType hpt (eps_PTE eps) n of Just (AnId v) -> v _ -> pprPanic "FlattenMonad: unknown name:" (ppr n) @@ -164,12 +162,12 @@ instance Monad Flatten where -- execute the given flattening computation (EXPORTED) -- runFlatten :: HscEnv - -> PersistentCompilerState + -> ExternalPackageState -> UniqSupply -> Flatten a -> a -runFlatten hsc_env pcs us m - = fst $ unFlatten m (initialFlattenState pcs (hsc_HPT hsc_env) us) +runFlatten hsc_env eps us m + = fst $ unFlatten m (initialFlattenState eps (hsc_HPT hsc_env) us) -- variable generation @@ -364,14 +362,14 @@ mk'or a1 a2 = mkFunApp orName [a1, a2] -- `Double') (EXPORTED) -- mk'eq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr -mk'eq ty a1 a2 = mkFunApp eqName [a1, a2] +mk'eq ty a1 a2 = return (mkApps (Var eqName) [a1, a2]) where - name = tyConName . tyConAppTyCon $ ty + tc = tyConAppTyCon ty -- - eqName | name == charPrimTyConName = eqCharName - | name == intPrimTyConName = eqIntName - | name == floatPrimTyConName = eqFloatName - | name == doublePrimTyConName = eqDoubleName + eqName | tc == charPrimTyCon = primOpId CharEqOp + | tc == intPrimTyCon = primOpId IntEqOp + | tc == floatPrimTyCon = primOpId FloatEqOp + | tc == doublePrimTyCon = primOpId DoubleEqOp | otherwise = pprPanic "FlattenMonad.mk'eq: " (ppr ty) @@ -380,12 +378,12 @@ mk'eq ty a1 a2 = mkFunApp eqName [a1, a2] -- `Double') (EXPORTED) -- mk'neq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr -mk'neq ty a1 a2 = mkFunApp neqName [a1, a2] +mk'neq ty a1 a2 = return (mkApps (Var neqName) [a1, a2]) where - name = tyConName . tyConAppTyCon $ ty + tc = tyConAppTyCon ty -- neqName {- | name == charPrimTyConName = neqCharName -} - | name == intPrimTyConName = neqIntName + | tc == intPrimTyCon = primOpId IntNeOp {- | name == floatPrimTyConName = neqFloatName -} {- | name == doublePrimTyConName = neqDoubleName -} | otherwise = diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index 4f0f86b53a..14b68d190d 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -73,8 +73,7 @@ import Var (Var(..)) import DataCon (DataCon, dataConTag) import TypeRep (Type(..)) import Type (isTypeKind) -import HscTypes (PersistentCompilerState, ModGuts(..), - ModGuts, HscEnv(..) ) +import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), hscEPS ) import CoreFVs (exprFreeVars) import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..), CoreBndr, CoreExpr, CoreBind, mkLams, mkLets, @@ -103,15 +102,15 @@ import Monad (liftM, foldM) -- compiling a complete module (EXPORTED) -- flatten :: HscEnv - -> PersistentCompilerState -> ModGuts -> IO ModGuts -flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds}) +flatten hsc_env mod_impl@(ModGuts {mg_binds = binds}) | not opt_Flatten = return mod_impl -- skip without -fflatten | otherwise = do let dflags = hsc_dflags hsc_env + eps <- hscEPS hsc_env us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening -- -- announce vectorisation @@ -120,7 +119,7 @@ flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds}) -- -- vectorise all toplevel bindings -- - let binds' = runFlatten hsc_env pcs us $ vectoriseTopLevelBinds binds + let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds -- -- and dump the result if requested -- @@ -132,14 +131,14 @@ flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds}) -- compiling a single expression in interactive mode (EXPORTED) -- flattenExpr :: HscEnv - -> PersistentCompilerState -> CoreExpr -- the expression to be flattened -> IO CoreExpr -flattenExpr hsc_env pcs expr +flattenExpr hsc_env expr | not opt_Flatten = return expr -- skip without -fflatten | otherwise = do let dflags = hsc_dflags hsc_env + eps <- hscEPS hsc_env us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening -- @@ -149,7 +148,7 @@ flattenExpr hsc_env pcs expr -- -- vectorise the expression -- - let expr' = fst . runFlatten hsc_env pcs us $ vectorise expr + let expr' = fst . runFlatten hsc_env eps us $ vectorise expr -- -- and dump the result if requested -- diff --git a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs index 1d221baae1..1bf74b4866 100644 --- a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs +++ b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs @@ -51,14 +51,13 @@ module NDPCoreUtils ( import Panic (panic) import Outputable (Outputable(ppr), pprPanic) import BasicTypes (Boxity(..)) -import Var (Var) import Type (Type, splitTyConApp_maybe, splitFunTy) -import TyCon (TyCon(..), isTupleTyCon) -import PrelNames (parrTyConName) +import TyCon (isTupleTyCon) import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy, boolTy) -import CoreSyn (CoreBndr, CoreExpr, CoreBind, CoreAlt, Expr(..), AltCon(..), +import CoreSyn (CoreExpr, CoreAlt, Expr(..), AltCon(..), Bind(..), mkConApp) +import PprCore ( {- instances -} ) import Var (Id) import VarEnv (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv) @@ -90,7 +89,7 @@ funTyArgs = splitFunTy parrElemTy :: Type -> Type parrElemTy ty = case splitTyConApp_maybe ty of - Just (tyCon, [argTy]) | tyConName tyCon == parrTyConName -> argTy + Just (tyCon, [argTy]) | tyCon == parrTyCon -> argTy _ -> pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty) diff --git a/ghc/compiler/ndpFlatten/PArrAnal.hs b/ghc/compiler/ndpFlatten/PArrAnal.hs index 0c25805d2c..46643d1a05 100644 --- a/ghc/compiler/ndpFlatten/PArrAnal.hs +++ b/ghc/compiler/ndpFlatten/PArrAnal.hs @@ -42,6 +42,7 @@ import TypeRep (Type(..)) import Var (Var(..),Id) import Literal (Literal) import CoreSyn (Expr(..),CoreExpr,Bind(..)) +import PprCore ( {- instances -} ) -- data ArrayUsage = Prim | NonPrim | Array @@ -135,8 +136,8 @@ typeArrayUsage (TyConApp tc tcargs) = tcargsAU = map typeArrayUsage tcargs tcCombine = foldr combineArrayUsage Prim tcargsAU in auCon tcCombine -typeArrayUsage t@(SourceTy _) = - pprPanic "PArrAnal.typeArrayUsage: encountered 'SourceType - shouldn't be here!" +typeArrayUsage t@(PredTy _) = + pprPanic "PArrAnal.typeArrayUsage: encountered 'PredType - shouldn't be here!" (ppr t) diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index 997a7d7d88..52fc03e7c0 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -1084,8 +1084,7 @@ data ParseResult a -- show this span, e.g. by highlighting it. Message -- The error message -showPFailed loc1 loc2 err - = showSDoc (hcat [ppr loc1, text ": ", err]) +showPFailed loc1 loc2 err = hcat [ppr loc1, text ": ", err] data PState = PState { buffer :: StringBuffer, diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 7976b1b25f..925be4e7e1 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.125 2003/09/24 13:04:51 simonmar Exp $ +$Id: Parser.y,v 1.126 2003/10/09 11:59:02 simonpj Exp $ Haskell grammar. @@ -14,29 +14,24 @@ module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where #include "HsVersions.h" import HsSyn -import HsTypes ( mkHsTupCon ) - import RdrHsSyn -import HscTypes ( ParsedIface(..), IsBootInterface, noDependencies ) +import HscTypes ( ModIface, IsBootInterface, DeprecTxt ) import Lexer import RdrName -import PrelNames ( mAIN_Name, funTyConName, listTyConName, - parrTyConName, consDataConName ) -import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, - tupleCon, nilDataCon ) +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, + listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) +import Type ( funTyCon ) import ForeignCall ( Safety(..), CExportSpec(..), - CCallConv(..), CCallTarget(..), defaultCCallConv, + CCallConv(..), CCallTarget(..), defaultCCallConv ) -import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName ) -import TyCon ( DataConDetails(..) ) +import OccName ( UserFS, varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import Module -import CmdLineOpts ( opt_SccProfilingOn, opt_InPackage ) +import CmdLineOpts ( opt_SccProfilingOn ) import Type ( Kind, mkArrowKind, liftedTypeKind ) -import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), - IPName(..), NewOrData(..), StrictnessMark(..), - Activation(..), FixitySig(..) ) +import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), + NewOrData(..), Activation(..) ) import Panic import GLAEXTS @@ -266,37 +261,32 @@ cvtopdecls :: { [RdrNameHsDecl] } ----------------------------------------------------------------------------- -- Interfaces (.hi-boot files) -iface :: { ParsedIface } - : 'module' modid 'where' ifacebody - { ParsedIface { - pi_mod = $2, - pi_pkg = opt_InPackage, - pi_vers = 1, -- Module version - pi_orphan = False, - pi_exports = (1,[($2,mkIfaceExports $4)]), - pi_deps = noDependencies, - pi_usages = [], - pi_fixity = [], - pi_insts = [], - pi_decls = map (\x -> (1,x)) $4, - pi_rules = (1,[]), - pi_deprecs = Nothing - } - } - -ifacebody :: { [RdrNameTyClDecl] } +iface :: { ModIface } + : 'module' modid 'where' ifacebody { mkBootIface $2 $4 } + +ifacebody :: { [HsDecl RdrName] } : '{' ifacedecls '}' { $2 } | vocurly ifacedecls close { $2 } -ifacedecls :: { [RdrNameTyClDecl] } +ifacedecls :: { [HsDecl RdrName] } : ifacedecl ';' ifacedecls { $1 : $3 } | ';' ifacedecls { $2 } | ifacedecl { [$1] } | {- empty -} { [] } -ifacedecl :: { RdrNameTyClDecl } - : tycl_decl { $1 } - | srcloc var '::' sigtype { IfaceSig $2 $4 [] $1 } +ifacedecl :: { HsDecl RdrName } + : var '::' sigtype + { SigD (Sig $1 $3 noSrcLoc) } + | 'type' syn_hdr '=' ctype + { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4 noSrcLoc) } + | new_or_data tycl_hdr + { TyClD (mkTyData $1 $2 [] Nothing noSrcLoc) } + | 'class' tycl_hdr fds + { TyClD (mkClassDecl $2 $3 [] EmptyMonoBinds noSrcLoc) } + +new_or_data :: { NewOrData } + : 'data' { DataType } + | 'newtype' { NewType } ----------------------------------------------------------------------------- -- The Export List @@ -393,7 +383,7 @@ topdecl :: { RdrBinding } : tycl_decl { RdrHsDecl (TyClD $1) } | srcloc 'instance' inst_type where { let (binds,sigs) = cvMonoBindsAndSigs $4 - in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) } + in RdrHsDecl (InstD (InstDecl $3 binds sigs $1)) } | srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) } | 'foreign' fdecl { RdrHsDecl $2 } | '{-# DEPRECATED' deprecations '#-}' { RdrBindings (reverse $2) } @@ -409,18 +399,17 @@ tycl_decl :: { RdrNameTyClDecl } -- Instead we just say b is out of scope { let (tc,tvs) = $3 in TySynonym tc tvs $5 $1 } - | srcloc 'data' tycl_hdr constrs deriving - { mkTyData DataType $3 (DataCons (reverse $4)) $5 $1 } + { mkTyData DataType $3 (reverse $4) $5 $1 } | srcloc 'newtype' tycl_hdr '=' newconstr deriving - { mkTyData NewType $3 (DataCons [$5]) $6 $1 } + { mkTyData NewType $3 [$5] $6 $1 } | srcloc 'class' tycl_hdr fds where { let (binds,sigs) = cvMonoBindsAndSigs $5 in - mkClassDecl $3 $4 sigs (Just binds) $1 } + mkClassDecl $3 $4 sigs binds $1 } syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an infix -- type synonym declaration. Oh well. @@ -434,10 +423,8 @@ syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an i -- (Eq a, Ord b) => T a b -- Rather a lot of inlining here, else we get reduce/reduce errors tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) } - : context '=>' type {% checkTyClHdr $3 >>= \ (tc,tvs) -> - return ($1, tc, tvs) } - | type {% checkTyClHdr $1 >>= \ (tc,tvs) -> - return ([], tc, tvs) } + : context '=>' type {% checkTyClHdr $1 $3 } + | type {% checkTyClHdr [] $1 } ----------------------------------------------------------------------------- -- Nested declarations @@ -715,9 +702,9 @@ type :: { RdrNameHsType } gentype :: { RdrNameHsType } : btype { $1 } - | btype qtyconop gentype { HsOpTy $1 (HsTyOp $2) $3 } - | btype '`' tyvar '`' gentype { HsOpTy $1 (HsTyOp $3) $5 } - | btype '->' gentype { HsOpTy $1 HsArrow $3 } + | btype qtyconop gentype { HsOpTy $1 $2 $3 } + | btype '`' tyvar '`' gentype { HsOpTy $1 $3 $5 } + | btype '->' gentype { HsFunTy $1 $3 } btype :: { RdrNameHsType } : btype atype { HsAppTy $1 $2 } @@ -726,8 +713,8 @@ btype :: { RdrNameHsType } atype :: { RdrNameHsType } : gtycon { HsTyVar $1 } | tyvar { HsTyVar $1 } - | '(' type ',' comma_types1 ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2:$4) } - | '(#' comma_types1 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } + | '(' type ',' comma_types1 ')' { HsTupleTy Boxed ($2:$4) } + | '(#' comma_types1 '#)' { HsTupleTy Unboxed $2 } | '[' type ']' { HsListTy $2 } | '[:' type ':]' { HsPArrTy $2 } | '(' ctype ')' { HsParTy $2 } @@ -756,7 +743,7 @@ tv_bndrs :: { [RdrNameHsTyVar] } tv_bndr :: { RdrNameHsTyVar } : tyvar { UserTyVar $1 } - | '(' tyvar '::' kind ')' { IfaceTyVar $2 $4 } + | '(' tyvar '::' kind ')' { KindedTyVar $2 $4 } fds :: { [([RdrName], [RdrName])] } : {- empty -} { [] } @@ -838,9 +825,9 @@ stype :: { RdrNameBangType } : ctype { unbangedType $1 } | strict_mark atype { BangType $1 $2 } -strict_mark :: { StrictnessMark } - : '!' { MarkedUserStrict } - | '!' '!' { MarkedUserUnboxed } +strict_mark :: { HsBang } + : '!' { HsStrict } + | '!' '!' { HsUnbox } deriving :: { Maybe RdrNameContext } : {- empty -} { Nothing } @@ -984,6 +971,8 @@ aexp1 :: { RdrNameHsExpr } -- Here was the syntax for type applications that I was planning -- but there are difficulties (e.g. what order for type args) -- so it's not enabled yet. +-- But this case *is* used for the left hand side of a generic definition, +-- which is parsed as an expression before being munged into a pattern | qcname '{|' gentype '|}' { (HsApp (HsVar $1) (HsType $3)) } aexp2 :: { RdrNameHsExpr } @@ -1267,9 +1256,9 @@ gtycon :: { RdrName } -- A "general" qualified tycon : oqtycon { $1 } | '(' ')' { getRdrName unitTyCon } | '(' commas ')' { getRdrName (tupleTyCon Boxed $2) } - | '(' '->' ')' { nameRdrName funTyConName } - | '[' ']' { nameRdrName listTyConName } - | '[:' ':]' { nameRdrName parrTyConName } + | '(' '->' ')' { getRdrName funTyCon } + | '[' ']' { listTyCon_RDR } + | '[:' ':]' { parrTyCon_RDR } oqtycon :: { RdrName } -- An "ordinary" qualified tycon : qtycon { $1 } @@ -1398,8 +1387,7 @@ consym :: { RdrName } : CONSYM { mkUnqual dataName $1 } -- ':' means only list cons - | ':' { nameRdrName consDataConName } - -- NB: SrcName because we are reading source + | ':' { consDataCon_RDR } ----------------------------------------------------------------------------- diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index dd438b1413..4f025f9c0f 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -1,23 +1,23 @@ { module ParserCore ( parseCore ) where +import IfaceSyn import ForeignCall - -import HsCore import RdrHsSyn +import TcIface ( tcIfaceKind ) import HsSyn -import TyCon -import TcType import RdrName import OccName +import Name( nameOccName, nameModuleName ) import Module import ParserCoreUtils import LexCore import Literal import BasicTypes -import Type import SrcLoc -import PrelNames +import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, + floatPrimTyCon, doublePrimTyCon, addrPrimTyCon ) +import TyCon ( TyCon, tyConName ) import FastString import Outputable @@ -68,154 +68,182 @@ import Outputable %% -module :: { RdrNameHsModule } - : '%module' modid tdefs vdefgs - { HsModule (Just (mkHomeModule $2)) Nothing - [] ($3 ++ concat $4) Nothing noSrcLoc} +module :: { HsExtCore RdrName } + : '%module' modid tdefs vdefgs + { HsExtCore (mkHomeModule $2) $3 $4 } + +modid :: { ModuleName } + : CNAME { mkSysModuleNameFS (mkFastString $1) } + +------------------------------------------------------------- +-- Type and newtype declarations are in HsSyn syntax -tdefs :: { [RdrNameHsDecl] } +tdefs :: { [TyClDecl RdrName] } : {- empty -} {[]} | tdef ';' tdefs {$1:$3} -tdef :: { RdrNameHsDecl } - : '%data' q_tc_name tbinds '=' '{' cons1 '}' - { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) } - | '%newtype' q_tc_name tbinds trep - { TyClD (mkTyData NewType ([], $2, $3) ($4 $2) Nothing noSrcLoc) } +tdef :: { TyClDecl RdrName } + : '%data' q_tc_name tv_bndrs '=' '{' cons1 '}' + { mkTyData DataType ([], ifaceExtRdrName $2, map toHsTvBndr $3) $6 Nothing noSrcLoc } + | '%newtype' q_tc_name tv_bndrs trep + { let tc_rdr = ifaceExtRdrName $2 in + mkTyData NewType ([], tc_rdr, map toHsTvBndr $3) ($4 (rdrNameOcc tc_rdr)) Nothing noSrcLoc } -- For a newtype we have to invent a fake data constructor name -- It doesn't matter what it is, because it won't be used -trep :: { (RdrName -> DataConDetails (ConDecl RdrName)) } - : {- empty -} { (\ tc_name -> Unknown) } - | '=' ty { (\ tc_name -> let { dc_name = setRdrNameSpace tc_name dataName ; - con_info = PrefixCon [unbangedType $2] } - in DataCons [ConDecl dc_name [] [] con_info noSrcLoc]) } +trep :: { OccName -> [ConDecl RdrName] } + : {- empty -} { (\ tc_occ -> []) } + | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ; + con_info = PrefixCon [unbangedType (toHsType $2)] } + in [ConDecl dc_name [] [] con_info noSrcLoc]) } -tbind :: { HsTyVarBndr RdrName } - : name { IfaceTyVar $1 liftedTypeKind } - | '(' name '::' akind ')' { IfaceTyVar $2 $4 } +cons1 :: { [ConDecl RdrName] } + : con { [$1] } + | con ';' cons1 { $1:$3 } -tbinds :: { [HsTyVarBndr RdrName] } - : {- empty -} { [] } - | tbind tbinds { $1:$2 } +con :: { ConDecl RdrName } + : d_pat_occ attv_bndrs hs_atys + { ConDecl (mkRdrUnqual $1) $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} -vdefgs :: { [[RdrNameHsDecl]] } - : {- empty -} { [] } - | vdefg ';' vdefgs { ($1:$3) } +attv_bndrs :: { [HsTyVarBndr RdrName] } + : {- empty -} { [] } + | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 } -vdefg :: { [RdrNameHsDecl] } - : '%rec' '{' vdefs1 '}' { map CoreD $3 } - | vdef { [CoreD $1] } +hs_atys :: { [HsType RdrName] } + : atys { map toHsType $1 } -let_bind :: { UfBinding RdrName } - : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) } - | vdef { let (b,r) = convBind $1 - in UfNonRec b r } -vdefs1 :: { [RdrNameCoreDecl] } - : vdef { [$1] } - | vdef ';' vdefs1 { $1:$3 } +--------------------------------------- +-- Types +--------------------------------------- -vdef :: { RdrNameCoreDecl } - : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc } - -- NB: qname includes data constructors, because - -- we allow data-constructor wrappers at top level +atys :: { [IfaceType] } + : {- empty -} { [] } + | aty atys { $1:$2 } +aty :: { IfaceType } + : tv_occ { IfaceTyVar $1 } + | q_tc_name { IfaceTyConApp (IfaceTc $1) [] } + | '(' ty ')' { $2 } -vbind :: { (RdrName, RdrNameHsType) } - : '(' name '::' ty ')' { ($2,$4) } +bty :: { IfaceType } + : tv_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 } + | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 } -vbinds :: { [(RdrName, RdrNameHsType)] } - : {-empty -} { [] } - | vbind vbinds { $1:$2 } +ty :: { IfaceType } + : bty { $1 } + | bty '->' ty { IfaceFunTy $1 $3 } + | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 } -bind :: { UfBinder RdrName } - : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k } - | vbind { let (v,ty) = $1 in UfValBinder v ty } +---------------------------------------------- +-- Bindings are in Iface syntax -binds1 :: { [UfBinder RdrName] } - : bind { [$1] } - | bind binds1 { $1:$2 } +vdefgs :: { [IfaceBinding] } + : {- empty -} { [] } + | let_bind ';' vdefgs { $1 : $3 } -attbinds :: { [RdrNameHsTyVar] } - : {- empty -} { [] } - | '@' tbind attbinds { $2:$3 } +let_bind :: { IfaceBinding } + : '%rec' '{' vdefs1 '}' { IfaceRec $3 } + | vdef { let (b,r) = $1 + in IfaceNonRec b r } -akind :: { Kind } - : '*' { liftedTypeKind } - | '#' { unliftedTypeKind } - | '?' { openTypeKind } - | '(' kind ')' { $2 } +vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] } + : vdef { [$1] } + | vdef ';' vdefs1 { $1:$3 } -kind :: { Kind } - : akind { $1 } - | akind '->' kind { mkArrowKind $1 $3 } +vdef :: { (IfaceIdBndr, IfaceExpr) } + : qd_occ '::' ty '=' exp { (($1, $3), $5) } + -- NB: qd_occ includes data constructors, because + -- we allow data-constructor wrappers at top level + -- But we discard the module name, because it must be the + -- same as the module being compiled, and Iface syntax only + -- has OccNames in binding positions -cons1 :: { [ConDecl RdrName] } - : con { [$1] } - | con ';' cons1 { $1:$3 } +qd_occ :: { OccName } + : var_occ { $1 } + | d_occ { $1 } -con :: { ConDecl RdrName } - : q_d_patt attbinds atys - { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} +--------------------------------------- +-- Binders +bndr :: { IfaceBndr } + : '@' tv_bndr { IfaceTvBndr $2 } + | id_bndr { IfaceIdBndr $1 } -atys :: { [ RdrNameHsType] } - : {- empty -} { [] } - | aty atys { $1:$2 } +bndrs :: { [IfaceBndr] } + : bndr { [$1] } + | bndr bndrs { $1:$2 } -aty :: { RdrNameHsType } - : name { HsTyVar $1 } - | q_tc_name { HsTyVar $1 } - | '(' ty ')' { $2 } +id_bndr :: { IfaceIdBndr } + : '(' var_occ '::' ty ')' { ($2,$4) } +id_bndrs :: { [IfaceIdBndr] } + : {-empty -} { [] } + | id_bndr id_bndrs { $1:$2 } + +tv_bndr :: { IfaceTvBndr } + : tv_occ { ($1, IfaceLiftedTypeKind) } + | '(' tv_occ '::' akind ')' { ($2, $4) } + +tv_bndrs :: { [IfaceTvBndr] } + : {- empty -} { [] } + | tv_bndr tv_bndrs { $1:$2 } + +akind :: { IfaceKind } + : '*' { IfaceLiftedTypeKind } + | '#' { IfaceUnliftedTypeKind } + | '?' { IfaceOpenTypeKind } + | '(' kind ')' { $2 } -bty :: { RdrNameHsType } - : aty { $1 } - | bty aty { HsAppTy $1 $2 } +kind :: { IfaceKind } + : akind { $1 } + | akind '->' kind { IfaceFunKind $1 $3 } -ty :: { RdrNameHsType } - : bty { $1 } - | bty '->' ty { HsFunTy $1 $3 } - | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 } +----------------------------------------- +-- Expressions -aexp :: { UfExpr RdrName } - : qname { UfVar $1 } - | lit { UfLit $1 } +aexp :: { IfaceExpr } + : var_occ { IfaceLcl $1 } + | modid '.' qd_occ { IfaceExt (ExtPkg $1 $3) } + | lit { IfaceLit $1 } | '(' exp ')' { $2 } -fexp :: { UfExpr RdrName } - : fexp aexp { UfApp $1 $2 } - | fexp '@' aty { UfApp $1 (UfType $3) } +fexp :: { IfaceExpr } + : fexp aexp { IfaceApp $1 $2 } + | fexp '@' aty { IfaceApp $1 (IfaceType $3) } | aexp { $1 } -exp :: { UfExpr RdrName } - : fexp { $1 } - | '\\' binds1 '->' exp { foldr UfLam $4 $2 } - | '%let' let_bind '%in' exp { UfLet $2 $4 } - | '%case' aexp '%of' vbind - '{' alts1 '}' { UfCase $2 (fst $4) $6 } - | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type? +exp :: { IfaceExpr } + : fexp { $1 } + | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 } + | '%let' let_bind '%in' exp { IfaceLet $2 $4 } + | '%case' aexp '%of' id_bndr + '{' alts1 '}' { IfaceCase $2 (fst $4) $6 } + | '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 } | '%note' STRING exp { case $2 of - --"SCC" -> UfNote (UfSCC "scc") $3 - "InlineCall" -> UfNote UfInlineCall $3 - "InlineMe" -> UfNote UfInlineMe $3 + --"SCC" -> IfaceNote (IfaceSCC "scc") $3 + "InlineCall" -> IfaceNote IfaceInlineCall $3 + "InlineMe" -> IfaceNote IfaceInlineMe $3 } - | '%external' STRING aty { UfFCall (ForeignCall.CCall - (CCallSpec (StaticTarget - (mkFastString $2)) - CCallConv (PlaySafe False))) $3 } -alts1 :: { [UfAlt RdrName] } + | '%external' STRING aty { IfaceFCall (ForeignCall.CCall + (CCallSpec (StaticTarget (mkFastString $2)) + CCallConv (PlaySafe False))) + $3 } + +alts1 :: { [IfaceAlt] } : alt { [$1] } | alt ';' alts1 { $1:$3 } -alt :: { UfAlt RdrName } - : q_d_patt attbinds vbinds '->' exp - { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } +alt :: { IfaceAlt } + : modid '.' d_pat_occ bndrs '->' exp + { (IfaceDataAlt $3, map ifaceBndrName $4, $6) } + -- The external syntax currently includes the types of the + -- the args, but they aren't needed internally + -- Nor is the module qualifier | lit '->' exp - { (UfLitAlt $1, [], $3) } + { (IfaceLitAlt $1, [], $3) } | '%_' '->' exp - { (UfDefault, [], $3) } + { (IfaceDefault, [], $3) } lit :: { Literal } : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } @@ -223,71 +251,76 @@ lit :: { Literal } | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } -name :: { RdrName } - : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) } - -cname :: { String } - : CNAME { $1 } - -mname :: { String } - : CNAME { $1 } +tv_occ :: { OccName } + : NAME { mkSysOcc tvName $1 } -modid :: { ModuleName } - : CNAME { mkSysModuleNameFS (mkFastString $1) } - -qname :: { RdrName } -- Includes data constructors - : name { $1 } - | mname '.' NAME { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) } - | q_d_occ { $1 } +var_occ :: { OccName } + : NAME { mkSysOcc varName $1 } -- Type constructor -q_tc_name :: { RdrName } - : mname '.' cname - { mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) } +q_tc_name :: { IfaceExtName } + : modid '.' CNAME { ExtPkg $1 (mkSysOcc tcName $3) } -- Data constructor in a pattern or data type declaration; use the dataName, -- because that's what we expect in Core case patterns -q_d_patt :: { RdrName } - : mname '.' cname - { mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) } +d_pat_occ :: { OccName } + : CNAME { mkSysOcc dataName $1 } -- Data constructor occurrence in an expression; -- use the varName because that's the worker Id -q_d_occ :: { RdrName } - : mname '.' cname - { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) } - +d_occ :: { OccName } + : CNAME { mkSysOcc varName $1 } { -convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName) -convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs) - -convIntLit :: Integer -> RdrNameHsType -> Literal -convIntLit i (HsTyVar n) - | n == intPrimRdrName = MachInt i - | n == wordPrimRdrName = MachWord i - | n == charPrimRdrName = MachChar (fromInteger i) - | n == addrPrimRdrName && i == 0 = MachNullAddr -convIntLit i aty - = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName) - -convRatLit :: Rational -> RdrNameHsType -> Literal -convRatLit r (HsTyVar n) - | n == floatPrimRdrName = MachFloat r - | n == doublePrimRdrName = MachDouble r -convRatLit i aty - = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName) +ifaceBndrName (IfaceIdBndr (n,_)) = n +ifaceBndrName (IfaceTvBndr (n,_)) = n -wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName, addrPrimRdrName :: RdrName -wordPrimRdrName = nameRdrName wordPrimTyConName -intPrimRdrName = nameRdrName intPrimTyConName -charPrimRdrName = nameRdrName charPrimTyConName -floatPrimRdrName = nameRdrName floatPrimTyConName -doublePrimRdrName = nameRdrName doublePrimTyConName -addrPrimRdrName = nameRdrName addrPrimTyConName +convIntLit :: Integer -> IfaceType -> Literal +convIntLit i (IfaceTyConApp tc []) + | tc `eqTc` intPrimTyCon = MachInt i + | tc `eqTc` wordPrimTyCon = MachWord i + | tc `eqTc` charPrimTyCon = MachChar (fromInteger i) + | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr +convIntLit i aty + = pprPanic "Unknown integer literal type" (ppr aty) +convRatLit :: Rational -> IfaceType -> Literal +convRatLit r (IfaceTyConApp tc []) + | tc `eqTc` floatPrimTyCon = MachFloat r + | tc `eqTc` doublePrimTyCon = MachDouble r +convRatLit i aty + = pprPanic "Unknown rational literal type" (ppr aty) + +eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh! +eqTc (IfaceTc (ExtPkg mod occ)) tycon + = mod == nameModuleName nm && occ == nameOccName nm + where + nm = tyConName tycon + +-- Tiresomely, we have to generate both HsTypes (in type/class decls) +-- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes, +-- and convert to HsTypes here. But the IfaceTypes we can see here +-- are very limited (see the productions for 'ty', so the translation +-- isn't hard +toHsType :: IfaceType -> HsType RdrName +toHsType (IfaceTyVar v) = HsTyVar (mkRdrUnqual v) +toHsType (IfaceAppTy t1 t2) = HsAppTy (toHsType t1) (toHsType t2) +toHsType (IfaceFunTy t1 t2) = HsFunTy (toHsType t1) (toHsType t2) +toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl HsAppTy (HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) +toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t) + +toHsTvBndr :: IfaceTvBndr -> HsTyVarBndr RdrName +toHsTvBndr (tv,k) = KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k) + +ifaceExtRdrName :: IfaceExtName -> RdrName +ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ +ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) + +add_forall tv (HsForAllTy (Just tvs) cxt t) = HsForAllTy (Just (tv:tvs)) cxt t +add_forall tv t = HsForAllTy (Just [tv]) [] t + happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 652a3e658d..4ecdec3559 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -16,7 +16,6 @@ module RdrHsSyn ( RdrNameContext, RdrNameDefaultDecl, RdrNameForeignDecl, - RdrNameCoreDecl, RdrNameGRHS, RdrNameGRHSs, RdrNameHsBinds, @@ -47,15 +46,15 @@ module RdrHsSyn ( main_RDR_Unqual, - extractHsTyRdrNames, extractHsTyRdrTyVars, - extractHsCtxtRdrTyVars, extractGenericPatTyVars, + extractHsTyRdrTyVars, + extractHsRhoRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, mkHsDo, mkHsSplice, mkSigDecls, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem] + mkBootIface, cvBinds, cvMonoBindsAndSigs, @@ -94,20 +93,26 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it +import IfaceType +import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) +import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) ) import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace ) -import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence ) -import Class ( DefMeth (..) ) + setRdrNameSpace, rdrNameModule ) +import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion ) import Lexer ( P, setSrcLocFor, getSrcLoc, failLocMsgP ) -import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) -import TysWiredIn ( unitTyCon ) +import HscTypes ( GenAvailInfo(..) ) +import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..)) -import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, - mkDefaultMethodOcc, mkVarOcc ) +import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, + occNameUserString, mkVarOcc, isValOcc ) +import BasicTypes ( initialVersion ) +import TyCon ( DataConDetails(..) ) +import Module ( ModuleName ) import SrcLoc import CStrings ( CLabelString ) +import CmdLineOpts ( opt_InPackage ) import List ( isSuffixOf, nub ) import Outputable import FastString @@ -131,7 +136,6 @@ type RdrNameContext = HsContext RdrName type RdrNameHsDecl = HsDecl RdrName type RdrNameDefaultDecl = DefaultDecl RdrName type RdrNameForeignDecl = ForeignDecl RdrName -type RdrNameCoreDecl = CoreDecl RdrName type RdrNameGRHS = GRHS RdrName type RdrNameGRHSs = GRHSs RdrName type RdrNameHsBinds = HsBinds RdrName @@ -176,24 +180,20 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") It's used when making the for-alls explicit. \begin{code} -extractHsTyRdrNames :: RdrNameHsType -> [RdrName] -extractHsTyRdrNames ty = nub (extract_ty ty []) - extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) -extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName] -extractHsCtxtRdrNames ty = nub (extract_ctxt ty []) -extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName] -extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty) +extractHsRhoRdrTyVars :: HsContext RdrName -> RdrNameHsType -> [RdrName] +-- This one takes the context and tau-part of a +-- sigma type and returns their free type variables +extractHsRhoRdrTyVars ctxt ty = nub $ filter isRdrTyVar $ + extract_ctxt ctxt (extract_ty ty []) extract_ctxt ctxt acc = foldr extract_pred acc ctxt extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys extract_pred (HsIParam n ty) acc = extract_ty ty acc -extract_tys tys = foldr extract_ty [] tys - extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsListTy ty) acc = extract_ty ty acc extract_ty (HsPArrTy ty) acc = extract_ty ty acc @@ -249,22 +249,14 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, - tcdSigs = map cvClassOpSig sigs, -- Convert to class-op sigs + tcdSigs = sigs, tcdMeths = mbinds, tcdLoc = loc } mkTyData new_or_data (context, tname, tyvars) data_cons maybe src = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, tcdTyVars = tyvars, tcdCons = data_cons, - tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing } - -cvClassOpSig :: RdrNameSig -> RdrNameSig -cvClassOpSig (Sig var poly_ty src_loc) - = ClassOpSig var (DefMeth dm_rn) poly_ty src_loc - where - dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc var)) -cvClassOpSig sig - = sig + tcdDerivs = maybe, tcdLoc = src } \end{code} \begin{code} @@ -276,7 +268,7 @@ mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) -mkHsNegApp expr = NegApp expr placeHolderName +mkHsNegApp expr = NegApp expr placeHolderName \end{code} A useful function for building @OpApps@. The operator is always a @@ -306,6 +298,143 @@ unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) %************************************************************************ %* * + Hi-boot files +%* * +%************************************************************************ + +mkBootIface, and its boring helper functions, have two purposes: +a) HsSyn to IfaceSyn. The parser parses the former, but we're reading + an hi-boot file, and interfaces consist of the latter +b) Convert unqualifed names from the "current module" to qualified Orig + names. E.g. + module This where + foo :: GHC.Base.Int -> GHC.Base.Int + becomes + This.foo :: GHC.Base.Int -> GHC.Base.Int + +It assumes that everything is well kinded, of course. + +\begin{code} +mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface +-- Make the ModIface for a hi-boot file +-- The decls are of very limited form +mkBootIface mod decls + = (emptyModIface opt_InPackage mod) { + mi_boot = True, + mi_exports = [(mod, map mk_export decls')], + mi_decls = decls_w_vers, + mi_ver_fn = mkIfaceVerCache decls_w_vers } + where + decls' = map hsIfaceDecl decls + decls_w_vers = repeat initialVersion `zip` decls' + + -- hi-boot declarations don't (currently) + -- expose constructors or class methods + mk_export decl | isValOcc occ = Avail occ + | otherwise = AvailTC occ [occ] + where + occ = ifName decl + + +hsIfaceDecl :: HsDecl RdrName -> IfaceDecl + -- Change to Iface syntax, and replace unqualified names with + -- qualified Orig names from this module. Reason: normal + -- iface files have everything fully qualified, so it's convenient + -- for hi-boot files to look the same + -- + -- NB: no constructors or class ops to worry about +hsIfaceDecl (SigD (Sig name ty _)) + = IfaceId { ifName = rdrNameOcc name, + ifType = hsIfaceType ty, + ifIdInfo = NoInfo } + +hsIfaceDecl (TyClD decl@(TySynonym {})) + = IfaceSyn { ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifSynRhs = hsIfaceType (tcdSynRhs decl), + ifVrcs = [] } + +hsIfaceDecl (TyClD decl@(TyData {})) + = IfaceData { ifND = tcdND decl, + ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifCtxt = hsIfaceCtxt (tcdCtxt decl), + ifCons = Unknown, ifRec = NonRecursive, + ifVrcs = [], ifGeneric = False } + +hsIfaceDecl (TyClD decl@(ClassDecl {})) + = IfaceClass { ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifCtxt = hsIfaceCtxt (tcdCtxt decl), + ifFDs = hsIfaceFDs (tcdFDs decl), + ifSigs = [], -- Is this right?? + ifRec = NonRecursive, ifVrcs = [] } + +hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl) + +hsIfaceName rdr_name -- Qualify unqualifed occurrences + -- with the module name + | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name) + | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +hsIfaceType :: HsType RdrName -> IfaceType +hsIfaceType (HsForAllTy mb_tvs cxt ty) + = foldr (IfaceForAllTy . hsIfaceTv) rho tvs + where + rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt + tau = hsIfaceType ty + tvs = case mb_tvs of + Just tvs -> tvs + Nothing -> map UserTyVar (extractHsRhoRdrTyVars cxt ty) + +hsIfaceType ty@(HsTyVar _) = hs_tc_app ty [] +hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty [] +hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceType t1) (hsIfaceType t2) +hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceType t] +hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceType t] +hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceTypes ts) +hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar tc) (hsIfaceTypes [t1, t2]) +hsIfaceType (HsParTy t) = hsIfaceType t +hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" +hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) +hsIfaceType (HsKindSig t _) = hsIfaceType t + +----------- +hsIfaceTypes tys = map hsIfaceType tys + +----------- +hsIfaceCtxt :: [HsPred RdrName] -> [IfacePredType] +hsIfaceCtxt ctxt = map hsIfacePred ctxt + +----------- +hsIfacePred :: HsPred RdrName -> IfacePredType +hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceTypes ts) +hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceType t) + +----------- +hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType +hs_tc_app (HsAppTy t1 t2) args = hs_tc_app t1 (hsIfaceType t2 : args) +hs_tc_app (HsTyVar n) args + | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args + | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args +hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args + +----------- +hsIfaceTvs tvs = map hsIfaceTv tvs + +----------- +hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind) +hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k) + +----------- +hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])] +hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys) + | (xs,ys) <- fds ] +\end{code} + + +%************************************************************************ +%* * \subsection[rdrBinding]{Bindings straight out of the parser} %* * %************************************************************************ @@ -416,7 +545,7 @@ emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive, -- they start life as a single giant MonoBinds hs_tyclds = [], hs_instds = [], hs_fixds = [], hs_defds = [], hs_fords = [], - hs_depds = [] ,hs_ruleds = [], hs_coreds = [] } + hs_depds = [] ,hs_ruleds = [] } findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) findSplice ds = add emptyGroup ds @@ -456,7 +585,6 @@ add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds -add gp@(HsGroup {hs_coreds = ts})(CoreD d : ds) = add (gp { hs_coreds = d : ts }) ds add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r @@ -520,29 +648,37 @@ checkTyVars tvs = mapM chk tvs where -- Check that the name space is correct! - chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (IfaceTyVar tv k) + chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (KindedTyVar tv k) chk (HsTyVar tv) | isRdrTyVar tv = return (UserTyVar tv) chk other = parseError "Type found where type variable expected" -checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar]) +checkTyClHdr :: RdrNameContext -> RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) -- The header of a type or class decl should look like -- (C a, D b) => T a b -- or T a b -- or a + b -- etc -checkTyClHdr ty - = go ty [] +checkTyClHdr cxt ty + = go ty [] >>= \ (tc, tvs) -> + mapM chk_pred cxt >>= \ _ -> + return (cxt, tc, tvs) where go (HsTyVar tc) acc | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs -> return (tc, tvs) - go (HsOpTy t1 (HsTyOp tc) t2) acc - = checkTyVars (t1:t2:acc) >>= \ tvs -> + go (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs -> return (tc, tvs) go (HsParTy ty) acc = go ty acc go (HsAppTy t1 t2) acc = go t1 (t2:acc) go other acc = parseError "Malformed LHS to type of class declaration" + -- The predicates in a type or class decl must all + -- be HsClassPs. They need not all be type variables, + -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m + chk_pred (HsClassP _ args) = return () + chk_pred pred = parseError "Malformed context in type or class declaration" + + checkContext :: RdrNameHsType -> P RdrNameContext checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type = mapM checkPred ts @@ -617,8 +753,15 @@ checkPat e [] = case e of EWildPat -> return (WildPat placeHolderType) HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x) | otherwise -> return (VarPat x) - HsLit l -> return (LitPat l) - HsOverLit l -> return (NPatIn l Nothing) + HsLit l -> return (LitPat l) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- Negation is recorded separately, so that the literal is zero or +ve + -- NB. Negative *primitive* literals are already handled by + -- RdrHsSyn.mkHsNegApp + HsOverLit pos_lit -> return (NPatIn pos_lit Nothing) + NegApp (HsOverLit pos_lit) _ -> return (NPatIn pos_lit (Just placeHolderName)) + ELazyPat e -> checkPat e [] >>= (return . LazyPat) EAsPat n e -> checkPat e [] >>= (return . AsPat n) ExprWithTySig e t -> checkPat e [] >>= \e -> @@ -631,13 +774,7 @@ checkPat e [] = case e of in return (SigPatIn e t') - -- Translate out NegApps of literals in patterns. We negate - -- the Integer here, and add back the call to 'negate' when - -- we typecheck the pattern. - -- NB. Negative *primitive* literals are already handled by - -- RdrHsSyn.mkHsNegApp - NegApp (HsOverLit lit) neg -> return (NPatIn lit (Just neg)) - + -- n+k patterns OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) | plus == plus_RDR -> return (mkNPlusKPat n lit) @@ -884,20 +1021,6 @@ mkExport DNCall (entity, v, ty) loc = -- mkExtName :: RdrName -> CLabelString mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) - --- --------------------------------------------------------------------------- --- Make the export list for an interface - -mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo] -mkIfaceExports decls = map getExport decls - where getExport d = case d of - TyData{} -> tc_export - ClassDecl{} -> tc_export - _other -> var_export - where - tc_export = AvailTC (rdrNameOcc (tcdName d)) - (map (rdrNameOcc.fst) (tyClDeclNames d)) - var_export = Avail (rdrNameOcc (tcdName d)) \end{code} diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index c6afe14b79..36b9520eef 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -5,12 +5,11 @@ \begin{code} module PrelInfo ( - module PrelNames, module MkId, - wiredInThingEnv, ghcPrimExports, - knownKeyNames, + wiredInThings, basicKnownKeyNames, + primOpId, -- Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -26,28 +25,22 @@ import PrelNames ( basicKnownKeyNames, hasKey, charDataConKey, intDataConKey, numericClassKeys, standardClassKeys, noDictClassKeys ) -#ifdef GHCI -import DsMeta ( templateHaskellNames ) -import NameSet ( nameSetToList ) -#endif -import PrimOp ( allThePrimOps, primOpOcc ) +import PrimOp ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag ) import DataCon ( DataCon ) -import Id ( idName ) +import Id ( Id, idName ) import MkId ( mkPrimOpId, wiredInIds ) import MkId -- All of it, for re-export -import Name ( Name, nameOccName, NamedThing(..) ) -import RdrName ( mkRdrUnqual ) -import HsSyn ( HsTyVarBndr(..) ) -import OccName ( mkVarOcc ) +import Name ( nameOccName ) import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) -import HscTypes ( TyThing(..), implicitTyThings, TypeEnv, mkTypeEnv, - GenAvailInfo(..), RdrAvailInfo ) -import Class ( Class, classKey, className ) -import Type ( funTyCon, openTypeKind, liftedTypeKind ) +import HscTypes ( TyThing(..), implicitTyThings, GenAvailInfo(..), RdrAvailInfo ) +import Class ( Class, classKey ) +import Type ( funTyCon ) import TyCon ( tyConName ) import Util ( isIn ) + +import Array ( Array, array, (!) ) \end{code} %************************************************************************ @@ -61,11 +54,11 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and \begin{code} wiredInThings :: [TyThing] -wiredInThings +wiredInThings = concat [ -- Wired in TyCons and their implicit Ids tycon_things - , implicitTyThings tycon_things + , concatMap implicitTyThings tycon_things -- Wired in Ids , map AnId wiredInIds @@ -75,17 +68,6 @@ wiredInThings ] where tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons) - -wiredInThingEnv :: TypeEnv -wiredInThingEnv = mkTypeEnv wiredInThings - -knownKeyNames :: [Name] -knownKeyNames - = map getName wiredInThings - ++ basicKnownKeyNames -#ifdef GHCI - ++ nameSetToList templateHaskellNames -#endif \end{code} We let a lot of "non-standard" values be visible, so that we can make @@ -94,6 +76,22 @@ sense of them in interface pragmas. It's cool, though they all have %************************************************************************ %* * + PrimOpIds +%* * +%************************************************************************ + +\begin{code} +primOpIds :: Array Int Id -- Indexed by PrimOp tag +primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) + | op <- allThePrimOps] + +primOpId :: PrimOp -> Id +primOpId op = primOpIds ! primOpTag op +\end{code} + + +%************************************************************************ +%* * \subsection{Export lists for pseudo-modules (GHC.Prim)} %* * %************************************************************************ @@ -108,10 +106,6 @@ ghcPrimExports :: [RdrAvailInfo] [ AvailTC occ [occ] | n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n) ] - -alpha = mkRdrUnqual (mkVarOcc FSLIT("a")) -openAlpha = IfaceTyVar alpha openTypeKind -liftedAlpha = IfaceTyVar alpha liftedTypeKind \end{code} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 4c8f926f84..e2e250f36b 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -49,9 +49,8 @@ module PrelNames ( #include "HsVersions.h" -import Module ( ModuleName, mkBasePkgModule, mkHomeModule, mkModuleName ) -import OccName ( UserFS, dataName, tcName, clsName, varName, - mkKindOccFS, mkOccFS +import Module ( Module, mkBasePkgModule, mkHomeModule, mkModuleName ) +import OccName ( dataName, tcName, clsName, varName, mkOccFS ) import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc ) @@ -60,11 +59,9 @@ import Unique ( Unique, Uniquable(..), hasKey, mkPreludeTyConUnique, mkPreludeClassUnique, mkTupleTyConUnique, isTupleKey ) -import BasicTypes ( Boxity(..) ) -import Name ( Name, mkInternalName, mkKnownKeyExternalName, mkWiredInName, nameUnique ) +import BasicTypes ( Boxity(..), Arity ) +import Name ( Name, mkInternalName, mkExternalName, nameUnique, nameModule ) import SrcLoc ( noSrcLoc ) -import Util ( nOfThem ) -import Panic ( panic ) import FastString @@ -126,7 +123,9 @@ wired in ones are defined in TysWiredIn etc. \begin{code} basicKnownKeyNames :: [Name] basicKnownKeyNames - = [ -- Type constructors (synonyms especially) + = genericTyConNames + ++ monadNames + ++ [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, runIOName, orderingTyConName, @@ -135,7 +134,7 @@ basicKnownKeyNames ratioTyConName, byteArrayTyConName, mutableByteArrayTyConName, - bcoPrimTyConName, + integerTyConName, smallIntegerDataConName, largeIntegerDataConName, -- Classes. *Must* include: -- classes that are grabbed by key (e.g., eqClassKey) @@ -167,7 +166,6 @@ basicKnownKeyNames enumFromToPName, enumFromThenToPName, -- Monad stuff - thenMName, bindMName, returnMName, failMName, thenIOName, bindIOName, returnIOName, failIOName, -- MonadRec stuff @@ -205,14 +203,13 @@ basicKnownKeyNames -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, addrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, - word8TyConName, word16TyConName, word32TyConName, word64TyConName, + wordTyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, -- Others - unsafeCoerceName, otherwiseIdName, + otherwiseIdName, plusIntegerName, timesIntegerName, - eqStringName, assertName, assertErrorName, runSTRepName, + eqStringName, assertName, runSTRepName, printName, splitName, fstName, sndName, - errorName, -- Booleans andName, orName @@ -227,6 +224,9 @@ basicKnownKeyNames monadNames :: [Name] -- The monad ops need by a HsDo monadNames = [returnMName, failMName, bindMName, thenMName] + +genericTyConNames :: [Name] +genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] \end{code} @@ -283,16 +283,37 @@ gLA_EXTS_Name = mkModuleName "GHC.Exts" gHC_PRIM = mkBasePkgModule gHC_PRIM_Name pREL_BASE = mkBasePkgModule pREL_BASE_Name +pREL_TUP = mkBasePkgModule pREL_TUP_Name +pREL_EITHER = mkBasePkgModule pREL_EITHER_Name +pREL_LIST = mkBasePkgModule pREL_LIST_Name +pREL_SHOW = mkBasePkgModule pREL_SHOW_Name +pREL_READ = mkBasePkgModule pREL_READ_Name pREL_ADDR = mkBasePkgModule pREL_ADDR_Name +pREL_WORD = mkBasePkgModule pREL_WORD_Name +pREL_INT = mkBasePkgModule pREL_INT_Name pREL_PTR = mkBasePkgModule pREL_PTR_Name +pREL_ST = mkBasePkgModule pREL_ST_Name pREL_STABLE = mkBasePkgModule pREL_STABLE_Name pREL_IO_BASE = mkBasePkgModule pREL_IO_BASE_Name pREL_PACK = mkBasePkgModule pREL_PACK_Name pREL_ERR = mkBasePkgModule pREL_ERR_Name pREL_NUM = mkBasePkgModule pREL_NUM_Name +pREL_ENUM = mkBasePkgModule pREL_ENUM_Name pREL_REAL = mkBasePkgModule pREL_REAL_Name pREL_FLOAT = mkBasePkgModule pREL_FLOAT_Name +pREL_ARR = mkBasePkgModule pREL_ARR_Name +pREL_PARR = mkBasePkgModule pREL_PARR_Name +pREL_BYTEARR = mkBasePkgModule pREL_BYTEARR_Name +pREL_TOP_HANDLER= mkBasePkgModule pREL_TOP_HANDLER_Name pRELUDE = mkBasePkgModule pRELUDE_Name +sYSTEM_IO = mkBasePkgModule sYSTEM_IO_Name +aDDR = mkBasePkgModule aDDR_Name +aRROW = mkBasePkgModule aRROW_Name +gENERICS = mkBasePkgModule gENERICS_Name +tYPEABLE = mkBasePkgModule tYPEABLE_Name +dOTNET = mkBasePkgModule dOTNET_Name +gLA_EXTS = mkBasePkgModule gLA_EXTS_Name +mONAD_FIX = mkBasePkgModule mONAD_FIX_Name -- MetaHaskell Extension text2 from Meta/work/gen.hs mETA_META_Name = mkModuleName "Language.Haskell.THSyntax" @@ -313,22 +334,10 @@ iNTERACTIVE = mkHomeModule (mkModuleName ":Interactive") %************************************************************************ \begin{code} -mkTupNameStr :: Boxity -> Int -> (ModuleName, UserFS) - -mkTupNameStr Boxed 0 = (pREL_BASE_Name, FSLIT("()")) -mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr Boxed 2 = (pREL_TUP_Name, mkFastString "(,)") -- not strictly necessary -mkTupNameStr Boxed 3 = (pREL_TUP_Name, mkFastString "(,,)") -- ditto -mkTupNameStr Boxed 4 = (pREL_TUP_Name, mkFastString "(,,,)") -- ditto -mkTupNameStr Boxed n = (pREL_TUP_Name, mkFastString ("(" ++ nOfThem (n-1) ',' ++ ")")) - -mkTupNameStr Unboxed 0 = (gHC_PRIM_Name, mkFastString "(# #)") -- 1 and 0 both make sense!!! ---panic "Name.mkUbxTupNameStr: 0 ???" -mkTupNameStr Unboxed 1 = (gHC_PRIM_Name, mkFastString "(# #)") -- 1 and 0 both make sense!!! -mkTupNameStr Unboxed 2 = (gHC_PRIM_Name, mkFastString "(#,#)") -mkTupNameStr Unboxed 3 = (gHC_PRIM_Name, mkFastString "(#,,#)") -mkTupNameStr Unboxed 4 = (gHC_PRIM_Name, mkFastString "(#,,,#)") -mkTupNameStr Unboxed n = (gHC_PRIM_Name, mkFastString ("(#" ++ nOfThem (n-1) ',' ++ "#)")) +mkTupleModule :: Boxity -> Arity -> Module +mkTupleModule Boxed 0 = pREL_BASE +mkTupleModule Boxed _ = pREL_TUP +mkTupleModule Unboxed _ = gHC_PRIM \end{code} @@ -364,18 +373,13 @@ returnM_RDR = nameRdrName returnMName bindM_RDR = nameRdrName bindMName failM_RDR = nameRdrName failMName -false_RDR = nameRdrName falseDataConName -true_RDR = nameRdrName trueDataConName and_RDR = nameRdrName andName left_RDR = nameRdrName leftDataConName right_RDR = nameRdrName rightDataConName -error_RDR = nameRdrName errorName - fromEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("fromEnum") toEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("toEnum") -mkInt_RDR = nameRdrName intDataConName enumFrom_RDR = nameRdrName enumFromName enumFromTo_RDR = nameRdrName enumFromToName @@ -395,6 +399,7 @@ unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name newStablePtr_RDR = nameRdrName newStablePtrName addrDataCon_RDR = dataQual_RDR aDDR_Name FSLIT("A#") +wordDataCon_RDR = dataQual_RDR pREL_WORD_Name FSLIT("W#") bindIO_RDR = nameRdrName bindIOName returnIO_RDR = nameRdrName returnIOName @@ -447,8 +452,18 @@ mkTypeRep_RDR = varQual_RDR tYPEABLE_Name FSLIT("mkAppTy") mkTyConRep_RDR = varQual_RDR tYPEABLE_Name FSLIT("mkTyCon") undefined_RDR = varQual_RDR pREL_ERR_Name FSLIT("undefined") -\end{code} +crossDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT(":*:") +inlDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Inl") +inrDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Inr") +genUnitDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Unit") + +---------------------- +varQual_RDR mod str = mkOrig mod (mkOccFS varName str) +tcQual_RDR mod str = mkOrig mod (mkOccFS tcName str) +clsQual_RDR mod str = mkOrig mod (mkOccFS clsName str) +dataQual_RDR mod str = mkOrig mod (mkOccFS dataName str) +\end{code} %************************************************************************ %* * @@ -465,261 +480,191 @@ and it's convenient to write them all down in one place. \begin{code} -rootMainName = varQual rOOT_MAIN_Name FSLIT("main") rootMainKey -runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey - --- Stuff from GHC.Prim -superKindName = kindQual FSLIT("KX") kindConKey -superBoxityName = kindQual FSLIT("BX") boxityConKey -liftedConName = kindQual FSLIT("*") liftedConKey -unliftedConName = kindQual FSLIT("#") unliftedConKey -openKindConName = kindQual FSLIT("?") anyBoxConKey -typeConName = kindQual FSLIT("Type") typeConKey - -funTyConName = tcQual gHC_PRIM_Name FSLIT("(->)") funTyConKey -charPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Char#") charPrimTyConKey -intPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int#") intPrimTyConKey -int32PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int32#") int32PrimTyConKey -int64PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int64#") int64PrimTyConKey -wordPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word#") wordPrimTyConKey -word32PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word32#") word32PrimTyConKey -word64PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word64#") word64PrimTyConKey -addrPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Addr#") addrPrimTyConKey -floatPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Float#") floatPrimTyConKey -doublePrimTyConName = tcQual gHC_PRIM_Name FSLIT("Double#") doublePrimTyConKey -statePrimTyConName = tcQual gHC_PRIM_Name FSLIT("State#") statePrimTyConKey -realWorldTyConName = tcQual gHC_PRIM_Name FSLIT("RealWorld") realWorldTyConKey -arrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Array#") arrayPrimTyConKey -byteArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ByteArray#") byteArrayPrimTyConKey -mutableArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutableArray#") mutableArrayPrimTyConKey -mutableByteArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey -mutVarPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutVar#") mutVarPrimTyConKey -mVarPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MVar#") mVarPrimTyConKey -stablePtrPrimTyConName = tcQual gHC_PRIM_Name FSLIT("StablePtr#") stablePtrPrimTyConKey -stableNamePrimTyConName = tcQual gHC_PRIM_Name FSLIT("StableName#") stableNamePrimTyConKey -foreignObjPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ForeignObj#") foreignObjPrimTyConKey -bcoPrimTyConName = tcQual gHC_PRIM_Name FSLIT("BCO#") bcoPrimTyConKey -weakPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Weak#") weakPrimTyConKey -threadIdPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ThreadId#") threadIdPrimTyConKey - -unsafeCoerceName = wVarQual gHC_PRIM_Name FSLIT("unsafeCoerce#") unsafeCoerceIdKey -nullAddrName = wVarQual gHC_PRIM_Name FSLIT("nullAddr#") nullAddrIdKey -seqName = wVarQual gHC_PRIM_Name FSLIT("seq") seqIdKey -realWorldName = wVarQual gHC_PRIM_Name FSLIT("realWorld#") realWorldPrimIdKey - --- PrelBase data types and constructors -charTyConName = wTcQual pREL_BASE_Name FSLIT("Char") charTyConKey -charDataConName = wDataQual pREL_BASE_Name FSLIT("C#") charDataConKey -intTyConName = wTcQual pREL_BASE_Name FSLIT("Int") intTyConKey -intDataConName = wDataQual pREL_BASE_Name FSLIT("I#") intDataConKey -orderingTyConName = tcQual pREL_BASE_Name FSLIT("Ordering") orderingTyConKey -boolTyConName = wTcQual pREL_BASE_Name FSLIT("Bool") boolTyConKey -falseDataConName = wDataQual pREL_BASE_Name FSLIT("False") falseDataConKey -trueDataConName = wDataQual pREL_BASE_Name FSLIT("True") trueDataConKey -listTyConName = wTcQual pREL_BASE_Name FSLIT("[]") listTyConKey -nilDataConName = wDataQual pREL_BASE_Name FSLIT("[]") nilDataConKey -consDataConName = wDataQual pREL_BASE_Name FSLIT(":") consDataConKey -eqName = varQual pREL_BASE_Name FSLIT("==") eqClassOpKey -geName = varQual pREL_BASE_Name FSLIT(">=") geClassOpKey - -eitherTyConName = tcQual pREL_EITHER_Name FSLIT("Either") eitherTyConKey -leftDataConName = dataQual pREL_EITHER_Name FSLIT("Left") leftDataConKey -rightDataConName = dataQual pREL_EITHER_Name FSLIT("Right") rightDataConKey +rootMainName = varQual rOOT_MAIN FSLIT("main") rootMainKey +runIOName = varQual pREL_TOP_HANDLER FSLIT("runIO") runMainKey + +orderingTyConName = tcQual pREL_BASE FSLIT("Ordering") orderingTyConKey + +eitherTyConName = tcQual pREL_EITHER FSLIT("Either") eitherTyConKey +leftDataConName = conName eitherTyConName FSLIT("Left") leftDataConKey +rightDataConName = conName eitherTyConName FSLIT("Right") rightDataConKey -- Generics -crossTyConName = tcQual pREL_BASE_Name FSLIT(":*:") crossTyConKey -crossDataConName = dataQual pREL_BASE_Name FSLIT(":*:") crossDataConKey -plusTyConName = wTcQual pREL_BASE_Name FSLIT(":+:") plusTyConKey -inlDataConName = wDataQual pREL_BASE_Name FSLIT("Inl") inlDataConKey -inrDataConName = wDataQual pREL_BASE_Name FSLIT("Inr") inrDataConKey -genUnitTyConName = wTcQual pREL_BASE_Name FSLIT("Unit") genUnitTyConKey -genUnitDataConName = wDataQual pREL_BASE_Name FSLIT("Unit") genUnitDataConKey +crossTyConName = tcQual pREL_BASE FSLIT(":*:") crossTyConKey +plusTyConName = tcQual pREL_BASE FSLIT(":+:") plusTyConKey +genUnitTyConName = tcQual pREL_BASE FSLIT("Unit") genUnitTyConKey -- Base strings Strings -unpackCStringName = varQual pREL_BASE_Name FSLIT("unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual pREL_BASE_Name FSLIT("unpackAppendCString#") unpackCStringAppendIdKey -unpackCStringFoldrName = varQual pREL_BASE_Name FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey -unpackCStringUtf8Name = varQual pREL_BASE_Name FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey -eqStringName = varQual pREL_BASE_Name FSLIT("eqString") eqStringIdKey +unpackCStringName = varQual pREL_BASE FSLIT("unpackCString#") unpackCStringIdKey +unpackCStringAppendName = varQual pREL_BASE FSLIT("unpackAppendCString#") unpackCStringAppendIdKey +unpackCStringFoldrName = varQual pREL_BASE FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey +unpackCStringUtf8Name = varQual pREL_BASE FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey +eqStringName = varQual pREL_BASE FSLIT("eqString") eqStringIdKey -- Base classes (Eq, Ord, Functor) -eqClassName = clsQual pREL_BASE_Name FSLIT("Eq") eqClassKey -functorClassName = clsQual pREL_BASE_Name FSLIT("Functor") functorClassKey -ordClassName = clsQual pREL_BASE_Name FSLIT("Ord") ordClassKey +eqClassName = clsQual pREL_BASE FSLIT("Eq") eqClassKey +eqName = methName eqClassName FSLIT("==") eqClassOpKey +ordClassName = clsQual pREL_BASE FSLIT("Ord") ordClassKey +geName = methName ordClassName FSLIT(">=") geClassOpKey +functorClassName = clsQual pREL_BASE FSLIT("Functor") functorClassKey -- Class Monad -monadClassName = clsQual pREL_BASE_Name FSLIT("Monad") monadClassKey -thenMName = varQual pREL_BASE_Name FSLIT(">>") thenMClassOpKey -bindMName = varQual pREL_BASE_Name FSLIT(">>=") bindMClassOpKey -returnMName = varQual pREL_BASE_Name FSLIT("return") returnMClassOpKey -failMName = varQual pREL_BASE_Name FSLIT("fail") failMClassOpKey - +monadClassName = clsQual pREL_BASE FSLIT("Monad") monadClassKey +thenMName = methName monadClassName FSLIT(">>") thenMClassOpKey +bindMName = methName monadClassName FSLIT(">>=") bindMClassOpKey +returnMName = methName monadClassName FSLIT("return") returnMClassOpKey +failMName = methName monadClassName FSLIT("fail") failMClassOpKey -- Random PrelBase functions -otherwiseIdName = varQual pREL_BASE_Name FSLIT("otherwise") otherwiseIdKey -foldrName = varQual pREL_BASE_Name FSLIT("foldr") foldrIdKey -buildName = varQual pREL_BASE_Name FSLIT("build") buildIdKey -augmentName = varQual pREL_BASE_Name FSLIT("augment") augmentIdKey -appendName = varQual pREL_BASE_Name FSLIT("++") appendIdKey -andName = varQual pREL_BASE_Name FSLIT("&&") andIdKey -orName = varQual pREL_BASE_Name FSLIT("||") orIdKey -assertName = varQual pREL_BASE_Name FSLIT("assert") assertIdKey -lazyIdName = wVarQual pREL_BASE_Name FSLIT("lazy") lazyIdKey +otherwiseIdName = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey +foldrName = varQual pREL_BASE FSLIT("foldr") foldrIdKey +buildName = varQual pREL_BASE FSLIT("build") buildIdKey +augmentName = varQual pREL_BASE FSLIT("augment") augmentIdKey +appendName = varQual pREL_BASE FSLIT("++") appendIdKey +andName = varQual pREL_BASE FSLIT("&&") andIdKey +orName = varQual pREL_BASE FSLIT("||") orIdKey +assertName = varQual pREL_BASE FSLIT("assert") assertIdKey -- PrelTup -fstName = varQual pREL_TUP_Name FSLIT("fst") fstIdKey -sndName = varQual pREL_TUP_Name FSLIT("snd") sndIdKey +fstName = varQual pREL_TUP FSLIT("fst") fstIdKey +sndName = varQual pREL_TUP FSLIT("snd") sndIdKey -- Module PrelNum -numClassName = clsQual pREL_NUM_Name FSLIT("Num") numClassKey -fromIntegerName = varQual pREL_NUM_Name FSLIT("fromInteger") fromIntegerClassOpKey -minusName = varQual pREL_NUM_Name FSLIT("-") minusClassOpKey -negateName = varQual pREL_NUM_Name FSLIT("negate") negateClassOpKey -plusIntegerName = varQual pREL_NUM_Name FSLIT("plusInteger") plusIntegerIdKey -timesIntegerName = varQual pREL_NUM_Name FSLIT("timesInteger") timesIntegerIdKey -integerTyConName = wTcQual pREL_NUM_Name FSLIT("Integer") integerTyConKey -smallIntegerDataConName = wDataQual pREL_NUM_Name FSLIT("S#") smallIntegerDataConKey -largeIntegerDataConName = wDataQual pREL_NUM_Name FSLIT("J#") largeIntegerDataConKey +numClassName = clsQual pREL_NUM FSLIT("Num") numClassKey +fromIntegerName = methName numClassName FSLIT("fromInteger") fromIntegerClassOpKey +minusName = methName numClassName FSLIT("-") minusClassOpKey +negateName = methName numClassName FSLIT("negate") negateClassOpKey +plusIntegerName = varQual pREL_NUM FSLIT("plusInteger") plusIntegerIdKey +timesIntegerName = varQual pREL_NUM FSLIT("timesInteger") timesIntegerIdKey +integerTyConName = tcQual pREL_NUM FSLIT("Integer") integerTyConKey +smallIntegerDataConName = conName integerTyConName FSLIT("S#") smallIntegerDataConKey +largeIntegerDataConName = conName integerTyConName FSLIT("J#") largeIntegerDataConKey -- PrelReal types and classes -rationalTyConName = tcQual pREL_REAL_Name FSLIT("Rational") rationalTyConKey -ratioTyConName = tcQual pREL_REAL_Name FSLIT("Ratio") ratioTyConKey -ratioDataConName = dataQual pREL_REAL_Name FSLIT(":%") ratioDataConKey -realClassName = clsQual pREL_REAL_Name FSLIT("Real") realClassKey -integralClassName = clsQual pREL_REAL_Name FSLIT("Integral") integralClassKey -realFracClassName = clsQual pREL_REAL_Name FSLIT("RealFrac") realFracClassKey -fractionalClassName = clsQual pREL_REAL_Name FSLIT("Fractional") fractionalClassKey -fromRationalName = varQual pREL_REAL_Name FSLIT("fromRational") fromRationalClassOpKey +rationalTyConName = tcQual pREL_REAL FSLIT("Rational") rationalTyConKey +ratioTyConName = tcQual pREL_REAL FSLIT("Ratio") ratioTyConKey +ratioDataConName = conName ratioTyConName FSLIT(":%") ratioDataConKey +realClassName = clsQual pREL_REAL FSLIT("Real") realClassKey +integralClassName = clsQual pREL_REAL FSLIT("Integral") integralClassKey +realFracClassName = clsQual pREL_REAL FSLIT("RealFrac") realFracClassKey +fractionalClassName = clsQual pREL_REAL FSLIT("Fractional") fractionalClassKey +fromRationalName = methName fractionalClassName FSLIT("fromRational") fromRationalClassOpKey -- PrelFloat classes -floatTyConName = wTcQual pREL_FLOAT_Name FSLIT("Float") floatTyConKey -floatDataConName = wDataQual pREL_FLOAT_Name FSLIT("F#") floatDataConKey -doubleTyConName = wTcQual pREL_FLOAT_Name FSLIT("Double") doubleTyConKey -doubleDataConName = wDataQual pREL_FLOAT_Name FSLIT("D#") doubleDataConKey -floatingClassName = clsQual pREL_FLOAT_Name FSLIT("Floating") floatingClassKey -realFloatClassName = clsQual pREL_FLOAT_Name FSLIT("RealFloat") realFloatClassKey +floatingClassName = clsQual pREL_FLOAT FSLIT("Floating") floatingClassKey +realFloatClassName = clsQual pREL_FLOAT FSLIT("RealFloat") realFloatClassKey -- Class Ix -ixClassName = clsQual pREL_ARR_Name FSLIT("Ix") ixClassKey +ixClassName = clsQual pREL_ARR FSLIT("Ix") ixClassKey -- Class Typeable and Data -typeableClassName = clsQual tYPEABLE_Name FSLIT("Typeable") typeableClassKey -dataClassName = clsQual gENERICS_Name FSLIT("Data") dataClassKey +typeableClassName = clsQual tYPEABLE FSLIT("Typeable") typeableClassKey +dataClassName = clsQual gENERICS FSLIT("Data") dataClassKey + +-- Error module +assertErrorName = varQual pREL_ERR FSLIT("assertError") assertErrorIdKey -- Enum module (Enum, Bounded) -enumClassName = clsQual pREL_ENUM_Name FSLIT("Enum") enumClassKey -enumFromName = varQual pREL_ENUM_Name FSLIT("enumFrom") enumFromClassOpKey -enumFromToName = varQual pREL_ENUM_Name FSLIT("enumFromTo") enumFromToClassOpKey -enumFromThenName = varQual pREL_ENUM_Name FSLIT("enumFromThen") enumFromThenClassOpKey -enumFromThenToName = varQual pREL_ENUM_Name FSLIT("enumFromThenTo") enumFromThenToClassOpKey -boundedClassName = clsQual pREL_ENUM_Name FSLIT("Bounded") boundedClassKey +enumClassName = clsQual pREL_ENUM FSLIT("Enum") enumClassKey +enumFromName = methName enumClassName FSLIT("enumFrom") enumFromClassOpKey +enumFromToName = methName enumClassName FSLIT("enumFromTo") enumFromToClassOpKey +enumFromThenName = methName enumClassName FSLIT("enumFromThen") enumFromThenClassOpKey +enumFromThenToName = methName enumClassName FSLIT("enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual pREL_ENUM FSLIT("Bounded") boundedClassKey -- List functions -concatName = varQual pREL_LIST_Name FSLIT("concat") concatIdKey -filterName = varQual pREL_LIST_Name FSLIT("filter") filterIdKey -zipName = varQual pREL_LIST_Name FSLIT("zip") zipIdKey +concatName = varQual pREL_LIST FSLIT("concat") concatIdKey +filterName = varQual pREL_LIST FSLIT("filter") filterIdKey +zipName = varQual pREL_LIST FSLIT("zip") zipIdKey -- Class Show -showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey +showClassName = clsQual pREL_SHOW FSLIT("Show") showClassKey -- Class Read -readClassName = clsQual pREL_READ_Name FSLIT("Read") readClassKey +readClassName = clsQual pREL_READ FSLIT("Read") readClassKey -- parallel array types and functions -enumFromToPName = varQual pREL_PARR_Name FSLIT("enumFromToP") enumFromToPIdKey -enumFromThenToPName= varQual pREL_PARR_Name FSLIT("enumFromThenToP") enumFromThenToPIdKey -parrTyConName = wTcQual pREL_PARR_Name FSLIT("[::]") parrTyConKey -parrDataConName = wDataQual pREL_PARR_Name FSLIT("PArr") parrDataConKey -nullPName = varQual pREL_PARR_Name FSLIT("nullP") nullPIdKey -lengthPName = varQual pREL_PARR_Name FSLIT("lengthP") lengthPIdKey -replicatePName = varQual pREL_PARR_Name FSLIT("replicateP") replicatePIdKey -mapPName = varQual pREL_PARR_Name FSLIT("mapP") mapPIdKey -filterPName = varQual pREL_PARR_Name FSLIT("filterP") filterPIdKey -zipPName = varQual pREL_PARR_Name FSLIT("zipP") zipPIdKey -crossPName = varQual pREL_PARR_Name FSLIT("crossP") crossPIdKey -indexPName = varQual pREL_PARR_Name FSLIT("!:") indexPIdKey -toPName = varQual pREL_PARR_Name FSLIT("toP") toPIdKey -bpermutePName = varQual pREL_PARR_Name FSLIT("bpermuteP") bpermutePIdKey -bpermuteDftPName = varQual pREL_PARR_Name FSLIT("bpermuteDftP") bpermuteDftPIdKey -indexOfPName = varQual pREL_PARR_Name FSLIT("indexOfP") indexOfPIdKey +enumFromToPName = varQual pREL_PARR FSLIT("enumFromToP") enumFromToPIdKey +enumFromThenToPName= varQual pREL_PARR FSLIT("enumFromThenToP") enumFromThenToPIdKey +nullPName = varQual pREL_PARR FSLIT("nullP") nullPIdKey +lengthPName = varQual pREL_PARR FSLIT("lengthP") lengthPIdKey +replicatePName = varQual pREL_PARR FSLIT("replicateP") replicatePIdKey +mapPName = varQual pREL_PARR FSLIT("mapP") mapPIdKey +filterPName = varQual pREL_PARR FSLIT("filterP") filterPIdKey +zipPName = varQual pREL_PARR FSLIT("zipP") zipPIdKey +crossPName = varQual pREL_PARR FSLIT("crossP") crossPIdKey +indexPName = varQual pREL_PARR FSLIT("!:") indexPIdKey +toPName = varQual pREL_PARR FSLIT("toP") toPIdKey +bpermutePName = varQual pREL_PARR FSLIT("bpermuteP") bpermutePIdKey +bpermuteDftPName = varQual pREL_PARR FSLIT("bpermuteDftP") bpermuteDftPIdKey +indexOfPName = varQual pREL_PARR FSLIT("indexOfP") indexOfPIdKey -- IOBase things -ioTyConName = tcQual pREL_IO_BASE_Name FSLIT("IO") ioTyConKey -ioDataConName = dataQual pREL_IO_BASE_Name FSLIT("IO") ioDataConKey -thenIOName = varQual pREL_IO_BASE_Name FSLIT("thenIO") thenIOIdKey -bindIOName = varQual pREL_IO_BASE_Name FSLIT("bindIO") bindIOIdKey -returnIOName = varQual pREL_IO_BASE_Name FSLIT("returnIO") returnIOIdKey -failIOName = varQual pREL_IO_BASE_Name FSLIT("failIO") failIOIdKey +ioTyConName = tcQual pREL_IO_BASE FSLIT("IO") ioTyConKey +ioDataConName = conName ioTyConName FSLIT("IO") ioDataConKey +thenIOName = varQual pREL_IO_BASE FSLIT("thenIO") thenIOIdKey +bindIOName = varQual pREL_IO_BASE FSLIT("bindIO") bindIOIdKey +returnIOName = varQual pREL_IO_BASE FSLIT("returnIO") returnIOIdKey +failIOName = varQual pREL_IO_BASE FSLIT("failIO") failIOIdKey -- IO things -printName = varQual sYSTEM_IO_Name FSLIT("print") printIdKey +printName = varQual sYSTEM_IO FSLIT("print") printIdKey -- Int, Word, and Addr things -int8TyConName = tcQual pREL_INT_Name FSLIT("Int8") int8TyConKey -int16TyConName = tcQual pREL_INT_Name FSLIT("Int16") int16TyConKey -int32TyConName = tcQual pREL_INT_Name FSLIT("Int32") int32TyConKey -int64TyConName = tcQual pREL_INT_Name FSLIT("Int64") int64TyConKey +int8TyConName = tcQual pREL_INT FSLIT("Int8") int8TyConKey +int16TyConName = tcQual pREL_INT FSLIT("Int16") int16TyConKey +int32TyConName = tcQual pREL_INT FSLIT("Int32") int32TyConKey +int64TyConName = tcQual pREL_INT FSLIT("Int64") int64TyConKey -- Word module -word8TyConName = tcQual pREL_WORD_Name FSLIT("Word8") word8TyConKey -word16TyConName = tcQual pREL_WORD_Name FSLIT("Word16") word16TyConKey -word32TyConName = tcQual pREL_WORD_Name FSLIT("Word32") word32TyConKey -word64TyConName = tcQual pREL_WORD_Name FSLIT("Word64") word64TyConKey -wordTyConName = wTcQual pREL_WORD_Name FSLIT("Word") wordTyConKey -wordDataConName = wDataQual pREL_WORD_Name FSLIT("W#") wordDataConKey +word8TyConName = tcQual pREL_WORD FSLIT("Word8") word8TyConKey +word16TyConName = tcQual pREL_WORD FSLIT("Word16") word16TyConKey +word32TyConName = tcQual pREL_WORD FSLIT("Word32") word32TyConKey +word64TyConName = tcQual pREL_WORD FSLIT("Word64") word64TyConKey +wordTyConName = tcQual pREL_WORD FSLIT("Word") wordTyConKey +wordDataConName = conName wordTyConName FSLIT("W#") wordDataConKey -- Addr module -addrTyConName = tcQual aDDR_Name FSLIT("Addr") addrTyConKey +addrTyConName = tcQual aDDR FSLIT("Addr") addrTyConKey -- PrelPtr module -ptrTyConName = tcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey -funPtrTyConName = tcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey +ptrTyConName = tcQual pREL_PTR FSLIT("Ptr") ptrTyConKey +funPtrTyConName = tcQual pREL_PTR FSLIT("FunPtr") funPtrTyConKey -- Byte array types -byteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("ByteArray") byteArrayTyConKey -mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("MutableByteArray") mutableByteArrayTyConKey +byteArrayTyConName = tcQual pREL_BYTEARR FSLIT("ByteArray") byteArrayTyConKey +mutableByteArrayTyConName = tcQual pREL_BYTEARR FSLIT("MutableByteArray") mutableByteArrayTyConKey -- Foreign objects and weak pointers -stablePtrTyConName = tcQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrTyConKey -newStablePtrName = varQual pREL_STABLE_Name FSLIT("newStablePtr") newStablePtrIdKey - --- Error module -errorName = wVarQual pREL_ERR_Name FSLIT("error") errorIdKey -assertErrorName = wVarQual pREL_ERR_Name FSLIT("assertError") assertErrorIdKey -recSelErrorName = wVarQual pREL_ERR_Name FSLIT("recSelError") recSelErrorIdKey -runtimeErrorName = wVarQual pREL_ERR_Name FSLIT("runtimeError") runtimeErrorIdKey -irrefutPatErrorName = wVarQual pREL_ERR_Name FSLIT("irrefutPatError") irrefutPatErrorIdKey -recConErrorName = wVarQual pREL_ERR_Name FSLIT("recConError") recConErrorIdKey -patErrorName = wVarQual pREL_ERR_Name FSLIT("patError") patErrorIdKey -noMethodBindingErrorName = wVarQual pREL_ERR_Name FSLIT("noMethodBindingError") noMethodBindingErrorIdKey -nonExhaustiveGuardsErrorName - = wVarQual pREL_ERR_Name FSLIT("nonExhaustiveGuardsError") nonExhaustiveGuardsErrorIdKey +stablePtrTyConName = tcQual pREL_STABLE FSLIT("StablePtr") stablePtrTyConKey +newStablePtrName = varQual pREL_STABLE FSLIT("newStablePtr") newStablePtrIdKey -- PrelST module -runSTRepName = varQual pREL_ST_Name FSLIT("runSTRep") runSTRepIdKey +runSTRepName = varQual pREL_ST FSLIT("runSTRep") runSTRepIdKey -- The "split" Id for splittable implicit parameters -splitName = varQual gLA_EXTS_Name FSLIT("split") splitIdKey +splitName = varQual gLA_EXTS FSLIT("split") splitIdKey -- Recursive-do notation -mfixName = varQual mONAD_FIX_Name FSLIT("mfix") mfixIdKey +mfixName = varQual mONAD_FIX FSLIT("mfix") mfixIdKey -- Arrow notation -arrAName = varQual aRROW_Name FSLIT("arr") arrAIdKey -composeAName = varQual aRROW_Name FSLIT(">>>") composeAIdKey -firstAName = varQual aRROW_Name FSLIT("first") firstAIdKey -appAName = varQual aRROW_Name FSLIT("app") appAIdKey -choiceAName = varQual aRROW_Name FSLIT("|||") choiceAIdKey -loopAName = varQual aRROW_Name FSLIT("loop") loopAIdKey +arrAName = varQual aRROW FSLIT("arr") arrAIdKey +composeAName = varQual aRROW FSLIT(">>>") composeAIdKey +firstAName = varQual aRROW FSLIT("first") firstAIdKey +appAName = varQual aRROW FSLIT("app") appAIdKey +choiceAName = varQual aRROW FSLIT("|||") choiceAIdKey +loopAName = varQual aRROW FSLIT("loop") loopAIdKey -- dotnet interop -objectTyConName = wTcQual dOTNET_Name FSLIT("Object") objectTyConKey -unmarshalObjectName = varQual dOTNET_Name FSLIT("unmarshalObject") unmarshalObjectIdKey -marshalObjectName = varQual dOTNET_Name FSLIT("marshalObject") marshalObjectIdKey -marshalStringName = varQual dOTNET_Name FSLIT("marshalString") marshalStringIdKey -unmarshalStringName = varQual dOTNET_Name FSLIT("unmarshalString") unmarshalStringIdKey -checkDotnetResName = varQual dOTNET_Name FSLIT("checkResult") checkDotnetResNameIdKey - +objectTyConName = tcQual dOTNET FSLIT("Object") objectTyConKey + -- objectTyConName was "wTcQual", but that's gone now, and + -- I can't see why it was wired in anyway... +unmarshalObjectName = varQual dOTNET FSLIT("unmarshalObject") unmarshalObjectIdKey +marshalObjectName = varQual dOTNET FSLIT("marshalObject") marshalObjectIdKey +marshalStringName = varQual dOTNET FSLIT("marshalString") marshalStringIdKey +unmarshalStringName = varQual dOTNET FSLIT("unmarshalString") unmarshalStringIdKey +checkDotnetResName = varQual dOTNET FSLIT("checkResult") checkDotnetResNameIdKey \end{code} %************************************************************************ @@ -732,29 +677,22 @@ All these are original names; hence mkOrig \begin{code} varQual = mk_known_key_name varName -dataQual = mk_known_key_name dataName -- All the constructor names here are for the DataCon - -- itself, which lives in the VarName name space tcQual = mk_known_key_name tcName clsQual = mk_known_key_name clsName -wVarQual = mk_wired_in_name varName -- The wired-in analogues -wDataQual = mk_wired_in_name dataName -wTcQual = mk_wired_in_name tcName - -varQual_RDR mod str = mkOrig mod (mkOccFS varName str) -- The RDR analogues -dataQual_RDR mod str = mkOrig mod (mkOccFS dataName str) -tcQual_RDR mod str = mkOrig mod (mkOccFS tcName str) -clsQual_RDR mod str = mkOrig mod (mkOccFS clsName str) - mk_known_key_name space mod str uniq - = mkKnownKeyExternalName (mkBasePkgModule mod) (mkOccFS space str) uniq -mk_wired_in_name space mod str uniq - = mkWiredInName (mkBasePkgModule mod) (mkOccFS space str) uniq - -kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) noSrcLoc - -- Kinds are not z-encoded in interface file, hence mkKindOccFS - -- And they don't come from any particular module; indeed we always - -- want to print them unqualified. Hence the LocalName + = mkExternalName uniq mod (mkOccFS space str) + Nothing noSrcLoc + +conName :: Name -> FastString -> Unique -> Name +conName tycon occ uniq + = mkExternalName uniq (nameModule tycon) (mkOccFS dataName occ) + (Just tycon) noSrcLoc + +methName :: Name -> FastString -> Unique -> Name +methName cls occ uniq + = mkExternalName uniq (nameModule cls) (mkOccFS varName occ) + (Just cls) noSrcLoc \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 94d42a074c..a9ac056139 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -7,7 +7,7 @@ module PrimOp ( PrimOp(..), allThePrimOps, primOpType, primOpSig, primOpArity, - mkPrimOpIdName, primOpTag, primOpOcc, + primOpTag, maxPrimOpTag, primOpOcc, commutableOp, @@ -15,12 +15,7 @@ module PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, primOpHasSideEffects, - getPrimOpResultInfo, PrimOpResultInfo(..), - - eqCharName, eqIntName, neqIntName, - ltCharName, eqWordName, ltWordName, eqAddrName, ltAddrName, - eqFloatName, ltFloatName, eqDoubleName, ltDoubleName, - ltIntName, geIntName, leIntName, minusIntName, tagToEnumName + getPrimOpResultInfo, PrimOpResultInfo(..) ) where #include "HsVersions.h" @@ -31,14 +26,10 @@ import TysWiredIn import NewDemand import Var ( TyVar ) -import Name ( Name, mkWiredInName ) import OccName ( OccName, pprOccName, mkVarOcc ) import TyCon ( TyCon, isPrimTyCon, tyConPrimRep ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, tyConAppTyCon ) -import PprType () -- get at Outputable Type instance. -import Unique ( mkPrimOpIdUnique ) import BasicTypes ( Arity, Boxity(..) ) -import PrelNames ( gHC_PRIM ) import Outputable import FastTypes \end{code} @@ -90,6 +81,7 @@ instance Show PrimOp where \end{code} An @Enum@-derived list would be better; meanwhile... (ToDo) + \begin{code} allThePrimOps :: [PrimOp] allThePrimOps = @@ -394,19 +386,12 @@ primOpType op GenPrimOp occ tyvars arg_tys res_ty -> mkForAllTys tyvars (mkFunTys arg_tys res_ty) -mkPrimOpIdName :: PrimOp -> Name - -- Make the name for the PrimOp's Id - -- We have to pass in the Id itself because it's a WiredInId - -- and hence recursive -mkPrimOpIdName op - = mkWiredInName gHC_PRIM (primOpOcc op) (mkPrimOpIdUnique (primOpTag op)) - primOpOcc :: PrimOp -> OccName primOpOcc op = case (primOpInfo op) of - Dyadic occ _ -> occ - Monadic occ _ -> occ - Compare occ _ -> occ - GenPrimOp occ _ _ _ -> occ + Dyadic occ _ -> occ + Monadic occ _ -> occ + Compare occ _ -> occ + GenPrimOp occ _ _ _ -> occ -- primOpSig is like primOpType but gives the result split apart: -- (type variables, argument types, result type) @@ -471,35 +456,3 @@ pprPrimOp :: PrimOp -> SDoc pprPrimOp other_op = pprOccName (primOpOcc other_op) \end{code} - -%************************************************************************ -%* * - Names for some primops (for ndpFlatten/FlattenMonad.lhs) -%* * -%************************************************************************ - -\begin{code} -eqIntName = mkPrimOpIdName IntEqOp -ltIntName = mkPrimOpIdName IntLtOp -geIntName = mkPrimOpIdName IntGeOp -leIntName = mkPrimOpIdName IntLeOp -neqIntName = mkPrimOpIdName IntNeOp -minusIntName = mkPrimOpIdName IntSubOp - -eqCharName = mkPrimOpIdName CharEqOp -ltCharName = mkPrimOpIdName CharLtOp - -eqFloatName = mkPrimOpIdName FloatEqOp -ltFloatName = mkPrimOpIdName FloatLtOp - -eqDoubleName = mkPrimOpIdName DoubleEqOp -ltDoubleName = mkPrimOpIdName DoubleLtOp - -eqWordName = mkPrimOpIdName WordEqOp -ltWordName = mkPrimOpIdName WordLtOp - -eqAddrName = mkPrimOpIdName AddrEqOp -ltAddrName = mkPrimOpIdName AddrLtOp - -tagToEnumName = mkPrimOpIdName TagToEnumOp -\end{code} diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 9ba2887375..fab63e5011 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -45,18 +45,19 @@ module TysPrim( #include "HsVersions.h" import Var ( TyVar, mkTyVar ) -import Name ( Name, mkInternalName ) -import OccName ( mkVarOcc ) +import Name ( Name, mkInternalName, mkWiredInName ) +import OccName ( mkVarOcc, mkOccFS, tcName ) import PrimRep ( PrimRep(..) ) import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon ) import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, unliftedTypeKind, liftedTypeKind, openTypeKind, - Kind, mkArrowKinds + Kind, mkArrowKinds, + TyThing(..) ) import SrcLoc ( noSrcLoc ) import Unique ( mkAlphaTyVarUnique ) import PrelNames -import FastString ( mkFastString ) +import FastString ( FastString, mkFastString ) import Outputable import Char ( ord, chr ) @@ -96,8 +97,39 @@ primTyCons , word32PrimTyCon , word64PrimTyCon ] -\end{code} +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc fs uniq tycon + = mkWiredInName gHC_PRIM (mkOccFS tcName fs) + uniq + Nothing -- No parent object + (ATyCon tycon) -- Relevant TyCon + +charPrimTyConName = mkPrimTc FSLIT("Char#") charPrimTyConKey charPrimTyCon +intPrimTyConName = mkPrimTc FSLIT("Int#") intPrimTyConKey intPrimTyCon +int32PrimTyConName = mkPrimTc FSLIT("Int32#") int32PrimTyConKey int32PrimTyCon +int64PrimTyConName = mkPrimTc FSLIT("Int64#") int64PrimTyConKey int64PrimTyCon +wordPrimTyConName = mkPrimTc FSLIT("Word#") wordPrimTyConKey wordPrimTyCon +word32PrimTyConName = mkPrimTc FSLIT("Word32#") word32PrimTyConKey word32PrimTyCon +word64PrimTyConName = mkPrimTc FSLIT("Word64#") word64PrimTyConKey word64PrimTyCon +addrPrimTyConName = mkPrimTc FSLIT("Addr#") addrPrimTyConKey addrPrimTyCon +floatPrimTyConName = mkPrimTc FSLIT("Float#") floatPrimTyConKey floatPrimTyCon +doublePrimTyConName = mkPrimTc FSLIT("Double#") doublePrimTyConKey doublePrimTyCon +statePrimTyConName = mkPrimTc FSLIT("State#") statePrimTyConKey statePrimTyCon +realWorldTyConName = mkPrimTc FSLIT("RealWorld") realWorldTyConKey realWorldTyCon +arrayPrimTyConName = mkPrimTc FSLIT("Array#") arrayPrimTyConKey arrayPrimTyCon +byteArrayPrimTyConName = mkPrimTc FSLIT("ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon +mutableArrayPrimTyConName = mkPrimTc FSLIT("MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon +mutableByteArrayPrimTyConName = mkPrimTc FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon +mutVarPrimTyConName = mkPrimTc FSLIT("MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +mVarPrimTyConName = mkPrimTc FSLIT("MVar#") mVarPrimTyConKey mVarPrimTyCon +stablePtrPrimTyConName = mkPrimTc FSLIT("StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon +stableNamePrimTyConName = mkPrimTc FSLIT("StableName#") stableNamePrimTyConKey stableNamePrimTyCon +foreignObjPrimTyConName = mkPrimTc FSLIT("ForeignObj#") foreignObjPrimTyConKey foreignObjPrimTyCon +bcoPrimTyConName = mkPrimTc FSLIT("BCO#") bcoPrimTyConKey bcoPrimTyCon +weakPrimTyConName = mkPrimTc FSLIT("Weak#") weakPrimTyConKey weakPrimTyCon +threadIdPrimTyConName = mkPrimTc FSLIT("ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon +\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 2975922af8..4d8de984e3 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -11,35 +11,26 @@ types and operations.'' \begin{code} module TysWiredIn ( - wiredInTyCons, genericTyCons, - - boolTy, - boolTyCon, - charDataCon, - charTy, - charTyCon, - consDataCon, - doubleDataCon, - doubleTy, - doubleTyCon, - falseDataCon, falseDataConId, - floatDataCon, - floatTy, - floatTyCon, - - intDataCon, - intTy, - intTyCon, + wiredInTyCons, + + boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, + trueDataCon, trueDataConId, true_RDR, + falseDataCon, falseDataConId, false_RDR, + + charTyCon, charDataCon, charTyCon_RDR, + charTy, stringTy, charTyConName, - integerTy, - integerTyCon, - smallIntegerDataCon, - largeIntegerDataCon, + + doubleTyCon, doubleDataCon, doubleTy, + + floatTyCon, floatDataCon, floatTy, - listTyCon, + intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, + intTy, + listTyCon, nilDataCon, consDataCon, + listTyCon_RDR, consDataCon_RDR, listTyConName, mkListTy, - nilDataCon, -- tuples mkTupleTy, @@ -48,28 +39,18 @@ module TysWiredIn ( unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, - -- Generics - genUnitTyCon, genUnitDataCon, - plusTyCon, inrDataCon, inlDataCon, - crossTyCon, crossDataCon, - - stringTy, - trueDataCon, trueDataConId, unitTy, voidTy, - wordDataCon, - wordTy, - wordTyCon, -- parallel arrays mkPArrTy, - parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon + parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, + parrTyCon_RDR, parrTyConName ) where #include "HsVersions.h" -import {-# SOURCE #-} MkId( mkDataConWorkId ) -import {-# SOURCE #-} Generics( mkTyConGenInfo ) +import {-# SOURCE #-} MkId( mkDataConIds ) -- friends: import PrelNames @@ -77,30 +58,31 @@ import TysPrim -- others: import Constants ( mAX_TUPLE_SIZE ) -import Module ( mkBasePkgModule ) +import Module ( Module ) +import RdrName ( nameRdrName ) import Name ( Name, nameUnique, nameOccName, nameModule, mkWiredInName ) -import OccName ( mkOccFS, tcName, dataName, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 ) +import OccName ( mkOccFS, tcName, dataName, mkTupleOcc, mkDataConWorkerOcc ) import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, mkTupleTyCon, mkAlgTyCon, tyConName ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, - ThetaType ) + ThetaType, TyThing(..) ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import PrelNames import Array import FastString +import Outputable -alpha_tyvar = [alphaTyVar] -alpha_ty = [alphaTy] -alpha_beta_tyvars = [alphaTyVar, betaTyVar] +alpha_tyvar = [alphaTyVar] +alpha_ty = [alphaTy] \end{code} @@ -114,26 +96,65 @@ If you change which things are wired in, make sure you change their names in PrelNames, so they use wTcQual, wDataQual, etc \begin{code} -wiredInTyCons :: [TyCon] -wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons - -data_tycons = genericTyCons ++ - [ boolTyCon +wiredInTyCons :: [TyCon] -- Excludes tuples +wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because + -- it's defined in GHC.Base, and there's only + -- one of it. We put it in wiredInTyCons so + -- that it'll pre-populate the name cache, so + -- the special case in lookupOrigNameCache + -- doesn't need to look out for it + , boolTyCon , charTyCon , doubleTyCon , floatTyCon , intTyCon - , integerTyCon , listTyCon , parrTyCon - , wordTyCon ] +\end{code} -genericTyCons :: [TyCon] -genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ] - -tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..mAX_TUPLE_SIZE] ] -unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ] +\begin{code} +mkWiredInTyConName :: Module -> FastString -> Unique -> TyCon -> Name +mkWiredInTyConName mod fs uniq tycon + = mkWiredInName mod (mkOccFS tcName fs) uniq + Nothing -- No parent object + (ATyCon tycon) -- Relevant TyCon + +mkWiredInDataConName :: Module -> FastString -> Unique -> DataCon -> Name -> Name +mkWiredInDataConName mod fs uniq datacon parent + = mkWiredInName mod (mkOccFS dataName fs) uniq + (Just parent) -- Name of parent TyCon + (ADataCon datacon) -- Relevant DataCon + +charTyConName = mkWiredInTyConName pREL_BASE FSLIT("Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName pREL_BASE FSLIT("C#") charDataConKey charDataCon charTyConName +intTyConName = mkWiredInTyConName pREL_BASE FSLIT("Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName pREL_BASE FSLIT("I#") intDataConKey intDataCon intTyConName + +boolTyConName = mkWiredInTyConName pREL_BASE FSLIT("Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName pREL_BASE FSLIT("False") falseDataConKey falseDataCon boolTyConName +trueDataConName = mkWiredInDataConName pREL_BASE FSLIT("True") trueDataConKey trueDataCon boolTyConName +listTyConName = mkWiredInTyConName pREL_BASE FSLIT("[]") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName pREL_BASE FSLIT("[]") nilDataConKey nilDataCon listTyConName +consDataConName = mkWiredInDataConName pREL_BASE FSLIT(":") consDataConKey consDataCon listTyConName + +floatTyConName = mkWiredInTyConName pREL_FLOAT FSLIT("Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName pREL_FLOAT FSLIT("F#") floatDataConKey floatDataCon floatTyConName +doubleTyConName = mkWiredInTyConName pREL_FLOAT FSLIT("Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName pREL_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon doubleTyConName + +parrTyConName = mkWiredInTyConName pREL_PARR FSLIT("[::]") parrTyConKey parrTyCon +parrDataConName = mkWiredInDataConName pREL_PARR FSLIT("PArr") parrDataConKey parrDataCon parrTyConName + +boolTyCon_RDR = nameRdrName boolTyConName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +intTyCon_RDR = nameRdrName intTyConName +charTyCon_RDR = nameRdrName charTyConName +intDataCon_RDR = nameRdrName intDataConName +listTyCon_RDR = nameRdrName listTyConName +consDataCon_RDR = nameRdrName consDataConName +parrTyCon_RDR = nameRdrName parrTyConName \end{code} @@ -144,39 +165,22 @@ unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ] %************************************************************************ \begin{code} -pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive -pcRecDataTyCon = pcTyCon DataTyCon Recursive +pcNonRecDataTyCon = pcTyCon False NonRecursive +pcRecDataTyCon = pcTyCon False Recursive -pcTyCon new_or_data is_rec name tyvars argvrcs cons +pcTyCon is_enum is_rec name tyvars argvrcs cons = tycon where - tycon = mkAlgTyCon name kind + tycon = mkAlgTyCon name + (mkArrowKinds (map tyVarKind tyvars) liftedTypeKind) tyvars [] -- No context argvrcs (DataCons cons) [] -- No record selectors - new_or_data + (DataTyCon is_enum) is_rec - gen_info - - mod = nameModule name - kind = mkArrowKinds (map tyVarKind tyvars) liftedTypeKind - gen_info = mk_tc_gen_info mod (nameUnique name) name tycon - --- We generate names for the generic to/from Ids by incrementing --- the TyCon unique. So each Prelude tycon needs 3 slots, one --- for itself and two more for the generic Ids. -mk_tc_gen_info mod tc_uniq tc_name tycon - = mkTyConGenInfo tycon [name1, name2] - where - tc_occ_name = nameOccName tc_name - occ_name1 = mkGenOcc1 tc_occ_name - occ_name2 = mkGenOcc2 tc_occ_name - fn1_key = incrUnique tc_uniq - fn2_key = incrUnique fn1_key - name1 = mkWiredInName mod occ_name1 fn1_key - name2 = mkWiredInName mod occ_name2 fn2_key + True -- All the wired-in tycons have generics pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name @@ -190,17 +194,19 @@ pcDataCon dc_name tyvars context arg_tys tycon = data_con where data_con = mkDataCon dc_name - [{- No strictness -}] + (map (const NotMarkedStrict) arg_tys) [{- No labelled fields -}] - tyvars context [] [] arg_tys tycon work_id - Nothing {- No wrapper for wired-in things - (they are too simple to need one) -} + tyvars context [] [] arg_tys tycon + (mkDataConIds bogus_wrap_name wrk_name data_con) mod = nameModule dc_name wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) wrk_key = incrUnique (nameUnique dc_name) wrk_name = mkWiredInName mod wrk_occ wrk_key - work_id = mkDataConWorkId wrk_name data_con + (Just (tyConName tycon)) + (AnId (dataConWorkId data_con)) + bogus_wrap_name = pprPanic "Wired-in data wrapper id" (ppr dc_name) + -- Wired-in types are too simple to need wrappers \end{code} @@ -229,7 +235,9 @@ mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) where tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info - tc_name = mkWiredInName mod (mkOccFS tcName name_str) tc_uniq + mod = mkTupleModule boxity arity + tc_name = mkWiredInName mod (mkTupleOcc tcName boxity arity) tc_uniq + Nothing (ATyCon tycon) tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind res_kind | isBoxed boxity = liftedTypeKind | otherwise = unliftedTypeKind @@ -237,14 +245,14 @@ mk_tuple boxity arity = (tycon, tuple_con) tyvars | isBoxed boxity = take arity alphaTyVars | otherwise = take arity openAlphaTyVars - tuple_con = pcDataCon name tyvars [] tyvar_tys tycon + tuple_con = pcDataCon dc_name tyvars [] tyvar_tys tycon tyvar_tys = mkTyVarTys tyvars - (mod_name, name_str) = mkTupNameStr boxity arity - name = mkWiredInName mod (mkOccFS dataName name_str) dc_uniq + dc_name = mkWiredInName mod (mkTupleOcc dataName boxity arity) dc_uniq + (Just tc_name) (ADataCon tuple_con) tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity - mod = mkBasePkgModule mod_name - gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon + gen_info = True -- Tuples all have generics.. + -- hmm: that's a *lot* of code unitTyCon = tupleTyCon Boxed 0 unitDataCon = head (tyConDataCons unitTyCon) @@ -298,13 +306,6 @@ intDataCon = pcDataCon intDataConName [] [] [intPrimTy] intTyCon \end{code} \begin{code} -wordTy = mkTyConTy wordTyCon - -wordTyCon = pcNonRecDataTyCon wordTyConName [] [] [wordDataCon] -wordDataCon = pcDataCon wordDataConName [] [] [wordPrimTy] wordTyCon -\end{code} - -\begin{code} floatTy = mkTyConTy floatTyCon floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] @@ -321,27 +322,6 @@ doubleDataCon = pcDataCon doubleDataConName [] [] [doublePrimTy] doubleTyCon %************************************************************************ %* * -\subsection[TysWiredIn-Integer]{@Integer@ and its related ``pairing'' types} -%* * -%************************************************************************ - -@Integer@ and its pals are not really primitive. @Integer@ itself, first: -\begin{code} -integerTy :: Type -integerTy = mkTyConTy integerTyCon - -integerTyCon = pcNonRecDataTyCon integerTyConName - [] [] [smallIntegerDataCon, largeIntegerDataCon] - -smallIntegerDataCon = pcDataCon smallIntegerDataConName - [] [] [intPrimTy] integerTyCon -largeIntegerDataCon = pcDataCon largeIntegerDataConName - [] [] [intPrimTy, byteArrayPrimTy] integerTyCon -\end{code} - - -%************************************************************************ -%* * \subsection[TysWiredIn-Bool]{The @Bool@ type} %* * %************************************************************************ @@ -391,7 +371,7 @@ primitive counterpart. \begin{code} boolTy = mkTyConTy boolTyCon -boolTyCon = pcTyCon EnumTyCon NonRecursive boolTyConName +boolTyCon = pcTyCon True NonRecursive boolTyConName [] [] [falseDataCon, trueDataCon] falseDataCon = pcDataCon falseDataConName [] [] [] boolTyCon @@ -508,23 +488,7 @@ mkPArrTy ty = mkTyConApp parrTyCon [ty] -- `PrelPArr'. -- parrTyCon :: TyCon -parrTyCon = tycon - where - tycon = mkAlgTyCon - parrTyConName - kind - tyvars - [] -- No context - [(True, False)] - (DataCons [parrDataCon]) -- The constructor defined in `PrelPArr' - [] -- No record selectors - DataTyCon - NonRecursive - genInfo - tyvars = alpha_tyvar - mod = nameModule parrTyConName - kind = mkArrowKinds (map tyVarKind tyvars) liftedTypeKind - genInfo = mk_tc_gen_info mod (nameUnique parrTyConName) parrTyConName tycon +parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [(True, False)] [parrDataCon] parrDataCon :: DataCon parrDataCon = pcDataCon @@ -562,14 +526,15 @@ parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) -- build a fake parallel array constructor for the given arity -- mkPArrFakeCon :: Int -> DataCon -mkPArrFakeCon arity = pcDataCon name [tyvar] [] tyvarTys parrTyCon +mkPArrFakeCon arity = data_con where + data_con = pcDataCon name [tyvar] [] tyvarTys parrTyCon tyvar = head alphaTyVars tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) - name = mkWiredInName mod (mkOccFS dataName nameStr) uniq + name = mkWiredInName pREL_PARR (mkOccFS dataName nameStr) uniq + Nothing (ADataCon data_con) uniq = mkPArrDataConUnique arity - mod = mkBasePkgModule pREL_PARR_Name -- checks whether a data constructor is a fake constructor for parallel arrays -- @@ -577,37 +542,3 @@ isPArrFakeCon :: DataCon -> Bool isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) \end{code} -%************************************************************************ -%* * -\subsection{Wired In Type Constructors for Representation Types} -%* * -%************************************************************************ - -The following code defines the wired in datatypes cross, plus, unit -and c_of needed for the generic methods. - -Ok, so the basic story is that for each type constructor I need to -create 2 things - a TyCon and a DataCon and then we are basically -ok. There are going to be no arguments passed to these functions -because -well- there is nothing to pass to these functions. - -\begin{code} -crossTyCon :: TyCon -crossTyCon = pcNonRecDataTyCon crossTyConName alpha_beta_tyvars [] [crossDataCon] - -crossDataCon :: DataCon -crossDataCon = pcDataCon crossDataConName alpha_beta_tyvars [] [alphaTy, betaTy] crossTyCon - -plusTyCon :: TyCon -plusTyCon = pcNonRecDataTyCon plusTyConName alpha_beta_tyvars [] [inlDataCon, inrDataCon] - -inlDataCon, inrDataCon :: DataCon -inlDataCon = pcDataCon inlDataConName alpha_beta_tyvars [] [alphaTy] plusTyCon -inrDataCon = pcDataCon inrDataConName alpha_beta_tyvars [] [betaTy] plusTyCon - -genUnitTyCon :: TyCon -- The "1" type constructor for generics -genUnitTyCon = pcNonRecDataTyCon genUnitTyConName [] [] [genUnitDataCon] - -genUnitDataCon :: DataCon -genUnitDataCon = pcDataCon genUnitDataConName [] [] [] genUnitTyCon -\end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 461016a228..3a72f3f0d8 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -18,7 +18,7 @@ module RnBinds ( import HsSyn -import HsBinds ( eqHsSig, hsSigDoc ) +import HsBinds ( hsSigDoc, sigLoc, eqHsSig ) import RdrHsSyn import RnHsSyn import TcRnMonad @@ -33,6 +33,7 @@ import CmdLineOpts ( DynFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) import Name ( Name, nameOccName, nameSrcLoc ) import NameSet +import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) import BasicTypes ( RecFlag(..), TopLevelFlag(..), isTopLevel ) import List ( unzip4 ) @@ -154,7 +155,7 @@ rnTopMonoBinds :: RdrNameMonoBinds -> RnM (RenamedHsBinds, DefUses) -- The binders of the binding are in scope already; --- the top level scope resoluttion does that +-- the top level scope resolution does that rnTopMonoBinds mbinds sigs = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ \ _ -> @@ -199,7 +200,6 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds let all_uses = duUses bind_dus `plusFV` result_fvs bndrs = duDefs bind_dus - real_uses = findUses bind_dus result_fvs unused_bndrs = nameSetToList (bndrs `minusNameSet` all_uses) in warnUnusedLocalBinds unused_bndrs `thenM_` @@ -260,11 +260,9 @@ rnMonoBinds top_lvl mbinds sigs -- Warn about missing signatures, -- but only at top level, and not in interface mode -- (The latter is important when renaming bindings from 'deriving' clauses.) - getModeRn `thenM` \ mode -> doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs -> (if isTopLevel top_lvl && - warn_missing_sigs && - not (isInterfaceMode mode) + warn_missing_sigs then let type_sig_vars = [n | Sig n _ _ <- siglist] un_sigd_binders = filter (not . (`elem` type_sig_vars)) @@ -322,13 +320,14 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) FunMonoBind new_name inf new_matches locn, sigs_for_me )] - sigsForMe names_bound_here sigs = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs) where + -- sigForThisGroup only returns signatures for + -- which sigName returns a Just check sigs sig = case filter (eqHsSig sig) sigs of [] -> returnM (sig:sigs) - other -> dupSigDeclErr sig `thenM_` + other -> dupSigDeclErr sig other `thenM_` returnM sigs \end{code} @@ -377,7 +376,7 @@ rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) = extendTyVarEnvFVRn gen_tvs $ rnMatch (FunRhs sel_name) match where - tvs = map rdrNameOcc (extractHsTyRdrNames ty) + tvs = map rdrNameOcc (extractHsTyRdrTyVars ty) gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] rn_match sel_name match = rnMatch (FunRhs sel_name) match @@ -464,9 +463,12 @@ checkSigs ok_sig sigs -- Check for (a) duplicate signatures -- (b) signatures for things not in this group -- Well, I can't see the check for (a)... ToDo! - = mappM_ unknownSigErr bad_sigs + = mappM_ unknownSigErr (filter bad sigs) where - bad_sigs = filter (not . ok_sig) sigs + bad sig = not (ok_sig sig) && + case sigName sig of + Just n | isUnboundName n -> False -- Don't complain about an unbound name again + other -> True -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -482,7 +484,7 @@ renameSigs sigs = mappM renameSig (filter (not . isFixitySig) sigs) -- Remove fixity sigs which have been dealt with already renameSig :: Sig RdrName -> RnM (Sig Name) --- ClassOpSig, FixitSig is renamed elsewhere. +-- FixitSig is renamed elsewhere. renameSig (Sig v ty src_loc) = addSrcLoc src_loc $ lookupSigOccRn v `thenM` \ new_v -> @@ -514,12 +516,13 @@ renameSig (InlineSig b v p src_loc) %************************************************************************ \begin{code} -dupSigDeclErr sig +dupSigDeclErr sig sigs = addSrcLoc loc $ - addErr (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon, - ppr sig]) + addErr (vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, + nest 2 (vcat (map ppr_sig (sig:sigs)))]) where (what_it_is, loc) = hsSigDoc sig + ppr_sig sig = ppr (sigLoc sig) <> colon <+> ppr sig unknownSigErr sig = addSrcLoc loc $ diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 84d0f69ac0..708f509e57 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -4,56 +4,55 @@ \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} -module RnEnv where -- Export everything +module RnEnv ( + newTopSrcBinder, + lookupBndrRn,lookupTopBndrRn, + lookupOccRn, lookupGlobalOccRn, + lookupTopFixSigNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupSigOccRn, lookupInstDeclBndr, + lookupSyntaxName, lookupSyntaxNames, lookupImportedName, + + newLocalsRn, newIPNameRn, + bindLocalNames, bindLocalNamesFV, + bindLocalsRn, bindLocalsFV, bindLocatedLocalsRn, + bindPatSigTyVars, bindPatSigTyVarsFV, + bindTyVarsRn, extendTyVarEnvFVRn, + bindLocalFixities, + + checkDupNames, mapFvRn, + warnUnusedMatches, warnUnusedModules, warnUnusedImports, + warnUnusedTopBinds, warnUnusedLocalBinds, + dataTcOccs, unknownNameErr + ) where #include "HsVersions.h" -import {-# SOURCE #-} RnHiFiles( loadInterface ) - -import FlattenInfo ( namesNeededForFlattening ) +import LoadIface ( loadSrcInterface ) +import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn import RdrHsSyn ( RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrQual, setRdrNameSpace, rdrNameOcc, - lookupRdrEnv, rdrEnvToList, elemRdrEnv, - extendRdrEnv, addListToRdrEnv, emptyRdrEnv, - isExact_maybe, unqualifyRdrName + mkRdrUnqual, setRdrNameSpace, rdrNameOcc, + pprGlobalRdrEnv, lookupGRE_RdrName, + isExact_maybe, isSrcRdrName, + GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, + isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, + Provenance(..), pprNameProvenance, ImportSpec(..) ) import HsTypes ( hsTyVarName, replaceTyVarName ) -import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), - GenAvailInfo(..), AvailInfo, Avails, - ModIface(..), NameCache(..), OrigNameCache, - Deprecations(..), lookupDeprec, isLocalGRE, - extendLocalRdrEnv, availName, availNames, - lookupFixity - ) +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad -import Name ( Name, getName, nameIsLocalOrFrom, - isWiredInName, mkInternalName, mkExternalName, mkIPName, - nameSrcLoc, nameOccName, setNameSrcLoc, nameModule ) +import Name ( Name, nameIsLocalOrFrom, mkInternalName, + nameSrcLoc, nameOccName, nameModuleName, nameParent ) import NameSet -import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused ) -import Module ( Module, ModuleName, moduleName, mkHomeModule, - lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) -import PrelNames ( mkUnboundName, intTyConName, - boolTyConName, funTyConName, - unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - eqStringName, printName, integerTyConName, - bindIOName, returnIOName, failIOName, thenIOName, - rOOT_MAIN_Name - ) -#ifdef GHCI -import DsMeta ( templateHaskellNames, qTyConName ) -#endif -import TysWiredIn ( unitTyCon ) -- A little odd -import Finder ( findModule ) -import FiniteMap +import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) +import Module ( Module, ModuleName, moduleName, mkHomeModule ) +import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE ) import UniqSupply -import SrcLoc ( SrcLoc, importedSrcLoc ) +import BasicTypes ( IPName, mapIPName ) +import SrcLoc ( SrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) -import BasicTypes ( mapIPName, FixitySig(..) ) import List ( nub ) import CmdLineOpts import FastString ( FastString ) @@ -61,13 +60,13 @@ import FastString ( FastString ) %********************************************************* %* * -\subsection{Making new names} + Source-code binders %* * %********************************************************* \begin{code} -newTopBinder :: Module -> RdrName -> SrcLoc -> TcRn m Name -newTopBinder mod rdr_name loc +newTopSrcBinder :: Module -> Maybe Name -> (RdrName, SrcLoc) -> RnM Name +newTopSrcBinder mod mb_parent (rdr_name, loc) | Just name <- isExact_maybe rdr_name = returnM name @@ -83,154 +82,17 @@ newTopBinder mod rdr_name loc -- not from the environment. In principle, it'd be fine to have an -- arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - newGlobalName (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) loc + newGlobalBinder (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) mb_parent loc | otherwise - = newGlobalName mod (rdrNameOcc rdr_name) loc + = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent loc where rdr_mod = rdrNameModule rdr_name - -newGlobalName :: Module -> OccName -> SrcLoc -> TcRn m Name -newGlobalName mod occ loc - = -- First check the cache - getNameCache `thenM` \ name_supply -> - case lookupOrigNameCache (nsNames name_supply) mod occ of - - -- A hit in the cache! We are at the binding site of the name. - -- This is the moment when we know the defining SrcLoc - -- of the Name, so we set the SrcLoc of the name we return. - -- - -- Main reason: then (bogus) multiple bindings of the same Name - -- get different SrcLocs can can be reported as such. - -- - -- Possible other reason: it might be in the cache because we - -- encountered an occurrence before the binding site for an - -- implicitly-imported Name. Perhaps the current SrcLoc is - -- better... but not really: it'll still just say 'imported' - -- - -- IMPORTANT: Don't mess with wired-in names. - -- Their wired-in-ness is in the SrcLoc - - Just name | isWiredInName name -> returnM name - | otherwise -> returnM (setNameSrcLoc name loc) - - -- Miss in the cache! - -- Build a completely new Name, and put it in the cache - Nothing -> addNewName name_supply mod occ loc - --- Look up a "system name" in the name cache. --- This is done by the type checker... -lookupSysName :: Name -- Base name - -> (OccName -> OccName) -- Occurrence name modifier - -> TcRn m Name -- System name -lookupSysName base_name mk_sys_occ - = newGlobalName (nameModule base_name) - (mk_sys_occ (nameOccName base_name)) - (nameSrcLoc base_name) - - -newGlobalNameFromRdrName rdr_name -- Qualified original name - = newGlobalName2 (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - -newGlobalName2 :: ModuleName -> OccName -> TcRn m Name - -- This one starts with a ModuleName, not a Module, because - -- we may be simply looking at an occurrence M.x in an interface file. - -- - -- Used for *occurrences*. Even if we get a miss in the - -- original-name cache, we make a new External Name. - -- We get its Module either from the OrigNameCache, or (if this - -- is the first Name from that module) from the Finder - -- - -- In the case of a miss, we have to make up the SrcLoc, but that's - -- OK: it must be an implicitly-imported Name, and that never occurs - -- in an error message. - -newGlobalName2 mod_name occ - = getNameCache `thenM` \ name_supply -> - let - new_name mod = addNewName name_supply mod occ importedSrcLoc - in - case lookupModuleEnvByName (nsNames name_supply) mod_name of - Just (mod, occ_env) -> - -- There are some names from this module already - -- Next, look up in the OccNameEnv - case lookupFM occ_env occ of - Just name -> returnM name - Nothing -> new_name mod - - Nothing -> -- No names from this module yet - ioToTcRn (findModule mod_name) `thenM` \ mb_loc -> - case mb_loc of - Right (mod, _) -> new_name mod - Left files -> - getDOpts `thenM` \ dflags -> - addErr (noIfaceErr dflags mod_name False files) `thenM_` - -- Things have really gone wrong at this point, - -- so having the wrong package info in the - -- Module is the least of our worries. - new_name (mkHomeModule mod_name) - - -newIPName rdr_name_ip - = getNameCache `thenM` \ name_supply -> - let - ipcache = nsIPs name_supply - in - case lookupFM ipcache key of - Just name_ip -> returnM name_ip - Nothing -> setNameCache new_ns `thenM_` - returnM name_ip - where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - name_ip = mapIPName mk_name rdr_name_ip - mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name) - new_ipcache = addToFM ipcache key name_ip - new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} - where - key = rdr_name_ip -- Ensures that ?x and %x get distinct Names - --- A local helper function -addNewName name_supply mod occ loc - = setNameCache new_name_supply `thenM_` - returnM name - where - (new_name_supply, name) = newExternalName name_supply mod occ loc - - -newExternalName :: NameCache -> Module -> OccName -> SrcLoc - -> (NameCache,Name) --- Allocate a new unique, manufacture a new External Name, --- put it in the cache, and return the two -newExternalName name_supply mod occ loc - = (new_name_supply, name) - where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - name = mkExternalName uniq mod occ loc - new_cache = extend_name_cache (nsNames name_supply) mod occ name - new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} - -lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - = case lookupModuleEnv nc mod of - Nothing -> Nothing - Just (_, occ_env) -> lookupFM occ_env occ - -extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache -extendOrigNameCache nc name - = extend_name_cache nc (nameModule name) (nameOccName name) name - -extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache -extend_name_cache nc mod occ name - = extendModuleEnv_C combine nc mod (mod, unitFM occ name) - where - combine (mod, occ_env) _ = (mod, addToFM occ_env occ name) \end{code} %********************************************************* %* * -\subsection{Looking up names} + Source code occurrences %* * %********************************************************* @@ -239,47 +101,28 @@ Looking up a name in the RnEnv. \begin{code} lookupBndrRn rdr_name = getLocalRdrEnv `thenM` \ local_env -> - case lookupRdrEnv local_env rdr_name of + case lookupLocalRdrEnv local_env rdr_name of Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name -lookupTopBndrRn rdr_name --- Look up a top-level local binder. We may be looking up an unqualified 'f', +lookupTopBndrRn :: RdrName -> RnM Name +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. +-- For example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course -- So we have to filter out the non-local ones. +-- -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. - +-- -- There should never be a qualified name in a binding position in Haskell, -- but there can be if we have read in an external-Core file. -- The Haskell parser checks for the illegal qualified name in Haskell -- source files, so we don't need to do so here. - = getModeRn `thenM` \ mode -> - case mode of - InterfaceMode mod -> - getSrcLocM `thenM` \ loc -> - newTopBinder mod rdr_name loc - - other -> lookupTopSrcBndr rdr_name - -lookupTopSrcBndr :: RdrName -> TcRn m Name -lookupTopSrcBndr rdr_name - = lookupTopSrcBndr_maybe rdr_name `thenM` \ maybe_name -> - case maybe_name of - Just name -> returnM name - Nothing -> unboundName rdr_name - - -lookupTopSrcBndr_maybe :: RdrName -> TcRn m (Maybe Name) --- Look up a source-code binder - --- Ignores imported names; for example, this is OK: --- import Foo( f ) --- infix 9 f -- The 'f' here does not need to be qualified --- f x = x -- Nor here, of course - -lookupTopSrcBndr_maybe rdr_name +lookupTopBndrRn rdr_name | Just name <- isExact_maybe rdr_name -- This is here just to catch the PrelBase defn of (say) [] and similar -- The parser reads the special syntax and returns an Exact RdrName @@ -292,19 +135,24 @@ lookupTopSrcBndr_maybe rdr_name -- data T = (,) Int Int -- unless we are in GHC.Tup = getModule `thenM` \ mod -> - checkErr (moduleName mod == moduleName (nameModule name)) + checkErr (moduleName mod == nameModuleName name) (badOrigBinding rdr_name) `thenM_` - returnM (Just name) + returnM name + + | isOrig rdr_name + -- This deals with the case of derived bindings, where + -- we don't bother to call newTopSrcBinder first + -- We assume there is no "parent" name + = getSrcLocM `thenM` \ loc -> + newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) Nothing loc | otherwise - = getGlobalRdrEnv `thenM` \ global_env -> - case lookupRdrEnv global_env rdr_name of - Nothing -> returnM Nothing - Just gres -> case [gre_name gre | gre <- gres, isLocalGRE gre] of - [] -> returnM Nothing - (n:ns) -> returnM (Just n) + = do { mb_gre <- lookupGreLocalRn rdr_name + ; case mb_gre of + Nothing -> unboundName rdr_name + Just gre -> returnM (gre_name gre) } - -- lookupSigOccRn is used for type signatures and pragmas -- Is this valid? -- module A @@ -323,182 +171,157 @@ lookupSigOccRn = lookupBndrRn -- disambiguate. lookupInstDeclBndr :: Name -> RdrName -> RnM Name - -- We use the selector name as the binder lookupInstDeclBndr cls_name rdr_name - | isUnqual rdr_name - = -- Find all the things the class op name maps to - -- and pick the one with the right parent name - getGblEnv `thenM` \ gbl_env -> - let - avail_env = imp_env (tcg_imports gbl_env) - occ = rdrNameOcc rdr_name - in - case lookupAvailEnv_maybe avail_env cls_name of - Nothing -> - -- If the class itself isn't in scope, then cls_name will - -- be unboundName, and there'll already be an error for - -- that in the error list. Example: - -- e.g. import Prelude hiding( Ord ) - -- instance Ord T where ... - -- The program is wrong, but that should not cause a crash. - returnM (mkUnboundName rdr_name) - - Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of - (n:ns)-> ASSERT( null ns ) returnM n - [] -> unboundName rdr_name - - other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) - - - | otherwise -- Occurs in derived instances, where we just - -- refer directly to the right method, and avail_env - -- isn't available + | isUnqual rdr_name -- Find all the things the rdr-name maps to + = do { -- and pick the one with the right parent name + let { is_op gre = cls_name == nameParent (gre_name gre) + ; occ = rdrNameOcc rdr_name + ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) } + ; mb_gre <- lookupGreRn_help rdr_name lookup_fn + ; case mb_gre of + Just gre -> return (gre_name gre) + Nothing -> do { addErr (unknownInstBndrErr cls_name rdr_name) + ; return (mkUnboundName rdr_name) } } + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method = ASSERT2( not (isQual rdr_name), ppr rdr_name ) -- NB: qualified names are rejected by the parser - lookupOrigName rdr_name + lookupImportedName rdr_name +newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) +newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) -lookupSysBndr :: RdrName -> RnM Name --- Used for the 'system binders' in a data type or class declaration --- Do *not* look up in the RdrEnv; these system binders are never in scope --- Instead, get the module from the monad... but remember that --- where the module is depends on whether we are renaming source or --- interface file stuff -lookupSysBndr rdr_name - = getSrcLocM `thenM` \ loc -> - getModeRn `thenM` \ mode -> - case mode of - InterfaceMode mod -> newTopBinder mod rdr_name loc - other -> getModule `thenM` \ mod -> - newTopBinder mod rdr_name loc +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name = getLocalRdrEnv `thenM` \ local_env -> - case lookupRdrEnv local_env rdr_name of + case lookupLocalRdrEnv local_env rdr_name of Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name +lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. It's used only for -- record field names -- class op names in class and instance decls lookupGlobalOccRn rdr_name - = getModeRn `thenM` \ mode -> - case mode of - InterfaceMode mod -> lookupIfaceName mod rdr_name - SourceMode -> lookupSrcName rdr_name - - CmdLineMode - | not (isQual rdr_name) -> - lookupSrcName rdr_name - - -- We allow qualified names on the command line to refer to - -- *any* name exported by any module in scope, just as if - -- there was an "import qualified M" declaration for every - -- module. - -- - -- First look up the name in the normal environment. If - -- it isn't there, we manufacture a new occurrence of an - -- original name. - | otherwise -> - lookupSrcName_maybe rdr_name `thenM` \ mb_name -> - case mb_name of - Just name -> returnM name - Nothing -> lookupQualifiedName rdr_name + | not (isSrcRdrName rdr_name) + = lookupImportedName rdr_name + + | otherwise + = -- First look up the name in the normal environment. + lookupGreRn rdr_name `thenM` \ mb_gre -> + case mb_gre of { + Just gre -> returnM (gre_name gre) ; + Nothing -> + + -- We allow qualified names on the command line to refer to + -- *any* name exported by any module in scope, just as if + -- there was an "import qualified M" declaration for every + -- module. + getModule `thenM` \ mod -> + if isQual rdr_name && mod == iNTERACTIVE then + -- This test is not expensive, + lookupQualifiedName rdr_name -- and only happens for failed lookups + else + unboundName rdr_name } + +lookupImportedName :: RdrName -> TcRnIf m n Name +-- Lookup the occurrence of an imported name +-- The RdrName is *always* qualified or Exact +-- Treat it as an original name, and conjure up the Name +-- Usually it's Exact or Orig, but it can be Qual if it +-- comes from an hi-boot file. (This minor infelicity is +-- just to reduce duplication in the parser.) +lookupImportedName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code + = returnM n + + | otherwise -- Always Orig, even when reading a .hi-boot file + = ASSERT( not (isUnqual rdr_name) ) + lookupOrig (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +unboundName :: RdrName -> RnM Name +unboundName rdr_name + = do { addErr (unknownNameErr rdr_name) + ; env <- getGlobalRdrEnv; + ; traceRn (vcat [unknownNameErr rdr_name, + ptext SLIT("Global envt is:"), + nest 3 (pprGlobalRdrEnv env)]) + ; returnM (mkUnboundName rdr_name) } + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name) +-- No filter function; does not report an error on failure +lookupSrcOcc_maybe rdr_name + = do { mb_gre <- lookupGreRn rdr_name + ; case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) } + +------------------------- +lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Just look up the RdrName in the GlobalRdrEnv +lookupGreRn rdr_name + = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) + +lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Similar, but restricted to locally-defined things +lookupGreLocalRn rdr_name + = lookupGreRn_help rdr_name lookup_fn + where + lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env) + +lookupGreRn_help :: RdrName -- Only used in error message + -> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function + -> RnM (Maybe GlobalRdrElt) +-- Checks for exactly one match; reports deprecations +-- Returns Nothing, without error, if too few +lookupGreRn_help rdr_name lookup + = do { env <- getGlobalRdrEnv + ; case lookup env of + [] -> returnM Nothing + [gre] -> case gre_deprec gre of + Nothing -> returnM (Just gre) + Just _ -> do { warnDeprec gre + ; returnM (Just gre) } + gres -> do { addNameClashErrRn rdr_name gres + ; returnM (Just (head gres)) } } + +------------------------------ +-- GHCi support +------------------------------ -- A qualified name on the command line can refer to any module at all: we -- try to load the interface if we don't already have it. -lookupQualifiedName :: RdrName -> TcRn m Name +lookupQualifiedName :: RdrName -> RnM Name lookupQualifiedName rdr_name = let mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in - loadInterface (ppr rdr_name) mod (ImportByUser False) `thenM` \ iface -> - case [ name | (_,avails) <- mi_exports iface, - avail <- avails, - name <- availNames avail, - nameOccName name == occ ] of - (n:ns) -> ASSERT (null ns) returnM n - _ -> unboundName rdr_name - -lookupSrcName :: RdrName -> TcRn m Name -lookupSrcName rdr_name - = lookupSrcName_maybe rdr_name `thenM` \ mb_name -> - case mb_name of - Nothing -> unboundName rdr_name - Just name -> returnM name - -lookupSrcName_maybe :: RdrName -> TcRn m (Maybe Name) -lookupSrcName_maybe rdr_name - | Just name <- isExact_maybe rdr_name -- Can occur in source code too - = returnM (Just name) - - | isOrig rdr_name -- An original name - = newGlobalNameFromRdrName rdr_name `thenM` \ name -> - returnM (Just name) - - | otherwise - = lookupGRE rdr_name `thenM` \ mb_gre -> - case mb_gre of - Nothing -> returnM Nothing - Just gre -> returnM (Just (gre_name gre)) - -lookupGRE :: RdrName -> TcRn m (Maybe GlobalRdrElt) -lookupGRE rdr_name - = getGlobalRdrEnv `thenM` \ global_env -> - case lookupRdrEnv global_env rdr_name of - Just [gre] -> case gre_deprec gre of - Nothing -> returnM (Just gre) - Just _ -> warnDeprec gre `thenM_` - returnM (Just gre) - Just stuff@(gre : _) -> addNameClashErrRn rdr_name stuff `thenM_` - returnM (Just gre) - Nothing -> return Nothing - -lookupIfaceName :: Module -> RdrName -> TcRn m Name - -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. -lookupIfaceName mod rdr_name - | isUnqual rdr_name = newGlobalName mod (rdrNameOcc rdr_name) importedSrcLoc - | otherwise = lookupOrigName rdr_name - -lookupOrigName :: RdrName -> TcRn m Name - -- Just for original or exact names -lookupOrigName rdr_name - | Just n <- isExact_maybe rdr_name - -- This happens in derived code, which we - -- rename in InterfaceMode - = returnM n - - | otherwise -- Usually Orig, but can be a Qual when - -- we are reading a .hi-boot file - = newGlobalNameFromRdrName rdr_name - - -dataTcOccs :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. --- --- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, --- and we don't have a systematic way to find the TyCon's Name from --- the DataCon's name. Sigh -dataTcOccs rdr_name - | isDataOcc occ = [rdr_name_tc, rdr_name] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName -\end{code} - -\begin{code} -unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_` - returnM (mkUnboundName rdr_name) + loadSrcInterface doc mod False `thenM` \ iface -> + + case [ (mod,occ) | + (mod,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + name == occ ] of + ((mod,occ):ns) -> ASSERT (null ns) + lookupOrig mod occ + _ -> unboundName rdr_name + where + doc = ptext SLIT("Need to find") <+> ppr rdr_name \end{code} %********************************************************* @@ -508,6 +331,17 @@ unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_` %********************************************************* \begin{code} +lookupTopFixSigNames :: RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con +-- for con-like things +lookupTopFixSigNames rdr_name + | Just n <- isExact_maybe rdr_name + -- Special case for (:), which doesn't get into the GlobalRdrEnv + = return [n] -- For this we don't need to try the tycon too + | otherwise + = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) + ; return [gre_name gre | Just gre <- mb_gres] } + -------------------------------- bindLocalFixities :: [RdrNameFixitySig] -> RnM a -> RnM a -- Used for nested fixity decls @@ -521,7 +355,7 @@ bindLocalFixities fixes thing_inside rn_sig (FixitySig v fix src_loc) = addSrcLoc src_loc $ lookupSigOccRn v `thenM` \ new_v -> - returnM (new_v, FixitySig new_v fix src_loc) + returnM (new_v, (FixItem (rdrNameOcc v) fix src_loc)) \end{code} -------------------------------- @@ -545,6 +379,7 @@ lookupFixityRn name if nameIsLocalOrFrom this_mod name then -- It's defined in this module getFixityEnv `thenM` \ local_fix_env -> + traceRn (text "lookupFixityRn" <+> (ppr name $$ ppr local_fix_env)) `thenM_` returnM (lookupFixity local_fix_env name) else -- It's imported @@ -561,83 +396,37 @@ lookupFixityRn name -- nothing from B will be used). When we come across a use of -- 'f', we need to know its fixity, and it's then, and only -- then, that we load B.hi. That is what's happening here. - loadInterface doc name_mod ImportBySystem `thenM` \ iface -> - returnM (lookupFixity (mi_fixities iface) name) + loadSrcInterface doc name_mod False `thenM` \ iface -> + returnM (mi_fix_fn iface (nameOccName name)) where doc = ptext SLIT("Checking fixity for") <+> ppr name - name_mod = moduleName (nameModule name) -\end{code} - - -%********************************************************* -%* * -\subsection{Implicit free vars and sugar names} -%* * -%********************************************************* - -@getXImplicitFVs@ forces the renamer to slurp in some things which aren't -mentioned explicitly, but which might be needed by the type checker. + name_mod = nameModuleName name -\begin{code} -implicitStmtFVs source_fvs -- Compiling a statement - = stmt_fvs `plusFV` implicitModuleFVs source_fvs - where - stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName, - integerTyConName] - -- These are all needed implicitly when compiling a statement - -- See TcModule.tc_stmts - -- Reason for integerTyConName: consider this in GHCi - -- ghci> [] - -- We get an ambigous constraint (Show a), which we now default just like - -- numeric types... but unless we have the instance decl for Integer we - -- won't find a valid default! - -implicitModuleFVs source_fvs - = mkTemplateHaskellFVs source_fvs `plusFV` - namesNeededForFlattening `plusFV` - ubiquitousNames - - -thProxyName :: NameSet -mkTemplateHaskellFVs :: NameSet -> NameSet - -- This is a bit of a hack. When we see the Template-Haskell construct - -- [| expr |] - -- we are going to need lots of the ``smart constructors'' defined in - -- the main Template Haskell data type module. Rather than treat them - -- all as free vars at every occurrence site, we just make the Q type - -- consructor a free var.... and then use that here to haul in the others - -#ifdef GHCI ---------------- Template Haskell enabled -------------- -thProxyName = unitFV qTyConName - -mkTemplateHaskellFVs source_fvs - | qTyConName `elemNameSet` source_fvs = templateHaskellNames - | otherwise = emptyFVs - -#else ---------------- Template Haskell disabled -------------- - -thProxyName = emptyFVs -mkTemplateHaskellFVs source_fvs = emptyFVs -#endif --------------------------------------------------------- - --- ubiquitous_names are loaded regardless, because --- they are needed in virtually every program -ubiquitousNames - = mkFVs [unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, eqStringName, - -- Virtually every program has error messages in it somewhere - getName unitTyCon, funTyConName, boolTyConName, intTyConName] - -- Add occurrences for very frequently used types. - -- (e.g. we don't want to be bothered with making - -- funTyCon a free var at every function application!) +dataTcOccs :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at. +-- +-- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and we don't have a systematic way to find the TyCon's Name from +-- the DataCon's name. Sigh +dataTcOccs rdr_name + | isDataOcc occ = [rdr_name_tc, rdr_name] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName \end{code} %************************************************************************ %* * -\subsection{Re-bindable desugaring names} + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_NoImplicitPrelude dynamic flag. + + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally + %* * %************************************************************************ @@ -675,15 +464,11 @@ lookupSyntaxName std_name = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> if not no_prelude then normal_case else - getModeRn `thenM` \ mode -> - if isInterfaceMode mode then normal_case - -- Happens for 'derived' code where we don't want to rebind - else -- Get the similarly named thing from the local environment lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> - returnM (usr_name, mkFVs [usr_name, std_name]) + returnM (usr_name, unitFV usr_name) where - normal_case = returnM (std_name, unitFV std_name) + normal_case = returnM (std_name, emptyFVs) lookupSyntaxNames :: [Name] -- Standard names -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames @@ -691,15 +476,12 @@ lookupSyntaxNames std_names = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> if not no_prelude then normal_case else - getModeRn `thenM` \ mode -> - if isInterfaceMode mode then normal_case - else -- Get the similarly named thing from the local environment mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> - returnM (std_names `zip` map HsVar usr_names, mkFVs std_names `plusFV` mkFVs usr_names) + returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names) where - normal_case = returnM (std_names `zip` map HsVar std_names, mkFVs std_names) + normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs) \end{code} @@ -728,56 +510,23 @@ bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> ([Name] -> RnM a) -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = getModeRn `thenM` \ mode -> - getLocalRdrEnv `thenM` \ local_env -> - getGlobalRdrEnv `thenM` \ global_env -> + = ASSERT2( all (isUnqual . fst) rdr_names_w_loc, ppr rdr_names_w_loc ) + -- We only bind unqualified names here + -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName - -- Check for duplicate names - checkDupOrQualNames doc_str rdr_names_w_loc `thenM_` + -- Check for duplicate names + checkDupNames doc_str rdr_names_w_loc `thenM_` -- Warn about shadowing, but only in source modules - let - check_shadow (rdr_name,loc) - | rdr_name `elemRdrEnv` local_env - || rdr_name `elemRdrEnv` global_env - = addSrcLoc loc $ addWarn (shadowedNameWarn rdr_name) - | otherwise - = returnM () - in - - (case mode of - SourceMode -> ifOptM Opt_WarnNameShadowing $ - mappM_ check_shadow rdr_names_w_loc - other -> returnM () - ) `thenM_` + ifOptM Opt_WarnNameShadowing + (checkShadowing doc_str rdr_names_w_loc) `thenM_` + -- Make fresh Names and extend the environment newLocalsRn rdr_names_w_loc `thenM` \ names -> - let - new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names) - in - setLocalRdrEnv new_local_env (enclosed_scope names) - -bindCoreLocalRn :: RdrName -> (Name -> RnM a) -> RnM a - -- A specialised variant when renaming stuff from interface - -- files (of which there is a lot) - -- * one at a time - -- * no checks for shadowing - -- * always imported - -- * deal with free vars -bindCoreLocalRn rdr_name enclosed_scope - = getSrcLocM `thenM` \ loc -> - getLocalRdrEnv `thenM` \ name_env -> - newUnique `thenM` \ uniq -> - let - name = mkInternalName uniq (rdrNameOcc rdr_name) loc - new_name_env = extendRdrEnv name_env rdr_name name - in - setLocalRdrEnv new_name_env (enclosed_scope name) + getLocalRdrEnv `thenM` \ local_env -> + setLocalRdrEnv (extendLocalRdrEnv local_env names) + (enclosed_scope names) -bindCoreLocalsRn [] thing_inside = thing_inside [] -bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> - bindCoreLocalsRn bs $ \ names' -> - thing_inside (name':names') bindLocalNames names enclosed_scope = getLocalRdrEnv `thenM` \ name_env -> @@ -791,12 +540,6 @@ bindLocalNamesFV names enclosed_scope ------------------------------------- -bindLocalRn doc rdr_name enclosed_scope - = getSrcLocM `thenM` \ loc -> - bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> - ASSERT( null ns ) - enclosed_scope n - bindLocalsRn doc rdr_names enclosed_scope = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc @@ -838,7 +581,7 @@ bindPatSigTyVars tys thing_inside let forall_tyvars = nub [ tv | ty <- tys, tv <- extractHsTyRdrTyVars ty, - not (tv `elemFM` name_env) + not (tv `elemLocalRdrEnv` name_env) ] -- The 'nub' is important. For example: -- f (x :: t) (y :: t) = .... @@ -858,126 +601,29 @@ bindPatSigTyVarsFV tys thing_inside returnM (result, fvs `delListFromNameSet` tvs) ------------------------------------- -checkDupOrQualNames, checkDupNames :: SDoc - -> [(RdrName, SrcLoc)] - -> TcRn m () - -- Works in any variant of the renamer monad - -checkDupOrQualNames doc_str rdr_names_w_loc - = -- Qualified names in patterns are now rejected by the parser - -- but I'm not 100% certain that it finds all cases, so I've left - -- this check in for now. Should go eventually. - -- Hmm. Sooner rather than later.. data type decls --- mappM_ (qualNameErr doc_str) quals `thenM_` - checkDupNames doc_str rdr_names_w_loc - where - quals = filter (isQual . fst) rdr_names_w_loc - +checkDupNames :: SDoc + -> [(RdrName, SrcLoc)] + -> RnM () checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group mappM_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc -\end{code} - - -%************************************************************************ -%* * -\subsection{GlobalRdrEnv} -%* * -%************************************************************************ - -\begin{code} -mkGlobalRdrEnv :: ModuleName -- Imported module (after doing the "as M" name change) - -> Bool -- True <=> want unqualified import - -> (Name -> Provenance) - -> Avails -- Whats imported - -> Deprecations - -> GlobalRdrEnv - -mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs - = gbl_env2 - where - -- Make the name environment. We're talking about a - -- single module here, so there must be no name clashes. - -- In practice there only ever will be if it's the module - -- being compiled. - - -- Add qualified names for the things that are available - -- (Qualified names are always imported) - gbl_env1 = foldl add_avail emptyRdrEnv avails - - -- Add unqualified names - gbl_env2 | unqual_imp = foldl add_unqual gbl_env1 (rdrEnvToList gbl_env1) - | otherwise = gbl_env1 - - add_unqual env (qual_name, elts) - = foldl add_one env elts - where - add_one env elt = addOneToGlobalRdrEnv env unqual_name elt - unqual_name = unqualifyRdrName qual_name - -- The qualified import should only have added one - -- binding for each qualified name! But if there's an error in - -- the module (multiple bindings for the same name) we may get - -- duplicates. So the simple thing is to do the fold. - - add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv - add_avail env avail = foldl (add_name (availName avail)) env (availNames avail) - - add_name parent env name -- Add qualified name only - = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt - where - occ = nameOccName name - elt = GRE {gre_name = name, - gre_parent = if name == parent - then Nothing - else Just parent, - gre_prov = mk_provenance name, - gre_deprec = lookupDeprec deprecs name} -\end{code} - -\begin{code} -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 - -addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv -addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] - -delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv -delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name -combine_globals :: [GlobalRdrElt] -- Old - -> [GlobalRdrElt] -- New - -> [GlobalRdrElt] -combine_globals ns_old ns_new -- ns_new is often short - = foldr add ns_old ns_new - where - add n ns | any (is_duplicate n) ns_old = map (choose n) ns -- Eliminate duplicates - | otherwise = n:ns - - choose n m | n `beats` m = n - | otherwise = m - - g1 `beats` g2 = gre_name g1 == gre_name g2 && - gre_prov g1 `hasBetterProv` gre_prov g2 - - is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool - is_duplicate g1 g2 | isLocalGRE g1 && isLocalGRE g2 = False - is_duplicate g1 g2 = gre_name g1 == gre_name g2 +------------------------------------- +checkShadowing doc_str rdr_names_w_loc + = getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> + let + check_shadow (rdr_name,loc) + | rdr_name `elemLocalRdrEnv` local_env + || not (null (lookupGRE_RdrName rdr_name global_env )) + = addSrcLoc loc $ addWarn (shadowedNameWarn doc_str rdr_name) + | otherwise = returnM () + in + mappM_ check_shadow rdr_names_w_loc \end{code} -We treat two bindings of a locally-defined name as a duplicate, -because they might be two separate, local defns and we want to report -and error for that, {\em not} eliminate a duplicate. - -On the other hand, if you import the same name from two different -import statements, we {\em do} want to eliminate the duplicate, not report -an error. - -If a module imports itself then there might be a local defn and an imported -defn of the same name; in this case the names will compare as equal, but -will still have different provenances. - %************************************************************************ %* * @@ -1002,7 +648,7 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [ModuleName] -> TcRn m () +warnUnusedModules :: [ModuleName] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) where @@ -1011,20 +657,20 @@ warnUnusedModules mods parens (ptext SLIT("except perhaps instances visible in") <+> quotes (ppr m))] -warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> TcRn m () +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> TcRn m () +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM () warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) ------------------------- -- Helpers -warnUnusedGREs gres = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] -warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] +warnUnusedGREs gres = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] +warnUnusedLocals names = warnUnusedBinds [(n,Nothing) | n<-names] -warnUnusedBinds :: [(Name,Provenance)] -> TcRn m () +warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () warnUnusedBinds names = mappM_ warnUnusedGroup groups where @@ -1037,7 +683,7 @@ warnUnusedBinds names ------------------------- -warnUnusedGroup :: [(Name,Provenance)] -> TcRn m () +warnUnusedGroup :: [(Name,Maybe Provenance)] -> RnM () warnUnusedGroup names = addSrcLoc def_loc $ addWarn $ @@ -1046,8 +692,10 @@ warnUnusedGroup names (name1, prov1) = head names loc1 = nameSrcLoc name1 (def_loc, msg) = case prov1 of - LocalDef -> (loc1, unused_msg) - NonLocalDef (UserImport mod loc _) -> (loc, imp_from mod) + Just (Imported is _) -> (is_loc imp_spec, imp_from (is_mod imp_spec)) + where + imp_spec = head is + other -> (loc1, unused_msg) unused_msg = text "Defined but not used" imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" @@ -1062,46 +710,33 @@ addNameClashErrRn rdr_name (np1:nps) msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre -shadowedNameWarn shadow +shadowedNameWarn doc shadow = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] + $$ doc unknownNameErr name - = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] + = sep [text flavour <+> ptext SLIT("not in scope:"), quotes (ppr name)] where flavour = occNameFlavour (rdrNameOcc name) +unknownInstBndrErr cls op + = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) + badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -qualNameErr descriptor (name,loc) - = addSrcLoc loc $ - addErr (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), - descriptor]) - dupNamesErr descriptor ((name,loc) : dup_things) = addSrcLoc loc $ addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ descriptor) - -noIfaceErr dflags mod_name boot_file files - = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) - $$ extra - where - extra - | verbosity dflags < 3 = - text "(use -v to see a list of the files searched for)" - | otherwise = - hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) - -warnDeprec :: GlobalRdrElt -> TcRn m () +warnDeprec :: GlobalRdrElt -> RnM () warnDeprec (GRE {gre_name = name, gre_deprec = Just txt}) = ifOptM Opt_WarnDeprecations $ addWarn (sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+> text "is deprecated:", nest 4 (ppr txt) ]) \end{code} - diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index daa9767c33..df881009e7 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -28,28 +28,22 @@ import RdrHsSyn import RnHsSyn import TcRnMonad import RnEnv +import RdrName ( plusGlobalRdrEnv ) import RnNames ( importsFromLocalDecls ) import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen, dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize ) import CmdLineOpts ( DynFlag(..) ) -import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), - defaultFixity, negateFixity, compareFixity ) -import PrelNames ( hasKey, assertIdKey, - foldrName, buildName, - enumClassName, +import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity ) +import PrelNames ( hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, - splitName, fstName, sndName, ioDataConName, - replicatePName, mapPName, filterPName, - crossPName, zipPName, toPName, - enumFromToPName, enumFromThenToPName, assertErrorName, negateName, monadNames, mfixName ) import Name ( Name, nameOccName ) import NameSet import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) -import Util ( isSingleton, mapAndUnzip ) -import List ( intersectBy, unzip4 ) +import Util ( isSingleton ) +import List ( unzip4 ) import ListSetOps ( removeDups ) import Outputable import SrcLoc ( noSrcLoc ) @@ -172,13 +166,8 @@ rnExpr (HsVar v) returnM (HsVar name, unitFV name) rnExpr (HsIPVar v) - = newIPName v `thenM` \ name -> - let - fvs = case name of - Linear _ -> mkFVs [splitName, fstName, sndName] - Dupable _ -> emptyFVs - in - returnM (HsIPVar name, fvs) + = newIPNameRn v `thenM` \ name -> + returnM (HsIPVar name, emptyFVs) rnExpr (HsLit lit) = litFVs lit `thenM` \ fvs -> @@ -204,15 +193,11 @@ rnExpr (OpApp e1 op _ e2) -- Deal with fixity -- When renaming code synthesised from "deriving" declarations - -- we're in Interface mode, and we should ignore fixity; assume - -- that the deriving code generator got the association correct - -- Don't even look up the fixity when in interface mode - getModeRn `thenM` \ mode -> - (if isInterfaceMode mode - then returnM (OpApp e1' op' defaultFixity e2') - else lookupFixityRn op_name `thenM` \ fixity -> - mkOpAppRn e1' op' fixity e2' - ) `thenM` \ final_e -> + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in TcGenDeriv + -- should prevent bad things happening. + lookupFixityRn op_name `thenM` \ fixity -> + mkOpAppRn e1' op' fixity e2' `thenM` \ final_e -> returnM (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) @@ -234,20 +219,20 @@ rnExpr e@(HsBracket br_body loc) = addSrcLoc loc $ checkTH e "bracket" `thenM_` rnBracket br_body `thenM` \ (body', fvs_e) -> - returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName) + returnM (HsBracket body' loc, fvs_e) rnExpr e@(HsSplice n splice loc) = addSrcLoc loc $ checkTH e "splice" `thenM_` newLocalsRn [(n,loc)] `thenM` \ [n'] -> rnExpr splice `thenM` \ (splice', fvs_e) -> - returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName) + returnM (HsSplice n' splice' loc, fvs_e) rnExpr e@(HsReify (Reify flavour name)) = checkTH e "reify" `thenM_` lookupGlobalOccRn name `thenM` \ name' -> -- For now, we can only reify top-level things - returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName) + returnM (HsReify (Reify flavour name'), unitFV name') rnExpr section@(SectionL expr op) = rnExpr expr `thenM` \ (expr', fvs_expr) -> @@ -294,13 +279,8 @@ rnExpr e@(HsDo do_or_lc stmts _ _ src_loc) lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) -> returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc, - fvs `plusFV` implicit_fvs do_or_lc `plusFV` monad_fvs) + fvs `plusFV` monad_fvs) where - implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName] - implicit_fvs ListComp = mkFVs [foldrName, buildName] - implicit_fvs DoExpr = emptyFVs - implicit_fvs MDoExpr = emptyFVs - syntax_names = case do_or_lc of DoExpr -> monadNames MDoExpr -> monadNames ++ [mfixName] @@ -312,8 +292,7 @@ rnExpr (ExplicitList _ exps) rnExpr (ExplicitPArr _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> - returnM (ExplicitPArr placeHolderType exps', - fvs `addOneFV` toPName `addOneFV` parrTyCon_name) + returnM (ExplicitPArr placeHolderType exps', fvs) rnExpr e@(ExplicitTuple exps boxity) = checkTupSize tup_size `thenM_` @@ -355,12 +334,11 @@ rnExpr (HsType a) rnExpr (ArithSeqIn seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) + returnM (ArithSeqIn new_seq, fvs) rnExpr (PArrSeqIn seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - returnM (PArrSeqIn new_seq, - fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) + returnM (PArrSeqIn new_seq, fvs) \end{code} These three are pattern syntax appearing in expressions. @@ -1047,16 +1025,13 @@ right_op_ok fix1 other = True -- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) mkNegAppRn neg_arg neg_name - = -#ifdef DEBUG - getModeRn `thenM` \ mode -> - ASSERT( not_op_app mode neg_arg ) -#endif + = ASSERT( not_op_app neg_arg ) returnM (NegApp neg_arg neg_name) -not_op_app SourceMode (OpApp _ _ _ _) = False -not_op_app mode other = True +not_op_app (OpApp _ _ _ _) = False +not_op_app other = True \end{code} \begin{code} @@ -1067,12 +1042,9 @@ checkPrecMatch False fn match checkPrecMatch True op (Match (p1:p2:_) _ _) -- True indicates an infix lhs - = getModeRn `thenM` \ mode -> - -- See comments with rnExpr (OpApp ...) - if isInterfaceMode mode - then returnM () - else checkPrec op p1 False `thenM_` - checkPrec op p2 True + = -- See comments with rnExpr (OpApp ...) about "deriving" + checkPrec op p1 False `thenM_` + checkPrec op p2 True checkPrecMatch True op _ = panic "checkPrecMatch" @@ -1129,7 +1101,7 @@ mkAssertErrorExpr expr = HsApp (HsVar assertErrorName) (HsLit msg) msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))) in - returnM (expr, unitFV assertErrorName) + returnM (expr, emptyFVs) \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs deleted file mode 100644 index d83b88104a..0000000000 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ /dev/null @@ -1,731 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section{Dealing with interface files} - -\begin{code} -module RnHiFiles ( - readIface, loadInterface, loadHomeInterface, - loadOrphanModules, - loadOldIface, - ParsedIface(..) - ) where - -#include "HsVersions.h" - -import DriverState ( v_GhcMode, isCompManagerMode ) -import DriverUtil ( replaceFilenameSuffix ) -import CmdLineOpts ( DynFlag(..) ) -import Parser ( parseIface ) -import HscTypes ( ModIface(..), emptyModIface, - ExternalPackageState(..), noDependencies, - VersionInfo(..), Usage(..), - lookupIfaceByModName, RdrExportItem, - IsBootInterface, - DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls, - AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs, - Avails, availNames, availName, Deprecations(..) - ) -import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), ConDecl(..), - hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames - ) -import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) -import RnHsSyn ( RenamedInstDecl, RenamedRuleDecl, RenamedTyClDecl, - extractHsTyNames_s ) -import BasicTypes ( Version, FixitySig(..), Fixity(..), FixityDirection(..) ) -import RnSource ( rnIfaceRuleDecl, rnTyClDecl, rnInstDecl ) -import RnTypes ( rnHsType ) -import RnEnv -import TcRnMonad - -import PrelNames ( gHC_PRIM_Name, gHC_PRIM ) -import PrelInfo ( ghcPrimExports ) -import Name ( Name {-instance NamedThing-}, - nameModule, isInternalName ) -import NameEnv -import NameSet -import Id ( idName ) -import MkId ( seqId ) -import Packages ( basePackage ) -import Module ( Module, ModuleName, ModLocation(ml_hi_file), - moduleName, isHomeModule, mkPackageModule, - extendModuleEnv, lookupModuleEnvByName - ) -import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName ) -import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc, - mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2, - mkDataConWrapperOcc, mkDataConWorkerOcc ) -import TyCon ( DataConDetails(..) ) -import SrcLoc ( noSrcLoc, mkSrcLoc ) -import Maybes ( maybeToBool ) -import StringBuffer ( hGetStringBuffer ) -import FastString ( mkFastString ) -import ErrUtils ( Message ) -import Finder ( findModule, findPackageModule, - hiBootExt, hiBootVerExt ) -import Lexer -import FiniteMap -import ListSetOps ( minusList ) -import Outputable -import Bag -import BinIface ( readBinIface ) -import Panic - -import EXCEPTION as Exception -import DATA_IOREF ( readIORef ) - -import Directory -\end{code} - - -%********************************************************* -%* * -\subsection{Loading a new interface file} -%* * -%********************************************************* - -\begin{code} -loadHomeInterface :: SDoc -> Name -> TcRn m ModIface -loadHomeInterface doc_str name - = ASSERT2( not (isInternalName name), ppr name <+> parens doc_str ) - loadInterface doc_str (moduleName (nameModule name)) ImportBySystem - -loadOrphanModules :: [ModuleName] -> TcRn m () -loadOrphanModules mods - | null mods = returnM () - | otherwise = traceRn (text "Loading orphan modules:" <+> - fsep (map ppr mods)) `thenM_` - mappM_ load mods `thenM_` - returnM () - where - load mod = loadInterface (mk_doc mod) mod ImportBySystem - mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") - -loadInterface :: SDoc -> ModuleName -> WhereFrom -> TcRn m ModIface - -- Returns Nothing if failed - -- If we can't find an interface file, and we are doing ImportForUsage, - -- just fail in the monad, and modify anything else - -- Otherwise, if we can't find an interface file, - -- add an error message to the monad (the first time only) - -- and return emptyIface - -- The "first time only" part is done by modifying the PackageIfaceTable - -- to have an empty entry - -- - -- The ImportForUsage case is because when we read the usage information from - -- an interface file, we try to read the interfaces it mentions. - -- But it's OK to fail; perhaps the module has changed, and that interface - -- is no longer used. - -loadInterface doc_str mod_name from - = getHpt `thenM` \ hpt -> - getModule `thenM` \ this_mod -> - getImports `thenM` \ import_avails -> - getEps `thenM` \ eps@(EPS { eps_PIT = pit }) -> - - -- CHECK WHETHER WE HAVE IT ALREADY - case lookupIfaceByModName hpt pit mod_name of { - Just iface | case from of - ImportByUser src_imp -> src_imp == mi_boot iface - ImportForUsage src_imp -> src_imp == mi_boot iface - ImportBySystem -> True - -> returnM iface ; -- Already loaded - -- The not (mi_boot iface) test checks that the already-loaded - -- interface isn't a boot iface. This can conceivably happen, - -- if the version checking happened to load a boot interface - -- before we got to real imports. - other -> - - let - mod_map = imp_dep_mods import_avails - mod_info = lookupModuleEnvByName mod_map mod_name - - hi_boot_file - = case (from, mod_info) of - (ImportByUser is_boot, _) -> is_boot - (ImportForUsage is_boot, _) -> is_boot - (ImportBySystem, Just (_, is_boot)) -> is_boot - (ImportBySystem, Nothing) -> False - -- We're importing a module we know absolutely - -- nothing about, so we assume it's from - -- another package, where we aren't doing - -- dependency tracking. So it won't be a hi-boot file. - - redundant_source_import - = case (from, mod_info) of - (ImportByUser True, Just (_, False)) -> True - other -> False - in - - -- Issue a warning for a redundant {- SOURCE -} import - -- NB that we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports - warnIf redundant_source_import - (warnRedundantSourceImport mod_name) `thenM_` - - -- Check that we aren't importing ourselves. - -- That only happens in Rename.checkOldIface, - -- which doesn't call loadInterface - warnIf - (isHomeModule this_mod && moduleName this_mod == mod_name) - (warnSelfImport this_mod) `thenM_` - - -- READ THE MODULE IN - findAndReadIface doc_str mod_name hi_boot_file - `thenM` \ read_result -> - case read_result of { - Left err - | case from of { ImportForUsage _ -> True ; other -> False } - -> failM -- Fail with no error messages - - | otherwise - -> let -- Not found, so add an empty export env to - -- the EPS map so that we don't look again - fake_mod = mkPackageModule mod_name - fake_iface = emptyModIface fake_mod - new_eps = eps { eps_PIT = extendModuleEnv pit fake_mod fake_iface } - in - setEps new_eps `thenM_` - addErr (elaborate err) `thenM_` - returnM fake_iface - where - elaborate err = hang (ptext SLIT("Failed to load interface for") <+> - quotes (ppr mod_name) <> colon) 4 err - ; - - -- Found and parsed! - Right (mod, iface) -> - - -- LOAD IT INTO EPS - - -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined - --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). - -- If we do loadExport first the wrong info gets into the cache (unless we - -- explicitly tag each export which seems a bit of a bore) - - - -- Sanity check. If we're system-importing a module we know nothing at all - -- about, it should be from a different package to this one - WARN( not (maybeToBool mod_info) && - case from of { ImportBySystem -> True; other -> False } && - isHomeModule mod, - ppr mod ) - - initRn (InterfaceMode mod) $ - -- Set the module, for use when looking up occurrences - -- of names in interface decls and rules - loadDecls mod (eps_decls eps) (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> - loadRules mod (eps_rules eps) (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> - loadInstDecls mod (eps_insts eps) (pi_insts iface) `thenM` \ new_insts -> - loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> - loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> - loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> - let - version = VersionInfo { vers_module = pi_vers iface, - vers_exports = export_vers, - vers_rules = rule_vers, - vers_decls = decls_vers } - - -- Now add info about this module to the PIT - -- Even home modules loaded by this route (which only - -- happens in OneShot mode) are put in the PIT - has_orphans = pi_orphan iface - new_pit = extendModuleEnv pit mod mod_iface - mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, - mi_version = version, - mi_orphan = has_orphans, mi_boot = hi_boot_file, - mi_exports = avails, - mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_deps = pi_deps iface, - mi_usages = panic "No mi_usages in PIT", - mi_decls = panic "No mi_decls in PIT", - mi_globals = Nothing - } - - new_eps = eps { eps_PIT = new_pit, - eps_decls = new_decls, - eps_insts = new_insts, - eps_rules = new_rules } - in - setEps new_eps `thenM_` - returnM mod_iface - }} - ------------------------------------------------------ --- Loading the export list ------------------------------------------------------ - -loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)]) -loadExports (vers, items) - = mappM loadExport items `thenM` \ avails_s -> - returnM (vers, avails_s) - - -loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails) -loadExport (mod, entities) - = mappM (load_entity mod) entities `thenM` \ avails -> - returnM (mod, avails) - where - load_entity mod (Avail occ) - = newGlobalName2 mod occ `thenM` \ name -> - returnM (Avail name) - load_entity mod (AvailTC occ occs) - = newGlobalName2 mod occ `thenM` \ name -> - mappM (newGlobalName2 mod) occs `thenM` \ names -> - returnM (AvailTC name names) - - ------------------------------------------------------ --- Loading type/class/value decls ------------------------------------------------------ - -loadDecls :: Module - -> DeclsMap - -> [(Version, RdrNameTyClDecl)] - -> TcRn m (NameEnv Version, DeclsMap) -loadDecls mod (decls_map, n_slurped) decls - = foldlM (loadDecl mod) (emptyNameEnv, decls_map) decls `thenM` \ (vers, decls_map') -> - returnM (vers, (decls_map', n_slurped)) - -loadDecl mod (version_map, decls_map) (version, decl) - = maybeStripPragmas decl `thenM` \ decl -> - getTyClDeclBinders mod decl `thenM` \ avail -> - getSysBinders mod decl `thenM` \ sys_names -> - let - full_avail = case avail of - Avail n -> avail - AvailTC n ns -> AvailTC n (sys_names ++ ns) - main_name = availName full_avail - new_decls_map = extendNameEnvList decls_map stuff - stuff = [ (name, (full_avail, name==main_name, (mod, decl))) - | name <- availNames full_avail] - - new_version_map = extendNameEnv version_map main_name version - in --- traceRn (text "Loading" <+> ppr full_avail) `thenM_` - returnM (new_version_map, new_decls_map) - -maybeStripPragmas sig@(IfaceSig {tcdIdInfo = idinfo}) - = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> - if ignore_prags - then returnM sig{ tcdIdInfo = [] } - else returnM sig -maybeStripPragmas other - = returnM other - ------------------ -getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo - -getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) - = newTopBinder mod var src_loc `thenM` \ var_name -> - returnM (Avail var_name) - -getTyClDeclBinders mod tycl_decl - = mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) -> - returnM (AvailTC main_name names) - where - new (nm,loc) = newTopBinder mod nm loc - --------------------------------- --- The "system names" are extra implicit names *bound* by the decl. - -getSysBinders :: Module -> TyClDecl RdrName -> TcRn m [Name] --- Similar to tyClDeclNames, but returns the "implicit" --- or "system" names of the declaration. And it only works --- on RdrNames, returning OccNames - -getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc}) - = mapM (new_sys_bndr mod loc) sys_occs - where - -- C.f. TcClassDcl.tcClassDecl1 - sys_occs = tc_occ : data_occ : dwrap_occ : dwork_occ : sc_sel_occs - cls_occ = rdrNameOcc cname - data_occ = mkClassDataConOcc cls_occ - dwrap_occ = mkDataConWrapperOcc data_occ - dwork_occ = mkDataConWorkerOcc data_occ - tc_occ = mkClassTyConOcc cls_occ - sc_sel_occs = [mkSuperDictSelOcc n cls_occ | n <- [1..length cxt]] - -getSysBinders mod (TyData {tcdName = tc_name, tcdCons = DataCons cons, - tcdGeneric = Just want_generic, tcdLoc = loc}) - -- The 'Just' is because this is an interface-file decl - -- so it will say whether to derive generic stuff for it or not - = mapM (new_sys_bndr mod loc) (gen_occs ++ concatMap mk_con_occs cons) - where - new = new_sys_bndr - -- c.f. TcTyDecls.tcTyDecl - tc_occ = rdrNameOcc tc_name - gen_occs | want_generic = [mkGenOcc1 tc_occ, mkGenOcc2 tc_occ] - | otherwise = [] - mk_con_occs (ConDecl name _ _ _ _) - = [mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ] - where - con_occ = rdrNameOcc name -- The "source name" - -getSysBinders mod decl = returnM [] - -new_sys_bndr mod loc occ = newTopBinder mod (mkRdrUnqual occ) loc - - ------------------------------------------------------ --- Loading fixity decls ------------------------------------------------------ - -loadFixDecls decls - = mappM loadFixDecl decls `thenM` \ to_add -> - returnM (mkNameEnv to_add) - -loadFixDecl (FixitySig rdr_name fixity loc) - = lookupGlobalOccRn rdr_name `thenM` \ name -> - returnM (name, FixitySig name fixity loc) - - ------------------------------------------------------ --- Loading instance decls ------------------------------------------------------ - -loadInstDecls :: Module -> IfaceInsts - -> [RdrNameInstDecl] - -> RnM IfaceInsts -loadInstDecls mod (insts, n_slurped) decls - = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' -> - returnM (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. - -- - -- We *don't* want to count names in the context part as gates, though. - -- For example: - -- instance Foo a => Baz (T a) where ... - -- - -- Here the gates are Baz and T, but *not* Foo. - -- - -- HOWEVER: functional dependencies make things more complicated - -- class C a b | a->b where ... - -- instance C Foo Baz where ... - -- Here, the gates are really only C and Foo, *not* Baz. - -- That is, if C and Foo are visible, even if Baz isn't, we must - -- slurp the decl. - -- - -- Rather than take fundeps into account "properly", we just slurp - -- if C is visible and *any one* of the Names in the types - -- This is a slightly brutal approximation, but most instance decls - -- are regular H98 ones and it's perfect for them. - -- - -- NOTICE that we rename the type before extracting its free - -- variables. The free-variable finder for a renamed HsType - -- does the Right Thing for built-in syntax like [] and (,). - rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' -> - let - (tvs,_,cls,tys) = splitHsInstDeclTy inst_ty' - free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs - - gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs) - -- The 'vis_fn' returns True for visible names - -- Here is the implementation of HOWEVER above - -- (Note that we do let the inst decl in if it mentions - -- no tycons at all. Hence the null free_ty_names.) - in --- traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_` - returnM ((gate_fn, (mod, decl)) `consBag` insts) - - - ------------------------------------------------------ --- Loading Rules ------------------------------------------------------ - -loadRules :: Module - -> IfaceRules - -> (Version, [RdrNameRuleDecl]) - -> RnM (Version, IfaceRules) -loadRules mod (rule_bag, n_slurped) (version, rules) - = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> - if null rules || ignore_prags - then returnM (version, (rule_bag, n_slurped)) - else mappM (loadRule mod) rules `thenM` \ new_rules -> - returnM (version, (rule_bag `unionBags` - listToBag new_rules, n_slurped)) - -loadRule :: Module -> RdrNameRuleDecl -> RnM (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) - = lookupGlobalOccRn var `thenM` \ var_name -> - returnM (\vis_fn -> vis_fn var_name, (mod, decl)) - - ------------------------------------------------------ --- Loading Deprecations ------------------------------------------------------ - -loadDeprecs :: IfaceDeprecs -> RnM Deprecations -loadDeprecs Nothing = returnM NoDeprecs -loadDeprecs (Just (Left txt)) = returnM (DeprecAll txt) -loadDeprecs (Just (Right prs)) = foldlM loadDeprec emptyNameEnv prs `thenM` \ env -> - returnM (DeprecSome env) -loadDeprec deprec_env (n, txt) - = lookupGlobalOccRn n `thenM` \ name -> --- traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_` - returnM (extendNameEnv deprec_env name (name,txt)) -\end{code} - - -%******************************************************** -%* * - Load the ParsedIface for the *current* module - into a ModIface; then it can be checked - for up-to-date-ness -%* * -%******************************************************** - -\begin{code} -loadOldIface :: ParsedIface -> RnM ModIface - -loadOldIface iface - = loadHomeDecls (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> - loadHomeRules (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> - loadHomeInsts (pi_insts iface) `thenM` \ new_insts -> - mappM loadHomeUsage (pi_usages iface) `thenM` \ usages -> - loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> - loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> - loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> - - getModeRn `thenM` \ (InterfaceMode mod) -> - -- Caller sets the module before the call; also needed - -- by the newGlobalName stuff in some of the loadHomeX calls - let - version = VersionInfo { vers_module = pi_vers iface, - vers_exports = export_vers, - vers_rules = rule_vers, - vers_decls = decls_vers } - - decls = mkIfaceDecls new_decls new_rules new_insts - - mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, - mi_version = version, mi_deps = pi_deps iface, - mi_exports = avails, mi_usages = usages, - mi_boot = False, mi_orphan = pi_orphan iface, - mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_decls = decls, - mi_globals = Nothing - } - in - returnM mod_iface -\end{code} - -\begin{code} -loadHomeDecls :: [(Version, RdrNameTyClDecl)] - -> RnM (NameEnv Version, [RenamedTyClDecl]) -loadHomeDecls decls = foldlM loadHomeDecl (emptyNameEnv, []) decls - -loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) - -> (Version, RdrNameTyClDecl) - -> RnM (NameEnv Version, [RenamedTyClDecl]) -loadHomeDecl (version_map, decls) (version, decl) - = rnTyClDecl decl `thenM` \ decl' -> - returnM (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) - ------------------- -loadHomeRules :: (Version, [RdrNameRuleDecl]) - -> RnM (Version, [RenamedRuleDecl]) -loadHomeRules (version, rules) - = mappM rnIfaceRuleDecl rules `thenM` \ rules' -> - returnM (version, rules') - ------------------- -loadHomeInsts :: [RdrNameInstDecl] - -> RnM [RenamedInstDecl] -loadHomeInsts insts = mappM rnInstDecl insts - ------------------- -loadHomeUsage :: Usage OccName -> TcRn m (Usage Name) -loadHomeUsage usage - = mappM rn_imp (usg_entities usage) `thenM` \ entities' -> - returnM (usage { usg_entities = entities' }) - where - mod_name = usg_name usage - rn_imp (occ,vers) = newGlobalName2 mod_name occ `thenM` \ name -> - returnM (name,vers) -\end{code} - - -%********************************************************* -%* * -\subsection{Reading an interface file} -%* * -%********************************************************* - -\begin{code} -findAndReadIface :: SDoc -> ModuleName - -> IsBootInterface -- True <=> Look for a .hi-boot file - -- False <=> Look for .hi file - -> TcRn m (Either Message (Module, ParsedIface)) - -- Nothing <=> file not found, or unreadable, or illegible - -- Just x <=> successfully found and parsed - - -- It *doesn't* add an error to the monad, because - -- sometimes it's ok to fail... see notes with loadInterface - -findAndReadIface doc_str mod_name hi_boot_file - = traceRn trace_msg `thenM_` - - -- Check for GHC.Prim, and return its static interface - if mod_name == gHC_PRIM_Name - then returnM (Right (gHC_PRIM, ghcPrimIface)) - else - - ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found -> - - case maybe_found of - Left files -> - traceRn (ptext SLIT("...not found")) `thenM_` - getDOpts `thenM` \ dflags -> - returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) - - Right (wanted_mod, file_path) -> - traceRn (ptext SLIT("readIFace") <+> text file_path) `thenM_` - - readIface wanted_mod file_path hi_boot_file `thenM` \ read_result -> - -- Catch exceptions here - - case read_result of - Left exn -> returnM (Left (badIfaceFile file_path - (text (showException exn)))) - - Right iface -> returnM (Right (wanted_mod, iface)) - - where - trace_msg = sep [hsep [ptext SLIT("Reading"), - if hi_boot_file then ptext SLIT("[boot]") else empty, - ptext SLIT("interface for"), - ppr mod_name <> semi], - nest 4 (ptext SLIT("reason:") <+> doc_str)] - -findHiFile :: ModuleName -> IsBootInterface - -> IO (Either [FilePath] (Module, FilePath)) -findHiFile mod_name hi_boot_file - = do { - -- In interactive or --make mode, we are *not allowed* to demand-load - -- a home package .hi file. So don't even look for them. - -- This helps in the case where you are sitting in eg. ghc/lib/std - -- and start up GHCi - it won't complain that all the modules it tries - -- to load are found in the home location. - ghci_mode <- readIORef v_GhcMode ; - let { home_allowed = hi_boot_file || - not (isCompManagerMode ghci_mode) } ; - maybe_found <- if home_allowed - then findModule mod_name - else findPackageModule mod_name ; - - case maybe_found of { - Left files -> return (Left files) ; - - Right (mod,loc) -> do { - - -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate - let { hi_path = ml_hi_file loc ; - hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ; - hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt - }; - - if not hi_boot_file then - return (Right (mod, hi_path)) - else do { - hi_ver_exists <- doesFileExist hi_boot_ver_path ; - if hi_ver_exists then return (Right (mod, hi_boot_ver_path)) - else return (Right (mod, hi_boot_path)) - }}}} -\end{code} - -@readIface@ tries just the one file. - -\begin{code} -readIface :: Module -> String -> IsBootInterface -> TcRn m (Either Exception ParsedIface) - -- Nothing <=> file not found, or unreadable, or illegible - -- Just x <=> successfully found and parsed - -readIface mod file_path is_hi_boot_file - = do dflags <- getDOpts - ioToTcRn (tryMost (read_iface mod dflags file_path is_hi_boot_file)) - -read_iface mod dflags file_path is_hi_boot_file - | is_hi_boot_file -- Read ascii - = do { buffer <- hGetStringBuffer file_path ; - case unP parseIface (mkPState buffer loc dflags) of - POk _ iface | wanted_mod_name == actual_mod_name - -> return iface - | otherwise - -> throwDyn (ProgramError (showSDoc err)) - -- 'showSDoc' is a bit yukky - where - wanted_mod_name = moduleName mod - actual_mod_name = pi_mod iface - err = hiModuleNameMismatchWarn wanted_mod_name actual_mod_name - - PFailed loc1 loc2 err -> - throwDyn (ProgramError (showPFailed loc1 loc2 err)) - } - - | otherwise -- Read binary - = readBinIface file_path - - where - loc = mkSrcLoc (mkFastString file_path) 1 0 -\end{code} - - -%********************************************************* -%* * - Wired-in interface for GHC.Prim -%* * -%********************************************************* - -\begin{code} -ghcPrimIface :: ParsedIface -ghcPrimIface = ParsedIface { - pi_mod = gHC_PRIM_Name, - pi_pkg = basePackage, - pi_deps = noDependencies, - pi_vers = 1, - pi_orphan = False, - pi_usages = [], - pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), - pi_decls = [], - pi_fixity = [FixitySig (nameRdrName (idName seqId)) - (Fixity 0 InfixR) noSrcLoc], - -- seq is infixr 0 - pi_insts = [], - pi_rules = (1,[]), - pi_deprecs = Nothing - } -\end{code} - -%********************************************************* -%* * -\subsection{Errors} -%* * -%********************************************************* - -\begin{code} -badIfaceFile file err - = vcat [ptext SLIT("Bad interface file:") <+> text file, - nest 4 err] - -hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message -hiModuleNameMismatchWarn requested_mod read_mod = - hsep [ ptext SLIT("Something is amiss; requested module name") - , ppr requested_mod - , ptext SLIT("differs from name found in the interface file") - , ppr read_mod - ] - -warnRedundantSourceImport mod_name - = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") - <+> quotes (ppr mod_name) - -warnSelfImport mod - = ptext SLIT("Importing my own interface: module") <+> ppr mod -\end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 0d20ecf8a2..716309ddb3 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -9,13 +9,11 @@ module RnHsSyn where #include "HsVersions.h" import HsSyn -import HsCore -import Class ( FunDep, DefMeth(..) ) -import TyCon ( visibleDataCons, tyConName ) +import Class ( FunDep ) import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet -import BasicTypes ( Boxity, FixitySig ) +import BasicTypes ( Boxity ) import Outputable \end{code} @@ -30,7 +28,6 @@ type RenamedRuleDecl = RuleDecl Name type RenamedTyClDecl = TyClDecl Name type RenamedDefaultDecl = DefaultDecl Name type RenamedForeignDecl = ForeignDecl Name -type RenamedCoreDecl = CoreDecl Name type RenamedGRHS = GRHS Name type RenamedGRHSs = GRHSs Name type RenamedHsBinds = HsBinds Name @@ -81,12 +78,10 @@ extractHsTyNames ty get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` get ty - get (HsTupleTy con tys) = hsTupConFVs con `unionNameSets` extractHsTyNames_s tys + get (HsTupleTy con tys) = extractHsTyNames_s tys get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsPredTy p) = extractHsPredTyNames p - get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` - case tycon of { HsTyOp n -> unitNameSet n ; - HsArrow -> emptyNameSet } + get (HsOpTy ty1 op ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` unitNameSet op get (HsParTy ty) = get ty get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv @@ -129,67 +124,14 @@ In all cases this is set up for interface-file declarations: \begin{code} ---------------- -impDeclFVs :: RenamedHsDecl -> NameSet - -- Just the ones that come from imports -impDeclFVs (InstD d) = instDeclFVs d -impDeclFVs (TyClD d) = tyClDeclFVs d - ----------------- -tyClDeclFVs :: RenamedTyClDecl -> NameSet -tyClDeclFVs (ForeignType {}) - = emptyFVs - -tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos}) - = extractHsTyNames ty `plusFV` - plusFVs (map hsIdInfoFVs id_infos) - -tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls}) - = delFVs (map hsTyVarName tyvars) $ - extractHsCtxtTyNames context `plusFV` - plusFVs (map conDeclFVs (visibleDataCons condecls)) - -tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty}) - = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty) - -tyClDeclFVs (ClassDecl {tcdCtxt = context, tcdTyVars = tyvars, tcdFDs = fds, - tcdSigs = sigs, tcdMeths = maybe_meths}) - = delFVs (map hsTyVarName tyvars) $ - extractHsCtxtTyNames context `plusFV` - plusFVs (map extractFunDepNames fds) `plusFV` - hsSigsFVs sigs `plusFV` - dm_fvs - where - dm_fvs = case maybe_meths of - Nothing -> mkFVs [v | ClassOpSig _ (DefMeth v) _ _ <- sigs] - -- No method bindings, so this class decl comes from an interface file, - -- So we want to treat the default-method names as free (they should - -- be defined somewhere else). [In source code this is not so; the class - -- decl will bind whatever default-methods are necessary.] - Just _ -> emptyFVs -- Source code, so the default methods - -- are *bound* not *free* - ----------------- hsSigsFVs sigs = plusFVs (map hsSigFVs sigs) hsSigFVs (Sig v ty _) = extractHsTyNames ty hsSigFVs (SpecInstSig ty _) = extractHsTyNames ty hsSigFVs (SpecSig v ty _) = extractHsTyNames ty -hsSigFVs (ClassOpSig _ _ ty _) = extractHsTyNames ty hsSigFVs other = emptyFVs ---------------- -instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _) - = extractHsTyNames inst_ty `plusFV` - (case maybe_dfun of { Just n -> unitFV n; Nothing -> emptyFVs }) - ----------------- -ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs -ruleDeclFVs (IfaceRuleOut _ _) = emptyFVs -ruleDeclFVs (IfaceRule _ _ vars _ args rhs _) - = delFVs (map ufBinderName vars) $ - ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args) - ----------------- conDeclFVs (ConDecl _ tyvars context details _) = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` @@ -200,41 +142,6 @@ conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds] bangTyFVs bty = extractHsTyNames (getBangType bty) - ----------------- -hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf -hsIdInfoFVs (HsWorker n a) = unitFV n -hsIdInfoFVs other = emptyFVs - ----------------- -ufExprFVs (UfVar n) = unitFV n -ufExprFVs (UfLit l) = emptyFVs -ufExprFVs (UfFCall cc ty) = extractHsTyNames ty -ufExprFVs (UfType ty) = extractHsTyNames ty -ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es) -ufExprFVs (UfLam v e) = ufBndrFVs v (ufExprFVs e) -ufExprFVs (UfApp e1 e2) = ufExprFVs e1 `plusFV` ufExprFVs e2 -ufExprFVs (UfCase e n as) = ufExprFVs e `plusFV` delFV n (plusFVs (map ufAltFVs as)) -ufExprFVs (UfNote n e) = ufNoteFVs n `plusFV` ufExprFVs e -ufExprFVs (UfLet (UfNonRec b r) e) = ufExprFVs r `plusFV` ufBndrFVs b (ufExprFVs e) -ufExprFVs (UfLet (UfRec prs) e) = foldr ufBndrFVs - (foldr (plusFV . ufExprFVs . snd) (ufExprFVs e) prs) - (map fst prs) - -ufBndrFVs (UfValBinder n ty) fvs = extractHsTyNames ty `plusFV` delFV n fvs -ufBndrFVs (UfTyBinder n k) fvs = delFV n fvs - -ufAltFVs (con, vs, e) = ufConFVs con `plusFV` delFVs vs (ufExprFVs e) - -ufConFVs (UfDataAlt n) = unitFV n -ufConFVs (UfTupleAlt t) = hsTupConFVs t -ufConFVs other = emptyFVs - -ufNoteFVs (UfCoerce ty) = extractHsTyNames ty -ufNoteFVs note = emptyFVs - -hsTupConFVs (HsTupCon bx n) = unitFV (tyConName (tupleTyCon bx n)) - -- Always return the TyCon; that'll suck in the data con \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs deleted file mode 100644 index 81a2990961..0000000000 --- a/ghc/compiler/rename/RnIfaces.lhs +++ /dev/null @@ -1,731 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -section -\%[RnIfaces]{Cacheing and Renaming of Interfaces} - -\begin{code} -module RnIfaces - ( slurpImpDecls, importSupportingDecls, - RecompileRequired, outOfDate, upToDate, checkVersions - ) -where - -#include "HsVersions.h" - -import CmdLineOpts ( DynFlag(..), opt_NoPruneDecls ) -import HscTypes -import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..), - InstDecl(..), HsType(..), hsTyVarNames, getBangType - ) -import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) -import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, - extractHsTyNames, extractHsCtxtTyNames, - tyClDeclFVs, ruleDeclFVs, impDeclFVs - ) -import RnHiFiles ( loadInterface, loadHomeInterface, loadOrphanModules ) -import RnNames ( mkModDeps ) -import RnSource ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl ) -import TcEnv ( getInGlobalScope, tcLookupGlobal_maybe ) -import TcRnMonad -import Id ( idType, idName, globalIdDetails ) -import IdInfo ( GlobalIdDetails(..) ) -import TcType ( tyClsNamesOfType, classNamesOfTheta ) -import FieldLabel ( fieldLabelTyCon ) -import DataCon ( dataConTyCon, dataConWrapId ) -import TyCon ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName ) -import Class ( className, classSCTheta ) -import Name ( Name {-instance NamedThing-}, isWiredInName, nameIsLocalOrFrom, - nameModule, NamedThing(..) ) -import NameEnv ( delFromNameEnv, lookupNameEnv ) -import NameSet -import Module ( Module, isHomeModule ) -import PrelNames ( hasKey, fractionalClassKey, numClassKey, - integerTyConName, doubleTyConName ) -import Outputable -import Bag -import Maybe( fromJust ) -\end{code} - - -%********************************************************* -%* * -\subsection{Slurping declarations} -%* * -%********************************************************* - -\begin{code} -------------------------------------------------------- -slurpImpDecls :: FreeVars -> TcRn m [RenamedHsDecl] -slurpImpDecls source_fvs - = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenM_` - - -- Slurp in things which might be 'gates' for instance - -- declarations, plus the instance declarations themselves - slurpSourceRefs source_fvs `thenM` \ (gate_decls, bndrs) -> - - -- Then get everything else - let - needed = foldr (plusFV . impDeclFVs) emptyFVs gate_decls - in - import_supporting_decls (gate_decls, bndrs) needed - - -------------------------------------------------------- -slurpSourceRefs :: FreeVars -- Variables referenced in source - -> TcRn m ([RenamedHsDecl], -- Needed declarations - NameSet) -- Names bound by those declarations --- Slurp imported declarations needed directly by the source code; --- and some of the ones they need. The goal is to find all the 'gates' --- for instance declarations. - -slurpSourceRefs source_fvs - = go_outer [] emptyFVs -- Accumulating decls - (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet - where - -- The outer loop repeatedly slurps the decls for the current gates - -- 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 bndrs [] = returnM (decls, bndrs) - - go_outer decls bndrs refs -- 'refs' are not necessarily slurped yet - = traceRn (text "go_outer" <+> ppr refs) `thenM_` - foldlM go_inner (decls, bndrs, emptyFVs) refs `thenM` \ (decls1, bndrs1, gates1) -> - getImportedInstDecls gates1 `thenM` \ (inst_decls, new_gates) -> - rnIfaceDecls rnInstDecl inst_decls `thenM` \ inst_decls' -> - go_outer (map InstD inst_decls' ++ decls1) - bndrs1 - (nameSetToList (new_gates `plusFV` plusFVs (map getInstDeclGates inst_decls'))) - -- NB: we go round again to fetch the decls for any gates of any decls - -- we have loaded. For example, if we mention - -- print :: Show a => a -> String - -- then we must load the decl for Show before stopping, to ensure - -- that instances from its home module are available - - go_inner (decls, bndrs, gates) wanted_name - = importDecl bndrs wanted_name `thenM` \ import_result -> - case import_result of - AlreadySlurped -> returnM (decls, bndrs, gates) - - InTypeEnv ty_thing - -> returnM (decls, - bndrs `addOneFV` wanted_name, -- Avoid repeated calls to getWiredInGates - gates `plusFV` getWiredInGates ty_thing) - - HereItIs decl new_bndrs - -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl -> - returnM (TyClD new_decl : decls, - bndrs `plusFV` new_bndrs, - gates `plusFV` getGates source_fvs new_decl) -\end{code} - -\begin{code} -------------------------------------------------------- --- import_supporting_decls keeps going until the free-var set is empty -importSupportingDecls needed - = import_supporting_decls ([], emptyNameSet) needed - -import_supporting_decls - :: ([RenamedHsDecl], NameSet) -- Some imported decls, with their binders - -> FreeVars -- Remaining un-slurped names - -> TcRn m [RenamedHsDecl] -import_supporting_decls decls needed - = slurpIfaceDecls decls needed `thenM` \ (decls1, bndrs1) -> - getImportedRules bndrs1 `thenM` \ rule_decls -> - case rule_decls of - [] -> returnM decls1 -- No new rules, so we are done - other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenM` \ rule_decls' -> - let - rule_fvs = plusFVs (map ruleDeclFVs rule_decls') - decls2 = decls1 ++ map RuleD rule_decls' - in - traceRn (text "closeRules" <+> ppr rule_decls' $$ - fsep (map ppr (nameSetToList rule_fvs))) `thenM_` - import_supporting_decls (decls2, bndrs1) rule_fvs - - -------------------------------------------------------- --- Augment decls with any decls needed by needed, --- and so on transitively -slurpIfaceDecls :: ([RenamedHsDecl], NameSet) -- Already slurped - -> FreeVars -- Still needed - -> TcRn m ([RenamedHsDecl], NameSet) -slurpIfaceDecls (decls, bndrs) needed - = slurp decls bndrs (nameSetToList needed) - where - slurp decls bndrs [] = returnM (decls, bndrs) - slurp decls bndrs (n:ns) - = importDecl bndrs n `thenM` \ import_result -> - case import_result of - HereItIs decl new_bndrs -- Found a declaration... rename it - -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl -> - slurp (TyClD new_decl : decls) - (bndrs `plusFV` new_bndrs) - (nameSetToList (tyClDeclFVs new_decl) ++ ns) - - - other -> -- No declaration... (wired in thing, or deferred, - -- or already slurped) - slurp decls (bndrs `addOneFV` n) ns - -------------------------------------------------------- -rnIfaceDecls rn decls = mappM (rnIfaceDecl rn) decls -rnIfaceDecl rn (mod, decl) = initRn (InterfaceMode mod) (rn decl) -\end{code} - - -\begin{code} - -- Tiresomely, we must get the "main" name for the - -- thing, because that's what VSlurp contains, and what - -- is recorded in the usage information -get_main_name (AClass cl) = className cl -get_main_name (ADataCon dc) = tyConName (dataConTyCon dc) -get_main_name (ATyCon tc) - | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas) - | otherwise = tyConName tc -get_main_name (AnId id) - = case globalIdDetails id of - DataConWorkId dc -> get_main_name (ATyCon (dataConTyCon dc)) - DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc)) - RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl)) - GenericOpId tc -> get_main_name (ATyCon tc) - ClassOpId cl -> className cl - other -> idName id - - -recordUsage :: Name -> TcRn m () --- Record that the Name has been used, for --- later generation of usage info in the interface file -recordUsage name = updUsages (upd_usg name) - -upd_usg name usages - | isHomeModule mod = addOneToNameSet usages name - | otherwise = usages - where - mod = nameModule name -\end{code} - - -%********************************************************* -%* * -\subsection{Getting in a declaration} -%* * -%********************************************************* - -\begin{code} -importDecl :: NameSet -> Name -> TcRn m ImportDeclResult - -data ImportDeclResult - = AlreadySlurped - | InTypeEnv TyThing - | HereItIs (Module, RdrNameTyClDecl) NameSet - -- The NameSet is the bunch of names bound by this decl - -importDecl already_slurped name - = -- STEP 0: Check if it's from this module - -- Doing this catches a common case quickly - getModule `thenM` \ this_mod -> - if nameIsLocalOrFrom this_mod name then - -- Variables defined on the GHCi command line (e.g. let x = 3) - -- are Internal names (which don't have a Module) - returnM AlreadySlurped - else - - -- STEP 1: Check if we've slurped it in while compiling this module - if name `elemNameSet` already_slurped then - returnM AlreadySlurped - else - - -- STEP 2: Check if it's already in the type environment - tcLookupGlobal_maybe name `thenM` \ maybe_thing -> - case maybe_thing of { - - Just ty_thing - | isWiredInName 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 `thenM_` - returnM (InTypeEnv ty_thing) - - | otherwise - -> -- We have slurp something that's already in the type environment, - -- that was not slurped in an earlier compilation. - -- Must still record it in the Usages info, because that's used to - -- generate usage information - - traceRn (text "not wired in" <+> ppr name) `thenM_` - recordUsage (get_main_name ty_thing) `thenM_` - returnM (InTypeEnv ty_thing) ; - - Nothing -> - - -- STEP 4: OK, we have to slurp it in from an interface file - -- First load the interface file - traceRn nd_doc `thenM_` - loadHomeInterface nd_doc name `thenM_` - - -- STEP 4: Get the declaration out - getEps `thenM` \ eps -> - let - (decls_map, n_slurped) = eps_decls eps - in - case lookupNameEnv decls_map name of - Just (avail,_,decl) -> setEps eps' `thenM_` - recordUsage (availName avail) `thenM_` - returnM (HereItIs decl (mkFVs avail_names)) - where - avail_names = availNames avail - new_decls_map = foldl delFromNameEnv decls_map avail_names - eps' = eps { eps_decls = (new_decls_map, n_slurped+1) } - - Nothing -> addErr (getDeclErr name) `thenM_` - returnM AlreadySlurped - } - where - wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name - nd_doc = ptext SLIT("need decl for") <+> ppr name - -\end{code} - - -%********************************************************* -%* * -\subsection{Extracting the `gates'} -%* * -%********************************************************* - -The gating story -~~~~~~~~~~~~~~~~~ -We want to avoid sucking in too many instance declarations. -An instance decl is only useful if the types and classes mentioned in -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 -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. - -More precisely, the gates of a module are the types and classes -that are mentioned in: - - a) the source code [Note: in fact these don't seem - to be treated as gates, perhaps - because no imported instance decl - can mention them; mutter mutter - recursive modules.] - 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 the gates of a previously-loaded module - -The latter constraint is because there might have been an instance -decl slurped in during an earlier compilation, like this: - - instance Foo a => Baz (Maybe a) where ... - -In the module being compiled we might need (Baz (Maybe T)), where T is -defined in this module, and hence we need the instance for (Foo T). -So @Foo@ becomes a gate. But there's no way to 'see' that. More -generally, types might be involved as well: - - instance Foo2 S a => Baz2 a where ... - -Now we must treat S as a gate too, as well as Foo2. So the solution -we adopt is: - - we simply treat the gates of all previously-loaded - modules as gates of this one - -So the gates are remembered across invocations of the renamer in the -PersistentRenamerState. This gloss mainly affects ghc --make and ghc ---interactive. - -(We used to use the persistent type environment for this purpose, -but it has too much. For a start, it contains all tuple types, -because they are in the wired-in type env!) - - -Consructors and class operations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we import a declaration like - - data T = T1 Wibble | T2 Wobble - -we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless} -@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. - -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 - -- Used for the cunning "constructors and - -- class ops" story described 10 lines above. - -> RenamedTyClDecl - -> FreeVars - -getGates source_fvs decl - = get_gates (\n -> n `elemNameSet` source_fvs) decl - -get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon -get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty - -get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs}) - = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` - implicitClassGates cls - where - super_cls_and_sigs = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) - (hsTyVarNames tvs) - get (ClassOpSig n _ ty _) - | is_used n = extractHsTyNames ty - | otherwise = emptyFVs - -get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty}) - = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs) - -- A type synonym type constructor isn't a "gate" for instance decls - -get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons}) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) - (visibleDataCons cons)) - (hsTyVarNames tvs) - `addOneToNameSet` tycon - where - get (ConDecl n tvs ctxt details _) - | is_used n - -- If the constructor is method, get fvs from all its fields - = delListFromNameSet (get_details details `plusFV` - extractHsCtxtTyNames ctxt) - (hsTyVarNames tvs) - get (ConDecl n tvs ctxt (RecCon fields) _) - -- Even if the constructor isn't mentioned, the fields - -- might be, as selectors. They can't mention existentially - -- bound tyvars (typechecker checks for that) so no need for - -- the deleteListFromNameSet part - = foldr (plusFV . get_field) emptyFVs fields - - get other_con = emptyFVs - - get_details (PrefixCon tys) = plusFVs (map get_bang tys) - get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 - get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - - get_field (f,t) | is_used f = get_bang t - | otherwise = emptyFVs - - get_bang bty = extractHsTyNames (getBangType bty) - -implicitClassGates :: Name -> FreeVars -implicitClassGates cls - -- If we load class Num, add Integer to the free gates - -- This takes account of the fact that Integer might be needed for - -- defaulting, but we don't want to load Integer (and all its baggage) - -- if there's no numeric stuff needed. - -- Similarly for class Fractional and Double - -- - -- NB: adding T to the gates will force T to be loaded - -- - -- NB: If we load (say) Floating, we'll end up loading Fractional too, - -- since Fractional is a superclass of Floating - | cls `hasKey` numClassKey = unitFV integerTyConName - | cls `hasKey` fractionalClassKey = unitFV doubleTyConName - | otherwise = emptyFVs -\end{code} - -@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 (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 (AClass cl) - = unitFV (getName cl) `plusFV` mkFVs super_classes - where - super_classes = classNamesOfTheta (classSCTheta cl) - -getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id) -getWiredInGates (ADataCon dc) = tyClsNamesOfType (idType (dataConWrapId dc)) - -- Should include classes in the 'stupid context' of the data con? -getWiredInGates (ATyCon tc) - | isSynTyCon tc = tyClsNamesOfType ty - | otherwise = unitFV (getName tc) - where - (_,ty) = getSynTyConDefn tc - -getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty -\end{code} - -\begin{code} -getImportedInstDecls :: NameSet -> TcRn m ([(Module,RdrNameInstDecl)], NameSet) - -- Returns the gates that are new since last time -getImportedInstDecls gates - = -- First, load any orphan-instance modules that aren't aready loaded - -- Orphan-instance modules are recorded in the module dependecnies - getImports `thenM` \ imports -> - getEps `thenM` \ eps -> - let - old_gates = eps_inst_gates eps - new_gates = gates `minusNameSet` old_gates - all_gates = new_gates `unionNameSets` old_gates - orphan_mods = imp_orphs imports - in - loadOrphanModules orphan_mods `thenM_` - - -- Now we're ready to grab the instance declarations - -- Find the un-gated ones and return them, - -- removing them from the bag kept in EPS - -- Don't foget to get the EPS a second time... - -- loadOrphanModules may have side-effected it! - getEps `thenM` \ eps -> - let - available n = n `elemNameSet` all_gates - (decls, new_insts) = selectGated available (eps_insts eps) - in - setEps (eps { eps_insts = new_insts, - eps_inst_gates = all_gates }) `thenM_` - - traceRn (sep [text "getImportedInstDecls:", - nest 4 (fsep (map ppr (nameSetToList gates))), - nest 4 (fsep (map ppr (nameSetToList all_gates))), - nest 4 (fsep (map ppr (nameSetToList new_gates))), - text "Slurped" <+> int (length decls) <+> text "instance declarations", - nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenM_` - returnM (decls, new_gates) - -ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _) - = case inst_ty of - HsForAllTy _ _ tau -> ppr tau - other -> ppr inst_ty - -getImportedRules :: NameSet -- Slurped already - -> TcRn m [(Module,RdrNameRuleDecl)] -getImportedRules slurped - = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> - if ignore_prags then returnM [] else -- ... - getEps `thenM` \ eps -> - getInGlobalScope `thenM` \ in_type_env -> - let -- Slurp rules for anything that is slurped, - -- either now, or previously - available n = n `elemNameSet` slurped || in_type_env n - (decls, new_rules) = selectGated available (eps_rules eps) - in - if null decls then - returnM [] - else - setEps (eps { eps_rules = new_rules }) `thenM_` - traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenM_` - returnM decls - -selectGated :: (Name->Bool) -> GatedDecls d - -> ([(Module,d)], GatedDecls d) -selectGated available (decl_bag, n_slurped) - -- Select only those decls whose gates are *all* available -#ifdef DEBUG - | opt_NoPruneDecls -- Just to try the effect of not gating at all - = let - decls = foldrBag (\ (_,d) ds -> d:ds) [] decl_bag -- Grab them all - in - (decls, (emptyBag, n_slurped + length decls)) - - | otherwise -#endif - = case foldrBag select ([], emptyBag) decl_bag of - (decls, new_bag) -> (decls, (new_bag, n_slurped + length decls)) - where - select (gate_fn, decl) (yes, no) - | gate_fn available = (decl:yes, no) - | otherwise = (yes, (gate_fn,decl) `consBag` no) -\end{code} - - -%******************************************************** -%* * -\subsection{Checking usage information} -%* * -%******************************************************** - -@recompileRequired@ is called from the HscMain. It checks whether -a recompilation is required. It needs access to the persistent state, -finder, etc, because it may have to load lots of interface files to -check their versions. - -\begin{code} -type RecompileRequired = Bool -upToDate = False -- Recompile not required -outOfDate = True -- Recompile required - -checkVersions :: Bool -- True <=> source unchanged - -> ModIface -- Old interface - -> TcRn m RecompileRequired -checkVersions source_unchanged iface - | not source_unchanged - = returnM outOfDate - | otherwise - = traceHiDiffs (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) `thenM_` - - -- Source code unchanged and no errors yet... carry on - -- First put the dependent-module info in the envt, just temporarily, - -- so that when we look for interfaces we look for the right one (.hi or .hi-boot) - -- It's just temporary because either the usage check will succeed - -- (in which case we are done with this module) or it'll fail (in which - -- case we'll compile the module from scratch anyhow). - updGblEnv (\ gbl -> gbl { tcg_imports = mod_deps }) ( - checkList [checkModUsage u | u <- mi_usages iface] - ) - - where - -- This is a bit of a hack really - mod_deps = emptyImportAvails { imp_dep_mods = mkModDeps (dep_mods (mi_deps iface)) } - -checkList :: [TcRn m RecompileRequired] -> TcRn m RecompileRequired -checkList [] = returnM upToDate -checkList (check:checks) = check `thenM` \ recompile -> - if recompile then - returnM outOfDate - else - checkList checks -\end{code} - -\begin{code} -checkModUsage :: Usage Name -> TcRn m RecompileRequired --- Given the usage information extracted from the old --- M.hi file for the module being compiled, figure out --- whether M needs to be recompiled. - -checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers, - usg_rules = old_rule_vers, - usg_exports = maybe_old_export_vers, - usg_entities = old_decl_vers }) - = -- Load the imported interface is possible - let - doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] - in - traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_` - - tryM (loadInterface doc_str mod_name ImportBySystem) `thenM` \ mb_iface -> - - case mb_iface of { - Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), - ppr mod_name])); - -- Couldn't find or parse a module mentioned in the - -- old interface file. Don't complain -- it might just be that - -- the current module doesn't need that import and it's been deleted - - Right iface -> - let - new_vers = mi_version iface - new_mod_vers = vers_module new_vers - new_decl_vers = vers_decls new_vers - new_export_vers = vers_exports new_vers - new_rule_vers = vers_rules new_vers - in - -- CHECK MODULE - checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile -> - if not recompile then - returnM upToDate - else - - -- CHECK EXPORT LIST - if checkExportList maybe_old_export_vers new_export_vers then - out_of_date_vers (ptext SLIT(" Export list changed")) - (fromJust maybe_old_export_vers) - new_export_vers - else - - -- CHECK RULES - if old_rule_vers /= new_rule_vers then - out_of_date_vers (ptext SLIT(" Rules changed")) - old_rule_vers new_rule_vers - else - - -- CHECK ITEMS ONE BY ONE - checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile -> - if recompile then - returnM outOfDate -- This one failed, so just bail out now - else - up_to_date (ptext SLIT(" Great! The bits I use are up to date")) - - } - ------------------------- -checkModuleVersion old_mod_vers new_mod_vers - | new_mod_vers == old_mod_vers - = up_to_date (ptext SLIT("Module version unchanged")) - - | otherwise - = out_of_date_vers (ptext SLIT(" Module version has changed")) - old_mod_vers new_mod_vers - ------------------------- -checkExportList Nothing new_vers = upToDate -checkExportList (Just v) new_vers = v /= new_vers - ------------------------- -checkEntityUsage new_vers (name,old_vers) - = case lookupNameEnv new_vers name of - - Nothing -> -- We used it before, but it ain't there now - out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) - - Just new_vers -- It's there, but is it up to date? - | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_` - returnM upToDate - | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name) - old_vers new_vers - -up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate -out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate -out_of_date_vers msg old_vers new_vers - = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers]) -\end{code} - - -%********************************************************* -%* * -\subsection{Errors} -%* * -%********************************************************* - -\begin{code} -getDeclErr name - = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name), - ptext SLIT("from module") <+> quotes (ppr (nameModule name)) - ] -\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index d1a4f016df..f394f43fdf 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -6,45 +6,46 @@ \begin{code} module RnNames ( rnImports, importsFromLocalDecls, exportsFromAvail, - reportUnusedNames, mkModDeps + reportUnusedNames, mkModDeps, exportsToAvails ) where #include "HsVersions.h" -import {-# SOURCE #-} RnHiFiles ( loadInterface ) - import CmdLineOpts ( DynFlag(..) ) - import HsSyn ( IE(..), ieName, ImportDecl(..), ForeignDecl(..), HsGroup(..), collectLocatedHsBinders, tyClDeclNames ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, main_RDR_Unqual ) import RnEnv +import IfaceEnv ( lookupOrig, lookupImplicitOrig ) +import LoadIface ( loadSrcInterface ) import TcRnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, isBuiltInSyntaxName ) -import Module ( Module, ModuleName, ModuleEnv, moduleName, +import PrelNames ( pRELUDE_Name, isBuiltInSyntaxName, isUnboundName ) +import Module ( Module, ModuleName, moduleName, moduleNameUserString, isHomeModule, - emptyModuleEnv, unitModuleEnvByName, unitModuleEnv, - lookupModuleEnvByName, extendModuleEnvByName, moduleEnvElts ) -import Name ( Name, nameSrcLoc, nameOccName, nameModule, isExternalName ) + unitModuleEnvByName, unitModuleEnv, + lookupModuleEnvByName, moduleEnvElts ) +import Name ( Name, nameSrcLoc, nameOccName, nameModuleName, + nameParent, nameParent_maybe, isExternalName ) import NameSet import NameEnv import OccName ( OccName, srcDataName, isTcOcc ) -import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, - GenAvailInfo(..), AvailInfo, Avails, GhciMode(..), - IsBootInterface, - availName, availNames, availsToNameSet, - Deprecations(..), ModIface(..), Dependencies(..), - GlobalRdrElt(..), unQualInScope, isLocalGRE, pprNameProvenance +import HscTypes ( GenAvailInfo(..), AvailInfo, Avails, GhciMode(..), + IsBootInterface, IfaceExport, + availName, availNames, availsToNameSet, unQualInScope, + Deprecs(..), ModIface(..), Dependencies(..) ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, lookupRdrEnv, rdrEnvToList, - emptyRdrEnv, foldRdrEnv, rdrEnvElts, mkRdrUnqual, isQual ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, + GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), + emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts, + unQualOK, lookupGRE_Name, + Provenance(..), ImportSpec(..), + isLocalGRE, pprNameProvenance ) import Outputable -import Maybe ( isJust, isNothing, catMaybes ) -import Maybes ( orElse ) +import Maybes ( isJust, isNothing, catMaybes, mapCatMaybes ) import ListSetOps ( removeDups ) import Util ( sortLt, notNull ) import List ( partition, insert ) @@ -61,7 +62,7 @@ import IO ( openFile, IOMode(..) ) \begin{code} rnImports :: [RdrNameImportDecl] - -> TcRn m (GlobalRdrEnv, ImportAvails) + -> RnM (GlobalRdrEnv, ImportAvails) rnImports imports = -- PROCESS IMPORT DECLS @@ -84,7 +85,7 @@ rnImports imports let (imp_gbl_envs, imp_avails) = unzip (stuff1 ++ stuff2) gbl_env :: GlobalRdrEnv - gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs + gbl_env = foldr plusGlobalRdrEnv emptyGlobalRdrEnv imp_gbl_envs all_avails :: ImportAvails all_avails = foldr plusImportAvails emptyImportAvails imp_avails @@ -119,35 +120,38 @@ preludeImportDecl loc \begin{code} importsFromImportDecl :: Module -> RdrNameImportDecl - -> TcRn m (GlobalRdrEnv, ImportAvails) + -> RnM (GlobalRdrEnv, ImportAvails) importsFromImportDecl this_mod - (ImportDecl imp_mod_name is_boot qual_only as_mod imp_spec iloc) + (ImportDecl imp_mod_name want_boot qual_only as_mod imp_details iloc) = addSrcLoc iloc $ + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' let + this_mod_name = moduleName this_mod doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") in + loadSrcInterface doc imp_mod_name want_boot `thenM` \ iface -> - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - tryM (loadInterface doc imp_mod_name (ImportByUser is_boot)) `thenM` \ mb_iface -> + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) - case mb_iface of { - Left exn -> returnM (emptyRdrEnv, emptyImportAvails ) ; - Right iface -> + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports + warnIf (want_boot && not (mi_boot iface)) + (warnRedundantSourceImport imp_mod_name) `thenM_` let - imp_mod = mi_module iface - avails_by_module = mi_exports iface - deprecs = mi_deprecs iface - is_orph = mi_orphan iface - deps = mi_deps iface - - avails :: Avails - avails = [ avail | (mod_name, avails) <- avails_by_module, - mod_name /= this_mod_name, - avail <- avails ] - this_mod_name = moduleName this_mod + imp_mod = mi_module iface + deprecs = mi_deprecs iface + is_orph = mi_orphan iface + deps = mi_deps iface + + filtered_exports = filter not_this_mod (mi_exports iface) + not_this_mod (mod,_) = mod /= this_mod_name -- If the module exports anything defined in this module, just ignore it. -- Reason: otherwise it looks as if there are two local definition sites -- for the thing, and an error gets reported. Easiest thing is just to @@ -164,10 +168,11 @@ importsFromImportDecl this_mod -- import {-# SOURCE #-} A( AType ) -- -- then you'll get a 'B does not export AType' message. Oh well. - in + exportsToAvails filtered_exports `thenM` \ avails -> + -- Filter the imports according to the import list - filterImports imp_mod is_boot imp_spec avails `thenM` \ (filtered_avails, explicits) -> + filterImports imp_mod want_boot imp_details avails `thenM` \ (filtered_avails, explicits) -> let -- Compute new transitive dependencies @@ -181,7 +186,7 @@ importsFromImportDecl this_mod -- (a) remove this_mod (might be there as a hi-boot) -- (b) add imp_mod itself -- Take its dependent packages unchanged - ((imp_mod_name, is_boot) : filter not_self (dep_mods deps), dep_pkgs deps) + ((imp_mod_name, want_boot) : filter not_self (dep_mods deps), dep_pkgs deps) | otherwise = -- Imported module is from another package @@ -192,10 +197,10 @@ importsFromImportDecl this_mod not_self (m, _) = m /= this_mod_name - import_all = case imp_spec of - Just (isHid, ls) -- Imports are spec'd explicitly - | not isHid -> Just (not (null ls)) - _ -> Nothing -- Everything is imported, + import_all = case imp_details of + Just (is_hiding, ls) -- Imports are spec'd explicitly + | not is_hiding -> Just (not (null ls)) + _ -> Nothing -- Everything is imported, -- (or almost everything [hiding]) qual_mod_name = case as_mod of @@ -206,12 +211,17 @@ importsFromImportDecl this_mod -- We need to know this so we know what to export when we see -- module M ( module P ) where ... -- Then we must export whatever came from P unqualified. + imp_spec = ImportSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_loc = iloc , is_as = qual_mod_name } + mk_deprec = mi_dep_fn iface + gres = [ GRE { gre_name = name, + gre_prov = Imported [imp_spec] (name `elemNameSet` explicits), + gre_deprec = mk_deprec name } + | avail <- filtered_avails, name <- availNames avail ] + gbl_env = mkGlobalRdrEnv gres + avail_env = mkAvailEnv filtered_avails - - mk_prov name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) - gbl_env = mkGlobalRdrEnv qual_mod_name (not qual_only) - mk_prov filtered_avails deprecs - imports = ImportAvails { + imports = ImportAvails { imp_qual = unitModuleEnvByName qual_mod_name avail_env, imp_env = avail_env, imp_mods = unitModuleEnv imp_mod (imp_mod, import_all), @@ -228,13 +238,26 @@ importsFromImportDecl this_mod ) `thenM_` returnM (gbl_env, imports) - } -mkModDeps :: [(ModuleName, IsBootInterface)] - -> ModuleEnv (ModuleName, IsBootInterface) -mkModDeps deps = foldl add emptyModuleEnv deps - where - add env elt@(m,_) = extendModuleEnvByName env m elt +exportsToAvails :: [IfaceExport] -> TcRnIf gbl lcl Avails +exportsToAvails exports + = do { avails_by_module <- mappM do_one exports + ; return (concat avails_by_module) } + where + do_one (mod_name, exports) = mapM (do_avail mod_name) exports + do_avail mod (Avail n) = do { n' <- lookupOrig mod n; + ; return (Avail n') } + do_avail mod (AvailTC n ns) = do { n' <- lookupOrig mod n + ; ns' <- mappM (lookupImplicitOrig n') ns + ; return (AvailTC n' ns') } + -- Note the lookupImplicitOrig. It ensures that the subordinate names + -- record their parent; and that in turn ensures that the GlobalRdrEnv + -- has the correct parent for all the names in its range. + -- For imported things, we only suck in the binding site later, if ever. + +warnRedundantSourceImport mod_name + = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") + <+> quotes (ppr mod_name) \end{code} @@ -253,7 +276,7 @@ Complain about duplicate bindings \begin{code} importsFromLocalDecls :: HsGroup RdrName - -> TcRn m (GlobalRdrEnv, ImportAvails) + -> RnM (GlobalRdrEnv, ImportAvails) importsFromLocalDecls group = getModule `thenM` \ this_mod -> getLocalDeclBinders this_mod group `thenM` \ avails -> @@ -273,12 +296,12 @@ importsFromLocalDecls group doptM Opt_NoImplicitPrelude `thenM` \ implicit_prelude -> let - mod_name = moduleName this_mod - mk_prov n = LocalDef -- Provenance is local - - unqual_imp = True -- Want unqualified names in scope - gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails NoDeprecs - -- NoDeprecs: don't complain about locally defined names + mod_name = moduleName this_mod + prov = LocalDef mod_name + gbl_env = mkGlobalRdrEnv gres + gres = [ GRE { gre_name = name, gre_prov = prov, gre_deprec = Nothing} + | name <- all_names] + -- gre_deprecs = Nothing: don't deprecate locally defined names -- For a start, we may be exporting a deprecated thing -- Also we may use a deprecated thing in the defn of another -- deprecated things. We may even use a deprecated thing in @@ -300,8 +323,9 @@ importsFromLocalDecls group -- defn of gbl_env above). Stupid reason: when parsing -- data type decls, the constructors start as Exact tycon-names, -- and then get turned into data con names by zapping the name space; - -- but that stops them being Exact, so they get looked up. Sigh. - -- It doesn't matter because it only affects the Data.Tuple really. + -- but that stops them being Exact, so they get looked up. + -- Ditto in fixity decls; e.g. infix 5 : + -- Sigh. It doesn't matter because it only affects the Data.Tuple really. -- The important thing is to trim down the exports. avails' | implicit_prelude = filter not_built_in_syntax avails @@ -309,7 +333,7 @@ importsFromLocalDecls group not_built_in_syntax a = not (all isBuiltInSyntaxName (availNames a)) -- Only filter it if all the names of the avail are built-in -- In particular, lists have (:) which is not built in syntax - -- so we don't filter it out. + -- so we don't filter it out. [Sept 03: wrong: see isBuiltInSyntaxName] avail_env = mkAvailEnv avails' imports = emptyImportAvails { @@ -334,7 +358,7 @@ files (@loadDecl@ calls @getTyClDeclBinders@). *** See "THE NAMING STORY" in HsDecls **** \begin{code} -getLocalDeclBinders :: Module -> HsGroup RdrName -> TcRn m [AvailInfo] +getLocalDeclBinders :: Module -> HsGroup RdrName -> RnM [AvailInfo] getLocalDeclBinders mod (HsGroup {hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) @@ -343,18 +367,22 @@ getLocalDeclBinders mod (HsGroup {hs_valds = val_decls, -- permanently bound into the TyCons and Classes. They don't need -- an export indicator because they are all implicitly exported. - mappM new_tc tycl_decls `thenM` \ tc_avails -> - mappM new_bndr (for_hs_bndrs ++ val_hs_bndrs) `thenM` \ simple_bndrs -> - - returnM (tc_avails ++ map Avail simple_bndrs) + mappM new_tc tycl_decls `thenM` \ tc_avails -> + mappM new_simple (for_hs_bndrs ++ val_hs_bndrs) `thenM` \ simple_avails -> + returnM (tc_avails ++ simple_avails) where - new_bndr (rdr_name,loc) = newTopBinder mod rdr_name loc + new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name `thenM` \ name -> + returnM (Avail name) val_hs_bndrs = collectLocatedHsBinders val_decls for_hs_bndrs = [(nm,loc) | ForeignImport nm _ _ _ loc <- foreign_decls] - new_tc tc_decl = mappM new_bndr (tyClDeclNames tc_decl) `thenM` \ names@(main_name:_) -> - returnM (AvailTC main_name names) + new_tc tc_decl + = newTopSrcBinder mod Nothing main_rdr `thenM` \ main_name -> + mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs `thenM` \ sub_names -> + returnM (AvailTC main_name (main_name : sub_names)) + where + (main_rdr : sub_rdrs) = tyClDeclNames tc_decl \end{code} @@ -372,7 +400,7 @@ filterImports :: Module -- The module being imported -> IsBootInterface -- Tells whether it's a {-# SOURCE #-} import -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding -> [AvailInfo] -- What's available - -> TcRn m ([AvailInfo], -- What's imported + -> RnM ([AvailInfo], -- What's imported NameSet) -- What was imported explicitly -- Complains if import spec mentions things that the module doesn't export @@ -407,7 +435,7 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails bale_out item = addErr (badImportItemErr mod from item) `thenM_` returnM [] - get_item :: RdrNameIE -> TcRn m [(AvailInfo, [Name])] + get_item :: RdrNameIE -> RnM [(AvailInfo, [Name])] -- Empty list for a bad item. -- Singleton is typical case. -- Can have two when we are hiding, and mention C which might be @@ -531,7 +559,7 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) exportsFromAvail :: Maybe Module -- Nothing => no 'module M(..) where' header at all -> Maybe [RdrNameIE] -- Nothing => no explicit export list - -> TcRn m Avails + -> RnM Avails -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope @@ -551,9 +579,9 @@ exportsFromAvail maybe_mod exports = case maybe_mod of Just mod -> exports Nothing | ghci_mode == Interactive -> Nothing - | otherwise -> Just [IEVar main_RDR_Unqual] } ; + | otherwise -> Just [IEVar main_RDR_Unqual] } ; - exports_from_avail exports rdr_env imports } + exports_from_avail real_exports rdr_env imports } exports_from_avail Nothing rdr_env imports@(ImportAvails { imp_env = entity_avail_env }) @@ -563,12 +591,11 @@ exports_from_avail Nothing rdr_env -- (b) locally defined, (c) a 'main' name -- Then we look up in the entity-avail-env return [ lookupAvailEnv entity_avail_env name - | (rdr_name, gres) <- rdrEnvToList rdr_env, - isQual rdr_name, -- Avoid duplicates - GRE { gre_name = name, - gre_parent = Nothing, -- Main things only - gre_prov = LocalDef } <- gres - ] + | gre <- globalRdrEnvElts rdr_env, + isLocalGRE gre, + let name = gre_name gre, + isNothing (nameParent_maybe name) -- Main things only + ] exports_from_avail (Just export_items) rdr_env (ImportAvails { imp_qual = mod_avail_env, @@ -578,7 +605,7 @@ exports_from_avail (Just export_items) rdr_env returnM (nameEnvElts export_avail_map) where - exports_from_item :: ExportAccum -> RdrNameIE -> TcRn m ExportAccum + exports_from_item :: ExportAccum -> RdrNameIE -> RnM ExportAccum exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod) | mod `elem` mods -- Duplicate export of M @@ -610,15 +637,13 @@ exports_from_avail (Just export_items) rdr_env returnM (mod:mods, occs', avails') exports_from_item acc@(mods, occs, avails) ie - = lookupGRE (ieName ie) `thenM` \ mb_gre -> - case mb_gre of { - Nothing -> addErr (unknownNameErr (ieName ie)) `thenM_` - returnM acc ; - Just gre -> - + = lookupGlobalOccRn (ieName ie) `thenM` \ name -> + if isUnboundName name then + returnM acc -- Avoid error cascade + else -- Get the AvailInfo for the parent of the specified name let - parent = gre_parent gre `orElse` gre_name gre + parent = nameParent name avail = lookupAvailEnv entity_avail_env parent in -- Filter out the bits we want @@ -633,7 +658,7 @@ exports_from_avail (Just export_items) rdr_env warnIf (not (ok_item ie avail)) (dodgyExportWarn ie) `thenM_` check_occs ie occs export_avail `thenM` \ occs' -> returnM (mods, occs', addAvail avails export_avail) - }} + } ------------------------------- @@ -651,10 +676,7 @@ filter_unqual env (AvailTC n ns) in_scope :: GlobalRdrEnv -> Name -> Bool -- Checks whether the Name is in scope unqualified, -- regardless of whether it's ambiguous or not -in_scope env n - = case lookupRdrEnv env (mkRdrUnqual (nameOccName n)) of - Nothing -> False - Just gres -> or [n == gre_name g | g <- gres] +in_scope env n = any unQualOK (lookupGRE_Name env n) ------------------------------- @@ -665,7 +687,7 @@ ok_item (IEThingAll _) (AvailTC _ [n]) = False ok_item _ _ = True ------------------------------- -check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> TcRn m ExportOccMap +check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnM ExportOccMap check_occs ie occs avail = foldlM check occs (availNames avail) where @@ -694,35 +716,28 @@ check_occs ie occs avail %********************************************************* \begin{code} -reportUnusedNames :: TcGblEnv -> DefUses -> TcRn m () -reportUnusedNames gbl_env dus +reportUnusedNames :: TcGblEnv -> RnM () +reportUnusedNames gbl_env = warnUnusedModules unused_imp_mods `thenM_` warnUnusedTopBinds bad_locals `thenM_` warnUnusedImports bad_imports `thenM_` printMinimalImports minimal_imports where - used_names :: NameSet - used_names = findUses dus emptyNameSet + used_names, all_used_names :: NameSet + used_names = findUses (tcg_dus gbl_env) emptyNameSet + all_used_names = used_names `unionNameSets` + mkNameSet (mapCatMaybes nameParent_maybe (nameSetToList used_names)) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) -- Collect the defined names from the in-scope environment - -- Look for the qualified ones only, else get duplicates defined_names :: [GlobalRdrElt] - defined_names = foldRdrEnv add [] (tcg_rdr_env gbl_env) - add rdr_name ns acc | isQual rdr_name = ns ++ acc - | otherwise = acc + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) defined_and_used, defined_but_not_used :: [GlobalRdrElt] (defined_and_used, defined_but_not_used) = partition is_used defined_names - is_used gre = n `elemNameSet` used_names || any (`elemNameSet` used_names) kids - -- The 'kids' part is because a use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - where - n = gre_name gre - kids = case lookupAvailEnv_maybe avail_env n of - Just (AvailTC n ns) -> ns - other -> [] -- Ids, class ops and datacons - -- (The latter two give Nothing) + is_used gre = gre_name gre `elemNameSet` all_used_names -- Filter out the ones that are -- (a) defined in this module, and @@ -735,8 +750,11 @@ reportUnusedNames gbl_env dus bad_imports :: [GlobalRdrElt] bad_imports = filter bad_imp defined_but_not_used - bad_imp (GRE {gre_prov = NonLocalDef (UserImport mod _ True)}) = not (module_unused mod) - bad_imp other = False + bad_imp (GRE {gre_prov = Imported imp_specs True}) + = not (all (module_unused . is_mod) imp_specs) + -- Don't complain about unused imports if we've already said the + -- entire import is unused + bad_imp other = False -- To figure out the minimal set of imports, start with the things -- that are in scope (i.e. in gbl_env). Then just combine them @@ -764,10 +782,10 @@ reportUnusedNames gbl_env dus -- We've carefully preserved the provenance so that we can -- construct minimal imports that import the name by (one of) -- the same route(s) as the programmer originally did. - add_name (GRE {gre_name = n, gre_parent = p, - gre_prov = NonLocalDef (UserImport m _ _)}) acc - = addToFM_C plusAvailEnv acc (moduleName m) - (unitAvailEnv (mk_avail n p)) + add_name (GRE {gre_name = n, + gre_prov = Imported imp_specs _}) acc + = addToFM_C plusAvailEnv acc (is_mod (head imp_specs)) + (unitAvailEnv (mk_avail n (nameParent_maybe n))) add_name other acc = acc @@ -782,8 +800,7 @@ reportUnusedNames gbl_env dus -- Add an empty collection of imports for a module -- from which we have sucked only instance decls - imports = tcg_imports gbl_env - avail_env = imp_env imports + imports = tcg_imports gbl_env direct_import_mods :: [ModuleName] direct_import_mods = map (moduleName . fst) @@ -803,14 +820,17 @@ reportUnusedNames gbl_env dus isNothing (lookupFM minimal_imports1 m), m /= pRELUDE_Name, not (hasEmptyImpList m)] - - module_unused :: Module -> Bool - module_unused mod = moduleName mod `elem` unused_imp_mods + -- hasEmptyImpList arranges not to complain about + -- import M (), which is an idiom for importing + -- instance declarations + + module_unused :: ModuleName -> Bool + module_unused mod = mod `elem` unused_imp_mods -- ToDo: deal with original imports with 'qualified' and 'as M' clauses printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports - -> TcRn m () + -> RnM () printMinimalImports imps = ifOptM Opt_D_dump_minimal_imports $ do { @@ -835,7 +855,7 @@ printMinimalImports imps to_ies (mod, avail_env) = mappM to_ie (availEnvElts avail_env) `thenM` \ ies -> returnM (mod, ies) - to_ie :: AvailInfo -> TcRn m (IE Name) + to_ie :: AvailInfo -> RnM (IE Name) -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. @@ -843,18 +863,19 @@ printMinimalImports imps to_ie (AvailTC n [m]) = ASSERT( n==m ) returnM (IEThingAbs n) to_ie (AvailTC n ns) - = loadInterface (text "Compute minimal imports from" <+> ppr n_mod) - n_mod ImportBySystem `thenM` \ iface -> + = loadSrcInterface doc n_mod False `thenM` \ iface -> case [xs | (m,as) <- mi_exports iface, m == n_mod, AvailTC x xs <- as, - x == n] of - [xs] | all (`elem` ns) xs -> returnM (IEThingAll n) - | otherwise -> returnM (IEThingWith n (filter (/= n) ns)) - other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ - returnM (IEVar n) + x == nameOccName n] of + [xs] | all_used xs -> returnM (IEThingAll n) + | otherwise -> returnM (IEThingWith n (filter (/= n) ns)) + other -> pprTrace "to_ie" (ppr n <+> ppr n_mod <+> ppr other) $ + returnM (IEVar n) where - n_mod = moduleName (nameModule n) + all_used avail_occs = all (`elem` map nameOccName ns) avail_occs + doc = text "Compute minimal imports from" <+> ppr n + n_mod = nameModuleName n \end{code} @@ -897,15 +918,9 @@ exportClashErr global_env name1 name2 ie1 ie2 ppr_export ie name = nest 2 (quotes (ppr ie) <+> ptext SLIT("exports") <+> quotes (ppr name) <+> pprNameProvenance (get_gre name)) - -- get_gre finds a GRE for the Name, in a very inefficient way - -- There isn't a more efficient way to do it, because we don't necessarily - -- know the RdrName under which this Name is in scope. So we just - -- search linearly. Shouldn't matter because this only happens - -- in an error message. + -- get_gre finds a GRE for the Name, so that we can show its provenance get_gre name - = case [gre | gres <- rdrEnvElts global_env, - gre <- gres, - gre_name gre == name] of + = case lookupGRE_Name global_env name of (gre:_) -> gre [] -> pprPanic "exportClashErr" (ppr name) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index ee01065696..8a7e7b2ff6 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -5,63 +5,46 @@ \begin{code} module RnSource ( - rnSrcDecls, checkModDeprec, - rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, - rnBinds, rnBindsAndThen, rnStats, + rnSrcDecls, addTcgDUs, + rnTyClDecls, checkModDeprec, + rnBinds, rnBindsAndThen ) where #include "HsVersions.h" import HsSyn -import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) -import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv ) +import RdrHsSyn ( RdrNameConDecl, RdrNameHsBinds, RdrNameDeprecation, RdrNameFixitySig, - RdrNameHsBinds, - extractGenericPatTyVars - ) + extractGenericPatTyVars ) import RnHsSyn -import HsCore import RnExpr ( rnExpr ) import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext ) - import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds, rnMonoBindsAndThen, renameSigs, checkSigs ) -import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr, - newLocalsRn, lookupGlobalOccRn, +import RnEnv ( lookupTopBndrRn, lookupTopFixSigNames, + lookupOccRn, newLocalsRn, bindLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, - checkDupOrQualNames, checkDupNames, mapFvRn, - lookupTopSrcBndr_maybe, lookupTopSrcBndr, - dataTcOccs, newIPName, unknownNameErr + bindLocalNames, newIPNameRn, + checkDupNames, mapFvRn, + unknownNameErr ) import TcRnMonad -import BasicTypes ( FixitySig(..), TopLevelFlag(..) ) -import HscTypes ( ExternalPackageState(..), FixityEnv, - Deprecations(..), plusDeprecs ) -import Module ( moduleEnvElts ) -import Class ( FunDep, DefMeth (..) ) -import TyCon ( DataConDetails(..), visibleDataCons ) +import BasicTypes ( TopLevelFlag(..) ) +import HscTypes ( FixityEnv, FixItem(..), + Deprecations, Deprecs(..), DeprecTxt, plusDeprecs ) +import Class ( FunDep ) import Name ( Name ) import NameSet import NameEnv -import ErrUtils ( dumpIfSet ) -import PrelNames ( newStablePtrName, bindIOName, returnIOName - -- dotnet interop - , objectTyConName, - , unmarshalObjectName, marshalObjectName - , unmarshalStringName, marshalStringName - , checkDotnetResName - ) -import List ( partition ) -import Bag ( bagToList ) import Outputable import SrcLoc ( SrcLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars -import Maybes ( maybeToBool, seqMaybe ) -import Maybe ( maybe, catMaybes, isNothing ) +import Maybes ( seqMaybe ) +import Maybe ( catMaybes, isNothing ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -81,7 +64,7 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} -rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, DefUses) +rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, hs_tyclds = tycl_decls, @@ -90,8 +73,7 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, hs_depds = deprec_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_coreds = core_decls }) + hs_ruleds = rule_decls }) = do { -- Deal with deprecations (returns only the extra deprecations) deprecs <- rnSrcDeprecDecls deprec_decls ; @@ -114,12 +96,11 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, -- So we content ourselves with gathering uses only; that -- means we'll only report a declaration as unused if it isn't -- mentioned at all. Ah well. - (rn_tycl_decls, src_fvs1) <- mapFvRn rnSrcTyClDecl tycl_decls ; + (rn_tycl_decls, src_fvs1) <- mapFvRn rnTyClDecl tycl_decls ; (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ; (rn_rule_decls, src_fvs3) <- mapFvRn rnHsRuleDecl rule_decls ; (rn_foreign_decls, src_fvs4) <- mapFvRn rnHsForeignDecl foreign_decls ; (rn_default_decls, src_fvs5) <- mapFvRn rnDefaultDecl default_decls ; - (rn_core_decls, src_fvs6) <- mapFvRn rnCoreDecl core_decls ; let { rn_group = HsGroup { hs_valds = rn_val_decls, @@ -129,17 +110,22 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, hs_depds = [], hs_fords = rn_foreign_decls, hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, - hs_coreds = rn_core_decls } ; + hs_ruleds = rn_rule_decls } ; other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, - src_fvs4, src_fvs5, src_fvs6] ; + src_fvs4, src_fvs5] ; src_dus = bind_dus `plusDU` usesOnly other_fvs } ; tcg_env <- getGblEnv ; - return (tcg_env, rn_group, src_dus) + return (tcg_env `addTcgDUs` src_dus, rn_group) }}} +rnTyClDecls :: [TyClDecl RdrName] -> RnM [TyClDecl Name] +rnTyClDecls tycl_decls = do { (decls', fvs) <- mapFvRn rnTyClDecl tycl_decls + ; return decls' } + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } \end{code} @@ -150,32 +136,40 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, %********************************************************* \begin{code} -rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv +rnSrcFixityDecls :: [RdrNameFixitySig] -> RnM FixityEnv rnSrcFixityDecls fix_decls = getGblEnv `thenM` \ gbl_env -> foldlM rnFixityDecl (tcg_fix_env gbl_env) - fix_decls `thenM` \ fix_env -> - traceRn (text "fixity env" <+> ppr fix_env) `thenM_` + fix_decls `thenM` \ fix_env -> + traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_` returnM fix_env -rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv +rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> RnM FixityEnv rnFixityDecl fix_env (FixitySig rdr_name fixity loc) = -- GHC extension: look up both the tycon and data con -- for con-like things -- If neither are in scope, report an error; otherwise -- add both to the fixity env - mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name) `thenM` \ maybe_ns -> - case catMaybes maybe_ns of - [] -> addSrcLoc loc $ - addErr (unknownNameErr rdr_name) `thenM_` - returnM fix_env - ns -> foldlM add fix_env ns + lookupTopFixSigNames rdr_name `thenM` \ names -> + if null names then + addSrcLoc loc (addErr (unknownNameErr rdr_name)) `thenM_` + returnM fix_env + else + foldlM add fix_env names where - add fix_env name + add fix_env name = case lookupNameEnv fix_env name of - Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc') `thenM_` - returnM fix_env - Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc)) + Just (FixItem _ _ loc') + -> addErr (dupFixityDecl rdr_name loc loc') `thenM_` + returnM fix_env + Nothing -> returnM (extendNameEnv fix_env name fix_item) + where + fix_item = FixItem (rdrNameOcc rdr_name) fixity loc + +pprFixEnv :: FixityEnv -> SDoc +pprFixEnv env + = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n) + (nameEnvElts env) dupFixityDecl rdr_name loc1 loc2 = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), @@ -195,7 +189,7 @@ It's only imported deprecations, dealt with in RnIfaces, that we gather them together. \begin{code} -rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations +rnSrcDeprecDecls :: [RdrNameDeprecation] -> RnM Deprecations rnSrcDeprecDecls [] = returnM NoDeprecs @@ -204,18 +198,14 @@ rnSrcDeprecDecls decls returnM (DeprecSome (mkNameEnv (catMaybes pairs))) where rn_deprec (Deprecation rdr_name txt loc) - = addSrcLoc loc $ - lookupTopSrcBndr rdr_name `thenM` \ name -> - returnM (Just (name, (name,txt))) + = addSrcLoc loc $ + lookupTopBndrRn rdr_name `thenM` \ name -> + returnM (Just (name, (rdrNameOcc rdr_name, txt))) checkModDeprec :: Maybe DeprecTxt -> Deprecations -- Check for a module deprecation; done once at top level checkModDeprec Nothing = NoDeprecs -checkModdeprec (Just txt) = DeprecAll txt - -badDeprec d - = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"), - nest 4 (ppr d)] +checkModDeprec (Just txt) = DeprecAll txt \end{code} %********************************************************* @@ -225,33 +215,12 @@ badDeprec d %********************************************************* \begin{code} -rnSrcTyClDecl tycl_decl - = rnTyClDecl tycl_decl `thenM` \ new_decl -> - finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) -> - returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl') - -rnSrcInstDecl inst - = rnInstDecl inst `thenM` \ new_inst -> - finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) -> - returnM (new_inst', fvs `plusFV` instDeclFVs new_inst') - rnDefaultDecl (DefaultDecl tys src_loc) - = addSrcLoc src_loc $ - mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> + = addSrcLoc src_loc $ + mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> returnM (DefaultDecl tys' src_loc, fvs) where doc_str = text "In a `default' declaration" - - -rnCoreDecl (CoreDecl name ty rhs loc) - = addSrcLoc loc $ - lookupTopBndrRn name `thenM` \ name' -> - rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) -> - rnCoreExpr rhs `thenM` \ rhs' -> - returnM (CoreDecl name' ty' rhs' loc, - ty_fvs `plusFV` ufExprFVs rhs') - where - doc_str = text "In the Core declaration for" <+> quotes (ppr name) \end{code} %********************************************************* @@ -285,22 +254,17 @@ rnBindsAndThen (IPBinds binds) thing_inside = rnIPBinds binds `thenM` \ (binds',fv_binds) -> thing_inside (IPBinds binds') `thenM` \ (thing, fvs_thing) -> returnM (thing, fvs_thing `plusFV` fv_binds) -\end{code} - -%************************************************************************ -%* * -\subsubsection{@rnIPBinds@s: in implicit parameter bindings} * -%* * -%************************************************************************ - -\begin{code} rnIPBinds [] = returnM ([], emptyFVs) rnIPBinds ((n, expr) : binds) - = newIPName n `thenM` \ name -> + = newIPNameRn n `thenM` \ name -> rnExpr expr `thenM` \ (expr',fvExpr) -> rnIPBinds binds `thenM` \ (binds',fvBinds) -> returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) + +badIpBinds binds + = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4 + (ppr binds) \end{code} @@ -315,31 +279,13 @@ rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc) = addSrcLoc src_loc $ lookupTopBndrRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignImport name' ty' spec isDeprec src_loc, - fvs `plusFV` extras spec) - where - extras (CImport _ _ _ _ CWrapper) - = mkFVs [ newStablePtrName - , bindIOName - , returnIOName - ] - extras (DNImport _) - = mkFVs [ bindIOName - , objectTyConName - , unmarshalObjectName - , marshalObjectName - , marshalStringName - , unmarshalStringName - , checkDotnetResName - ] - extras _ = emptyFVs + returnM (ForeignImport name' ty' spec isDeprec src_loc, fvs) rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc) = addSrcLoc src_loc $ - lookupOccRn name `thenM` \ name' -> - rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignExport name' ty' spec isDeprec src_loc, - mkFVs [name', bindIOName, returnIOName] `plusFV` fvs ) + lookupOccRn name `thenM` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> + returnM (ForeignExport name' ty' spec isDeprec src_loc, fvs ) -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module @@ -355,42 +301,25 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name %********************************************************* \begin{code} -rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) +rnSrcInstDecl (InstDecl inst_ty mbinds uprags src_loc) -- Used for both source and interface file decls = addSrcLoc src_loc $ rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> - (case maybe_dfun_rdr_name of - Nothing -> returnM Nothing - Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name `thenM` \ dfun_name -> - returnM (Just dfun_name) - ) `thenM` \ maybe_dfun_name -> - - -- The typechecker checks that all the bindings are for the right class. - returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc) - --- Compare finishSourceTyClDecl -finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) - (InstDecl inst_ty _ _ maybe_dfun_name src_loc) - -- Used for both source decls only - = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl! + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class let meth_doc = text "In the bindings in an instance declaration" meth_names = collectLocatedMonoBinders mbinds - (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty - -- (Slightly strangely) the forall-d tyvars scope over - -- the method bindings too + (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty' in - - -- Rename the bindings - -- NB meth_names can be qualified! - checkDupNames meth_doc meth_names `thenM_` + checkDupNames meth_doc meth_names `thenM_` extendTyVarEnvForMethodBinds inst_tyvars ( + -- (Slightly strangely) the forall-d tyvars scope over + -- the method bindings too rnMethodBinds cls [] mbinds ) `thenM` \ (mbinds', meth_fvs) -> - let - binders = collectMonoBinders mbinds' - in -- Rename the prags and signatures. -- Note that the type variables are not in scope here, -- so that instance Eq a => Eq (T a) where @@ -398,13 +327,30 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) -- works OK. -- -- But the (unqualified) method names are in scope + let + binders = collectMonoBinders mbinds' + in bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' -> checkSigs (okInstDclSig (mkNameSet binders)) uprags' `thenM_` - returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc, - meth_fvs `plusFV` hsSigsFVs uprags') + returnM (InstDecl inst_ty' mbinds' uprags' src_loc, + meth_fvs `plusFV` hsSigsFVs uprags' + `plusFV` extractHsTyNames inst_ty') \end{code} +For the method bindings in class and instance decls, we extend the +type variable environment iff -fglasgow-exts + +\begin{code} +extendTyVarEnvForMethodBinds tyvars thing_inside + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + if opt_GlasgowExts then + extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside + else + thing_inside +\end{code} + + %********************************************************* %* * \subsection{Rules} @@ -412,18 +358,6 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) %********************************************************* \begin{code} -rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc) - = addSrcLoc src_loc $ - lookupOccRn fn `thenM` \ fn' -> - rnCoreBndrs vars $ \ vars' -> - mappM rnCoreExpr args `thenM` \ args' -> - rnCoreExpr rhs `thenM` \ rhs' -> - returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc) - -rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way - = lookupOccRn fn `thenM` \ fn' -> - returnM (IfaceRuleOut fn' rule) - rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) = addSrcLoc src_loc $ bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ @@ -443,7 +377,7 @@ rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) in mappM (addErr . badRuleVar rule_name) bad_vars `thenM_` returnM (HsRule rule_name act vars' lhs' rhs' src_loc, - fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) + fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where doc = text "In the transformation rule" <+> ftext rule_name @@ -488,6 +422,18 @@ validRuleLhs foralls lhs check_e other = Just other -- Fails check_es es = foldr (seqMaybe . check_e) Nothing es + +badRuleLhsErr name lhs (Just bad_e) + = sep [ptext SLIT("Rule") <+> ftext name <> colon, + nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, + ptext SLIT("in left-hand side:") <+> ppr lhs])] + $$ + ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") + +badRuleVar name var + = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, + ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> + ptext SLIT("does not appear on left hand side")] \end{code} @@ -511,120 +457,75 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc}) - = addSrcLoc loc $ - lookupTopBndrRn name `thenM` \ name' -> - rnHsType doc_str ty `thenM` \ ty' -> - mappM rnIdInfo id_infos `thenM` \ id_infos' -> - returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc}) - where - doc_str = text "In the interface signature for" <+> quotes (ppr name) - rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) = addSrcLoc loc $ lookupTopBndrRn name `thenM` \ name' -> - returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) + returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}, + emptyFVs) rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, - tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic, - tcdDerivs = derivs, tcdLoc = src_loc}) + tcdTyVars = tyvars, tcdCons = condecls, + tcdDerivs = derivs, tcdLoc = src_loc}) = addSrcLoc src_loc $ lookupTopBndrRn tycon `thenM` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenM` \ context' -> - rn_derivs derivs `thenM` \ derivs' -> - checkDupOrQualNames data_doc con_names `thenM_` - + rn_derivs derivs `thenM` \ (derivs', deriv_fvs) -> + checkDupNames data_doc con_names `thenM_` rnConDecls tycon' condecls `thenM` \ condecls' -> returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic, - tcdDerivs = derivs', tcdLoc = src_loc}) + tcdTyVars = tyvars', tcdCons = condecls', + tcdDerivs = derivs', tcdLoc = src_loc}, + delFVs (map hsTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map conDeclFVs condecls') `plusFV` + deriv_fvs) where data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) - con_names = map conDeclName (visibleDataCons condecls) + con_names = map conDeclName condecls - rn_derivs Nothing = returnM Nothing - rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds') + rn_derivs Nothing = returnM (Nothing, emptyFVs) + rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> + returnM (Just ds', extractHsCtxtTyNames ds') rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc}) = addSrcLoc src_loc $ lookupTopBndrRn name `thenM` \ name' -> bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - rnHsType syn_doc ty `thenM` \ ty' -> - returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc}) + rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) -> + returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', + tcdSynRhs = ty', tcdLoc = src_loc}, + delFVs (map hsTyVarName tyvars') fvs) where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdLoc = src_loc}) - -- Used for both source and interface file decls + tcdMeths = mbinds, tcdLoc = src_loc}) = addSrcLoc src_loc $ - lookupTopBndrRn cname `thenM` \ cname' -> -- Tyvars scope over superclass context and method signatures - bindTyVarsRn cls_doc tyvars $ \ tyvars' -> - - -- Check the superclasses - rnContext cls_doc context `thenM` \ context' -> - - -- Check the functional dependencies - rnFds cls_doc fds `thenM` \ fds' -> + bindTyVarsRn cls_doc tyvars ( \ tyvars' -> + rnContext cls_doc context `thenM` \ context' -> + rnFds cls_doc fds `thenM` \ fds' -> + renameSigs sigs `thenM` \ sigs' -> + returnM (tyvars', context', fds', sigs') + ) `thenM` \ (tyvars', context', fds', sigs') -> -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). let - (op_sigs, non_op_sigs) = partition isClassOpSig sigs - sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] + sig_rdr_names_w_locs = [(op,locn) | Sig op _ locn <- sigs] in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_` - mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' -> - renameSigs non_op_sigs `thenM` \ non_ops' -> - checkSigs okClsDclSig non_ops' `thenM_` + checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` + checkSigs okClsDclSig sigs' `thenM_` -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't -- for instance decls. - returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', - tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, - tcdLoc = src_loc}) - where - cls_doc = text "In the declaration for class" <+> ppr cname - sig_doc = text "In the signatures for class" <+> ppr cname - -rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn) - = addSrcLoc locn $ - lookupTopBndrRn op `thenM` \ op_name -> - - -- Check the signature - rnHsSigType (quotes (ppr op)) ty `thenM` \ new_ty -> - - -- Make the default-method name - (case dm_stuff of - DefMeth dm_rdr_name - -> -- Imported class that has a default method decl - lookupSysBndr dm_rdr_name `thenM` \ dm_name -> - returnM (DefMeth dm_name) - -- An imported class decl for a class decl that had an explicit default - -- method, mentions, rather than defines, - -- the default method, so we must arrange to pull it in - - GenDefMeth -> returnM GenDefMeth - NoDefMeth -> returnM NoDefMeth - ) `thenM` \ dm_stuff' -> - - returnM (ClassOpSig op_name dm_stuff' new_ty locn) - -finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars) - -- Used for source file decls only - -- Renames the default-bindings of a class decl -finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here - rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here - -- There are some default-method bindings (abeit possibly empty) so - -- this is a source-code class declaration - = -- The newLocals call is tiresome: given a generic class decl + -- The newLocals call is tiresome: given a generic class decl -- class C a where -- op :: a -> a -- op {| x+y |} (Inl a) = ... @@ -632,48 +533,32 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G -- op {| a*b |} (a*b) = ... -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. - -- Hence the - addSrcLoc src_loc $ - extendTyVarEnvForMethodBinds tyvars $ - getLocalRdrEnv `thenM` \ name_env -> - let - meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds - gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, - not (tv `elemRdrEnv` name_env)] - in - checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_` - newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> - rnMethodBinds cls gen_tyvars mbinds `thenM` \ (mbinds', meth_fvs) -> - returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) - where - meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) - -finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings}) - -- Derivings are returned here so that they don't form part of the tyClDeclFVs. - -- This is important, because tyClDeclFVs should contain only the - -- FVs that are `needed' by the interface file declaration, and - -- derivings do not appear in this. It also means that the tcGroups - -- are smaller, which turned out to be important for the usage inference. KSW 2002-02. - = returnM (tycl_decl, - maybe emptyFVs extractHsCtxtTyNames derivings) - -finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs) - -- Not a class declaration -\end{code} + extendTyVarEnvForMethodBinds tyvars' ( + getLocalRdrEnv `thenM` \ name_env -> + let + meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds + gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, + not (tv `elemLocalRdrEnv` name_env)] + in + checkDupNames meth_doc meth_rdr_names_w_locs `thenM_` + newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> + rnMethodBinds cname' gen_tyvars mbinds + ) `thenM` \ (mbinds', meth_fvs) -> -For the method bindings in class and instance decls, we extend the -type variable environment iff -fglasgow-exts - -\begin{code} -extendTyVarEnvForMethodBinds tyvars thing_inside - = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> - if opt_GlasgowExts then - extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside - else - thing_inside + returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', + tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', + tcdLoc = src_loc}, + delFVs (map hsTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map extractFunDepNames fds') `plusFV` + hsSigsFVs sigs' `plusFV` + meth_fvs) + where + meth_doc = text "In the default-methods for class" <+> ppr cname + cls_doc = text "In the declaration for class" <+> ppr cname + sig_doc = text "In the signatures for class" <+> ppr cname \end{code} - %********************************************************* %* * \subsection{Support code for type/data declarations} @@ -684,22 +569,16 @@ extendTyVarEnvForMethodBinds tyvars thing_inside conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) conDeclName (ConDecl n _ _ _ l) = (n,l) -rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl) -rnConDecls tycon Unknown = returnM Unknown -rnConDecls tycon (HasCons n) = returnM (HasCons n) -rnConDecls tycon (DataCons condecls) +rnConDecls :: Name -> [RdrNameConDecl] -> RnM [RenamedConDecl] +rnConDecls tycon condecls = -- Check that there's at least one condecl, -- or else we're reading an interface file, or -fglasgow-exts (if null condecls then doptM Opt_GlasgowExts `thenM` \ glaExts -> - getModeRn `thenM` \ mode -> - checkErr (glaExts || isInterfaceMode mode) - (emptyConDeclsErr tycon) + checkErr glaExts (emptyConDeclsErr tycon) else returnM () ) `thenM_` - - mappM rnConDecl condecls `thenM` \ condecls' -> - returnM (DataCons condecls') + mappM rnConDecl condecls rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl rnConDecl (ConDecl name tvs cxt details locn) @@ -724,7 +603,7 @@ rnConDetails doc locn (InfixCon ty1 ty2) returnM (InfixCon new_ty1 new_ty2) rnConDetails doc locn (RecCon fields) - = checkDupOrQualNames doc field_names `thenM_` + = checkDupNames doc field_names `thenM_` mappM (rnField doc) fields `thenM` \ new_fields -> returnM (RecCon new_fields) where @@ -749,8 +628,14 @@ rnBangTy doc (BangType s ty) -- data T = :% Int Int -- from interface files, which always print in prefix form -checkConName name - = checkErr (isRdrDataCon name) (badDataCon name) +checkConName name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon name + = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] + +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), + nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] \end{code} @@ -775,217 +660,3 @@ rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs rnHsTyvar doc tyvar = lookupOccRn tyvar \end{code} -%********************************************************* -%* * -\subsection{IdInfo} -%* * -%********************************************************* - -\begin{code} -rnIdInfo (HsWorker worker arity) - = lookupOccRn worker `thenM` \ worker' -> - returnM (HsWorker worker' arity) - -rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' -> - returnM (HsUnfold inline expr') -rnIdInfo (HsStrictness str) = returnM (HsStrictness str) -rnIdInfo (HsArity arity) = returnM (HsArity arity) -rnIdInfo HsNoCafRefs = returnM HsNoCafRefs -\end{code} - -@UfCore@ expressions. - -\begin{code} -rnCoreExpr (UfType ty) - = rnHsType (text "unfolding type") ty `thenM` \ ty' -> - returnM (UfType ty') - -rnCoreExpr (UfVar v) - = lookupOccRn v `thenM` \ v' -> - returnM (UfVar v') - -rnCoreExpr (UfLit l) - = returnM (UfLit l) - -rnCoreExpr (UfFCall cc ty) - = rnHsType (text "ccall") ty `thenM` \ ty' -> - returnM (UfFCall cc ty') - -rnCoreExpr (UfTuple (HsTupCon boxity arity) args) - = mappM rnCoreExpr args `thenM` \ args' -> - returnM (UfTuple (HsTupCon boxity arity) args') - -rnCoreExpr (UfApp fun arg) - = rnCoreExpr fun `thenM` \ fun' -> - rnCoreExpr arg `thenM` \ arg' -> - returnM (UfApp fun' arg') - -rnCoreExpr (UfCase scrut bndr alts) - = rnCoreExpr scrut `thenM` \ scrut' -> - bindCoreLocalRn bndr $ \ bndr' -> - mappM rnCoreAlt alts `thenM` \ alts' -> - returnM (UfCase scrut' bndr' alts') - -rnCoreExpr (UfNote note expr) - = rnNote note `thenM` \ note' -> - rnCoreExpr expr `thenM` \ expr' -> - returnM (UfNote note' expr') - -rnCoreExpr (UfLam bndr body) - = rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenM` \ body' -> - returnM (UfLam bndr' body') - -rnCoreExpr (UfLet (UfNonRec bndr rhs) body) - = rnCoreExpr rhs `thenM` \ rhs' -> - rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenM` \ body' -> - returnM (UfLet (UfNonRec bndr' rhs') body') - -rnCoreExpr (UfLet (UfRec pairs) body) - = rnCoreBndrs bndrs $ \ bndrs' -> - mappM rnCoreExpr rhss `thenM` \ rhss' -> - rnCoreExpr body `thenM` \ body' -> - returnM (UfLet (UfRec (bndrs' `zip` rhss')) body') - where - (bndrs, rhss) = unzip pairs -\end{code} - -\begin{code} -rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsType doc ty `thenM` \ ty' -> - bindCoreLocalRn name $ \ name' -> - thing_inside (UfValBinder name' ty') - where - doc = text "unfolding id" - -rnCoreBndr (UfTyBinder name kind) thing_inside - = bindCoreLocalRn name $ \ name' -> - thing_inside (UfTyBinder name' kind) - -rnCoreBndrs [] thing_inside = thing_inside [] -rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> - rnCoreBndrs bs $ \ names' -> - thing_inside (name':names') -\end{code} - -\begin{code} -rnCoreAlt (con, bndrs, rhs) - = rnUfCon con `thenM` \ con' -> - bindCoreLocalsRn bndrs $ \ bndrs' -> - rnCoreExpr rhs `thenM` \ rhs' -> - returnM (con', bndrs', rhs') - -rnNote (UfCoerce ty) - = rnHsType (text "unfolding coerce") ty `thenM` \ ty' -> - returnM (UfCoerce ty') - -rnNote (UfSCC cc) = returnM (UfSCC cc) -rnNote UfInlineCall = returnM UfInlineCall -rnNote UfInlineMe = returnM UfInlineMe -rnNote (UfCoreNote s) = returnM (UfCoreNote s) - -rnUfCon UfDefault - = returnM UfDefault - -rnUfCon (UfTupleAlt tup_con) - = returnM (UfTupleAlt tup_con) - -rnUfCon (UfDataAlt con) - = lookupOccRn con `thenM` \ con' -> - returnM (UfDataAlt con') - -rnUfCon (UfLitAlt lit) - = returnM (UfLitAlt lit) -\end{code} - -%********************************************************* -%* * -\subsection{Statistics} -%* * -%********************************************************* - -\begin{code} -rnStats :: [RenamedHsDecl] -- Imported decls - -> TcRn m () -rnStats imp_decls - = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace -> - doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats -> - doptM Opt_D_dump_rn `thenM` \ dump_rn -> - getEps `thenM` \ eps -> - - ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn) - "Renamer statistics" - (getRnStats eps imp_decls)) `thenM_` - returnM () - -getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc -getRnStats eps imported_decls - = hcat [text "Renamer stats: ", stats] - where - n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)] - -- This is really only right for a one-shot compile - - (decls_map, n_decls_slurped) = eps_decls eps - - 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 - ] - - (insts_left, n_insts_slurped) = eps_insts eps - n_insts_left = length (bagToList insts_left) - - (rules_left, n_rules_slurped) = eps_rules eps - n_rules_left = length (bagToList rules_left) - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int n_decls_slurped, text "type/class/variable 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"] - ] -\end{code} - -%********************************************************* -%* * -\subsection{Errors} -%* * -%********************************************************* - -\begin{code} -badDataCon name - = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] - -badRuleLhsErr name lhs (Just bad_e) - = sep [ptext SLIT("Rule") <+> ftext name <> colon, - nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, - ptext SLIT("in left-hand side:") <+> ppr lhs])] - $$ - ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") - -badRuleVar name var - = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, - ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> - ptext SLIT("does not appear on left hand side")] - -emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), - nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] - -withWarning - = sep [quotes (ptext SLIT("with")), - ptext SLIT("is deprecated, use"), - quotes (ptext SLIT("let")), - ptext SLIT("instead")] - -badIpBinds binds - = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4 - (ppr binds) -\end{code} - diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 0125dab3bb..4b6f799cf5 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -11,19 +11,19 @@ module RnTypes ( rnHsType, rnContext, precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize ) where -import CmdLineOpts ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExts) ) +import CmdLineOpts ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) import HsSyn import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNamePat, - extractHsTyRdrTyVars, extractHsCtxtRdrTyVars ) + extractHsRhoRdrTyVars ) import RnHsSyn ( RenamedContext, RenamedHsType, RenamedPat, extractHsTyNames, parrTyCon_name, tupleTyCon_name, listTyCon_name, charTyCon_name ) import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn, - newIPName, bindTyVarsRn, lookupFixityRn, mapFvRn, + bindTyVarsRn, lookupFixityRn, mapFvRn, newIPNameRn, bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches ) import TcRnMonad - +import RdrName ( elemLocalRdrEnv ) import PrelNames( eqStringName, eqClassName, integralClassName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, timesIntegerName, ratioDataConName, fromRationalName ) @@ -31,15 +31,12 @@ import Constants ( mAX_TUPLE_SIZE ) import TysWiredIn ( intTyCon ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import RdrName ( elemRdrEnv ) import Name ( Name, NamedThing(..) ) import NameSet -import Unique ( Uniquable(..) ) import Literal ( inIntRange, inCharRange ) -import BasicTypes ( compareFixity, arrowFixity ) -import List ( nub ) -import ListSetOps ( removeDupsEq, removeDups ) +import BasicTypes ( compareFixity ) +import ListSetOps ( removeDups ) import Outputable #include "HsVersions.h" @@ -84,15 +81,13 @@ rnHsType doc (HsForAllTy Nothing ctxt ty) -- over FV(T) \ {in-scope-tyvars} = getLocalRdrEnv `thenM` \ name_env -> let - mentioned_in_tau = extractHsTyRdrTyVars ty - mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt - mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) + mentioned = extractHsRhoRdrTyVars ctxt ty -- Don't quantify over type variables that are in scope; -- when GlasgowExts is off, there usually won't be any, except for -- class signatures: -- class C a where { op :: a -> a } - forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned + forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned in rnForAll doc (map UserTyVar forall_tyvars) ctxt ty @@ -101,13 +96,11 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not = let - mentioned_in_tau = extractHsTyRdrTyVars tau - mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt - mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) - forall_tyvar_names = hsTyVarNames forall_tyvars + mentioned = extractHsRhoRdrTyVars ctxt tau + forall_tyvar_names = hsTyVarNames forall_tyvars -- Explicitly quantified but not mentioned in ctxt or tau - warn_guys = filter (`notElem` mentioned) forall_tyvar_names + warn_guys = filter (`notElem` mentioned) forall_tyvar_names in mappM_ (forAllWarn doc tau) warn_guys `thenM_` rnForAll doc forall_tyvars ctxt tau @@ -117,11 +110,7 @@ rnHsType doc (HsTyVar tyvar) returnM (HsTyVar tyvar') rnHsType doc (HsOpTy ty1 op ty2) - = (case op of - HsArrow -> returnM HsArrow - HsTyOp n -> lookupOccRn n `thenM` \ n' -> - returnM (HsTyOp n') - ) `thenM` \ op' -> + = lookupOccRn op `thenM` \ op' -> rnHsType doc ty1 `thenM` \ ty1' -> rnHsType doc ty2 `thenM` \ ty2' -> lookupTyFixityRn op' `thenM` \ fix -> @@ -202,14 +191,13 @@ have already been renamed and rearranged. It's made rather tiresome by the presence of -> \begin{code} -lookupTyFixityRn HsArrow = returnM arrowFixity -lookupTyFixityRn (HsTyOp n) +lookupTyFixityRn n = doptM Opt_GlasgowExts `thenM` \ glaExts -> warnIf (not glaExts) (infixTyConWarn n) `thenM_` lookupFixityRn n -- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: HsTyOp Name -> Fixity +mkHsOpTyRn :: Name -> Fixity -> RenamedHsType -> RenamedHsType -> RnM RenamedHsType @@ -232,13 +220,6 @@ mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22) mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment = returnM (HsOpTy ty1 op ty2) - -mkHsFunTyRn ty1 ty2 -- Precedence of function arrow is 0 - = returnM (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change - -- this if fixity of -> increases. - -not_op_ty (HsOpTy _ _ _) = False -not_op_ty other = True \end{code} %********************************************************* @@ -249,24 +230,7 @@ not_op_ty other = True \begin{code} rnContext :: SDoc -> RdrNameContext -> RnM RenamedContext -rnContext doc ctxt - = mappM rn_pred ctxt `thenM` \ theta -> - - -- Check for duplicate assertions - -- If this isn't an error, then it ought to be: - ifOptM Opt_WarnMisc ( - let - (_, dups) = removeDupsEq theta - -- We only have equality, not ordering - in - mappM_ (addWarn . dupClassAssertWarn theta) dups - ) `thenM_` - - returnM theta - where - rn_pred pred = rnPred doc pred `thenM` \ pred'-> - returnM pred' - +rnContext doc ctxt = mappM (rnPred doc) ctxt rnPred doc (HsClassP clas tys) = lookupOccRn clas `thenM` \ clas_name -> @@ -274,7 +238,7 @@ rnPred doc (HsClassP clas tys) returnM (HsClassP clas_name tys') rnPred doc (HsIParam n ty) - = newIPName n `thenM` \ name -> + = newIPNameRn n `thenM` \ name -> rnHsType doc ty `thenM` \ ty' -> returnM (HsIParam name ty') \end{code} @@ -419,17 +383,11 @@ rnConPat con (RecCon rpats) returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con') rnConPat con (InfixCon pat1 pat2) - = lookupOccRn con `thenM` \ con' -> - rnPat pat1 `thenM` \ (pat1', fvs1) -> - rnPat pat2 `thenM` \ (pat2', fvs2) -> - - getModeRn `thenM` \ mode -> - -- See comments with rnExpr (OpApp ...) - (if isInterfaceMode mode - then returnM (ConPatIn con' (InfixCon pat1' pat2')) - else lookupFixityRn con' `thenM` \ fixity -> - mkConOpPatRn con' fixity pat1' pat2' - ) `thenM` \ pat' -> + = lookupOccRn con `thenM` \ con' -> + rnPat pat1 `thenM` \ (pat1', fvs1) -> + rnPat pat2 `thenM` \ (pat2', fvs2) -> + lookupFixityRn con' `thenM` \ fixity -> + mkConOpPatRn con' fixity pat1' pat2' `thenM` \ pat' -> returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con') ------------------------ @@ -552,32 +510,11 @@ checkTupSize tup_size forAllWarn doc ty tyvar = ifOptM Opt_WarnUnusedMatches $ - getModeRn `thenM` \ mode -> - case mode of { -#ifndef DEBUG - InterfaceMode _ -> returnM () ; -- Don't warn of unused tyvars in interface files - -- unless DEBUG is on, in which case it is slightly - -- informative. They can arise from mkRhsTyLam, - -- leading to (say) f :: forall a b. [b] -> [b] -#endif - other -> - addWarn ( - sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), + addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] $$ doc ) - } - -dupClassAssertWarn ctxt (assertion : dups) - = sep [hsep [ptext SLIT("Duplicate class assertion"), - quotes (ppr assertion), - ptext SLIT("in the context:")], - nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] - -naughtyCCallContextErr (HsClassP clas _) - = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), - ptext SLIT("in a context")] precParseErr op1 op2 = hang (ptext SLIT("precedence parsing error")) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 24f465b85b..af78fb7f4f 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -16,12 +16,12 @@ import CoreSyn import CoreFVs ( ruleRhsFreeVars ) import HscTypes ( HscEnv(..), GhciMode(..), ModGuts(..), ModGuts, Avails, availsToNameSet, - PackageRuleBase, HomePackageTable, ModDetails(..), - HomeModInfo(..) + ModDetails(..), + HomeModInfo(..), ExternalPackageState(..), hscEPS ) import CSE ( cseProgram ) -import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, - extendRuleBaseList, addRuleBaseFVs, pprRuleBase, +import Rules ( RuleBase, emptyRuleBase, ruleBaseIds, + extendRuleBaseList, pprRuleBase, ruleCheckProgram ) import Module ( moduleEnvElts ) import Name ( Name, isExternalName ) @@ -65,17 +65,15 @@ import List ( partition ) \begin{code} core2core :: HscEnv - -> PackageRuleBase -> ModGuts -> IO ModGuts -core2core hsc_env pkg_rule_base +core2core hsc_env mod_impl@(ModGuts { mg_exports = exports, mg_binds = binds_in, mg_rules = rules_in }) = do let dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env ghci_mode = hsc_mode hsc_env core_todos | Just todo <- dopt_CoreToDo dflags = todo @@ -85,12 +83,12 @@ core2core hsc_env pkg_rule_base let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE - (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) - <- prepareRules dflags pkg_rule_base hpt ru_us binds_in rules_in + (rule_base, local_rule_ids, orphan_rules) + <- prepareRules hsc_env ru_us binds_in rules_in -- PREPARE THE BINDINGS let binds1 = updateBinders ghci_mode local_rule_ids - rule_rhs_fvs exports binds_in + orphan_rules exports binds_in -- DO THE BUSINESS (stats, processed_binds) @@ -216,17 +214,19 @@ noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } -- so that the opportunity to apply the rule isn't lost too soon \begin{code} -prepareRules :: DynFlags -> PackageRuleBase -> HomePackageTable +prepareRules :: HscEnv -> UniqSupply -> [CoreBind] -> [IdCoreRule] -- Local rules -> IO (RuleBase, -- Full rule base IdSet, -- Local rule Ids - [IdCoreRule], -- Orphan rules - IdSet) -- RHS free vars of all rules + [IdCoreRule]) -- Orphan rules defined in this module -prepareRules dflags pkg_rule_base hpt us binds local_rules - = do { let env = emptySimplEnv SimplGently [] local_ids +prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) + us binds local_rules + = do { eps <- hscEPS hsc_env + + ; let env = emptySimplEnv SimplGently [] local_ids (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules @@ -239,21 +239,18 @@ prepareRules dflags pkg_rule_base hpt us binds local_rules -- Example: class Foo a where -- op :: a -> a -- {-# RULES "op" op x = x #-} + local_rule_base = extendRuleBaseList emptyRuleBase local_rules + local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached - rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) better_rules) - local_rule_base = extendRuleBaseList emptyRuleBase local_rules - local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached - imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt) - rule_base = extendRuleBaseList imp_rule_base orphan_rules - final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base) - -- The last step black-lists the free vars of local rules too + imp_rule_base = foldl add_rules (eps_rule_base eps) (moduleEnvElts hpt) + final_rule_base = extendRuleBaseList imp_rule_base orphan_rules ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" (vcat [text "Local rules", pprRuleBase local_rule_base, text "", text "Imported rules", pprRuleBase final_rule_base]) - ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) + ; return (final_rule_base, local_rule_ids, orphan_rules) } where add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info)) @@ -264,7 +261,7 @@ prepareRules dflags pkg_rule_base hpt us binds local_rules updateBinders :: GhciMode -> IdSet -- Locally defined ids with their Rules attached - -> IdSet -- Ids free in the RHS of local rules + -> [IdCoreRule] -- Orphan rules -> Avails -- What is exported -> [CoreBind] -> [CoreBind] -- A horrible function @@ -294,7 +291,7 @@ updateBinders :: GhciMode -- the rules (maybe we should?), so this substitution would make the rule -- bogus. -updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds +updateBinders ghci_mode rule_ids orphan_rules exports binds = map update_bndrs binds where update_bndrs (NonRec b r) = NonRec (update_bndr b) r @@ -306,8 +303,14 @@ updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds where bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr + orph_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) orphan_rules) + -- An orphan rule must keep alive the free vars + -- of its right-hand side. + -- Non-orphan rules are attached to the Id (bndr_with_rules above) + -- and that keeps the rhs free vars alive + dont_discard bndr = is_exported (idName bndr) - || bndr `elemVarSet` rule_rhs_fvs + || bndr `elemVarSet` orph_rhs_fvs -- In interactive mode, we don't want to discard any top-level -- entities at all (eg. do not inline them away during diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 34813e7c49..4f9c24d01c 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -6,8 +6,8 @@ \begin{code} module Rules ( RuleBase, emptyRuleBase, - extendRuleBase, extendRuleBaseList, addRuleBaseFVs, - ruleBaseIds, ruleBaseFVs, + extendRuleBase, extendRuleBaseList, + ruleBaseIds, pprRuleBase, ruleCheckProgram, lookupRule, addRule, addIdSpecialisations @@ -17,7 +17,7 @@ module Rules ( import CoreSyn -- All of it import OccurAnal ( occurAnalyseRule ) -import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds ) +import CoreFVs ( exprFreeVars, ruleRhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( eqExpr ) import CoreTidy ( pprTidyIdRules ) @@ -373,14 +373,6 @@ bind vs1 vs2 matcher tpl_vars kont subst bug_msg = sep [ppr vs1, ppr vs2] ---------------------------------------- -matches [] [] tpl_vars kont subst - = kont subst -matches (e:es) (e':es') tpl_vars kont subst - = match e e' tpl_vars (matches es es' tpl_vars kont) subst -matches es es' tpl_vars kont subst - = match_fail - ----------------------------------------- mkVarArg :: CoreBndr -> CoreArg mkVarArg v | isId v = Var v | otherwise = Type (mkTyVarTy v) @@ -594,43 +586,27 @@ data RuleBase = RuleBase IdSet -- Ids with their rules in their specialisations -- Held as a set, so that it can simply be the initial -- in-scope set in the simplifier - - IdSet -- Ids (whether local or imported) mentioned on - -- LHS of some rule; these should be black listed - -- This representation is a bit cute, and I wonder if we should -- change it to use (IdEnv CoreRule) which seems a bit more natural -ruleBaseIds (RuleBase ids _) = ids -ruleBaseFVs (RuleBase _ fvs) = fvs - -emptyRuleBase = RuleBase emptyVarSet emptyVarSet - -addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase -addRuleBaseFVs (RuleBase rules fvs) extra_fvs - = RuleBase rules (fvs `unionVarSet` extra_fvs) +ruleBaseIds (RuleBase ids) = ids +emptyRuleBase = RuleBase emptyVarSet extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase extendRuleBaseList rule_base new_guys = foldl extendRuleBase rule_base new_guys extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase -extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule) +extendRuleBase (RuleBase rule_ids) (id, rule) = RuleBase (extendVarSet rule_ids new_id) - (rule_fvs `unionVarSet` extendVarSet lhs_fvs id) where - new_id = setIdSpecialisation id (addRule id old_rules rule) - + new_id = setIdSpecialisation id (addRule id old_rules rule) old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id)) -- Get the old rules from rule_ids if the Id is already there, but -- if not, use the Id from the incoming rule. If may be a PrimOpId, -- in which case it may have rules in its belly already. Seems -- dreadfully hackoid. - lhs_fvs = ruleLhsFreeIds rule - -- Finds *all* the free Ids of the LHS, not just - -- locally defined ones!! - pprRuleBase :: RuleBase -> SDoc -pprRuleBase (RuleBase rules _) = vcat [ pprTidyIdRules id | id <- varSetElems rules ] +pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ] \end{code} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 8fdc00398f..3291c0df4c 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -860,15 +860,7 @@ thenLne :: LneM a -> (a -> LneM b) -> LneM b thenLne m k env lvs_cont = k (m env lvs_cont) env lvs_cont -mapLne :: (a -> LneM b) -> [a] -> LneM [b] -mapLne f [] = returnLne [] -mapLne f (x:xs) - = f x `thenLne` \ r -> - mapLne f xs `thenLne` \ rs -> - returnLne (r:rs) - mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c]) - mapAndUnzipLne f [] = returnLne ([],[]) mapAndUnzipLne f (x:xs) = f x `thenLne` \ (r1, r2) -> @@ -876,7 +868,6 @@ mapAndUnzipLne f (x:xs) returnLne (r1:rs1, r2:rs2) mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d]) - mapAndUnzip3Lne f [] = returnLne ([],[],[]) mapAndUnzip3Lne f (x:xs) = f x `thenLne` \ (r1, r2, r3) -> @@ -884,7 +875,6 @@ mapAndUnzip3Lne f (x:xs) returnLne (r1:rs1, r2:rs2, r3:rs3) mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e]) - mapAndUnzip4Lne f [] = returnLne ([],[],[],[]) mapAndUnzip4Lne f (x:xs) = f x `thenLne` \ (r1, r2, r3, r4) -> diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index f634185c0c..31cc98afce 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -23,11 +23,11 @@ import ErrUtils ( Message, addErrLocHdrLine ) import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, isUnLiftedType, isTyVarTy, dropForAlls, Type ) -import TyCon ( TyCon, isAlgTyCon, isNewTyCon, tyConDataCons ) +import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons ) import Util ( zipEqual, equalLength ) import Outputable -infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` +infixr 9 `thenL`, `thenL_`, `thenMaybeL` \end{code} Checks for @@ -345,12 +345,6 @@ thenMaybeL m k loc scope errs (Nothing, errs2) -> (Nothing, errs2) (Just r, errs2) -> k r loc scope errs2 -thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b) -thenMaybeL_ m k loc scope errs - = case m loc scope errs of - (Nothing, errs2) -> (Nothing, errs2) - (Just _, errs2) -> k loc scope errs2 - mapL :: (a -> LintM b) -> [a] -> LintM [b] mapL f [] = returnL [] mapL f (x:xs) @@ -461,11 +455,6 @@ mkCaseAltMsg alts = ($$) (text "In some case alternatives, type of alternatives not all same:") (empty) -- LATER: ppr alts -mkCaseAbstractMsg :: TyCon -> Message -mkCaseAbstractMsg tycon - = ($$) (ptext SLIT("An algebraic case on an abstract type:")) - (ppr tycon) - mkDefltMsg :: Id -> Message mkDefltMsg bndr = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:")) @@ -484,12 +473,6 @@ mkRhsConMsg fun_ty arg_tys hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty), hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))] -mkUnappTyMsg :: Id -> Type -> Message -mkUnappTyMsg var ty - = vcat [text "Variable has a for-all type, but isn't applied to any types.", - (<>) (ptext SLIT("Var: ")) (ppr var), - (<>) (ptext SLIT("Its type: ")) (ppr ty)] - mkAltMsg1 :: Type -> Message mkAltMsg1 ty = ($$) (text "In a case expression, type of scrutinee does not match patterns") diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index ed1dacfb24..156e8dbada 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -56,6 +56,7 @@ import Literal ( Literal, literalType, literalPrimRep ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) import CoreSyn ( AltCon ) +import PprCore ( {- instances -} ) import PrimOp ( PrimOp ) import Outputable import Util ( count ) diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index b27a30ee2b..fe588f0131 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -55,10 +55,6 @@ To think about * Consider f x = x+1 `fatbar` error (show x) We'd like to unbox x, even if that means reboxing it in the error case. -\begin{code} -instance Outputable TopLevelFlag where - ppr flag = empty -\end{code} %************************************************************************ %* * @@ -886,17 +882,6 @@ argDemand d = d \end{code} \begin{code} -betterStrictness :: StrictSig -> StrictSig -> Bool -betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2 - -betterDmdType t1 t2 = (t1 `lubType` t2) == t2 - -betterDemand :: Demand -> Demand -> Bool --- If d1 `better` d2, and d2 `better` d2, then d1==d2 -betterDemand d1 d2 = (d1 `lub` d2) == d2 -\end{code} - -\begin{code} ------------------------- -- Consider (if x then y else []) with demand V -- Then the first branch gives {y->V} and the second @@ -1166,7 +1151,15 @@ get_changes_dmd id old = newDemand (idDemandInfo id) new_better = new `betterDemand` old old_better = old `betterDemand` new -#endif + +betterStrictness :: StrictSig -> StrictSig -> Bool +betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2 + +betterDmdType t1 t2 = (t1 `lubType` t2) == t2 + +betterDemand :: Demand -> Demand -> Bool +-- If d1 `better` d2, and d2 `better` d2, then d1==d2 +betterDemand d1 d2 = (d1 `lub` d2) == d2 squashSig (StrictSig (DmdType fv ds res)) = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res) @@ -1178,4 +1171,5 @@ squashDmd (Box d) = Box (squashDmd d) squashDmd (Eval ds) = Eval (mapDmds squashDmd ds) squashDmd (Defer ds) = Defer (mapDmds squashDmd ds) squashDmd d = d +#endif \end{code} diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index d587894ac3..8b889970c9 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -228,7 +228,6 @@ tryWW is_rec fn_id rhs maybe_fn_dmd = newDemandInfo fn_info unfolding = unfoldingInfo fn_info inline_prag = inlinePragInfo fn_info - maybe_sig = newStrictnessInfo fn_info -- In practice it always will have a strictness -- signature, even if it's a uninformative one diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 49571f3087..e1a1da6463 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -20,7 +20,7 @@ import NewDemand ( Demand(..), DmdResult(..), Demands(..) ) import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID ) import TysWiredIn ( tupleCon ) import Type ( Type, isUnLiftedType, mkFunTys, - splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType + splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType ) import BasicTypes ( Boxity(..) ) import Var ( Var, isId ) @@ -223,7 +223,7 @@ mkWWargs :: Type Type) -- Type of wrapper body mkWWargs fun_ty demands one_shots - | Just rep_ty <- splitNewType_maybe fun_ty + | Just rep_ty <- splitRecNewType_maybe fun_ty -- The newtype case is for when the function has -- a recursive newtype after the arrow (rare) -- We check for arity >= 0 to avoid looping in the case diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 61bfd6018a..2a2663a8b7 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -10,7 +10,8 @@ module Inst ( showLIE, Inst, - pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts, + pprInst, pprInsts, pprInstsInFull, pprDFuns, + tidyInsts, tidyMoreInsts, newDictsFromOld, newDicts, cloneDict, newOverloadedLit, newIPDict, @@ -23,6 +24,7 @@ module Inst ( instLoc, getDictClassTys, dictPred, lookupInst, LookupInstResult(..), + tcExtendLocalInstEnv, tcGetInstEnvs, isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, @@ -45,15 +47,16 @@ import TcHsSyn ( TcExpr, TcId, TcIdSet, mkCoercion, ExprCoFn ) import TcRnMonad -import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl ) -import InstEnv ( InstLookupResult(..), lookupInstEnv ) +import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy ) +import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv ) +import TcIface ( loadImportedInsts ) import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars ) import TcType ( Type, TcType, TcThetaType, TcTyVarSet, - SourceType(..), PredType, TyVarDetails(VanillaTv), + PredType(..), TyVarDetails(VanillaTv), tcSplitForAllTys, tcSplitForAllTys, mkTyConApp, - tcSplitPhiTy, mkGenTyConApp, + tcSplitPhiTy, isTyVarTy, tcSplitDFunTy, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, @@ -62,19 +65,21 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy ) +import HscTypes ( ExternalPackageState(..) ) import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon,dataConSig ) import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique ) import PrelInfo ( isStandardClass, isNoDictClass ) -import Name ( Name, mkMethodOcc, getOccName ) -import PprType ( pprPred, pprParendType ) +import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName ) +import NameSet ( addOneToNameSet ) +import PprType ( pprPred, pprParendType, pprThetaArrow, pprClassPred ) import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst ) import Literal ( inIntRange ) import Var ( TyVar ) import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) import TysWiredIn ( floatDataCon, doubleDataCon ) -import PrelNames( fromIntegerName, fromRationalName, rationalTyConName ) +import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import Outputable @@ -358,7 +363,8 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty -- syntax. Reason: tcSyntaxName does unification -- which is very inconvenient in tcSimplify = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) -> - returnM (HsApp expr (HsLit (HsInteger i))) + mkIntegerLit i `thenM` \ integer_lit -> + returnM (HsApp expr integer_lit) | Just expr <- shortCutIntLit i expected_ty = returnM expr @@ -390,10 +396,10 @@ newLitInst orig lit expected_ty shortCutIntLit :: Integer -> TcType -> Maybe TcExpr shortCutIntLit i ty - | isIntTy ty && inIntRange i -- Short cut for Int + | isIntTy ty && inIntRange i -- Short cut for Int = Just (HsLit (HsInt i)) - | isIntegerTy ty -- Short cut for Integer - = Just (HsLit (HsInteger i)) + | isIntegerTy ty -- Short cut for Integer + = Just (HsLit (HsInteger i ty)) | otherwise = Nothing shortCutFracLit :: Rational -> TcType -> Maybe TcExpr @@ -404,13 +410,15 @@ shortCutFracLit f ty = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)]) | otherwise = Nothing +mkIntegerLit :: Integer -> TcM TcExpr +mkIntegerLit i + = tcMetaTy integerTyConName `thenM` \ integer_ty -> + returnM (HsLit (HsInteger i integer_ty)) + mkRatLit :: Rational -> TcM TcExpr mkRatLit r - = tcLookupTyCon rationalTyConName `thenM` \ rat_tc -> - let - rational_ty = mkGenTyConApp rat_tc [] - in - returnM (HsLit (HsRat r rational_ty)) + = tcMetaTy rationalTyConName `thenM` \ rat_ty -> + returnM (HsLit (HsRat r rat_ty)) \end{code} @@ -483,6 +491,16 @@ pprInst m@(Method u id tys theta tau loc) show_uniq u, ppr (instToId m) -}] + +pprDFuns :: [DFunId] -> SDoc +-- Prints the dfun as an instance declaration +pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon) + 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, + pprClassPred clas tys]) + | dfun <- dfuns + , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ] + -- Print without the for-all, which the programmer doesn't write + show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") tidyInst :: TidyEnv -> Inst -> Inst @@ -511,6 +529,43 @@ showLIE str %************************************************************************ %* * + Extending the instance environment +%* * +%************************************************************************ + +\begin{code} +tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a + -- Add new locally-defined instances +tcExtendLocalInstEnv dfuns thing_inside + = do { traceDFuns dfuns + ; eps <- getEps + ; env <- getGblEnv + ; inst_env' <- foldlM (extend (eps_inst_env eps)) + (tcg_inst_env env) + dfuns + ; let env' = env { tcg_insts = dfuns ++ tcg_insts env, + tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + where + extend pkg_ie home_ie dfun + = do { case checkFunDeps (home_ie, pkg_ie) dfun of + Just dfuns -> funDepErr dfun dfuns + Nothing -> return () + ; return (extendInstEnv home_ie dfun) } + +traceDFuns dfuns + = traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) + where + pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) + +funDepErr dfun dfuns + = addSrcLoc (getSrcLoc dfun) $ + addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:")) + 2 (pprDFuns (dfun:dfuns))) +\end{code} + +%************************************************************************ +%* * \subsection{Looking up Insts} %* * %************************************************************************ @@ -527,48 +582,6 @@ lookupInst :: Inst -> TcM (LookupInstResult s) -- the LookupInstResult, where they can be further processed by tcSimplify --- Dictionaries -lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) - = getDOpts `thenM` \ dflags -> - tcGetInstEnv `thenM` \ inst_env -> - case lookupInstEnv dflags inst_env clas tys of - - FoundInst tenv dfun_id - -> -- It's possible that not all the tyvars are in - -- the substitution, tenv. For example: - -- instance C X a => D X where ... - -- (presumably there's a functional dependency in class C) - -- Hence the mk_ty_arg to instantiate any un-substituted tyvars. - getStage `thenM` \ use_stage -> - checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) - (topIdLvl dfun_id) use_stage `thenM_` - traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_` - let - (tyvars, rho) = tcSplitForAllTys (idType dfun_id) - mk_ty_arg tv = case lookupSubstEnv tenv tv of - Just (DoneTy ty) -> returnM ty - Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv -> - returnM (mkTyVarTy tc_tv) - in - mappM mk_ty_arg tyvars `thenM` \ ty_args -> - let - dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho - (theta, _) = tcSplitPhiTy dfun_rho - ty_app = mkHsTyApp (HsVar dfun_id) ty_args - in - if null theta then - returnM (SimpleInst ty_app) - else - newDictsAtLoc loc theta `thenM` \ dicts -> - let - rhs = mkHsDictApp ty_app (map instToId dicts) - in - returnM (GenInst dicts rhs) - - other -> returnM NoInstance - -lookupInst (Dict _ _ _) = returnM NoInstance - -- Methods lookupInst inst@(Method _ id tys theta _ loc) @@ -592,9 +605,9 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant tcLookupId fromIntegerName `thenM` \ from_integer -> tcInstClassOp loc from_integer [ty] `thenM` \ method_inst -> + mkIntegerLit i `thenM` \ integer_lit -> returnM (GenInst [method_inst] - (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i)))) - + (HsApp (HsVar (instToId method_inst)) integer_lit)) lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | Just expr <- shortCutFracLit f ty @@ -606,6 +619,78 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) tcInstClassOp loc from_rational [ty] `thenM` \ method_inst -> mkRatLit f `thenM` \ rat_lit -> returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit)) + +-- Dictionaries +lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) + | all isTyVarTy tys -- Common special case; no lookup + = returnM NoInstance + + | otherwise + = do { pkg_ie <- loadImportedInsts clas tys + -- Suck in any instance decls that may be relevant + ; tcg_env <- getGblEnv + ; dflags <- getDOpts + ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of { + ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ; + other -> return NoInstance } } + -- In the case of overlap (multiple matches) we report + -- NoInstance here. That has the effect of making the + -- context-simplifier return the dict as an irreducible one. + -- Then it'll be given to addNoInstanceErrs, which will do another + -- lookupInstEnv to get the detailed info about what went wrong. + +lookupInst (Dict _ _ _) = returnM NoInstance + +----------------- +instantiate_dfun tenv dfun_id pred loc + = -- Record that this dfun is needed + record_dfun_usage dfun_id `thenM_` + + -- It's possible that not all the tyvars are in + -- the substitution, tenv. For example: + -- instance C X a => D X where ... + -- (presumably there's a functional dependency in class C) + -- Hence the mk_ty_arg to instantiate any un-substituted tyvars. + getStage `thenM` \ use_stage -> + checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) + (topIdLvl dfun_id) use_stage `thenM_` + traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_` + let + (tyvars, rho) = tcSplitForAllTys (idType dfun_id) + mk_ty_arg tv = case lookupSubstEnv tenv tv of + Just (DoneTy ty) -> returnM ty + Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv -> + returnM (mkTyVarTy tc_tv) + in + mappM mk_ty_arg tyvars `thenM` \ ty_args -> + let + dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho + (theta, _) = tcSplitPhiTy dfun_rho + ty_app = mkHsTyApp (HsVar dfun_id) ty_args + in + if null theta then + returnM (SimpleInst ty_app) + else + newDictsAtLoc loc theta `thenM` \ dicts -> + let + rhs = mkHsDictApp ty_app (map instToId dicts) + in + returnM (GenInst dicts rhs) + +record_dfun_usage dfun_id + | isInternalName dfun_name = return () -- From this module + | not (isHomePackageName dfun_name) = return () -- From another package package + | otherwise = getGblEnv `thenM` \ tcg_env -> + updMutVar (tcg_inst_uses tcg_env) + (`addOneToNameSet` idName dfun_id) + where + dfun_name = idName dfun_id + +tcGetInstEnvs :: TcM (InstEnv, InstEnv) +-- Gets both the home-pkg inst env (includes module being compiled) +-- and the external-package inst-env +tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; + return (tcg_inst_env env, eps_inst_env eps) } \end{code} @@ -662,6 +747,9 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) -- case of locally-polymorphic methods. in addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $ + + -- Check that the user-supplied thing has the + -- same type as the standard one tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> returnM (std_nm, expr) diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index 77c7165bcb..eda193a095 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -11,14 +11,14 @@ module TcArrows ( tcProc ) where import {-# SOURCE #-} TcExpr( tcCheckRho ) import HsSyn -import TcHsSyn ( TcCmd, TcCmdTop, TcExpr, TcPat, mkHsLet ) +import TcHsSyn ( TcCmdTop, TcExpr, TcPat, mkHsLet ) import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts, TcMatchCtxt(..), tcMatchesCase ) import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp, mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType ) -import TcMType ( newTyVar, newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType ) +import TcMType ( newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType ) import TcBinds ( tcBindsAndThen ) import TcSimplify ( tcSimplifyCheck ) import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo ) @@ -28,7 +28,7 @@ import TysWiredIn ( boolTy, pairTyCon ) import VarSet import Type ( Kind, mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes ) -import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmd, RenamedHsCmdTop ) +import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmdTop ) import Outputable import Util ( lengthAtLeast ) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 446f198b31..a0b0a4ebcf 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -26,7 +26,7 @@ import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName ) import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), +import TcHsType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars ) import TcPat ( tcPat, tcSubPat, tcMonoPatBndr ) @@ -221,12 +221,11 @@ so all the clever stuff is in here. as the Name in the tc_ty_sig \begin{code} -tcBindWithSigs - :: TopLevelFlag - -> RenamedMonoBinds - -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs - -> RecFlag - -> TcM (TcMonoBinds, [TcId]) +tcBindWithSigs :: TopLevelFlag + -> RenamedMonoBinds + -> [RenamedSig] + -> RecFlag + -> TcM (TcMonoBinds, [TcId]) tcBindWithSigs top_lvl mbind sigs is_rec = -- TYPECHECK THE SIGNATURES @@ -253,6 +252,8 @@ tcBindWithSigs top_lvl mbind sigs is_rec ) $ -- TYPECHECK THE BINDINGS + traceTc (ptext SLIT("--------------------------------------------------------")) `thenM_` + traceTc (ptext SLIT("Bindings for") <+> ppr (collectMonoBinders mbind)) `thenM_` getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) -> let (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids) @@ -820,7 +821,6 @@ tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs tcSpecSigs [] = returnM EmptyMonoBinds \end{code} - %************************************************************************ %* * \subsection[TcBinds-errors]{Error contexts and messages} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 820ed749f5..5e515b6063 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -4,63 +4,69 @@ \section[TcClassDcl]{Typechecking class declarations} \begin{code} -module TcClassDcl ( tcClassDecl1, tcClassDecls2, - MethodSpec, tcMethodBind, mkMethodBind, badMethodErr +module TcClassDcl ( tcClassSigs, tcClassDecl2, + getGenericInstances, + MethodSpec, tcMethodBind, mkMethodBind, + tcAddDeclCtxt, badMethodErr ) where #include "HsVersions.h" -import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), - HsExpr(..), HsLit(..), Pat(WildPat), +import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..), + HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..), mkSimpleMatch, andMonoBinds, andMonoBindList, - isClassOpSig, isPragSig, - placeHolderType + isPragSig, placeHolderType, mkHsForAllTy ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), NewOrData(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedSig, RenamedClassOpSig, RenamedMonoBinds, - maybeGenericMatch + maybeGenericMatch, extractHsTyVars ) -import RnEnv ( lookupSysName ) +import RnExpr ( rnExpr ) +import RnEnv ( lookupTopBndrRn, lookupImportedName ) import TcHsSyn ( TcMonoBinds ) import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod ) -import TcEnv ( TyThingDetails(..), - tcLookupClass, tcExtendLocalValEnv2, - tcExtendTyVarEnv2, tcExtendTyVarEnv +import TcEnv ( tcLookupClass, tcExtendLocalValEnv2, tcExtendTyVarEnv2, + InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, + InstBindings(..), newDFunName ) -import TcTyDecls ( tcMkDataCon ) import TcBinds ( tcMonoBinds, tcSpecSigs ) -import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig ) +import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import TcUnify ( checkSigTyVars, sigCtxt ) -import TcMType ( tcInstTyVars ) +import TcMType ( tcInstTyVars, UserTypeCtxt( GenPatCtxt ) ) import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, - mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys, + mkClassPred, tcSplitSigmaTy, tcSplitFunTys, tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy, - getClassPredTys_maybe, mkPhiTy + getClassPredTys_maybe, mkPhiTy, mkTyVarTy ) import TcRnMonad -import Generics ( mkGenericRhs ) +import Generics ( mkGenericRhs, validGenericInstanceType ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) -import Class ( classTyVars, classBigSig, classTyCon, +import Class ( classTyVars, classBigSig, Class, ClassOpItem, DefMeth (..) ) -import TyCon ( tyConGenInfo ) +import TyCon ( TyCon, tyConName, tyConHasGenerics ) import Subst ( substTyWith ) -import MkId ( mkDictSelId, mkDefaultMethodId ) +import MkId ( mkDefaultMethodId, mkDictFunId ) import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv ) -import NameSet ( emptyNameSet, unitNameSet ) -import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused ) +import NameSet ( emptyNameSet, unitNameSet, nameSetToList ) +import OccName ( reportIfUnused, mkDefaultMethodOcc ) +import RdrName ( RdrName, mkDerivedRdrName ) import Outputable import Var ( TyVar ) +import PrelNames ( genericTyConNames ) import CmdLineOpts import UnicodeUtil ( stringToUtf8 ) -import ErrUtils ( dumpIfSet ) -import Util ( count, lengthIs, isSingleton ) -import Maybes ( seqMaybe ) -import Maybe ( isJust ) +import ErrUtils ( dumpIfSet, dumpIfSet_dyn ) +import Util ( count, lengthIs, isSingleton, lengthExceeds ) +import Unique ( Uniquable(..) ) +import ListSetOps ( equivClassesByUniq, minusList ) +import SrcLoc ( SrcLoc ) +import Maybes ( seqMaybe, isJust, mapCatMaybes ) +import List ( partition ) import FastString \end{code} @@ -101,151 +107,70 @@ Death to "ExpandingDicts". %************************************************************************ %* * -\subsection{Type checking} + Type-checking the class op signatures %* * %************************************************************************ \begin{code} +tcClassSigs :: Name -- Name of the class + -> [RenamedClassOpSig] + -> RenamedMonoBinds + -> TcM [TcMethInfo] + +type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate + -- between tcClassSigs and buildClass +tcClassSigs clas sigs def_methods + = do { dm_env <- checkDefaultBinds clas op_names def_methods + ; mappM (tcClassSig dm_env) op_sigs } + where + op_sigs = [sig | sig@(Sig n _ _) <- sigs] + op_names = [n | sig@(Sig n _ _) <- op_sigs] -tcClassDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails) -tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, - tcdTyVars = tyvar_names, tcdFDs = fundeps, - tcdSigs = class_sigs, tcdMeths = def_methods, - tcdLoc = src_loc}) - = -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupClass class_name `thenM` \ clas -> - let - tyvars = classTyVars clas - op_sigs = filter isClassOpSig class_sigs - op_names = [n | ClassOpSig n _ _ _ <- op_sigs] - in - tcExtendTyVarEnv tyvars $ - - checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env -> - - -- CHECK THE CONTEXT - -- The renamer has already checked that the context mentions - -- only the type variable of the class decl. - -- Context is already kind-checked - tcHsTheta context `thenM` \ sc_theta -> - - -- CHECK THE CLASS SIGNATURES, - mappM (tcClassSig clas tyvars mb_dm_env) op_sigs `thenM` \ sig_stuff -> - - -- MAKE THE CLASS DETAILS - lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name -> - lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name -> - mapM (lookupSysName class_name . mkSuperDictSelOcc) - [1..length context] `thenM` \ sc_sel_names -> - -- We number off the superclass selectors, 1, 2, 3 etc so that we - -- can construct names for the selectors. Thus - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - let - (op_tys, op_items) = unzip sig_stuff - sc_tys = mkPredTys sc_theta - dict_component_tys = sc_tys ++ op_tys - sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names] - in - tcMkDataCon datacon_name - [{- No strictness -}] - [{- No labelled fields -}] - tyvars [{-No context-}] - [{-No existential tyvars-}] [{-Or context-}] - dict_component_tys - (classTyCon clas) `thenM` \ dict_con -> - - returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name) -\end{code} - -\begin{code} -checkDefaultBinds :: Class -> [Name] -> Maybe RenamedMonoBinds - -> TcM (Maybe (NameEnv Bool)) - -- The returned environment says - -- x not in env => no default method - -- x -> True => generic default method - -- x -> False => polymorphic default method - + +checkDefaultBinds :: Name -> [Name] -> RenamedMonoBinds + -> TcM (NameEnv Bool) -- Check default bindings -- a) must be for a class op for this class -- b) must be all generic or all non-generic - -- and return a mapping from class-op to DefMeth info + -- and return a mapping from class-op to Bool + -- where True <=> it's a generic default method - -- But do all this only for source binds +checkDefaultBinds clas ops EmptyMonoBinds + = returnM emptyNameEnv -checkDefaultBinds clas ops Nothing - = returnM Nothing +checkDefaultBinds clas ops (AndMonoBinds b1 b2) + = do { dm_info1 <- checkDefaultBinds clas ops b1 + ; dm_info2 <- checkDefaultBinds clas ops b2 + ; returnM (dm_info1 `plusNameEnv` dm_info2) } -checkDefaultBinds clas ops (Just mbs) - = go mbs `thenM` \ dm_env -> - returnM (Just dm_env) - where - go EmptyMonoBinds = returnM emptyNameEnv - - go (AndMonoBinds b1 b2) - = go b1 `thenM` \ dm_info1 -> - go b2 `thenM` \ dm_info2 -> - returnM (dm_info1 `plusNameEnv` dm_info2) - - go (FunMonoBind op _ matches loc) - = addSrcLoc loc $ - - -- Check that the op is from this class - checkTc (op `elem` ops) (badMethodErr clas op) `thenM_` +checkDefaultBinds clas ops (FunMonoBind op _ matches loc) + = addSrcLoc loc $ do + { -- Check that the op is from this class + checkTc (op `elem` ops) (badMethodErr clas op) -- Check that all the defns ar generic, or none are - checkTc (all_generic || none_generic) (mixedGenericErr op) `thenM_` + ; checkTc (all_generic || none_generic) (mixedGenericErr op) - returnM (unitNameEnv op all_generic) - where - n_generic = count (isJust . maybeGenericMatch) matches - none_generic = n_generic == 0 - all_generic = matches `lengthIs` n_generic -\end{code} + ; returnM (unitNameEnv op all_generic) + } + where + n_generic = count (isJust . maybeGenericMatch) matches + none_generic = n_generic == 0 + all_generic = matches `lengthIs` n_generic -\begin{code} -tcClassSig :: Class -- ...ditto... - -> [TyVar] -- The class type variable, used for error check only - -> Maybe (NameEnv Bool) -- Info about default methods; - -- Nothing => imported class defn with no method binds +tcClassSig :: NameEnv Bool -- Info about default methods; -> RenamedClassOpSig - -> TcM (Type, -- Type of the method - ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding - --- This warrants an explanation: we need to separate generic --- default methods and default methods later on in the compiler --- so we distinguish them in checkDefaultBinds, and pass this knowledge in the --- Class.DefMeth data structure. - -tcClassSig clas clas_tyvars maybe_dm_env - (ClassOpSig op_name sig_dm op_ty src_loc) - = addSrcLoc src_loc $ - - -- Check the type signature. NB that the envt *already has* - -- bindings for the type variables; see comments in TcTyAndClassDcls. - tcHsType op_ty `thenM` \ local_ty -> - - let - theta = [mkClassPred clas (mkTyVarTys clas_tyvars)] - - -- Build the selector id and default method id - sel_id = mkDictSelId op_name clas - DefMeth dm_name = sig_dm - - dm_info = case maybe_dm_env of - Nothing -> sig_dm - Just dm_env -> mk_src_dm_info dm_env - - mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of - Nothing -> NoDefMeth - Just True -> GenDefMeth - Just False -> DefMeth dm_name - in - returnM (local_ty, (sel_id, dm_info)) + -> TcM TcMethInfo + +tcClassSig dm_env (Sig op_name op_hs_ty src_loc) + = addSrcLoc src_loc $ do + { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope + ; let dm = case lookupNameEnv dm_env op_name of + Nothing -> NoDefMeth + Just False -> DefMeth + Just True -> GenDefMeth + ; returnM (op_name, dm, op_ty) } \end{code} @@ -310,25 +235,7 @@ dfun.Foo.List dfoo_list \end{verbatim} -The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to -each local class decl. - -\begin{code} -tcClassDecls2 :: [RenamedTyClDecl] -> TcM (TcMonoBinds, [Id]) - -tcClassDecls2 decls - = foldr combine - (returnM (EmptyMonoBinds, [])) - [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls] - -- The 'Just' picks out source ClassDecls - where - combine tc1 tc2 = tc1 `thenM` \ (binds1, ids1) -> - tc2 `thenM` \ (binds2, ids2) -> - returnM (binds1 `AndMonoBinds` binds2, - ids1 ++ ids2) -\end{code} - -@tcClassDecl2@ generates bindings for polymorphic default methods +@tcClassDecls2@ generates bindings for polymorphic default methods (generic default methods have by now turned into instance declarations) \begin{code} @@ -336,9 +243,8 @@ tcClassDecl2 :: RenamedTyClDecl -- The class declaration -> TcM (TcMonoBinds, [Id]) tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, - tcdMeths = Just default_binds, tcdLoc = src_loc}) - = -- The 'Just' picks out source ClassDecls - recoverM (returnM (EmptyMonoBinds, [])) $ + tcdMeths = default_binds, tcdLoc = src_loc}) + = recoverM (returnM (EmptyMonoBinds, [])) $ addSrcLoc src_loc $ tcLookupClass class_name `thenM` \ clas -> @@ -354,32 +260,31 @@ tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, (tyvars, _, _, op_items) = classBigSig clas prags = filter isPragSig sigs tc_dm = tcDefMeth clas tyvars default_binds prags - in - mapAndUnzipM tc_dm op_items `thenM` \ (defm_binds, dm_ids_s) -> - - returnM (andMonoBindList defm_binds, concat dm_ids_s) - -tcDefMeth clas tyvars binds_in prags (_, NoDefMeth) = returnM (EmptyMonoBinds, []) -tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds, []) + dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items] -- Generate code for polymorphic default methods only -- (Generic default methods have turned into instance decls by now.) -- This is incompatible with Hugs, which expects a polymorphic -- default method for every class op, regardless of whether or not -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) - -tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) - = tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) -> + in + mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) -> + returnM (andMonoBindList defm_binds, concat dm_ids_s) + +tcDefMeth clas tyvars binds_in prags sel_id + = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name -> + tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) -> let dm_ty = idType sel_id -- Same as dict selector! theta = [mkClassPred clas inst_tys] local_dm_id = mkDefaultMethodId dm_name dm_ty xtve = tyvars `zip` clas_tyvars + origin = ClassDeclOrigin in + mkMethodBind origin clas inst_tys + binds_in (sel_id, DefMeth) `thenM` \ (_, meth_info) -> newDicts origin theta `thenM` \ [this_dict] -> - - mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (_, meth_info) -> getLIE (tcMethodBind xtve clas_tyvars theta [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) -> @@ -405,11 +310,11 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) (dict_binds `andMonoBinds` defm_bind) in returnM (full_bind, [local_dm_id]) - where - origin = ClassDeclOrigin + +mkDefMethRdrName :: Id -> RdrName +mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc \end{code} - %************************************************************************ %* * @@ -586,9 +491,11 @@ mkMethId origin clas sel_id inst_tys -- The user didn't supply a method binding, -- so we have to make up a default binding -- The RHS of a default method depends on the default-method info -mkDefMethRhs origin clas inst_tys sel_id loc (DefMeth dm_name) +mkDefMethRhs origin clas inst_tys sel_id loc DefMeth = -- An polymorphic default method - traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_` + lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name -> + -- Might not be imported, but will be an OrigName + traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_` returnM (HsVar dm_name) mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth @@ -636,11 +543,14 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth checkTc (isJust maybe_tycon) (badGenericInstance sel_id (notSimple inst_tys)) `thenM_` - checkTc (isJust (tyConGenInfo tycon)) + checkTc (tyConHasGenerics tycon) (badGenericInstance sel_id (notGeneric tycon)) `thenM_` ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenM_` - returnM rhs + + -- Rename it before returning it + rnExpr rhs `thenM` \ (rn_rhs, _) -> + returnM rn_rhs where rhs = mkGenericRhs sel_id clas_tyvar tycon @@ -672,21 +582,183 @@ find_bind sel_name meth_name (FunMonoBind op_name fix matches loc) find_bind sel_name meth_name (AndMonoBinds b1 b2) = find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2 find_bind sel_name meth_name other = Nothing -- Default case +\end{code} + + +%************************************************************************ +%* * +\subsection{Extracting generic instance declaration from class declarations} +%* * +%************************************************************************ + +@getGenericInstances@ extracts the generic instance declarations from a class +declaration. For exmaple + + class C a where + op :: a -> a + + op{ x+y } (Inl v) = ... + op{ x+y } (Inr v) = ... + op{ x*y } (v :*: w) = ... + op{ 1 } Unit = ... + +gives rise to the instance declarations + + instance C (x+y) where + op (Inl v) = ... + op (Inr v) = ... + + instance C (x*y) where + op (v :*: w) = ... + + instance C 1 where + op Unit = ... + + +\begin{code} +getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo] +getGenericInstances class_decls + = do { gen_inst_infos <- mappM get_generics class_decls + ; let { gen_inst_info = concat gen_inst_infos } + + -- Return right away if there is no generic stuff + ; if null gen_inst_info then returnM [] + else do + + -- Otherwise print it out + { dflags <- getDOpts + ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" + (vcat (map pprInstInfo gen_inst_info))) + ; returnM gen_inst_info }} + +get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdLoc = loc}) + | null generic_binds + = returnM [] -- The comon case: no generic default methods + + | otherwise -- A source class decl with generic default methods + = recoverM (returnM []) $ + tcAddDeclCtxt decl $ + tcLookupClass class_name `thenM` \ clas -> + + -- Group by type, and + -- make an InstInfo out of each group + let + groups = groupWith andMonoBindList generic_binds + in + mappM (mkGenericInstance clas loc) groups `thenM` \ inst_infos -> + + -- Check that there is only one InstInfo for each type constructor + -- The main way this can fail is if you write + -- f {| a+b |} ... = ... + -- f {| x+y |} ... = ... + -- Then at this point we'll have an InstInfo for each + let + tc_inst_infos :: [(TyCon, InstInfo)] + tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos] + + bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos, + group `lengthExceeds` 1] + get_uniq (tc,_) = getUnique tc + in + mappM (addErrTc . dupGenericInsts) bad_groups `thenM_` + + -- Check that there is an InstInfo for each generic type constructor + let + missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos] + in + checkTc (null missing) (missingGenericInstances missing) `thenM_` - -- Find the prags for this method, and replace the - -- selector name with the method name -find_prags sel_name meth_name [] = [] -find_prags sel_name meth_name (SpecSig name ty loc : prags) - | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags -find_prags sel_name meth_name (InlineSig sense name phase loc : prags) - | name == sel_name = InlineSig sense meth_name phase loc : find_prags sel_name meth_name prags -find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags + returnM inst_infos + + where + generic_binds :: [(HsType Name, RenamedMonoBinds)] + generic_binds = getGenericBinds def_methods + + +--------------------------------- +getGenericBinds :: RenamedMonoBinds -> [(HsType Name, RenamedMonoBinds)] + -- Takes a group of method bindings, finds the generic ones, and returns + -- them in finite map indexed by the type parameter in the definition. + +getGenericBinds EmptyMonoBinds = [] +getGenericBinds (AndMonoBinds m1 m2) = getGenericBinds m1 ++ getGenericBinds m2 + +getGenericBinds (FunMonoBind id infixop matches loc) + = groupWith wrap (mapCatMaybes maybeGenericMatch matches) + where + wrap ms = FunMonoBind id infixop ms loc + +groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)] +groupWith op [] = [] +groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest + where + vs = map snd this + (this,rest) = partition same_t prs + same_t (t',v) = t `eqPatType` t' + +eqPatType :: HsType Name -> HsType Name -> Bool +-- A very simple equality function, only for +-- type patterns in generic function definitions. +eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2 +eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 +eqPatType _ _ = False + +--------------------------------- +mkGenericInstance :: Class -> SrcLoc + -> (HsType Name, RenamedMonoBinds) + -> TcM InstInfo + +mkGenericInstance clas loc (hs_ty, binds) + -- Make a generic instance declaration + -- For example: instance (C a, C b) => C (a+b) where { binds } + + = -- Extract the universally quantified type variables + -- and wrap them as forall'd tyvars, so that kind inference + -- works in the standard way + let + sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty)) + hs_forall_ty = mkHsForAllTy (Just sig_tvs) [] hs_ty + in + -- Type-check the instance type, and check its form + tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty -> + let + (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty + in + checkTc (validGenericInstanceType inst_ty) + (badGenericInstanceType binds) `thenM_` + + -- Make the dictionary function. + newDFunName clas [inst_ty] loc `thenM` \ dfun_name -> + let + inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] + dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] + in + + returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] }) \end{code} -Contexts and errors -~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * + Error messages +%* * +%************************************************************************ + \begin{code} +tcAddDeclCtxt decl thing_inside + = addSrcLoc (tcdLoc decl) $ + addErrCtxt ctxt $ + thing_inside + where + thing = case decl of + ClassDecl {} -> "class" + TySynonym {} -> "type synonym" + TyData {tcdND = NewType} -> "newtype" + TyData {tcdND = DataType} -> "data type" + + ctxt = hsep [ptext SLIT("In the"), text thing, + ptext SLIT("declaration for"), quotes (ppr (tcdName decl))] + defltMethCtxt clas = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas) @@ -713,6 +785,21 @@ notGeneric tycon = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+> ptext SLIT("was not compiled with -fgenerics")] +badGenericInstanceType binds + = vcat [ptext SLIT("Illegal type pattern in the generic bindings"), + nest 4 (ppr binds)] + +missingGenericInstances missing + = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing + +dupGenericInsts tc_inst_infos + = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"), + nest 4 (vcat (map ppr_inst_ty tc_inst_infos)), + ptext SLIT("All the type patterns for a generic type constructor must be identical") + ] + where + ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst) + mixedGenericErr op = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op) \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index f10745121e..5db1537687 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -11,18 +11,17 @@ module TcDefaults ( tcDefaults ) where import HsSyn ( DefaultDecl(..) ) import Name ( Name ) import TcRnMonad -import TcEnv ( tcLookupGlobal_maybe ) -import TcMonoType ( tcHsType ) +import TcEnv ( tcLookupClass ) +import TcHsType ( tcHsSigType, UserTypeCtxt( DefaultDeclCtxt ) ) import TcSimplify ( tcSimplifyDefault ) import TcType ( Type, mkClassPred, isTauTy ) import PrelNames ( numClassName ) import Outputable -import HscTypes ( TyThing(..) ) \end{code} \begin{code} tcDefaults :: [DefaultDecl Name] - -> TcM [Type] -- Defaulting types to heave + -> TcM (Maybe [Type]) -- Defaulting types to heave -- into Tc monad for later use -- in Disambig. @@ -39,29 +38,19 @@ tcDefaults [] -- defaultDefaultTys tcDefaults [DefaultDecl [] locn] - = returnM [] -- Default declaration specifying no types + = returnM (Just []) -- Default declaration specifying no types tcDefaults [DefaultDecl mono_tys locn] - = tcLookupGlobal_maybe numClassName `thenM` \ maybe_num -> - case maybe_num of - Just (AClass num_class) -> common_case num_class - other -> returnM [] - -- In the Nothing case, Num has not been sucked in, so the - -- defaults will never be used; so simply discard the default decl. - -- This slightly benefits modules that don't use any - -- numeric stuff at all, by avoid the necessity of - -- always sucking in Num - where - common_case num_class - = addSrcLoc locn $ - addErrCtxt defaultDeclCtxt $ - mappM tc_default_ty mono_tys `thenM` \ tau_tys -> + = addSrcLoc locn $ + addErrCtxt defaultDeclCtxt $ + tcLookupClass numClassName `thenM` \ num_class -> + mappM tc_default_ty mono_tys `thenM` \ tau_tys -> - -- Check that all the types are instances of Num - -- We only care about whether it worked or not - tcSimplifyDefault [mkClassPred num_class [ty] | ty <- tau_tys] `thenM_` + -- Check that all the types are instances of Num + -- We only care about whether it worked or not + tcSimplifyDefault [mkClassPred num_class [ty] | ty <- tau_tys] `thenM_` - returnM tau_tys + returnM (Just tau_tys) tcDefaults decls@(DefaultDecl _ loc : _) = addSrcLoc loc $ @@ -69,7 +58,7 @@ tcDefaults decls@(DefaultDecl _ loc : _) = tc_default_ty hs_ty - = tcHsType hs_ty `thenM` \ ty -> + = tcHsSigType DefaultDeclCtxt hs_ty `thenM` \ ty -> checkTc (isTauTy ty) (polyDefErr hs_ty) `thenM_` returnM ty diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 60b7b2fcaf..2f63cf7ce7 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -11,25 +11,26 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" import HsSyn ( HsBinds(..), TyClDecl(..), MonoBinds(..), - andMonoBindList, collectMonoBinders ) + andMonoBindList ) import RdrHsSyn ( RdrNameMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred ) import CmdLineOpts ( DynFlag(..) ) +import Generics ( mkGenericBinds ) import TcRnMonad -import TcEnv ( tcExtendTempInstEnv, newDFunName, +import TcEnv ( newDFunName, InstInfo(..), pprInstInfo, InstBindings(..), pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff -import InstEnv ( simpleDFunClassTyCon ) -import TcMonoType ( tcHsPred ) +import InstEnv ( simpleDFunClassTyCon, extendInstEnv ) +import TcHsType ( tcHsPred ) import TcSimplify ( tcSimplifyDeriv ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) -import RnEnv ( bindLocalsFV, extendTyVarEnvFVRn ) +import RnEnv ( bindLocalNames ) import TcRnMonad ( thenM, returnM, mapAndUnzipM ) -import HscTypes ( DFunId ) +import HscTypes ( DFunId, FixityEnv, typeEnvTyCons ) import BasicTypes ( NewOrData(..) ) import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) @@ -37,18 +38,16 @@ import Subst ( mkTyVarSubst, substTheta ) import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) import DataCon ( dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon ) -import Maybes ( maybeToBool, catMaybes ) +import Maybes ( catMaybes ) import Name ( Name, getSrcLoc ) import Unique ( Unique, getUnique ) -import NameSet -import RdrName ( RdrName ) import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConTheta, isProductTyCon, isDataTyCon, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTy, mkTyVarTys, mkTyConApp, - getClassPredTys_maybe, + getClassPredTys_maybe, tcTyConAppTyCon, isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, isTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy ) import Var ( TyVar, tyVarKind, idType, varName ) @@ -194,22 +193,21 @@ version. So now all classes are "offending". \begin{code} tcDeriving :: [RenamedTyClDecl] -- All type constructors - -> TcM ([InstInfo], -- The generated "instance decls". - RenamedHsBinds, -- Extra generated bindings - FreeVars) -- These are free in the generated bindings + -> TcM ([InstInfo], -- The generated "instance decls" + RenamedHsBinds) -- Extra generated top-level bindings tcDeriving tycl_decls - = recoverM (returnM ([], EmptyBinds, emptyFVs)) $ + = recoverM (returnM ([], EmptyBinds)) $ getDOpts `thenM` \ dflags -> -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". makeDerivEqns tycl_decls `thenM` \ (ordinary_eqns, newtype_inst_info) -> - tcExtendTempInstEnv (map iDFunId newtype_inst_info) $ + extendLocalInstEnv (map iDFunId newtype_inst_info) $ -- Add the newtype-derived instances to the inst env -- before tacking the "ordinary" ones - deriveOrdinaryStuff ordinary_eqns `thenM` \ (ordinary_inst_info, binds, fvs) -> + deriveOrdinaryStuff ordinary_eqns `thenM` \ (ordinary_inst_info, binds) -> let inst_info = newtype_inst_info ++ ordinary_inst_info in @@ -217,7 +215,7 @@ tcDeriving tycl_decls ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" (ddump_deriving inst_info binds)) `thenM_` - returnM (inst_info, binds, fvs) + returnM (inst_info, binds) where ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc @@ -230,64 +228,35 @@ tcDeriving tycl_decls ----------------------------------------- deriveOrdinaryStuff [] -- Short cut - = returnM ([], EmptyBinds, emptyFVs) + = returnM ([], EmptyBinds) deriveOrdinaryStuff eqns - = -- Take the equation list and solve it, to deliver a list of - -- solutions, a.k.a. the contexts for the instance decls - -- required for the corresponding equations. - solveDerivEqns eqns `thenM` \ new_dfuns -> - - -- Now augment the InstInfos, adding in the rather boring - -- actual-code-to-do-the-methods binds. We may also need to - -- generate extra not-one-inst-decl-specific binds, notably - -- "con2tag" and/or "tag2con" functions. We do these - -- separately. - gen_taggery_Names new_dfuns `thenM` \ nm_alist_etc -> + = do { -- Take the equation list and solve it, to deliver a list of + -- solutions, a.k.a. the contexts for the instance decls + -- required for the corresponding equations. + ; new_dfuns <- solveDerivEqns eqns - let - extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc - extra_mbinds = andMonoBindList extra_mbind_list - mbinders = collectMonoBinders extra_mbinds - in - mappM gen_bind new_dfuns `thenM` \ rdr_name_inst_infos -> - - traceTc (text "tcDeriv" <+> vcat (map ppr rdr_name_inst_infos)) `thenM_` - getModule `thenM` \ this_mod -> - initRn (InterfaceMode this_mod) ( - -- Rename to get RenamedBinds. - -- The only tricky bit is that the extra_binds must scope - -- over the method bindings for the instances. - bindLocalsFV (ptext (SLIT("deriving"))) mbinders $ \ _ -> - rnTopMonoBinds extra_mbinds [] `thenM` \ (rn_extra_binds, dus) -> - - mapAndUnzipM rn_inst_info rdr_name_inst_infos `thenM` \ (pairs, fvs_s) -> - - let - (rn_inst_infos, aux_binds_s) = unzip pairs - all_binds = rn_extra_binds `ThenBinds` foldr ThenBinds EmptyBinds aux_binds_s - in - returnM ((rn_inst_infos, all_binds), - duUses dus `plusFV` plusFVs fvs_s) - ) `thenM` \ ((rn_inst_infos, rn_extra_binds), fvs) -> - returnM (rn_inst_infos, rn_extra_binds, fvs) + -- Generate the InstInfo for each dfun, + -- plus any auxiliary bindings it needs + ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst new_dfuns - where - rn_inst_info (dfun, (meth_binds, aux_binds)) - = -- Rename the auxiliary bindings - bindLocalsFV (ptext (SLIT("deriving"))) mbinders $ \ _ -> - rnTopMonoBinds aux_binds [] `thenM` \ (rn_aux_binds, dus) -> - - -- Bring the right type variables into scope - extendTyVarEnvFVRn (map varName tyvars) $ - rnMethodBinds (className cls) [] meth_binds `thenM` \ (rn_meth_binds, fvs) -> - - return ((InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, - rn_aux_binds), - duUses dus `plusFV` fvs) - where - mbinders = collectMonoBinders aux_binds - (tyvars, _, cls, _) = tcSplitDFunTy (idType dfun) + -- Generate any extra not-one-inst-decl-specific binds, + -- notably "con2tag" and/or "tag2con" functions. + ; extra_binds <- genTaggeryBinds new_dfuns + + -- Generate the generic to/from functions from each type declaration + ; tcg_env <- getGblEnv + ; let gen_binds = mkGenericBinds (typeEnvTyCons (tcg_type_env tcg_env)) + + -- Rename these extra bindings + ; (rn_binds, _fvs1) <- rnTopMonoBinds (extra_binds `AndMonoBinds` gen_binds) [] + + ; let all_binds = rn_binds `ThenBinds` + foldr ThenBinds EmptyBinds aux_binds_s + + -- Done + ; traceTc (text "tcDeriv" <+> vcat (map pprInstInfo inst_infos)) + ; returnM (inst_infos, all_binds) } \end{code} @@ -354,8 +323,7 @@ makeDerivEqns tycl_decls = new_dfun_name clas tycon `thenM` \ dfun_name -> returnM (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing) where - tyvars = tyConTyVars tycon - data_cons = tyConDataCons tycon + tyvars = tyConTyVars tycon constraints = extra_constraints ++ ordinary_constraints -- "extra_constraints": see note [Data decl contexts] above extra_constraints = tyConTheta tycon @@ -544,7 +512,6 @@ new_dfun_name clas tycon -- Just a simple wrapper -- The type passed to newDFunName is only used to generate -- a suitable string; hence the empty type arg list - ------------------------------------------------------------------ -- Check side conditions that dis-allow derivability for particular classes -- This is *apart* from the newtype-deriving mechanism @@ -682,7 +649,7 @@ solveDerivEqns orig_eqns checkNoErrs ( -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - tcExtendTempInstEnv dfuns $ + extendLocalInstEnv dfuns $ mappM gen_soln orig_eqns ) `thenM` \ new_solns -> if (current_solns == new_solns) then @@ -701,6 +668,15 @@ solveDerivEqns orig_eqns mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta = mkDictFunId dfun_name tyvars theta clas [mkTyConApp tycon (mkTyVarTys tyvars)] + +extendLocalInstEnv :: [DFunId] -> TcM a -> TcM a +-- Add new locall-defined instances; don't bother to check +-- for functional dependency errors -- that'll happen in TcInstDcls +extendLocalInstEnv dfuns thing_inside + = do { env <- getGblEnv + ; let inst_env' = foldl extendInstEnv (tcg_inst_env env) dfuns + env' = env { tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } \end{code} %************************************************************************ @@ -766,33 +742,46 @@ the renamer. What a great hack! \end{itemize} \begin{code} --- Generate the method bindings for the required instance --- (paired with DFunId, as we need that when renaming --- the method binds) -gen_bind :: DFunId -> TcM (DFunId, (RdrNameMonoBinds, RdrNameMonoBinds)) -gen_bind dfun +-- Generate the InstInfo for the required instance, +-- plus any auxiliary bindings required +genInst :: DFunId -> TcM (InstInfo, RenamedHsBinds) +genInst dfun = getFixityEnv `thenM` \ fix_env -> let - (clas, tycon) = simpleDFunClassTyCon dfun - gen_binds_fn = assoc "gen_bind:bad derived class" - gen_list (getUnique clas) - - gen_list = [(eqClassKey, no_aux_binds gen_Eq_binds) - ,(ordClassKey, no_aux_binds gen_Ord_binds) - ,(enumClassKey, no_aux_binds gen_Enum_binds) - ,(boundedClassKey, no_aux_binds gen_Bounded_binds) - ,(ixClassKey, no_aux_binds gen_Ix_binds) - ,(showClassKey, no_aux_binds (gen_Show_binds fix_env)) - ,(readClassKey, no_aux_binds (gen_Read_binds fix_env)) - ,(typeableClassKey,no_aux_binds gen_Typeable_binds) - ,(dataClassKey, gen_Data_binds fix_env) - ] - - -- Used for generators that don't need to produce - -- any auxiliary bindings - no_aux_binds f tc = (f tc, EmptyMonoBinds) + (tyvars,_,clas,[ty]) = tcSplitDFunTy (idType dfun) + clas_nm = className clas + tycon = tcTyConAppTyCon ty + (meth_binds, aux_binds) = assoc "gen_bind:bad derived class" + gen_list (getUnique clas) fix_env tycon in - returnM (dfun, gen_binds_fn tycon) + -- Rename the auxiliary bindings (if any) + rnTopMonoBinds aux_binds [] `thenM` \ (rn_aux_binds, _dus) -> + + -- Bring the right type variables into + -- scope, and rename the method binds + bindLocalNames (map varName tyvars) $ + rnMethodBinds clas_nm [] meth_binds `thenM` \ (rn_meth_binds, _fvs) -> + + -- Build the InstInfo + returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, + rn_aux_binds) + +gen_list :: [(Unique, FixityEnv -> TyCon -> (RdrNameMonoBinds, RdrNameMonoBinds))] +gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds)) + ,(ordClassKey, no_aux_binds (ignore_fix_env gen_Ord_binds)) + ,(enumClassKey, no_aux_binds (ignore_fix_env gen_Enum_binds)) + ,(boundedClassKey, no_aux_binds (ignore_fix_env gen_Bounded_binds)) + ,(ixClassKey, no_aux_binds (ignore_fix_env gen_Ix_binds)) + ,(typeableClassKey,no_aux_binds (ignore_fix_env gen_Typeable_binds)) + ,(showClassKey, no_aux_binds gen_Show_binds) + ,(readClassKey, no_aux_binds gen_Read_binds) + ,(dataClassKey, gen_Data_binds) + ] + + -- no_aux_binds is used for generators that don't + -- need to produce any auxiliary bindings +no_aux_binds f fix_env tc = (f fix_env tc, EmptyMonoBinds) +ignore_fix_env f fix_env tc = f tc \end{code} @@ -829,14 +818,11 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -gen_taggery_Names :: [DFunId] - -> TcM [(RdrName, -- for an assoc list - TyCon, -- related tycon - TagThingWanted)] - -gen_taggery_Names dfuns - = foldlM do_con2tag [] tycons_of_interest `thenM` \ names_so_far -> - foldlM do_tag2con names_so_far tycons_of_interest +genTaggeryBinds :: [DFunId] -> TcM RdrNameMonoBinds +genTaggeryBinds dfuns + = do { names_so_far <- foldlM do_con2tag [] tycons_of_interest + ; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest + ; return (andMonoBindList (map gen_tag_n_con_monobind nm_alist_etc)) } where all_CTs = map simpleDFunClassTyCon dfuns all_tycons = map snd all_CTs diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5360887b78..21fecddae5 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -1,9 +1,8 @@ \begin{code} module TcEnv( - TyThing(..), TyThingDetails(..), TcTyThing(..), TcId, + TyThing(..), TcTyThing(..), TcId, -- Instance environment, and InstInfo type - tcGetInstEnv, InstInfo(..), pprInstInfo, pprInstInfoDetails, simpleInstInfoTy, simpleInstInfoTyCon, InstBindings(..), @@ -11,21 +10,20 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, - tcExtendGlobalTypeEnv, - tcLookupTyCon, tcLookupClass, tcLookupDataCon, - tcLookupGlobal_maybe, tcLookupGlobal, tcLookupGlobalId, + tcLookupGlobal, + tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon, + getInGlobalScope, -- Local environment - tcExtendKindEnv, + tcExtendTyVarKindEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendLocalValEnv, tcExtendLocalValEnv2, - tcLookup, tcLookupLocalIds, tcLookup_maybe, - tcLookupId, + tcLookup, tcLookupLocalIds, + tcLookupId, tcLookupTyVar, lclEnvElts, getInLocalScope, findGlobals, - -- Instance environment - tcExtendLocalInstEnv, tcExtendInstEnv, tcExtendTempInstEnv, tcWithTempInstEnv, + tcExtendRecEnv, -- For knot-tying -- Rules tcExtendRules, @@ -41,298 +39,121 @@ module TcEnv( checkProcLevel, -- New Ids - newLocalName, newDFunName, - - -- Misc - isLocalThing + newLocalName, newDFunName ) where #include "HsVersions.h" import RnHsSyn ( RenamedMonoBinds, RenamedSig ) -import HsSyn ( RuleDecl(..), ifaceRuleDeclName ) +import HsSyn ( RuleDecl(..), , HsTyVarBndr(..) ) +import TcIface ( tcImportDecl ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV ) -import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, +import TcType ( Type, TcTyVar, TcTyVarSet, tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp, getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo, tidyOpenType, tidyOpenTyVar ) import qualified Type ( getTyVar_maybe ) -import Rules ( extendRuleBase ) import Id ( idName, isLocalId ) -import Var ( TyVar, Id, idType ) +import Var ( TyVar, Id, mkTyVar, idType ) import VarSet import VarEnv -import CoreSyn ( IdCoreRule ) import DataCon ( DataCon ) -import TyCon ( TyCon, DataConDetails ) -import Class ( Class, ClassOpItem ) +import TyCon ( TyCon ) +import Class ( Class ) import Name ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom ) import NameEnv import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( DFunId, TypeEnv, extendTypeEnvList, lookupType, - TyThing(..), ExternalPackageState(..) ) -import Rules ( RuleBase ) -import BasicTypes ( EP ) -import Module ( Module ) -import InstEnv ( InstEnv, extendInstEnv ) +import HscTypes ( DFunId, extendTypeEnvList, lookupType, + TyThing(..), tyThingId, tyThingTyCon, tyThingClass, tyThingDataCon, + ExternalPackageState(..) ) + import SrcLoc ( SrcLoc ) import Outputable import Maybe ( isJust ) -import List ( partition ) \end{code} %************************************************************************ %* * - Arrow notation proc levels +%* tcLookupGlobal * %* * %************************************************************************ \begin{code} -checkProcLevel :: TcId -> ProcLevel -> TcM () -checkProcLevel id id_lvl - = do { banned <- getBannedProcLevels - ; checkTc (not (id_lvl `elem` banned)) - (procLevelErr id id_lvl) } - -procLevelErr id id_lvl - = hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here")) - 4 (ptext SLIT("Reason: it is used in the left argument of (-<)")) +tcLookupGlobal :: Name -> TcM TyThing +-- c.f. IfaceEnvEnv.tcIfaceGlobal +tcLookupGlobal name + = do { env <- getGblEnv + ; if nameIsLocalOrFrom (tcg_mod env) name + + then -- It's defined in this module + case lookupNameEnv (tcg_type_env env) name of + Just thing -> return thing + Nothing -> notFound "tcLookupGlobal" name + + else do -- It's imported + { eps <- getEps + ; hpt <- getHpt + ; case lookupType hpt (eps_PTE eps) name of + Just thing -> return thing + Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name) + ; initIfaceTcRn (tcImportDecl name) } + }} \end{code} - - -%************************************************************************ -%* * - Meta level -%* * -%************************************************************************ \begin{code} -instance Outputable ThStage where - ppr Comp = text "Comp" - ppr (Brack l _ _) = text "Brack" <+> int l - ppr (Splice l) = text "Splice" <+> int l - - -thLevel :: ThStage -> ThLevel -thLevel Comp = topLevel -thLevel (Splice l) = l -thLevel (Brack l _ _) = l - - -checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level - -> ThStage -- Use stage - -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_stage - | bind_lvl <= use_lvl -- OK! - = returnM () - - | bind_lvl == topLevel -- GHC restriction on top level splices - = failWithTc $ - sep [ptext SLIT("GHC stage restriction:") <+> pp_thing, - nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))] - - | otherwise -- Badly staged - = failWithTc $ - ptext SLIT("Stage error:") <+> pp_thing <+> - hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, - ptext SLIT("but used at stage") <+> ppr use_lvl] - where - use_lvl = thLevel use_stage - - -topIdLvl :: Id -> ThLevel --- Globals may either be imported, or may be from an earlier "chunk" --- (separated by declaration splices) of this module. The former --- *can* be used inside a top-level splice, but the latter cannot. --- Hence we give the former impLevel, but the latter topLevel --- E.g. this is bad: --- x = [| foo |] --- $( f x ) --- By the time we are prcessing the $(f x), the binding for "x" --- will be in the global env, not the local one. -topIdLvl id | isLocalId id = topLevel - | otherwise = impLevel - --- Indicates the legal transitions on bracket( [| |] ). -bracketOK :: ThStage -> Maybe ThLevel -bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket -bracketOK stage = (Just (thLevel stage + 1)) - --- Indicates the legal transitions on splice($). -spliceOK :: ThStage -> Maybe ThLevel -spliceOK (Splice _) = Nothing -- Splice illegal inside splice -spliceOK stage = Just (thLevel stage - 1) - -tcMetaTy :: Name -> TcM Type --- Given the name of a Template Haskell data type, --- return the type --- E.g. given the name "Expr" return the type "Expr" -tcMetaTy tc_name - = tcLookupTyCon tc_name `thenM` \ t -> - returnM (mkGenTyConApp t []) - -- Use mkGenTyConApp because it might be a synonym -\end{code} - - -%************************************************************************ -%* * -\subsection{TyThingDetails} -%* * -%************************************************************************ +tcLookupGlobalId :: Name -> TcM Id +-- Never used for Haskell-source DataCons, hence no ADataCon case +tcLookupGlobalId name + = tcLookupGlobal name `thenM` \ thing -> + return (tyThingId thing) -This data type is used to help tie the knot - when type checking type and class declarations +tcLookupDataCon :: Name -> TcM DataCon +tcLookupDataCon con_name + = tcLookupGlobal con_name `thenM` \ thing -> + return (tyThingDataCon thing) -\begin{code} -data TyThingDetails = SynTyDetails Type - | DataTyDetails ThetaType (DataConDetails DataCon) [Id] (Maybe (EP Id)) - | ClassDetails ThetaType [Id] [ClassOpItem] DataCon Name - -- The Name is the Name of the implicit TyCon for the class - | ForeignTyDetails -- Nothing yet +tcLookupClass :: Name -> TcM Class +tcLookupClass name + = tcLookupGlobal name `thenM` \ thing -> + return (tyThingClass thing) + +tcLookupTyCon :: Name -> TcM TyCon +tcLookupTyCon name + = tcLookupGlobal name `thenM` \ thing -> + return (tyThingTyCon thing) \end{code} - %************************************************************************ %* * -\subsection{Making new Ids} + Extending the global environment %* * %************************************************************************ -Constructing new Ids - -\begin{code} -newLocalName :: Name -> TcM Name -newLocalName name -- Make a clone - = newUnique `thenM` \ uniq -> - returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) -\end{code} - -Make a name for the dict fun for an instance decl. It's a *local* -name for the moment. The CoreTidy pass will externalise it. Even in ---make and ghci stuff, we rebuild the instance environment each time, -so the dfun id is internal to begin with, and external when compiling -other modules - -\begin{code} -newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name -newDFunName clas (ty:_) loc - = newUnique `thenM` \ uniq -> - returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc) - where - -- Any string that is somewhat unique will do - dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) - -newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) -\end{code} - -\begin{code} -isLocalThing :: NamedThing a => Module -> a -> Bool -isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing) -\end{code} - -%************************************************************************ -%* * -\subsection{The global environment} -%* * -%************************************************************************ \begin{code} tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, perhaps from the - -- module being compiled, perhaps from a package module, - -- extend the global environment, and update the EPS + -- Given a mixture of Ids, TyCons, Classes, all from the + -- module being compiled, extend the global environment tcExtendGlobalEnv things thing_inside - = do { eps <- getEps - ; hpt <- getHpt - ; env <- getGblEnv - ; let mod = tcg_mod env - (lcl_things, pkg_things) = partition (isLocalThing mod) things - ge' = extendTypeEnvList (tcg_type_env env) lcl_things - eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things } - ; setEps eps' + = do { env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env env) things ; setGblEnv (env {tcg_type_env = ge'}) thing_inside } tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside - -tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r - -- Top-level things of the interactive context - -- No need to extend the package env -tcExtendGlobalTypeEnv extra_env thing_inside - = do { env <- getGblEnv - ; let ge' = tcg_type_env env `plusNameEnv` extra_env - ; setGblEnv (env {tcg_type_env = ge'}) thing_inside } -\end{code} - - -\begin{code} -tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing) --- This is a rather heavily-used function, so I've inlined a few things (e.g. getEps) --- Notice that for imported things we read the current version from the EPS --- mutable variable. This is important in situations like --- ...$(e1)...$(e2)... --- where the code that e1 expands to might import some defns that --- also turn out to be needed by the code that e2 expands to. -tcLookupGlobal_maybe name - = do { env <- getGblEnv - ; if nameIsLocalOrFrom (tcg_mod env) name then - -- Defined in this module - return (lookupNameEnv (tcg_type_env env) name) - else - do { env <- getTopEnv - ; eps <- readMutVar (top_eps env) - ; return (lookupType (top_hpt env) (eps_PTE eps) name) }} \end{code} A variety of global lookups, when we know what we are looking for. \begin{code} -tcLookupGlobal :: Name -> TcM TyThing -tcLookupGlobal name - = tcLookupGlobal_maybe name `thenM` \ maybe_thing -> - case maybe_thing of - Just thing -> returnM thing - other -> notFound "tcLookupGlobal" name - -tcLookupGlobalId :: Name -> TcM Id --- Never used for Haskell-source DataCons, hence no ADataCon case -tcLookupGlobalId name - = tcLookupGlobal_maybe name `thenM` \ maybe_thing -> - case maybe_thing of - Just (AnId id) -> returnM id - other -> notFound "tcLookupGlobal (id)" name - -tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon con_name - = tcLookupGlobal_maybe con_name `thenM` \ maybe_thing -> - case maybe_thing of - Just (ADataCon data_con) -> returnM data_con - other -> notFound "tcLookupDataCon" con_name - -tcLookupClass :: Name -> TcM Class -tcLookupClass name - = tcLookupGlobal_maybe name `thenM` \ maybe_clas -> - case maybe_clas of - Just (AClass clas) -> returnM clas - other -> notFound "tcLookupClass" name - -tcLookupTyCon :: Name -> TcM TyCon -tcLookupTyCon name - = tcLookupGlobal_maybe name `thenM` \ maybe_tc -> - case maybe_tc of - Just (ATyCon tc) -> returnM tc - other -> notFound "tcLookupTyCon" name - - -getInGlobalScope :: TcRn m (Name -> Bool) +getInGlobalScope :: TcM (Name -> Bool) -- Get all things in the global environment; used for deciding what -- rules to suck in. Anything defined in this module (nameIsLocalOrFrom) -- is certainly in the envt, so we don't bother to look. @@ -345,6 +166,20 @@ getInGlobalScope \end{code} +\begin{code} +tcExtendRecEnv :: [(Name,TyThing)] -- Global bindings + -> [(Name,TcTyThing)] -- Local bindings + -> TcM r -> TcM r +-- Extend both local and global environments for the type/class knot tying game +tcExtendRecEnv gbl_stuff lcl_stuff thing_inside + = do { (gbl_env, lcl_env) <- getEnvs + ; let { ge' = extendNameEnvList (tcg_type_env gbl_env) gbl_stuff + ; le' = extendNameEnvList (tcl_env lcl_env) lcl_stuff } + ; setEnvs (gbl_env {tcg_type_env = ge'}, lcl_env {tcl_env = le'}) + thing_inside } +\end{code} + + %************************************************************************ %* * \subsection{The local environment} @@ -352,23 +187,20 @@ getInGlobalScope %************************************************************************ \begin{code} -tcLookup_maybe :: Name -> TcM (Maybe TcTyThing) -tcLookup_maybe name - = getLclEnv `thenM` \ local_env -> - case lookupNameEnv (tcl_env local_env) name of - Just thing -> returnM (Just thing) - Nothing -> tcLookupGlobal_maybe name `thenM` \ mb_res -> - returnM (case mb_res of - Just thing -> Just (AGlobal thing) - Nothing -> Nothing) - tcLookup :: Name -> TcM TcTyThing tcLookup name - = tcLookup_maybe name `thenM` \ maybe_thing -> - case maybe_thing of + = getLclEnv `thenM` \ local_env -> + case lookupNameEnv (tcl_env local_env) name of Just thing -> returnM thing - other -> notFound "tcLookup" name - -- Extract the IdInfo from an IfaceSig imported from an interface file + Nothing -> tcLookupGlobal name `thenM` \ thing -> + returnM (AGlobal thing) + +tcLookupTyVar :: Name -> TcM Id +tcLookupTyVar name + = tcLookup name `thenM` \ thing -> + case thing of + ATyVar tv -> returnM tv + other -> pprPanic "tcLookupTyVar" (ppr name) tcLookupId :: Name -> TcM Id -- Used when we aren't interested in the binding level @@ -405,14 +237,16 @@ getInLocalScope = getLclEnv `thenM` \ env -> \end{code} \begin{code} -tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r -tcExtendKindEnv pairs thing_inside +tcExtendTyVarKindEnv :: [HsTyVarBndr Name] -> TcM r -> TcM r +-- The tyvars are all kinded +tcExtendTyVarKindEnv tvs thing_inside = updLclEnv upd thing_inside where upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- pairs] + extend env = extendNameEnvList env [(n, ATyVar (mkTyVar n k)) + | KindedTyVar n k <- tvs] -- No need to extend global tyvars for kind checking - + tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside @@ -431,7 +265,7 @@ tc_extend_tv_env binds tyvars thing_inside in -- It's important to add the in-scope tyvars to the global tyvar set -- as well. Consider - -- f (x::r) = let g y = y::r in ... + -- f (_::r) = let g y = y::r in ... -- Here, g mustn't be generalised. This is also important during -- class and instance decls, when we mustn't generalise the class tyvars -- when typechecking the methods. @@ -477,8 +311,8 @@ tcExtendLocalValEnv2 names_w_ids thing_inside -- We must be careful to pass it a zonked type variable, too. findGlobals :: TcTyVarSet - -> TidyEnv - -> TcM (TidyEnv, [SDoc]) + -> TidyEnv + -> TcM (TidyEnv, [SDoc]) findGlobals tvs tidy_env = getLclEnv `thenM` \ lcl_env -> @@ -515,8 +349,9 @@ find_thing ignore_it tidy_env (ATyVar tv) (tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at] - eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty - | otherwise = equals <+> ppr tv_ty + eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, + tv == tv' = empty + | otherwise = equals <+> ppr tidy_ty -- It's ok to use Type.getTyVar_maybe because ty is zonked by now bound_at = tyVarBindingInfo tv @@ -554,132 +389,149 @@ tcGetGlobalTyVars %************************************************************************ %* * -\subsection{The instance environment} +\subsection{Rules} %* * %************************************************************************ -The TcGblEnv holds a mutable variable containing the current full, instance environment. -The ExtendInstEnv functions extend this environment by side effect, in case we are -sucking in new instance declarations deep in the body of a TH splice, which are needed -in another TH splice. The tcg_insts field of the TcGblEnv contains just the dfuns -from this module - \begin{code} -tcGetInstEnv :: TcM InstEnv -tcGetInstEnv = do { env <- getGblEnv; readMutVar (tcg_inst_env env) } - -tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a - -- Add instances from local or imported - -- instances, and refresh the instance-env cache -tcExtendInstEnv dfuns thing_inside - = do { dflags <- getDOpts - ; eps <- getEps - ; env <- getGblEnv - ; let ie_var = tcg_inst_env env - ; inst_env <- readMutVar ie_var +tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a + -- Just pop the new rules into the EPS and envt resp + -- All the rules come from an interface file, not soruce + -- Nevertheless, some may be for this module, if we read + -- its interface instead of its source code +tcExtendRules lcl_rules thing_inside + = do { env <- getGblEnv ; let - -- Extend the total inst-env with the new dfuns - (inst_env', errs) = extendInstEnv dflags inst_env dfuns - - -- Sort the ones from this module from the others - (lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns - mod = tcg_mod env - - -- And add the pieces to the right places - (eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns - eps' = eps { eps_inst_env = eps_inst_env' } - - env' = env { tcg_insts = lcl_dfuns ++ tcg_insts env } - - ; traceDFuns dfuns - ; addErrs errs - ; writeMutVar ie_var inst_env' - ; setEps eps' + env' = env { tcg_rules = lcl_rules ++ tcg_rules env } ; setGblEnv env' thing_inside } +\end{code} -tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a - -- Special case for local instance decls -tcExtendLocalInstEnv infos thing_inside - = do { dflags <- getDOpts - ; env <- getGblEnv - ; let ie_var = tcg_inst_env env - ; inst_env <- readMutVar ie_var - ; let - dfuns = map iDFunId infos - (inst_env', errs) = extendInstEnv dflags inst_env dfuns - env' = env { tcg_insts = dfuns ++ tcg_insts env } - ; traceDFuns dfuns - ; addErrs errs - ; writeMutVar ie_var inst_env' - ; setGblEnv env' thing_inside } -tcExtendTempInstEnv :: [DFunId] -> TcM a -> TcM a - -- Extend the instance envt, but with *no* permanent - -- effect on mutable variables; also ignore errors - -- Used during 'deriving' stuff -tcExtendTempInstEnv dfuns thing_inside - = do { dflags <- getDOpts - ; env <- getGblEnv - ; let ie_var = tcg_inst_env env - ; inst_env <- readMutVar ie_var - ; let (inst_env', errs) = extendInstEnv dflags inst_env dfuns - -- Ignore the errors about duplicate instances. - -- We don't want repeated error messages - -- They'll appear later, when we do the top-level extendInstEnvs - ; writeMutVar ie_var inst_env' - ; result <- thing_inside - ; writeMutVar ie_var inst_env -- Restore! - ; return result } - -tcWithTempInstEnv :: TcM a -> TcM a --- Run thing_inside, discarding any effects on the instance environment -tcWithTempInstEnv thing_inside - = do { env <- getGblEnv - ; let ie_var = tcg_inst_env env - ; old_ie <- readMutVar ie_var - ; result <- thing_inside - ; writeMutVar ie_var old_ie -- Restore - ; return result } - -traceDFuns dfuns - = traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) +%************************************************************************ +%* * + Arrow notation proc levels +%* * +%************************************************************************ + +\begin{code} +checkProcLevel :: TcId -> ProcLevel -> TcM () +checkProcLevel id id_lvl + = do { banned <- getBannedProcLevels + ; checkTc (not (id_lvl `elem` banned)) + (procLevelErr id id_lvl) } + +procLevelErr id id_lvl + = hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here")) + 4 (ptext SLIT("Reason: it is used in the left argument of (-<)")) +\end{code} + + +%************************************************************************ +%* * + Meta level +%* * +%************************************************************************ + +\begin{code} +instance Outputable ThStage where + ppr Comp = text "Comp" + ppr (Brack l _ _) = text "Brack" <+> int l + ppr (Splice l) = text "Splice" <+> int l + + +thLevel :: ThStage -> ThLevel +thLevel Comp = topLevel +thLevel (Splice l) = l +thLevel (Brack l _ _) = l + + +checkWellStaged :: SDoc -- What the stage check is for + -> ThLevel -- Binding level + -> ThStage -- Use stage + -> TcM () -- Fail if badly staged, adding an error +checkWellStaged pp_thing bind_lvl use_stage + | bind_lvl <= use_lvl -- OK! + = returnM () + + | bind_lvl == topLevel -- GHC restriction on top level splices + = failWithTc $ + sep [ptext SLIT("GHC stage restriction:") <+> pp_thing, + nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))] + + | otherwise -- Badly staged + = failWithTc $ + ptext SLIT("Stage error:") <+> pp_thing <+> + hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, + ptext SLIT("but used at stage") <+> ppr use_lvl] where - pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) + use_lvl = thLevel use_stage + + +topIdLvl :: Id -> ThLevel +-- Globals may either be imported, or may be from an earlier "chunk" +-- (separated by declaration splices) of this module. The former +-- *can* be used inside a top-level splice, but the latter cannot. +-- Hence we give the former impLevel, but the latter topLevel +-- E.g. this is bad: +-- x = [| foo |] +-- $( f x ) +-- By the time we are prcessing the $(f x), the binding for "x" +-- will be in the global env, not the local one. +topIdLvl id | isLocalId id = topLevel + | otherwise = impLevel + +-- Indicates the legal transitions on bracket( [| |] ). +bracketOK :: ThStage -> Maybe ThLevel +bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket +bracketOK stage = (Just (thLevel stage + 1)) + +-- Indicates the legal transitions on splice($). +spliceOK :: ThStage -> Maybe ThLevel +spliceOK (Splice _) = Nothing -- Splice illegal inside splice +spliceOK stage = Just (thLevel stage - 1) + +tcMetaTy :: Name -> TcM Type +-- Given the name of a Template Haskell data type, +-- return the type +-- E.g. given the name "Expr" return the type "Expr" +tcMetaTy tc_name + = tcLookupTyCon tc_name `thenM` \ t -> + returnM (mkGenTyConApp t []) + -- Use mkGenTyConApp because it might be a synonym \end{code} %************************************************************************ %* * -\subsection{Rules} +\subsection{Making new Ids} %* * %************************************************************************ -\begin{code} -tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a - -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not soruce - -- Nevertheless, some may be for this module, if we read - -- its interface instead of its source code -tcExtendRules rules thing_inside - = do { eps <- getEps - ; env <- getGblEnv - ; let - (lcl_rules, pkg_rules) = partition is_local_rule rules - is_local_rule = isLocalThing mod . ifaceRuleDeclName - mod = tcg_mod env +Constructing new Ids - core_rules = [(id,rule) | IfaceRuleOut id rule <- pkg_rules] - eps' = eps { eps_rule_base = addIfaceRules (eps_rule_base eps) core_rules } - -- All the rules from an interface are of the IfaceRuleOut form +\begin{code} +newLocalName :: Name -> TcM Name +newLocalName name -- Make a clone + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) +\end{code} - env' = env { tcg_rules = lcl_rules ++ tcg_rules env } +Make a name for the dict fun for an instance decl. It's a *local* +name for the moment. The CoreTidy pass will externalise it. Even in +--make and ghci stuff, we rebuild the instance environment each time, +so the dfun id is internal to begin with, and external when compiling +other modules - ; setEps eps' - ; setGblEnv env' thing_inside } +\begin{code} +newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name +newDFunName clas (ty:_) loc + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc) + where + -- Any string that is somewhat unique will do + dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) -addIfaceRules :: RuleBase -> [IdCoreRule] -> RuleBase -addIfaceRules rule_base rules - = foldl extendRuleBase rule_base rules +newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} @@ -741,8 +593,6 @@ simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) %************************************************************************ \begin{code} -badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor") - notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> ptext SLIT("is not in scope")) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 096efb4353..562510e847 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -11,16 +11,16 @@ module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import HsSyn ( HsReify(..), ReifyFlavour(..) ) +import Id ( Id ) import TcType ( isTauTy ) -import TcEnv ( bracketOK, tcMetaTy, checkWellStaged ) -import Name ( isExternalName ) +import TcEnv ( tcMetaTy, checkWellStaged ) import qualified DsMeta #endif import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields, HsMatchContext(..) ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) ) +import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, (<$>) ) import TcRnMonad import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy ) @@ -31,25 +31,24 @@ import Inst ( InstOrigin(..), instToId, tcInstCall, tcInstDataCon ) import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookup, - tcLookupTyCon, tcLookupDataCon, tcLookupId, checkProcLevel +import TcEnv ( tcLookup, tcLookupGlobalId, + tcLookupDataCon, tcLookupId, checkProcLevel ) import TcArrows ( tcProc ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( badFieldCon ) -import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, newTyVarTys, zonkTcType ) +import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, zonkTcType ) import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, isSigmaTy, mkFunTy, mkFunTys, - mkTyConApp, mkClassPred, - tyVarsOfTypes, isLinearPred, + mkTyConApp, tyVarsOfTypes, isLinearPred, liftedTypeKind, openTypeKind, tcSplitSigmaTy, tidyOpenType ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector ) -import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) import Name ( Name ) import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) @@ -57,8 +56,7 @@ import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy ) import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, - enumFromToPName, enumFromThenToPName, - ioTyConName + enumFromToPName, enumFromThenToPName ) import ListSetOps ( minusList ) import CmdLineOpts @@ -388,14 +386,14 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let field_names = recBindFields rbinds in - mappM tcLookupGlobal_maybe field_names `thenM` \ maybe_sel_ids -> + mappM tcLookupGlobalId field_names `thenM` \ sel_ids -> + -- The renamer has already checked that they + -- are all in scope let bad_guys = [ addErrTc (notSelector field_name) - | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, - not (is_selector maybe_sel_id) + | (field_name, sel_id) <- field_names `zip` sel_ids, + not (isRecordSelector sel_id) -- Excludes class ops ] - is_selector (Just (AnId sel_id)) = isRecordSelector sel_id -- Excludes class ops - is_selector other = False in checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_` @@ -403,7 +401,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- Figure out the tycon and data cons from the first field name let -- It's OK to use the non-tc splitters here (for a selector) - (Just (AnId sel_id) : _) = maybe_sel_ids + sel_id : _ = sel_ids field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if tycon = fieldLabelTyCon field_lbl -- it's not a field label data_cons = tyConDataCons tycon @@ -731,15 +729,15 @@ tcId name -- Look up the Id and instantiate its type = -- First check whether it's a DataCon -- Reason: we must not forget to chuck in the -- constraints from their "silly context" - tcLookup name `thenM` \ maybe_thing -> - case maybe_thing of { + tcLookup name `thenM` \ thing -> + case thing of { AGlobal (ADataCon data_con) -> inst_data_con data_con ; AGlobal (AnId id) -> loop (HsVar id) (idType id) -- A global cannot possibly be ill-staged -- nor does it need the 'lifting' treatment ; ATcId id th_level proc_level -> tc_local_id id th_level proc_level - ; other -> pprPanic "tcId" (ppr name) + ; other -> pprPanic "tcId" (ppr name $$ ppr thing) } where @@ -931,10 +929,7 @@ checkMissingFields data_con rbinds field_labels field_strs - field_strs = dropList ex_theta (dataConStrictMarks data_con) - -- The 'drop' is because dataConStrictMarks - -- includes the existential dictionaries - (_, _, _, ex_theta, _, _) = dataConSig data_con + field_strs = dataConStrictMarks data_con \end{code} %************************************************************************ @@ -1019,11 +1014,6 @@ appCtxt fun args where the_app = foldl HsApp fun args -- Used in error messages -lurkingRank2Err fun fun_ty - = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)]) - 4 (vcat [ptext SLIT("It is applied to too few arguments"), - ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty]) - badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) 4 (pprQuotedList (recBindFields rbinds)) @@ -1050,10 +1040,6 @@ missingFields con fields = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") <+> pprWithCommas ppr fields -polySpliceErr :: Id -> SDoc -polySpliceErr id - = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) - wrongArgsCtxt too_many_or_few fun args = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun) <+> ptext SLIT("is applied to") <+> text too_many_or_few @@ -1061,4 +1047,10 @@ wrongArgsCtxt too_many_or_few fun args 4 (parens (ppr the_app)) where the_app = foldl HsApp fun args -- Used in error messages + +#ifdef GHCI +polySpliceErr :: Id -> SDoc +polySpliceErr id + = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) +#endif \end{code} diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 04e6ce4709..3b880c0c61 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -27,7 +27,7 @@ import HsSyn ( ForeignDecl(..), HsExpr(..), import RnHsSyn ( RenamedForeignDecl ) import TcRnMonad -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl ) import TcExpr ( tcCheckSigma ) @@ -225,7 +225,8 @@ tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = newUnique `thenM` \ uniq -> getModule `thenM` \ mod -> let - gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc + gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) + Nothing src_loc id = setIdLocalExported (mkLocalId gnm sig_ty) bind = VarMonoBind id rhs in @@ -291,9 +292,6 @@ checkDotnet _ = Just (text "requires C code generation (-fvia-C)") checkDotnet other = Just (text "requires .NET support (-filx or win32)") #endif -checkC HscC = Nothing -checkC other = Just (text "requires C code generation (-fvia-C)") - checkCOrAsm HscC = Nothing checkCOrAsm HscAsm = Nothing checkCOrAsm other @@ -305,12 +303,6 @@ checkCOrAsmOrInterp HscInterpreted = Nothing checkCOrAsmOrInterp other = Just (text "requires interpreted, C or native code generation") -checkCOrAsmOrDotNet HscC = Nothing -checkCOrAsmOrDotNet HscAsm = Nothing -checkCOrAsmOrDotNet HscILX = Nothing -checkCOrAsmOrDotNet other - = Just (text "requires C, native or .NET ILX code generation") - checkCOrAsmOrDotNetOrInterp HscC = Nothing checkCOrAsmOrDotNetOrInterp HscAsm = Nothing checkCOrAsmOrDotNetOrInterp HscILX = Nothing diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 210710ed30..9cef7b8211 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -28,42 +28,38 @@ module TcGenDeriv ( #include "HsVersions.h" -import HsSyn ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..), - Match(..), GRHSs(..), Stmt(..), HsLit(..), - HsBinds(..), HsType(..), HsStmtContext(..), - unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType - ) -import RdrName ( RdrName, mkUnqual, mkRdrUnqual, nameRdrName, getRdrName ) +import HsSyn +import RdrName ( RdrName, mkVarUnqual, mkRdrUnqual, getRdrName, mkDerivedRdrName ) import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo ) -import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) - , maxPrecedence - , Boxity(..) - ) +import BasicTypes ( RecFlag(..), Fixity(..), maxPrecedence, Boxity(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, dataConOrigArgTys, dataConSourceArity, fIRST_TAG, - DataCon, + DataCon, dataConName, dataConFieldLabels ) import Name ( getOccString, getOccName, getSrcLoc, occNameString, - occNameUserString, varName, + occNameUserString, Name, NamedThing(..), isDataSymOcc, isSymOcc ) import HscTypes ( FixityEnv, lookupFixity ) -import PrelNames -- Lots of Names -import PrimOp -- Lots of Names +import PrelInfo +import PrelNames +import TysWiredIn +import MkId ( eRROR_ID ) +import PrimOp ( PrimOp(..) ) import SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, - maybeTyConSingleCon, tyConFamilySize, tyConTyVars + maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName ) import TcType ( isUnLiftedType, tcEqType, Type ) -import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) -import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, wordDataCon ) +import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, + intPrimTyCon ) +import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon ) import Util ( zipWithEqual, isSingleton, zipWith3Equal, nOfThem, zipEqual ) -import Panic ( panic, assertPanic ) -import Char ( ord, isAlpha ) +import Char ( isAlpha ) import Constants import List ( partition, intersperse ) import Outputable @@ -423,10 +419,10 @@ gen_Enum_binds tycon = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon), - mkHsVarApps mkInt_RDR [ah_RDR]]) + mkHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") (HsApp (HsVar (tag2con_RDR tycon)) - (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR], + (mkHsApps plus_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], mkHsIntLit 1])) tycon_loc @@ -434,10 +430,10 @@ gen_Enum_binds tycon = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ HsIf (mkHsApps eq_RDR [mkHsIntLit 0, - mkHsVarApps mkInt_RDR [ah_RDR]]) + mkHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") (HsApp (HsVar (tag2con_RDR tycon)) - (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR], + (mkHsApps plus_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], HsLit (HsInt (-1))])) tycon_loc @@ -456,7 +452,7 @@ gen_Enum_binds tycon mkHsApps map_RDR [HsVar (tag2con_RDR tycon), HsPar (enum_from_to_Expr - (mkHsVarApps mkInt_RDR [ah_RDR]) + (mkHsVarApps intDataCon_RDR [ah_RDR]) (HsVar (maxtag_RDR tycon)))] enum_from_then @@ -464,10 +460,10 @@ gen_Enum_binds tycon untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $ HsPar (enum_from_then_to_Expr - (mkHsVarApps mkInt_RDR [ah_RDR]) - (mkHsVarApps mkInt_RDR [bh_RDR]) - (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR], - mkHsVarApps mkInt_RDR [bh_RDR]]) + (mkHsVarApps intDataCon_RDR [ah_RDR]) + (mkHsVarApps intDataCon_RDR [bh_RDR]) + (HsIf (mkHsApps gt_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], + mkHsVarApps intDataCon_RDR [bh_RDR]]) (mkHsIntLit 0) (HsVar (maxtag_RDR tycon)) tycon_loc)) @@ -475,7 +471,7 @@ gen_Enum_binds tycon from_enum = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ - (mkHsVarApps mkInt_RDR [ah_RDR]) + (mkHsVarApps intDataCon_RDR [ah_RDR]) \end{code} %************************************************************************ @@ -593,8 +589,8 @@ gen_Ix_binds tycon untag_Expr tycon [(b_RDR, bh_RDR)] $ HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $ HsPar (enum_from_to_Expr - (mkHsVarApps mkInt_RDR [ah_RDR]) - (mkHsVarApps mkInt_RDR [bh_RDR])) + (mkHsVarApps intDataCon_RDR [ah_RDR]) + (mkHsVarApps intDataCon_RDR [bh_RDR])) enum_index = mk_easy_FunMonoBind tycon_loc index_RDR @@ -604,11 +600,11 @@ gen_Ix_binds tycon untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( let - rhs = mkHsVarApps mkInt_RDR [c_RDR] + rhs = mkHsVarApps intDataCon_RDR [c_RDR] in HsCase (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR)) - [mk_triv_Match (VarPat c_RDR) rhs] + [mkSimpleHsAlt (VarPat c_RDR) rhs] tycon_loc )) ) {-else-} ( @@ -808,9 +804,7 @@ gen_Read_binds get_fixity tycon field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed con_arity = dataConSourceArity data_con - nullary_con = con_arity == 0 labels = dataConFieldLabels data_con - lab_fields = length labels dc_nm = getName data_con is_infix = isDataSymOcc (getOccName dc_nm) as_needed = take con_arity as_RDRs @@ -985,13 +979,6 @@ getPrecedence :: FixityEnv -> Name -> Integer getPrecedence get_fixity nm = case lookupFixity get_fixity nm of Fixity x _ -> fromIntegral x - -isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) -isLRAssoc get_fixity nm = - case lookupFixity get_fixity nm of - Fixity _ InfixN -> (False, False) - Fixity _ InfixR -> (False, True) - Fixity _ InfixL -> (True, False) \end{code} @@ -1072,6 +1059,7 @@ gen_Data_binds fix_env tycon datatype_bind `AndMonoBinds` andMonoBindList (map mk_con_bind data_cons)) where tycon_loc = getSrcLoc tycon + tycon_name = tyConName tycon data_cons = tyConDataCons tycon ------------ gfoldl @@ -1088,27 +1076,29 @@ gen_Data_binds fix_env tycon fromCon_bind = mk_FunMonoBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)] from_con_rhs = HsCase (HsVar conIndex_RDR `HsApp` c_Expr) (map from_con_alt data_cons) tycon_loc - from_con_alt dc = mk_triv_Match (ConPatIn mkInt_RDR (PrefixCon [LitPat (HsIntPrim (toInteger (dataConTag dc)))])) + from_con_alt dc = mkSimpleHsAlt (ConPatIn intDataCon_RDR (PrefixCon [LitPat (HsIntPrim (toInteger (dataConTag dc)))])) (mkHsVarApps (getRdrName dc) (replicate (dataConSourceArity dc) undefined_RDR)) ------------ toConstr toCon_bind = mk_FunMonoBind tycon_loc toConstr_RDR (map to_con_eqn data_cons) - to_con_eqn dc = ([mkWildConPat dc], HsVar (mkConstrName dc)) + to_con_eqn dc = ([mkWildConPat dc], HsVar (mk_constr_name dc)) ------------ dataTypeOf dataTypeOf_bind = mk_easy_FunMonoBind tycon_loc dataTypeOf_RDR [wildPat] [] (HsVar data_type_name) ------------ $dT - data_type_name = mkDataTypeName tycon + data_type_name = mkDerivedRdrName tycon_name mkDataTOcc datatype_bind = mkVarMonoBind tycon_loc data_type_name (HsVar mkDataType_RDR `HsApp` ExplicitList placeHolderType constrs) - constrs = [HsVar (mkConstrName con) | con <- data_cons] + constrs = [HsVar (mk_constr_name con) | con <- data_cons] + ------------ $cT1 etc - mk_con_bind dc = mkVarMonoBind tycon_loc (mkConstrName dc) + mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc + mk_con_bind dc = mkVarMonoBind tycon_loc (mk_constr_name dc) (mkHsApps mkConstr_RDR (constr_args dc)) constr_args dc = [mkHsIntLit (toInteger (dataConTag dc)), -- Tag HsLit (mkHsString (occNameUserString dc_occ)), -- String name @@ -1128,17 +1118,6 @@ mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType") conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("conIndex") prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix") infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix") - -mkDataTypeName :: TyCon -> RdrName -- $tT -mkDataTypeName tc = mkRdrUnqual (mkDataTOcc (getOccName tc)) - -mkConstrName :: DataCon -> RdrName -- $cT1 -mkConstrName con = mkRdrUnqual (mkDataCOcc (getOccName con)) - - -apN :: Int -> (a -> a) -> a -> a -apN 0 k z = z -apN n k z = apN (n-1) k (k z) \end{code} %************************************************************************ @@ -1178,20 +1157,22 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) where loc = getSrcLoc tycon + tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon) + -- We can't use gerRdrName because that makes an Exact RdrName + -- and we can't put them in the LocalRdrEnv + -- Give a signature to the bound variable, so -- that the case expression generated by getTag is -- monomorphic. In the push-enter model we get better code. get_tag_rhs = ExprWithTySig - (HsLam (mk_match loc [VarPat a_RDR] - (HsApp getTag_Expr a_Expr) - EmptyBinds)) - (HsForAllTy Nothing [] con2tag_ty) - -- Nothing => implicit quantification + (HsLam (mkSimpleHsAlt (VarPat a_RDR) + (HsApp (HsVar getTag_RDR) a_Expr))) + (HsForAllTy (Just (map UserTyVar tvs)) [] con2tag_ty) con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon)) - [HsTyVar (getRdrName tv) | tv <- tyConTyVars tycon] + (map HsTyVar tvs) `HsFunTy` - HsTyVar (getRdrName intPrimTyConName) + HsTyVar (getRdrName intPrimTyCon) lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS @@ -1201,13 +1182,13 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) = mk_FunMonoBind (getSrcLoc tycon) rdr_name - [([mkConPat mkInt_RDR [a_RDR]], - ExprWithTySig (HsApp tagToEnum_Expr a_Expr) + [([mkConPat intDataCon_RDR [a_RDR]], + ExprWithTySig (HsApp (HsVar tagToEnum_RDR) a_Expr) (HsTyVar (getRdrName tycon)))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) = mkVarMonoBind (getSrcLoc tycon) rdr_name - (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag))) + (HsApp (HsVar intDataCon_RDR) (HsLit (HsIntPrim max_tag))) where max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) @@ -1251,8 +1232,6 @@ mk_easy_Match loc pats binds expr -- "recursive" MonoBinds, and it is its job to sort things out -- from there. -mk_triv_Match pat expr = mkSimpleMatch [pat] expr placeHolderType generatedSrcLoc - mk_FunMonoBind :: SrcLoc -> RdrName -> [([RdrNamePat], RdrNameHsExpr)] -> RdrNameMonoBinds @@ -1269,19 +1248,12 @@ mk_match loc pats expr binds where paren p@(VarPat _) = p paren other_p = ParPat other_p -\end{code} -\begin{code} -mkHsApps f xs = foldl HsApp (HsVar f) xs -mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs) - -mkHsIntLit n = HsLit (HsInt n) -mkHsString s = HsString (mkFastString s) -mkHsChar c = HsChar (ord c) +mkWildConPat :: DataCon -> Pat RdrName +mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat)) -mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars)) -mkNullaryConPat con = ConPatIn con (PrefixCon []) -mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat)) +wildPat :: Pat id +wildPat = WildPat placeHolderType -- Pre-typechecking \end{code} ToDo: Better SrcLocs. @@ -1305,9 +1277,9 @@ compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case compare_gen_Case eq a b -- General case = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-} - [mk_triv_Match (mkNullaryConPat ltTag_RDR) ltTag_Expr, - mk_triv_Match (mkNullaryConPat eqTag_RDR) eq, - mk_triv_Match (mkNullaryConPat gtTag_RDR) gtTag_Expr] + [mkSimpleHsAlt (mkNullaryConPat ltTag_RDR) ltTag_Expr, + mkSimpleHsAlt (mkNullaryConPat eqTag_RDR) eq, + mkSimpleHsAlt (mkNullaryConPat gtTag_RDR) gtTag_Expr] generatedSrcLoc careful_compare_Case tycon ty eq a b @@ -1319,8 +1291,8 @@ careful_compare_Case tycon ty eq a b (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc) generatedSrcLoc where - relevant_eq_op = assoc_ty_id "Ord" tycon eq_op_tbl ty - relevant_lt_op = assoc_ty_id "Ord" tycon lt_op_tbl ty + relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty) + relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty) box_if_necy :: String -- The class involved @@ -1346,28 +1318,30 @@ assoc_ty_id cls_str tycon tbl ty where res = [id | (ty',id) <- tbl, ty `tcEqType` ty'] +eq_op_tbl :: [(Type, PrimOp)] eq_op_tbl = - [(charPrimTy, eqChar_RDR) - ,(intPrimTy, eqInt_RDR) - ,(wordPrimTy, eqWord_RDR) - ,(addrPrimTy, eqAddr_RDR) - ,(floatPrimTy, eqFloat_RDR) - ,(doublePrimTy, eqDouble_RDR) + [(charPrimTy, CharEqOp) + ,(intPrimTy, IntEqOp) + ,(wordPrimTy, WordEqOp) + ,(addrPrimTy, AddrEqOp) + ,(floatPrimTy, FloatEqOp) + ,(doublePrimTy, DoubleEqOp) ] +lt_op_tbl :: [(Type, PrimOp)] lt_op_tbl = - [(charPrimTy, ltChar_RDR) - ,(intPrimTy, ltInt_RDR) - ,(wordPrimTy, ltWord_RDR) - ,(addrPrimTy, ltAddr_RDR) - ,(floatPrimTy, ltFloat_RDR) - ,(doublePrimTy, ltDouble_RDR) + [(charPrimTy, CharLtOp) + ,(intPrimTy, IntLtOp) + ,(wordPrimTy, WordLtOp) + ,(addrPrimTy, AddrLtOp) + ,(floatPrimTy, FloatLtOp) + ,(doublePrimTy, DoubleLtOp) ] box_con_tbl = [(charPrimTy, getRdrName charDataCon) ,(intPrimTy, getRdrName intDataCon) - ,(wordPrimTy, getRdrName wordDataCon) + ,(wordPrimTy, wordDataCon_RDR) ,(addrPrimTy, addrDataCon_RDR) ,(floatPrimTy, getRdrName floatDataCon) ,(doublePrimTy, getRdrName doubleDataCon) @@ -1375,10 +1349,8 @@ box_con_tbl = ----------------------------------------------------------------------- -and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr - -and_Expr a b = genOpApp a and_RDR b -append_Expr a b = genOpApp a append_RDR b +and_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr +and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- @@ -1389,16 +1361,15 @@ eq_Expr tycon ty a b = genOpApp a eq_op b | not (isUnLiftedType ty) = eq_RDR | otherwise = -- we have to do something special for primitive things... - assoc_ty_id "Eq" tycon eq_op_tbl ty - + primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty) \end{code} \begin{code} untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr untag_Expr tycon [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr - = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-} - [mk_triv_Match (VarPat put_tag_here) (untag_Expr tycon more expr)] + = HsCase (HsPar (mkHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} + [mkSimpleHsAlt (VarPat put_tag_here) (untag_Expr tycon more expr)] generatedSrcLoc cmp_tags_Expr :: RdrName -- Comparison op @@ -1465,82 +1436,68 @@ parenify e = HsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. --- For some reason the renamer doesn't reassociate it right, and I can't --- be bothered to find out why just now. - -genOpApp e1 op e2 = mkHsOpApp e1 op e2 +genOpApp e1 op e2 = HsPar (mkHsOpApp e1 op e2) \end{code} \begin{code} -varUnqual n = mkUnqual OccName.varName n - -zz_a_RDR = varUnqual FSLIT("_a") -a_RDR = varUnqual FSLIT("a") -b_RDR = varUnqual FSLIT("b") -c_RDR = varUnqual FSLIT("c") -d_RDR = varUnqual FSLIT("d") -e_RDR = varUnqual FSLIT("e") -k_RDR = varUnqual FSLIT("k") -z_RDR = varUnqual FSLIT("z") :: RdrName -ah_RDR = varUnqual FSLIT("a#") -bh_RDR = varUnqual FSLIT("b#") -ch_RDR = varUnqual FSLIT("c#") -dh_RDR = varUnqual FSLIT("d#") -cmp_eq_RDR = varUnqual FSLIT("cmp_eq") -rangeSize_RDR = varUnqual FSLIT("rangeSize") - -as_RDRs = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] -cs_RDRs = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] - -zz_a_Expr = HsVar zz_a_RDR +a_RDR = mkVarUnqual FSLIT("a") +b_RDR = mkVarUnqual FSLIT("b") +c_RDR = mkVarUnqual FSLIT("c") +d_RDR = mkVarUnqual FSLIT("d") +k_RDR = mkVarUnqual FSLIT("k") +z_RDR = mkVarUnqual FSLIT("z") +ah_RDR = mkVarUnqual FSLIT("a#") +bh_RDR = mkVarUnqual FSLIT("b#") +ch_RDR = mkVarUnqual FSLIT("c#") +dh_RDR = mkVarUnqual FSLIT("d#") +cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq") +rangeSize_RDR = mkVarUnqual FSLIT("rangeSize") + +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] + a_Expr = HsVar a_RDR b_Expr = HsVar b_RDR c_Expr = HsVar c_RDR -d_Expr = HsVar d_RDR -z_Expr = HsVar z_RDR ltTag_Expr = HsVar ltTag_RDR eqTag_Expr = HsVar eqTag_RDR gtTag_Expr = HsVar gtTag_RDR false_Expr = HsVar false_RDR true_Expr = HsVar true_RDR -getTag_Expr = HsVar getTag_RDR -tagToEnum_Expr = HsVar tagToEnum_RDR -con2tag_Expr tycon = HsVar (con2tag_RDR tycon) - -wildPat = WildPat placeHolderType -zz_a_Pat = VarPat zz_a_RDR a_Pat = VarPat a_RDR b_Pat = VarPat b_RDR c_Pat = VarPat c_RDR d_Pat = VarPat d_RDR con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +-- Generates Orig RdrNames, for the binding positions +con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_" +tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_" +maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_" -con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#")) -tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#")) -maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#")) +mk_tc_deriv_name tycon str + = mkDerivedRdrName tc_name mk_occ + where + tc_name = tyConName tycon + mk_occ tc_occ = mkOccFS varName (mkFastString new_str) + where + new_str = str ++ occNameString tc_occ ++ "#" \end{code} RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports PrelNames, so PrelNames can't import PrimOp. \begin{code} -minusInt_RDR = nameRdrName minusIntName -eqInt_RDR = nameRdrName eqIntName -ltInt_RDR = nameRdrName ltIntName -geInt_RDR = nameRdrName geIntName -leInt_RDR = nameRdrName leIntName -eqChar_RDR = nameRdrName eqCharName -eqWord_RDR = nameRdrName eqWordName -eqAddr_RDR = nameRdrName eqAddrName -eqFloat_RDR = nameRdrName eqFloatName -eqDouble_RDR = nameRdrName eqDoubleName -ltChar_RDR = nameRdrName ltCharName -ltWord_RDR = nameRdrName ltWordName -ltAddr_RDR = nameRdrName ltAddrName -ltFloat_RDR = nameRdrName ltFloatName -ltDouble_RDR = nameRdrName ltDoubleName -tagToEnum_RDR = nameRdrName tagToEnumName +primOpRdrName op = getRdrName (primOpId op) + +minusInt_RDR = primOpRdrName IntSubOp +eqInt_RDR = primOpRdrName IntEqOp +ltInt_RDR = primOpRdrName IntLtOp +geInt_RDR = primOpRdrName IntGeOp +leInt_RDR = primOpRdrName IntLeOp +tagToEnum_RDR = primOpRdrName TagToEnumOp + +error_RDR = getRdrName eRROR_ID \end{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index bb84ca8af7..dcdb63a718 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -60,7 +60,7 @@ import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars, import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) -import TysWiredIn ( charTy, stringTy, intTy, integerTy, +import TysWiredIn ( charTy, stringTy, intTy, mkListTy, mkPArrTy, mkTupleTy, unitTy, voidTy, listTyCon, tupleTyCon ) import TyCon ( mkPrimTyCon, tyConKind ) @@ -187,7 +187,7 @@ hsLitType (HsString str) = stringTy hsLitType (HsStringPrim s) = addrPrimTy hsLitType (HsInt i) = intTy hsLitType (HsIntPrim i) = intPrimTy -hsLitType (HsInteger i) = integerTy +hsLitType (HsInteger i ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim f) = floatPrimTy hsLitType (HsDoublePrim d) = doublePrimTy @@ -828,7 +828,7 @@ zonkPat env (ConPatOut n stuff ty tvs dicts) let env1 = extendZonkEnv env new_dicts in - zonkConStuff env stuff `thenM` \ (new_stuff, ids) -> + zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) -> returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, listToBag new_dicts `unionBags` ids) @@ -948,9 +948,6 @@ zonkRule env (HsRule name act vars lhs rhs loc) zonk_bndr (RuleBndr v) | isId v = zonkIdBndr env v | otherwise = zonkTcTyVarToTyVar v - -zonkRule env (IfaceRuleOut fun rule) - = returnM (IfaceRuleOut (zonkIdOcc env fun) rule) \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs deleted file mode 100644 index ebfdb499be..0000000000 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ /dev/null @@ -1,425 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[TcIfaceSig]{Type checking of type signatures in interface files} - -\begin{code} -module TcIfaceSig ( tcInterfaceSigs, - tcCoreExpr, - tcCoreLamBndrs, - tcCoreBinds ) where - -#include "HsVersions.h" - -import HsSyn ( CoreDecl(..), TyClDecl(..), HsTupCon(..) ) -import TcHsSyn ( TypecheckedCoreBind ) -import TcRnTypes -import TcRnMonad -import TcMonoType ( tcIfaceType, kcHsSigType ) -import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId, - tcLookupDataCon ) - -import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl ) -import HsCore -import Literal ( Literal(..) ) -import CoreSyn -import CoreUtils ( exprType ) -import CoreUnfold -import CoreLint ( lintUnfolding ) -import WorkWrap ( mkWrapper ) - -import Id ( Id, mkVanillaGlobal, mkLocalId ) -import MkId ( mkFCallId ) -import IdInfo -import TyCon ( tyConDataCons, tyConTyVars ) -import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys ) -import Type ( mkTyVarTys, splitTyConApp ) -import TysWiredIn ( tupleCon ) -import Var ( mkTyVar, tyVarKind ) -import Name ( Name ) -import UniqSupply ( initUs_ ) -import Outputable -import Util ( zipWithEqual, dropList, equalLength ) -import HscTypes ( typeEnvIds ) -import CmdLineOpts ( DynFlag(..) ) -\end{code} - -Ultimately, type signatures in interfaces will have pragmatic -information attached, so it is a good idea to have separate code to -check them. - -As always, we do not have to worry about user-pragmas in interface -signatures. - -\begin{code} -tcInterfaceSigs :: [RenamedTyClDecl] -- Ignore non-sig-decls in these decls - -> TcM TcGblEnv - --- May 2003: --- NOTE 1: careful about the side-effected EPS --- in the two tcExtendGlobalValueEnv calls --- NOTE 2: no point in tying the knot with fixM; all --- the important knot-tying comes via the PCS global variable - -tcInterfaceSigs decls = - zapEnv (fixM (tc_interface_sigs decls)) `thenM` \ (_,sig_ids) -> - -- The zapEnv dramatically trims the environment, solely - -- to plug the space leak that would otherwise be caused - -- by a rich environment bound into lots of lazy thunks - -- The thunks are the lazily-typechecked IdInfo of the - -- imported things. - - tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env -> - returnM gbl_env - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - -- - -- NOTE ALSO: the knot is in two parts: - -- * Ids defined in this module are added to the typechecker envt - -- which is knot-tied by the fixM. - -- * Imported Ids are side-effected into the PCS by the - -- tcExtendGlobalValueEnv, so they will be seen there provided - -- we don't look them up too early. - -- In both cases, we must defer lookups until after the knot is tied - -- - -- We used to have a much bigger loop (in TcRnDriver), so that the - -- interface pragmas could mention variables bound in this module - -- (by mutual recn), but - -- (a) the knot is tiresomely big, and - -- (b) it black-holes when we have Template Haskell - -- - -- For (b) consider: f = $(...h....) - -- where h is imported, and calls f via an hi-boot file. - -- This is bad! But it is not seen as a staging error, because h - -- is indeed imported. We don't want the type-checker to black-hole - -- when simplifying and compiling the splice! - -- - -- Simple solution: discard any unfolding that mentions a variable - -- bound in this module (and hence not yet processed). - -- The discarding happens when forkM finds a type error. - -tc_interface_sigs decls ~(unf_env, _) - = sequenceM [do_one d | d@(IfaceSig {}) <- decls] `thenM` \ sig_ids -> - tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env -> - returnM (gbl_env, sig_ids) - where - in_scope_vars = typeEnvIds (tcg_type_env unf_env) - -- When we have hi-boot files, an unfolding might refer to - -- something defined in this module, so we must build a - -- suitable in-scope set. This thunk will only be poked - -- if -dcore-lint is on. - - do_one IfaceSig {tcdName = name, tcdType = ty, - tcdIdInfo = id_infos, tcdLoc = src_loc} - = addSrcLoc src_loc $ - addErrCtxt (ifaceSigCtxt name) $ - tcIfaceType ty `thenM` \ sigma_ty -> - tcIdInfo unf_env in_scope_vars name - sigma_ty id_infos `thenM` \ id_info -> - returnM (mkVanillaGlobal name sigma_ty id_info) -\end{code} - -\begin{code} -tcIdInfo unf_env in_scope_vars name ty info_ins - = setGblEnv unf_env $ - -- Use the knot-tied environment for the IdInfo - -- In particular: typechecking unfoldings and worker names - foldlM tcPrag init_info info_ins - where - -- Set the CgInfo to something sensible but uninformative before - -- we start; default assumption is that it has CAFs - init_info = vanillaIdInfo - - tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str) - tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity - - tcPrag info (HsUnfold inline_prag expr) - = tcPragExpr name in_scope_vars expr `thenM` \ maybe_expr' -> - let - -- maybe_expr' doesn't get looked at if the unfolding - -- is never inspected; so the typecheck doesn't even happen - unfold_info = case maybe_expr' of - Nothing -> noUnfolding - Just expr' -> mkTopUnfolding expr' - in - returnM (info `setUnfoldingInfoLazily` unfold_info - `setInlinePragInfo` inline_prag) -\end{code} - -\begin{code} -tcWorkerInfo ty info wkr_name arity - = forkM doc (tcVar wkr_name) `thenM` \ maybe_wkr_id -> - -- Watch out! We can't pull on unf_env too eagerly! - -- Hence the forkM - - -- We return without testing maybe_wkr_id, but as soon as info is - -- looked at we will test it. That's ok, because its outside the - -- knot; and there seems no big reason to further defer the - -- tcVar lookup. (Contrast with tcPragExpr, where postponing walking - -- over the unfolding until it's actually used does seem worth while.) - newUniqueSupply `thenM` \ us -> - returnM (case maybe_wkr_id of - Nothing -> info - Just wkr_id -> info `setUnfoldingInfoLazily` mk_unfolding us wkr_id - `setWorkerInfo` HasWorker wkr_id arity) - - where - doc = text "worker for" <+> ppr wkr_name - - mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id) - - -- We are relying here on strictness info always appearing - -- before worker info, fingers crossed .... - strict_sig = case newStrictnessInfo info of - Just sig -> sig - Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr_name) -\end{code} - -For unfoldings we try to do the job lazily, so that we never type check -an unfolding that isn't going to be looked at. - -\begin{code} -tcPragExpr :: Name -> [Id] -> UfExpr Name -> TcM (Maybe CoreExpr) -tcPragExpr name in_scope_vars expr - = forkM doc $ - tcCoreExpr expr `thenM` \ core_expr' -> - - -- Check for type consistency in the unfolding - ifOptM Opt_DoCoreLinting ( - getSrcLocM `thenM` \ src_loc -> - case lintUnfolding src_loc in_scope_vars core_expr' of - Nothing -> returnM () - Just fail_msg -> failWithTc ((doc <+> text "Failed Lint") $$ fail_msg) - ) `thenM_` - - returnM core_expr' - where - doc = text "unfolding of" <+> ppr name -\end{code} - - -Variables in unfoldings -~~~~~~~~~~~~~~~~~~~~~~~ - -\begin{code} -tcVar :: Name -> TcM Id - -- Inside here we use only the Global environment, even for locally bound variables. - -- Why? Because we know all the types and want to bind them to real Ids. -tcVar name = tcLookupGlobalId name -\end{code} - -UfCore expressions. - -\begin{code} -tcCoreExpr :: UfExpr Name -> TcM CoreExpr - -tcCoreExpr (UfType ty) - = tcIfaceType ty `thenM` \ ty' -> - -- It might not be of kind type - returnM (Type ty') - -tcCoreExpr (UfVar name) - = tcVar name `thenM` \ id -> - returnM (Var id) - -tcCoreExpr (UfLit lit) - = returnM (Lit lit) - -tcCoreExpr (UfFCall cc ty) - = tcIfaceType ty `thenM` \ ty' -> - newUnique `thenM` \ u -> - returnM (Var (mkFCallId u cc ty')) - -tcCoreExpr (UfTuple (HsTupCon boxity arity) args) - = mappM tcCoreExpr args `thenM` \ args' -> - let - -- Put the missing type arguments back in - con_args = map (Type . exprType) args' ++ args' - in - returnM (mkApps (Var con_id) con_args) - where - con_id = dataConWorkId (tupleCon boxity arity) - - -tcCoreExpr (UfLam bndr body) - = tcCoreLamBndr bndr $ \ bndr' -> - tcCoreExpr body `thenM` \ body' -> - returnM (Lam bndr' body') - -tcCoreExpr (UfApp fun arg) - = tcCoreExpr fun `thenM` \ fun' -> - tcCoreExpr arg `thenM` \ arg' -> - returnM (App fun' arg') - -tcCoreExpr (UfCase scrut case_bndr alts) - = tcCoreExpr scrut `thenM` \ scrut' -> - let - scrut_ty = exprType scrut' - case_bndr' = mkLocalId case_bndr scrut_ty - in - tcExtendGlobalValEnv [case_bndr'] $ - mappM (tcCoreAlt scrut_ty) alts `thenM` \ alts' -> - returnM (Case scrut' case_bndr' alts') - -tcCoreExpr (UfLet (UfNonRec bndr rhs) body) - = tcCoreExpr rhs `thenM` \ rhs' -> - tcCoreValBndr bndr $ \ bndr' -> - tcCoreExpr body `thenM` \ body' -> - returnM (Let (NonRec bndr' rhs') body') - -tcCoreExpr (UfLet (UfRec pairs) body) - = tcCoreValBndrs bndrs $ \ bndrs' -> - mappM tcCoreExpr rhss `thenM` \ rhss' -> - tcCoreExpr body `thenM` \ body' -> - returnM (Let (Rec (bndrs' `zip` rhss')) body') - where - (bndrs, rhss) = unzip pairs - -tcCoreExpr (UfNote note expr) - = tcCoreExpr expr `thenM` \ expr' -> - case note of - UfCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> - returnM (Note (Coerce to_ty' - (exprType expr')) expr') - UfInlineCall -> returnM (Note InlineCall expr') - UfInlineMe -> returnM (Note InlineMe expr') - UfSCC cc -> returnM (Note (SCC cc) expr') -\end{code} - -\begin{code} -tcCoreLamBndr (UfValBinder name ty) thing_inside - = tcIfaceType ty `thenM` \ ty' -> - let - id = mkLocalId name ty' - in - tcExtendGlobalValEnv [id] $ - thing_inside id - -tcCoreLamBndr (UfTyBinder name kind) thing_inside - = let - tyvar = mkTyVar name kind - in - tcExtendTyVarEnv [tyvar] (thing_inside tyvar) - -tcCoreLamBndrs [] thing_inside = thing_inside [] -tcCoreLamBndrs (b:bs) thing_inside - = tcCoreLamBndr b $ \ b' -> - tcCoreLamBndrs bs $ \ bs' -> - thing_inside (b':bs') - -tcCoreValBndr (UfValBinder name ty) thing_inside - = tcIfaceType ty `thenM` \ ty' -> - let - id = mkLocalId name ty' - in - tcExtendGlobalValEnv [id] $ - thing_inside id - -tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders - = mappM tcIfaceType tys `thenM` \ tys' -> - let - ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' - in - tcExtendGlobalValEnv ids $ - thing_inside ids - where - names = [name | UfValBinder name _ <- bndrs] - tys = [ty | UfValBinder _ ty <- bndrs] -\end{code} - -\begin{code} -tcCoreAlt scrut_ty (UfDefault, names, rhs) - = ASSERT( null names ) - tcCoreExpr rhs `thenM` \ rhs' -> - returnM (DEFAULT, [], rhs') - -tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs) - = ASSERT( null names ) - tcCoreExpr rhs `thenM` \ rhs' -> - returnM (LitAlt lit, [], rhs') - --- A case alternative is made quite a bit more complicated --- by the fact that we omit type annotations because we can --- work them out. True enough, but its not that easy! -tcCoreAlt scrut_ty alt@(con, names, rhs) - = tcConAlt con `thenM` \ con -> - let - ex_tyvars = dataConExistentialTyVars con - (tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp - -- We are looking at Core here - main_tyvars = tyConTyVars tycon - ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] - ex_tys' = mkTyVarTys ex_tyvars' - arg_tys = dataConArgTys con (inst_tys ++ ex_tys') - id_names = dropList ex_tyvars names - arg_ids -#ifdef DEBUG - | not (equalLength id_names arg_tys) - = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$ - (ppr main_tyvars <+> ppr ex_tyvars) $$ - ppr arg_tys) - | otherwise -#endif - = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys - in - ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars ) - tcExtendTyVarEnv ex_tyvars' $ - tcExtendGlobalValEnv arg_ids $ - tcCoreExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs') - - -tcConAlt :: UfConAlt Name -> TcM DataCon -tcConAlt (UfTupleAlt (HsTupCon boxity arity)) - = returnM (tupleCon boxity arity) - -tcConAlt (UfDataAlt con_name) -- When reading interface files - -- the con_name will be the real name of - -- the data con - = tcLookupDataCon con_name -\end{code} - -%************************************************************************ -%* * -\subsection{Core decls} -%* * -%************************************************************************ - - -\begin{code} -tcCoreBinds :: [RenamedCoreDecl] -> TcM [TypecheckedCoreBind] --- We don't assume the bindings are in dependency order --- So first build the environment, then check the RHSs -tcCoreBinds ls = mappM tcCoreBinder ls `thenM` \ bndrs -> - tcExtendGlobalValEnv bndrs $ - mappM (tcCoreBind bndrs) ls - -tcCoreBinder (CoreDecl nm ty _ _) - = kcHsSigType ty `thenM_` - tcIfaceType ty `thenM` \ ty' -> - returnM (mkLocalId nm ty') - -tcCoreBind bndrs (CoreDecl nm _ rhs loc) - = tcVar nm `thenM` \ id -> - tcCoreExpr rhs `thenM` \ rhs' -> - let - mb_err = lintUnfolding loc bndrs rhs' - in - (case mb_err of - Just err -> addErr err - Nothing -> returnM ()) `thenM_` - - returnM (id, rhs') -\end{code} - - -\begin{code} -ifaceSigCtxt sig_name - = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name] -\end{code} - diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index d35c0de5aa..8bb47542f9 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -4,69 +4,50 @@ \section[TcInstDecls]{Typechecking instance declarations} \begin{code} -module TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, - tcInstDecls2, tcAddDeclCtxt ) where +module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where #include "HsVersions.h" - -import CmdLineOpts ( DynFlag(..) ) - -import HsSyn ( InstDecl(..), TyClDecl(..), HsType(..), - MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), HsTyVarBndr(..), +import HsSyn ( InstDecl(..), HsType(..), + MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), andMonoBindList, collectMonoBinders, - isClassDecl, isSourceInstDecl, toHsType - ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, - RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, - extractHsTyVars, maybeGenericMatch + isClassDecl ) +import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedTyClDecl ) import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) -import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr ) +import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, + tcClassDecl2, getGenericInstances ) import TcRnMonad import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr, - checkAmbiguity, UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType, + checkAmbiguity, SourceTyCtxt(..) ) +import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType, tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys, - TyVarDetails(..) + TyVarDetails(..), tcSplitDFunTy ) -import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE ) +import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, + showLIE, tcExtendLocalInstEnv ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcExtendGlobalValEnv, - tcLookupClass, tcExtendTyVarEnv2, - tcExtendInstEnv, tcExtendLocalInstEnv, tcLookupGlobalId, - InstInfo(..), InstBindings(..), pprInstInfo, simpleInstInfoTyCon, - simpleInstInfoTy, newDFunName +import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv2, + InstInfo(..), InstBindings(..), + newDFunName, tcExtendLocalValEnv ) import PprType ( pprClassPred ) -import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType ) +import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) -import HscTypes ( DFunId ) import Subst ( mkTyVarSubst, substTheta, substTy ) import DataCon ( classDataCon ) -import Class ( Class, classBigSig ) +import Class ( classBigSig ) import Var ( idName, idType ) import NameSet import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) -import Generics ( validGenericInstanceType ) import Name ( getSrcLoc ) import NameSet ( unitNameSet, emptyNameSet, nameSetToList ) -import TyCon ( TyCon ) -import TysWiredIn ( genericTyCons ) -import SrcLoc ( SrcLoc ) -import Unique ( Uniquable(..) ) -import Util ( lengthExceeds ) -import BasicTypes ( NewOrData(..) ) import UnicodeUtil ( stringToUtf8 ) -import ErrUtils ( dumpIfSet_dyn ) -import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, - assocElts, extendAssoc_C, equivClassesByUniq, minusList - ) import Maybe ( catMaybes ) -import List ( partition ) +import ListSetOps ( minusList ) import Outputable import FastString \end{code} @@ -160,23 +141,15 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls -> TcM (TcGblEnv, -- The full inst env [InstInfo], -- Source-code instance decls to process; -- contains all dfuns for this module - RenamedHsBinds, -- Supporting bindings for derived instances - FreeVars) -- And the free vars of the derived code + RenamedHsBinds) -- Supporting bindings for derived instances tcInstDecls1 tycl_decls inst_decls = checkNoErrs $ -- Stop if addInstInfos etc discovers any errors -- (they recover, so that we get more than one error each round) - let - (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls - in - - -- (0) Deal with the imported instance decls - tcIfaceInstDecls iface_inst_decls `thenM` \ imp_dfuns -> - tcExtendInstEnv imp_dfuns $ -- (1) Do the ordinary instance declarations - mappM tcLocalInstDecl1 src_inst_decls `thenM` \ local_inst_infos -> + mappM tcLocalInstDecl1 inst_decls `thenM` \ local_inst_infos -> let local_inst_info = catMaybes local_inst_infos @@ -189,21 +162,23 @@ tcInstDecls1 tycl_decls inst_decls -- a) imported instance decls (from this module) -- b) local instance decls -- c) generic instances - tcExtendLocalInstEnv local_inst_info $ - tcExtendLocalInstEnv generic_inst_info $ + addInsts local_inst_info $ + addInsts generic_inst_info $ -- (3) Compute instances from "deriving" clauses; - -- note that we only do derivings for things in this module; - -- 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; hence inst_env4 - tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds, fvs) -> - tcExtendLocalInstEnv deriv_inst_info $ + tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds) -> + addInsts deriv_inst_info $ - getGblEnv `thenM` \ gbl_env -> + getGblEnv `thenM` \ gbl_env -> returnM (gbl_env, generic_inst_info ++ deriv_inst_info ++ local_inst_info, - deriv_binds, fvs) + deriv_binds) + +addInsts :: [InstInfo] -> TcM a -> TcM a +addInsts infos thing_inside + = tcExtendLocalInstEnv (map iDFunId infos) thing_inside \end{code} \begin{code} @@ -217,16 +192,16 @@ tcLocalInstDecl1 :: RenamedInstDecl -- Imported ones should have been checked already, and may indeed -- contain something illegal in normal Haskell, notably -- instance CCallable [Char] -tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc) +tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags src_loc) = -- Prime error recovery, set source location recoverM (returnM Nothing) $ addSrcLoc src_loc $ - addErrCtxt (instDeclCtxt poly_ty) $ + addErrCtxt (instDeclCtxt1 poly_ty) $ -- Typecheck the instance type itself. We can't use -- tcHsSigType, because it's not a valid user type. - kcHsSigType poly_ty `thenM_` - tcHsType poly_ty `thenM` \ poly_ty' -> + kcHsSigType poly_ty `thenM` \ kinded_ty -> + tcHsKindedType kinded_ty `thenM` \ poly_ty' -> let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty' in @@ -242,163 +217,6 @@ tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc) msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class")) \end{code} -Imported instance declarations - -\begin{code} -tcIfaceInstDecls :: [RenamedInstDecl] -> TcM [DFunId] --- Deal with the instance decls, -tcIfaceInstDecls decls = mappM tcIfaceInstDecl decls - -tcIfaceInstDecl :: RenamedInstDecl -> TcM DFunId - -- An interface-file instance declaration - -- Should be in scope by now, because we should - -- have sucked in its interface-file definition - -- So it will be replete with its unfolding etc -tcIfaceInstDecl decl@(InstDecl poly_ty binds uprags (Just dfun_name) src_loc) - = tcLookupGlobalId dfun_name -\end{code} - - -%************************************************************************ -%* * -\subsection{Extracting generic instance declaration from class declarations} -%* * -%************************************************************************ - -@getGenericInstances@ extracts the generic instance declarations from a class -declaration. For exmaple - - class C a where - op :: a -> a - - op{ x+y } (Inl v) = ... - op{ x+y } (Inr v) = ... - op{ x*y } (v :*: w) = ... - op{ 1 } Unit = ... - -gives rise to the instance declarations - - instance C (x+y) where - op (Inl v) = ... - op (Inr v) = ... - - instance C (x*y) where - op (v :*: w) = ... - - instance C 1 where - op Unit = ... - - -\begin{code} -getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo] -getGenericInstances class_decls - = mappM get_generics class_decls `thenM` \ gen_inst_infos -> - let - gen_inst_info = concat gen_inst_infos - in - if null gen_inst_info then - returnM [] - else - getDOpts `thenM` \ dflags -> - ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" - (vcat (map pprInstInfo gen_inst_info))) - `thenM_` - returnM gen_inst_info - -get_generics decl@(ClassDecl {tcdMeths = Nothing}) - = returnM [] -- Imported class decls - -get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, tcdLoc = loc}) - | null groups - = returnM [] -- The comon case: no generic default methods - - | otherwise -- A source class decl with generic default methods - = recoverM (returnM []) $ - tcAddDeclCtxt decl $ - tcLookupClass class_name `thenM` \ clas -> - - -- Make an InstInfo out of each group - mappM (mkGenericInstance clas loc) groups `thenM` \ inst_infos -> - - -- Check that there is only one InstInfo for each type constructor - -- The main way this can fail is if you write - -- f {| a+b |} ... = ... - -- f {| x+y |} ... = ... - -- Then at this point we'll have an InstInfo for each - let - tc_inst_infos :: [(TyCon, InstInfo)] - tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos] - - bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos, - group `lengthExceeds` 1] - get_uniq (tc,_) = getUnique tc - in - mappM (addErrTc . dupGenericInsts) bad_groups `thenM_` - - -- Check that there is an InstInfo for each generic type constructor - let - missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos] - in - checkTc (null missing) (missingGenericInstances missing) `thenM_` - - returnM inst_infos - - where - -- Group the declarations by type pattern - groups :: [(RenamedHsType, RenamedMonoBinds)] - groups = assocElts (getGenericBinds def_methods) - - ---------------------------------- -getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds - -- Takes a group of method bindings, finds the generic ones, and returns - -- them in finite map indexed by the type parameter in the definition. - -getGenericBinds EmptyMonoBinds = emptyAssoc -getGenericBinds (AndMonoBinds m1 m2) - = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2) - -getGenericBinds (FunMonoBind id infixop matches loc) - = mapAssoc wrap (foldl add emptyAssoc matches) - -- Using foldl not foldr is vital, else - -- we reverse the order of the bindings! - where - add env match = case maybeGenericMatch match of - Nothing -> env - Just (ty, match') -> extendAssoc_C (++) env (ty, [match']) - - wrap ms = FunMonoBind id infixop ms loc - ---------------------------------- -mkGenericInstance :: Class -> SrcLoc - -> (RenamedHsType, RenamedMonoBinds) - -> TcM InstInfo - -mkGenericInstance clas loc (hs_ty, binds) - -- Make a generic instance declaration - -- For example: instance (C a, C b) => C (a+b) where { binds } - - = -- Extract the universally quantified type variables - let - sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty)) - in - tcHsTyVars sig_tvs (kcHsSigType hs_ty) $ \ tyvars -> - - -- Type-check the instance type, and check its form - tcHsSigType GenPatCtxt hs_ty `thenM` \ inst_ty -> - checkTc (validGenericInstanceType inst_ty) - (badGenericInstanceType binds) `thenM_` - - -- Make the dictionary function. - newDFunName clas [inst_ty] loc `thenM` \ dfun_name -> - let - inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] - dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] - in - - returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] }) -\end{code} - %************************************************************************ %* * @@ -407,10 +225,26 @@ mkGenericInstance clas loc (hs_ty, binds) %************************************************************************ \begin{code} -tcInstDecls2 :: [InstInfo] -> TcM TcMonoBinds -tcInstDecls2 inst_decls - = mappM tcInstDecl2 inst_decls `thenM` \ binds_s -> - returnM (andMonoBindList binds_s) +tcInstDecls2 :: [RenamedTyClDecl] -> [InstInfo] + -> TcM (TcLclEnv, TcMonoBinds) +-- (a) From each class declaration, +-- generate any default-method bindings +-- (b) From each instance decl +-- generate the dfun binding + +tcInstDecls2 tycl_decls inst_decls + = do { -- (a) Default methods from class decls + (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $ + filter isClassDecl tycl_decls + ; tcExtendLocalValEnv (concat dm_ids_s) $ do + + -- (b) instance declarations + ; inst_binds_s <- mappM tcInstDecl2 inst_decls + + -- Done + ; tcl_env <- getLclEnv + ; returnM (tcl_env, andMonoBindList dm_binds_s `AndMonoBinds` + andMonoBindList inst_binds_s) } \end{code} ======= New documentation starts here (Sept 92) ============== @@ -485,9 +319,9 @@ tcInstDecl2 :: InstInfo -> TcM TcMonoBinds tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) = -- Prime error recovery - recoverM (returnM EmptyMonoBinds) $ - addSrcLoc (getSrcLoc dfun_id) $ - addErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $ + recoverM (returnM EmptyMonoBinds) $ + addSrcLoc (getSrcLoc dfun_id) $ + addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ let inst_ty = idType dfun_id (inst_tyvars, _) = tcSplitForAllTys inst_ty @@ -844,44 +678,17 @@ simplified: only zeze2 is extracted and its body is simplified. %************************************************************************ \begin{code} -tcAddDeclCtxt decl thing_inside - = addSrcLoc (tcdLoc decl) $ - addErrCtxt ctxt $ - thing_inside +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (case hs_inst_ty of + HsForAllTy _ _ (HsPredTy pred) -> ppr pred + HsPredTy pred -> ppr pred + other -> ppr hs_inst_ty) -- Don't expect this +instDeclCtxt2 dfun_ty + = inst_decl_ctxt (ppr (mkClassPred cls tys)) where - thing = case decl of - ClassDecl {} -> "class" - TySynonym {} -> "type synonym" - TyData {tcdND = NewType} -> "newtype" - TyData {tcdND = DataType} -> "data type" - - ctxt = hsep [ptext SLIT("In the"), text thing, - ptext SLIT("declaration for"), quotes (ppr (tcdName decl))] - -instDeclCtxt inst_ty = ptext SLIT("In the instance declaration for") <+> quotes doc - where - doc = case inst_ty of - HsForAllTy _ _ (HsPredTy pred) -> ppr pred - HsPredTy pred -> ppr pred - other -> ppr inst_ty -- Don't expect this -\end{code} + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc -\begin{code} -badGenericInstanceType binds - = vcat [ptext SLIT("Illegal type pattern in the generic bindings"), - nest 4 (ppr binds)] - -missingGenericInstances missing - = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing - -dupGenericInsts tc_inst_infos - = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"), - nest 4 (vcat (map ppr_inst_ty tc_inst_infos)), - ptext SLIT("All the type patterns for a generic type constructor must be identical") - ] - where - ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst) - -methodCtxt = ptext SLIT("When checking the methods of an instance declaration") superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration") \end{code} diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index cc45bf4a16..df9bd11344 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -14,7 +14,7 @@ module TcMType ( newTyVar, newSigTyVar, newTyVarTy, -- Kind -> TcM TcType newTyVarTys, -- Int -> Kind -> TcM [TcType] - newKindVar, newKindVars, newOpenTypeKind, + newKindVar, newKindVars, newBoxityVar, putTcTyVar, getTcTyVar, newMutTyVar, readMutTyVar, writeMutTyVar, @@ -25,17 +25,17 @@ module TcMType ( -------------------------------- -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt, - SourceTyCtxt(..), checkValidTheta, - checkValidTyCon, checkValidClass, + SourceTyCtxt(..), checkValidTheta, checkFreeness, checkValidInstHead, instTypeErr, checkAmbiguity, - arityErr, + arityErr, -------------------------------- -- Zonking zonkType, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, - zonkTcPredType, zonkTcTyVarToTyVar, zonkKindEnv, + zonkTcPredType, zonkTcTyVarToTyVar, + zonkTcKindToKind ) where @@ -43,48 +43,41 @@ module TcMType ( -- friends: -import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see representation - Kind, ThetaType, typeCon +import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see representation + Kind, ThetaType ) import TcType ( TcType, TcThetaType, TcTauType, TcPredType, TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..), tcEqType, tcCmpPred, isClassPred, tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcSplitForAllTys, - tcIsTyVarTy, tcSplitSigmaTy, mkTyConApp, + tcIsTyVarTy, tcSplitSigmaTy, isUnLiftedType, isIPPred, isTyVarTy, mkAppTy, mkTyVarTy, mkTyVarTys, tyVarsOfPred, getClassPredTys_maybe, - liftedTypeKind, openTypeKind, defaultKind, superKind, + liftedTypeKind, defaultKind, superKind, superBoxity, liftedBoxity, typeKind, tyVarsOfType, tyVarsOfTypes, eqKind, isTypeKind, - isFFIArgumentTy, isFFIImportResultTy ) import Subst ( Subst, mkTopTyVarSubst, substTy ) -import Class ( Class, DefMeth(..), classArity, className, classBigSig ) +import Class ( Class, classArity, className ) import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon, - tyConArity, tyConName, tyConTheta, - getSynTyConDefn, tyConDataCons ) -import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) -import FieldLabel ( fieldLabelName, fieldLabelType ) -import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar, + tyConArity, tyConName ) +import Var ( TyVar, tyVarKind, tyVarName, isTyVar, mkTyVar, mkMutTyVar, isMutTyVar, mutTyVarRef ) -- others: -import Generics ( validGenericMethodType ) import TcRnMonad -- TcType, amongst others -import PrelNames ( hasKey ) -import ForeignCall ( Safety(..) ) import FunDeps ( grow ) -import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred ) +import PprType ( pprPred, pprTheta, pprClassPred ) import Name ( Name, setNameUnique, mkSystemTvNameEncoded ) import VarSet import CmdLineOpts ( dopt, DynFlag(..) ) -import Util ( nOfThem, isSingleton, equalLength, notNull, lengthExceeds ) -import ListSetOps ( equivClasses, removeDups ) +import Util ( nOfThem, isSingleton, equalLength, notNull ) +import ListSetOps ( removeDups ) import Outputable \end{code} @@ -134,11 +127,11 @@ newKindVar newKindVars :: Int -> TcM [TcKind] newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ()) -newOpenTypeKind :: TcM TcKind -- Returns the kind (Type bx), where bx is fresh -newOpenTypeKind - = newUnique `thenM` \ uniq -> - newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenM` \ kv -> - returnM (mkTyConApp typeCon [TyVarTy kv]) +newBoxityVar :: TcM TcKind -- Really TcBoxity + = newUnique `thenM` \ uniq -> + newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) + superBoxity VanillaTv `thenM` \ kv -> + returnM (TyVarTy kv) \end{code} @@ -319,19 +312,17 @@ zonkTcPredType (IParam n t) are used at the end of type checking \begin{code} -zonkKindEnv :: [(Name, TcKind)] -> TcM [(Name, Kind)] -zonkKindEnv pairs - = mappM zonk_it pairs - where - zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenM` \ kind -> - returnM (name, kind) - +zonkTcKindToKind :: TcKind -> TcM Kind +zonkTcKindToKind tc_kind + = zonkType zonk_unbound_kind_var tc_kind + where -- When zonking a kind, we want to -- zonk a *kind* variable to (Type *) -- zonk a *boxity* variable to * - zonk_unbound_kind_var kv | tyVarKind kv `eqKind` superKind = putTcTyVar kv liftedTypeKind - | tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity - | otherwise = pprPanic "zonkKindEnv" (ppr kv) + zonk_unbound_kind_var kv + | tyVarKind kv `eqKind` superKind = putTcTyVar kv liftedTypeKind + | tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity + | otherwise = pprPanic "zonkKindEnv" (ppr kv) -- zonkTcTyVarToTyVar is applied to the *binding* occurrence -- of a type variable, at the *end* of type checking. It changes @@ -421,14 +412,17 @@ zonkType unbound_var_fn ty go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' -> returnM (TyConApp tycon tys') + go (NewTcApp tycon tys) = mappM go tys `thenM` \ tys' -> + returnM (NewTcApp tycon tys') + go (NoteTy (SynNote ty1) ty2) = go ty1 `thenM` \ ty1' -> go ty2 `thenM` \ ty2' -> returnM (NoteTy (SynNote ty1') ty2') go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations - go (SourceTy p) = go_pred p `thenM` \ p' -> - returnM (SourceTy p') + go (PredTy p) = go_pred p `thenM` \ p' -> + returnM (PredTy p') go (FunTy arg res) = go arg `thenM` \ arg' -> go res `thenM` \ res' -> @@ -450,8 +444,6 @@ zonkType unbound_var_fn ty go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' -> returnM (ClassP c tys') - go_pred (NType tc tys) = mappM go tys `thenM` \ tys' -> - returnM (NType tc tys') go_pred (IParam n ty) = go ty `thenM` \ ty' -> returnM (IParam n ty') @@ -521,6 +513,7 @@ data UserTypeCtxt -- f x :: t = .... | ForSigCtxt Name -- Foreign inport or export signature | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE + | DefaultDeclCtxt -- Types in a default declaration -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] @@ -542,19 +535,22 @@ pprUserTypeCtxt PatSigCtxt = ptext SLIT("a pattern type signature") pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature") pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign signature for") <+> quotes (ppr n) pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature on") <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a `default' declaration") \end{code} \begin{code} checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context checkValidType ctxt ty - = doptM Opt_GlasgowExts `thenM` \ gla_exts -> + = traceTc (text "checkValidType" <+> ppr ty) `thenM_` + doptM Opt_GlasgowExts `thenM` \ gla_exts -> let rank | gla_exts = Arbitrary | otherwise = case ctxt of -- Haskell 98 GenPatCtxt -> Rank 0 PatSigCtxt -> Rank 0 + DefaultDeclCtxt-> Rank 0 ResSigCtxt -> Rank 0 TySynCtxt _ -> Rank 0 ExprSigCtxt -> Rank 1 @@ -582,31 +578,13 @@ checkValidType ctxt ty -- but for type synonyms we allow them even at -- top level in - addErrCtxt (checkTypeCtxt ctxt ty) $ - -- Check that the thing has kind Type, and is lifted if necessary checkTc kind_ok (kindErr actual_kind) `thenM_` -- Check the internal validity of the type itself - check_poly_type rank ubx_tup ty - - -checkTypeCtxt ctxt ty - = vcat [ptext SLIT("In the type:") <+> ppr_ty ty, - ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ] - - -- Hack alert. If there are no tyvars, (ppr sigma_ty) will print - -- something strange like {Eq k} -> k -> k, because there is no - -- ForAll at the top of the type. Since this is going to the user - -- we want it to look like a proper Haskell type even then; hence the hack - -- - -- This shows up in the complaint about - -- case C a where - -- op :: Eq a => a -> a -ppr_ty ty | null forall_tvs && notNull theta = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau - | otherwise = ppr ty - where - (forall_tvs, theta, tau) = tcSplitSigmaTy ty + check_poly_type rank ubx_tup ty `thenM_` + + traceTc (text "checkValidType done" <+> ppr ty) \end{code} @@ -665,7 +643,7 @@ check_tau_type :: Rank -> UbxTupFlag -> Type -> TcM () -- No foralls otherwise check_tau_type rank ubx_tup ty@(ForAllTy _ _) = failWithTc (forAllTyErr ty) -check_tau_type rank ubx_tup (SourceTy sty) = getDOpts `thenM` \ dflags -> +check_tau_type rank ubx_tup (PredTy sty) = getDOpts `thenM` \ dflags -> check_source_ty dflags TypeCtxt sty check_tau_type rank ubx_tup (TyVarTy _) = returnM () check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty) @@ -701,6 +679,9 @@ check_tau_type rank ubx_tup (NoteTy (SynNote syn) ty) check_tau_type rank ubx_tup (NoteTy other_note ty) = check_tau_type rank ubx_tup ty +check_tau_type rank ubx_tup (NewTcApp tc tys) + = mappM_ check_arg_type tys + check_tau_type rank ubx_tup ty@(TyConApp tc tys) | isSynTyCon tc = -- NB: Type.mkSynTy builds a TyConApp (not a NoteTy) for an unsaturated @@ -734,9 +715,9 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys) ubx_tup_msg = ubxArgTyErr ty ---------------------------------------- -forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty -unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty -ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty +forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr ty +unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr ty +ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr ty kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind \end{code} @@ -789,7 +770,7 @@ check_valid_theta ctxt theta = getDOpts `thenM` \ dflags -> warnTc (notNull dups) (dupPredWarn dups) `thenM_` -- Actually, in instance decls and type signatures, - -- duplicate constraints are eliminated by TcMonoType.hoistForAllTys, + -- duplicate constraints are eliminated by TcHsType.hoistForAllTys, -- so this error can only fire for the context of a class or -- data type decl. mappM_ (check_source_ty dflags ctxt) theta @@ -799,8 +780,10 @@ check_valid_theta ctxt theta ------------------------- check_source_ty dflags ctxt pred@(ClassP cls tys) = -- Class predicates are valid in all contexts - mappM_ check_arg_type tys `thenM_` checkTc (arity == n_tys) arity_err `thenM_` + + -- Check the form of the argument types + mappM_ check_arg_type tys `thenM_` checkTc (check_class_pred_tys dflags ctxt tys) (predTyVarErr pred $$ how_to_allow) @@ -825,8 +808,6 @@ check_source_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty -- constraint Foo [Int] might come out of e,and applying the -- instance decl would show up two uses of ?x. -check_source_ty dflags TypeCtxt (NType tc tys) = mappM_ check_arg_type tys - -- Catch-all check_source_ty dflags ctxt sty = failWithTc (badSourceTyErr sty) @@ -931,7 +912,7 @@ checkThetaCtxt ctxt theta = vcat [ptext SLIT("In the context:") <+> pprTheta theta, ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ] -badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprSourceType sty +badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty predTyVarErr pred = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) @@ -947,133 +928,6 @@ arityErr kind name n m %************************************************************************ %* * -\subsection{Validity check for TyCons} -%* * -%************************************************************************ - -checkValidTyCon is called once the mutually-recursive knot has been -tied, so we can look at things freely. - -\begin{code} -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc - | isSynTyCon tc = checkValidType (TySynCtxt name) syn_rhs - | otherwise - = -- Check the context on the data decl - checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_` - - -- Check arg types of data constructors - mappM_ checkValidDataCon data_cons `thenM_` - - -- Check that fields with the same name share a type - mappM_ check_fields groups - - where - name = tyConName tc - (_, syn_rhs) = getSynTyConDefn tc - data_cons = tyConDataCons tc - - fields = [field | con <- data_cons, field <- dataConFieldLabels con] - groups = equivClasses cmp_name fields - cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2 - - check_fields fields@(first_field_label : other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - = -- Check that all the fields in the group have the same type - -- NB: this check assumes that all the constructors of a given - -- data type use the same type variables - checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name) - where - field_ty = fieldLabelType first_field_label - field_name = fieldLabelName first_field_label - other_tys = map fieldLabelType other_fields - -checkValidDataCon :: DataCon -> TcM () -checkValidDataCon con - = checkValidType ctxt (idType (dataConWrapId con)) `thenM_` - -- This checks the argument types and - -- ambiguity of the existential context (if any) - addErrCtxt (existentialCtxt con) - (checkFreeness ex_tvs ex_theta) - where - ctxt = ConArgCtxt (dataConName con) - (_, _, ex_tvs, ex_theta, _, _) = dataConSig con - - -fieldTypeMisMatch field_name - = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)] - -existentialCtxt con = ptext SLIT("When checking the existential context of constructor") - <+> quotes (ppr con) -\end{code} - - -checkValidClass is called once the mutually-recursive knot has been -tied, so we can look at things freely. - -\begin{code} -checkValidClass :: Class -> TcM () -checkValidClass cls - = -- CHECK ARITY 1 FOR HASKELL 1.4 - doptM Opt_GlasgowExts `thenM` \ gla_exts -> - - -- Check that the class is unary, unless GlaExs - checkTc (notNull tyvars) (nullaryClassErr cls) `thenM_` - checkTc (gla_exts || unary) (classArityErr cls) `thenM_` - - -- Check the super-classes - checkValidTheta (ClassSCCtxt (className cls)) theta `thenM_` - - -- Check the class operations - mappM_ check_op op_stuff `thenM_` - - -- Check that if the class has generic methods, then the - -- class has only one parameter. We can't do generic - -- multi-parameter type classes! - checkTc (unary || no_generics) (genericMultiParamErr cls) - - where - (tyvars, theta, _, op_stuff) = classBigSig cls - unary = isSingleton tyvars - no_generics = null [() | (_, GenDefMeth) <- op_stuff] - - check_op (sel_id, dm) - = checkValidTheta SigmaCtxt (tail theta) `thenM_` - -- The 'tail' removes the initial (C a) from the - -- class itself, leaving just the method type - - checkValidType (FunSigCtxt op_name) tau `thenM_` - - -- Check that for a generic method, the type of - -- the method is sufficiently simple - checkTc (dm /= GenDefMeth || validGenericMethodType op_ty) - (badGenericMethodType op_name op_ty) - where - op_name = idName sel_id - op_ty = idType sel_id - (_,theta,tau) = tcSplitSigmaTy op_ty - -nullaryClassErr cls - = ptext SLIT("No parameters for class") <+> quotes (ppr cls) - -classArityErr cls - = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls), - parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))] - -genericMultiParamErr clas - = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> - ptext SLIT("cannot have generic methods") - -badGenericMethodType op op_ty - = hang (ptext SLIT("Generic method type is too complex")) - 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, - ptext SLIT("You can only use type variables, arrows, and tuples")]) -\end{code} - - -%************************************************************************ -%* * \subsection{Checking for a decent instance head type} %* * %************************************************************************ diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 1a19b03aa6..21c74dcce4 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -20,22 +20,22 @@ import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..), ReboundNames, pprMatch, getMatchLoc, isDoExpr, pprMatchContext, pprStmtContext, pprStmtResultContext, - mkMonoBind, collectSigTysFromPats, andMonoBindList, glueBindsOnGRHSs + mkMonoBind, collectSigTysFromPats, glueBindsOnGRHSs ) import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedHsExpr, RenamedPat, RenamedMatchContext ) import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, TcExpr, - TcMonoBinds, TcPat, TcStmt, ExprCoFn, + TcPat, TcStmt, ExprCoFn, isIdCoercion, (<$>), (<.>) ) import TcRnMonad -import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) ) import Inst ( tcSyntaxName, tcInstCall ) import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 ) import TcPat ( tcPat, tcMonoPatBndr ) import TcMType ( newTyVarTy, newTyVarTys, zonkTcType ) import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, - tyVarsOfTypes, tidyOpenTypes, tidyOpenType, isSigmaTy, + tyVarsOfTypes, tidyOpenTypes, isSigmaTy, mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind, mkArrowKind, mkAppTy ) import TcBinds ( tcBindsAndThen ) @@ -44,15 +44,13 @@ import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, r checkSigTyVarsWrt, tcSubExp, tcGen ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import Name ( Name ) -import PrelNames ( monadNames, mfixName ) import TysWiredIn ( boolTy, mkListTy, mkPArrTy ) -import Id ( idType, mkSysLocal, mkLocalId ) +import Id ( idType, mkLocalId ) import CoreFVs ( idFreeTyVars ) import BasicTypes ( RecFlag(..) ) import VarSet -import Var ( Id ) import Bag -import Util ( isSingleton, notNull, zipEqual ) +import Util ( isSingleton, notNull ) import Outputable import List ( nub ) @@ -146,9 +144,11 @@ tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty \end{code} \begin{code} -data TcMatchCtxt - = MC { mc_what :: RenamedMatchContext, -- What kind of thing this is - mc_body :: RenamedHsExpr -> Expected TcRhoType -> TcM TcExpr } -- Type checker for a body of an alternative +data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module + = MC { mc_what :: RenamedMatchContext, -- What kind of thing this is + mc_body :: RenamedHsExpr -- Type checker for a body of an alternative + -> Expected TcRhoType + -> TcM TcExpr } tcMatches :: TcMatchCtxt -> [RenamedMatch] @@ -481,7 +481,7 @@ tcStmts ctxt stmts tcStmtsAndThen (:) ctxt stmts (returnM []) data TcStmtCtxt - = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is + = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is sc_rhs :: RenamedHsExpr -> TcType -> TcM TcExpr, -- Type checker for RHS computations sc_body :: RenamedHsExpr -> TcM TcExpr, -- Type checker for return computation sc_ty :: TcType } -- Return type; used *only* to check @@ -634,8 +634,8 @@ sigPatCtxt bound_tvs bound_ids tys tidy_env = -- tys is (body_ty : pat_tys) mapM zonkTcType tys `thenM` \ tys' -> let - (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids) - (env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys' + (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids) + (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys' in returnM (env1, sep [ptext SLIT("When checking an existential match that binds"), diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs deleted file mode 100644 index c257251ee0..0000000000 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ /dev/null @@ -1,772 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[TcMonoType]{Typechecking user-specified @MonoTypes@} - -\begin{code} -module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred, - UserTypeCtxt(..), - - -- Kind checking - kcHsTyVar, kcHsTyVars, mkTyClTyVars, - kcHsType, kcHsSigType, kcHsSigTypes, - kcHsLiftedSigType, kcHsContext, - tcAddScopedTyVars, tcHsTyVars, mkImmutTyVars, - - TcSigInfo(..), tcTySig, mkTcSig, maybeSig, tcSigPolyId, tcSigMonoId - ) where - -#include "HsVersions.h" - -import HsSyn ( HsType(..), HsTyVarBndr(..), HsTyOp(..), - Sig(..), HsPred(..), HsTupCon(..), hsTyVarNames ) -import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars ) -import TcHsSyn ( TcId ) - -import TcRnMonad -import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal, - TyThing(..), TcTyThing(..), tcExtendKindEnv, - getInLocalScope - ) -import TcMType ( newMutTyVar, newKindVar, zonkKindEnv, tcInstType, zonkTcType, - checkValidType, UserTypeCtxt(..), pprUserTypeCtxt, newOpenTypeKind - ) -import TcUnify ( unifyKind, unifyFunKind ) -import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..), - TcTyVar, TcKind, TcThetaType, TcTauType, - mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind, - zipFunTys, mkForAllTys, mkFunTys, tcEqType, isPredTy, - mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, - liftedTypeKind, unliftedTypeKind, eqKind, - tcSplitFunTy_maybe, tcSplitForAllTys - ) -import qualified Type ( splitFunTys ) -import Inst ( Inst, InstOrigin(..), newMethod, instToId ) - -import Id ( mkLocalId, idName, idType ) -import Var ( TyVar, mkTyVar, tyVarKind ) -import ErrUtils ( Message ) -import TyCon ( TyCon, tyConKind ) -import Class ( classTyCon ) -import Name ( Name ) -import NameSet -import Subst ( deShadowTy ) -import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy, genUnitTyCon ) -import BasicTypes ( Boxity(..) ) -import SrcLoc ( SrcLoc ) -import Util ( lengthIs ) -import Outputable -import List ( nubBy ) -\end{code} - - -%************************************************************************ -%* * -\subsection{Checking types} -%* * -%************************************************************************ - -Generally speaking we now type-check types in three phases - - 1. Kind check the HsType [kcHsType] - 2. Convert from HsType to Type, and hoist the foralls [tcHsType] - 3. Check the validity of the resulting type [checkValidType] - -Often these steps are done one after the othe (tcHsSigType). -But in mutually recursive groups of type and class decls we do - 1 kind-check the whole group - 2 build TyCons/Classes in a knot-tied wa - 3 check the validity of types in the now-unknotted TyCons/Classes - -\begin{code} -tcHsSigType :: UserTypeCtxt -> RenamedHsType -> TcM Type - -- Do kind checking, and hoist for-alls to the top -tcHsSigType ctxt ty = addErrCtxt (checkTypeCtxt ctxt ty) ( - kcTypeType ty `thenM_` - tcHsType ty - ) `thenM` \ ty' -> - checkValidType ctxt ty' `thenM_` - returnM ty' - -checkTypeCtxt ctxt ty - = vcat [ptext SLIT("In the type:") <+> ppr ty, - ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ] - -tcHsType :: RenamedHsType -> TcM Type - -- Don't do kind checking, nor validity checking, - -- but do hoist for-alls to the top - -- This is used in type and class decls, where kinding is - -- done in advance, and validity checking is done later - -- [Validity checking done later because of knot-tying issues.] -tcHsType ty = tc_type ty `thenM` \ ty' -> - returnM (hoistForAllTys ty') - -tcHsTheta :: RenamedContext -> TcM ThetaType --- Used when we are expecting a ClassContext (i.e. no implicit params) --- Does not do validity checking, like tcHsType -tcHsTheta hs_theta = mappM tc_pred hs_theta - --- In interface files the type is already kinded, --- and we definitely don't want to hoist for-alls. --- Otherwise we'll change --- dmfail :: forall m:(*->*) Monad m => forall a:* => String -> m a --- into --- dmfail :: forall m:(*->*) a:* Monad m => String -> m a --- which definitely isn't right! -tcIfaceType ty = tc_type ty -\end{code} - - -%************************************************************************ -%* * -\subsection{Kind checking} -%* * -%************************************************************************ - -Kind checking -~~~~~~~~~~~~~ -When we come across the binding site for some type variables, we -proceed in two stages - -1. Figure out what kind each tyvar has - -2. Create suitably-kinded tyvars, - extend the envt, - and typecheck the body - -To do step 1, we proceed thus: - -1a. Bind each type variable to a kind variable -1b. Apply the kind checker -1c. Zonk the resulting kinds - -The kind checker is passed to tcHsTyVars as an argument. - -For example, when we find - (forall a m. m a -> m a) -we bind a,m to kind varibles and kind-check (m a -> m a). This -makes a get kind *, and m get kind *->*. Now we typecheck (m a -> m a) -in an environment that binds a and m suitably. - -The kind checker passed to tcHsTyVars needs to look at enough to -establish the kind of the tyvar: - * For a group of type and class decls, it's just the group, not - the rest of the program - * For a tyvar bound in a pattern type signature, its the types - mentioned in the other type signatures in that bunch of patterns - * For a tyvar bound in a RULE, it's the type signatures on other - universally quantified variables in the rule - -Note that this may occasionally give surprising results. For example: - - data T a b = MkT (a b) - -Here we deduce a::*->*, b::*. -But equally valid would be - a::(*->*)-> *, b::*->* - -\begin{code} --- tcHsTyVars is used for type variables in type signatures --- e.g. forall a. a->a --- They are immutable, because they scope only over the signature --- They may or may not be explicitly-kinded -tcHsTyVars :: [HsTyVarBndr Name] - -> TcM a -- The kind checker - -> ([TyVar] -> TcM b) - -> TcM b - -tcHsTyVars [] kind_check thing_inside = thing_inside [] - -- A useful short cut for a common case! - -tcHsTyVars tv_names kind_check thing_inside - = kcHsTyVars tv_names `thenM` \ tv_names_w_kinds -> - tcExtendKindEnv tv_names_w_kinds kind_check `thenM_` - zonkKindEnv tv_names_w_kinds `thenM` \ tvs_w_kinds -> - let - tyvars = mkImmutTyVars tvs_w_kinds - in - tcExtendTyVarEnv tyvars (thing_inside tyvars) - - - -tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a --- tcAddScopedTyVars is used for scoped type variables --- added by pattern type signatures --- e.g. \ (x::a) (y::a) -> x+y --- They never have explicit kinds (because this is source-code only) --- They are mutable (because they can get bound to a more specific type) - --- Find the not-already-in-scope signature type variables, --- kind-check them, and bring them into scope --- --- We no longer specify that these type variables must be univerally --- quantified (lots of email on the subject). If you want to put that --- back in, you need to --- a) Do a checkSigTyVars after thing_inside --- b) More insidiously, don't pass in expected_ty, else --- we unify with it too early and checkSigTyVars barfs --- Instead you have to pass in a fresh ty var, and unify --- it with expected_ty afterwards -tcAddScopedTyVars [] thing_inside - = thing_inside -- Quick get-out for the empty case - -tcAddScopedTyVars sig_tys thing_inside - = getInLocalScope `thenM` \ in_scope -> - let - all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys - sig_tvs = filter (not . in_scope) (nameSetToList all_sig_tvs) - in - mappM newNamedKindVar sig_tvs `thenM` \ kind_env -> - tcExtendKindEnv kind_env (kcHsSigTypes sig_tys) `thenM_` - zonkKindEnv kind_env `thenM` \ tvs_w_kinds -> - sequenceM [ newMutTyVar name kind PatSigTv - | (name, kind) <- tvs_w_kinds] `thenM` \ tyvars -> - tcExtendTyVarEnv tyvars thing_inside -\end{code} - - -\begin{code} -kcHsTyVar :: HsTyVarBndr name -> TcM (name, TcKind) -kcHsTyVars :: [HsTyVarBndr name] -> TcM [(name, TcKind)] - -kcHsTyVar (UserTyVar name) = newNamedKindVar name -kcHsTyVar (IfaceTyVar name kind) = returnM (name, kind) - -kcHsTyVars tvs = mappM kcHsTyVar tvs - -newNamedKindVar name = newKindVar `thenM` \ kind -> - returnM (name, kind) - ---------------------------- -kcLiftedType :: RenamedHsType -> TcM Kind - -- The type ty must be a *lifted* *type* -kcLiftedType ty = kcHsType ty `thenM` \ act_kind -> - checkExpectedKind (ppr ty) act_kind liftedTypeKind - ---------------------------- -kcTypeType :: RenamedHsType -> TcM () - -- The type ty must be a *type*, but it can be lifted or unlifted. -kcTypeType ty - = kcHsType ty `thenM` \ kind -> - if isTypeKind kind then - return () - else - newOpenTypeKind `thenM` \ exp_kind -> - checkExpectedKind (ppr ty) kind exp_kind `thenM_` - returnM () - ---------------------------- -kcHsSigType, kcHsLiftedSigType :: RenamedHsType -> TcM () - -- Used for type signatures -kcHsSigType ty = kcTypeType ty -kcHsSigTypes tys = mappM_ kcHsSigType tys -kcHsLiftedSigType ty = kcLiftedType ty `thenM_` returnM () - ---------------------------- -kcHsType :: RenamedHsType -> TcM TcKind --- kcHsType *returns* the kind of the type, rather than taking an expected --- kind as argument as tcExpr does. Reason: the kind of (->) is --- forall bx1 bx2. Type bx1 -> Type bx2 -> Type Boxed --- so we'd need to generate huge numbers of bx variables. - -kcHsType (HsTyVar name) = kcTyVar name -kcHsType (HsListTy ty) = kcLiftedType ty -kcHsType (HsPArrTy ty) = kcLiftedType ty -kcHsType (HsParTy ty) = kcHsType ty -- Skip parentheses markers -kcHsType (HsNumTy _) = returnM liftedTypeKind -- The unit type for generics -kcHsType (HsKindSig ty k) = kcHsType ty `thenM` \ act_kind -> - checkExpectedKind (ppr ty) act_kind k - -kcHsType (HsTupleTy (HsTupCon boxity _) tys) - = mappM kcTypeType tys `thenM_` - returnM (case boxity of - Boxed -> liftedTypeKind - Unboxed -> unliftedTypeKind) - -kcHsType (HsFunTy ty1 ty2) - = kcTypeType ty1 `thenM_` - kcTypeType ty2 `thenM_` - returnM liftedTypeKind - -kcHsType (HsOpTy ty1 HsArrow ty2) - = kcTypeType ty1 `thenM_` - kcTypeType ty2 `thenM_` - returnM liftedTypeKind - -kcHsType ty@(HsOpTy ty1 op_ty@(HsTyOp op) ty2) - = addErrCtxt (appKindCtxt (ppr ty)) $ - kcTyVar op `thenM` \ op_kind -> - kcApps (ppr op_ty) op_kind [ty1,ty2] - -kcHsType (HsPredTy pred) - = kcHsPred pred `thenM_` - returnM liftedTypeKind - -kcHsType ty@(HsAppTy ty1 ty2) - = addErrCtxt (appKindCtxt (ppr ty)) $ - kc_app ty [] - where - kc_app (HsAppTy f a) as = kc_app f (a:as) - kc_app f as = kcHsType f `thenM` \ fk -> - kcApps (ppr f) fk as - -kcHsType (HsForAllTy (Just tv_names) context ty) - = kcHsTyVars tv_names `thenM` \ kind_env -> - tcExtendKindEnv kind_env $ - kcHsContext context `thenM_` - kcLiftedType ty - -- The body of a forall must be of kind * - -- In principle, I suppose, we could allow unlifted types, - -- but it seems simpler to stick to lifted types for now. - ---------------------------- -kcApps :: SDoc -- The function - -> TcKind -- Function kind - -> [RenamedHsType] -- Arg types - -> TcM TcKind -- Result kind -kcApps pp_fun fun_kind args - = go fun_kind args - where - go fk [] = returnM fk - go fk (ty:tys) = unifyFunKind fk `thenM` \ mb_fk -> - case mb_fk of { - Nothing -> failWithTc too_few_args ; - Just (ak',fk') -> - kcHsType ty `thenM` \ ak -> - checkExpectedKind (ppr ty) ak ak' `thenM_` - go fk' tys } - - too_few_args = ptext SLIT("Kind error:") <+> quotes pp_fun <+> - ptext SLIT("is applied to too many type arguments") - ---------------------------- --- We would like to get a decent error message from --- (a) Under-applied type constructors --- f :: (Maybe, Maybe) --- (b) Over-applied type constructors --- f :: Int x -> Int x --- - -checkExpectedKind :: SDoc -> TcKind -> TcKind -> TcM TcKind --- A fancy wrapper for 'unifyKind', which tries to give --- decent error messages. --- Returns the same kind that it is passed, exp_kind -checkExpectedKind pp_ty act_kind exp_kind - | act_kind `eqKind` exp_kind -- Short cut for a very common case - = returnM exp_kind - | otherwise - = tryTc (unifyKind exp_kind act_kind) `thenM` \ (errs, mb_r) -> - case mb_r of { - Just _ -> returnM exp_kind ; -- Unification succeeded - Nothing -> - - -- So there's definitely an error - -- Now to find out what sort - zonkTcType exp_kind `thenM` \ exp_kind -> - zonkTcType act_kind `thenM` \ act_kind -> - - let (exp_as, _) = Type.splitFunTys exp_kind - (act_as, _) = Type.splitFunTys act_kind - -- Use the Type versions for kinds - n_exp_as = length exp_as - n_act_as = length act_as - - err | n_exp_as < n_act_as -- E.g. [Maybe] - = quotes pp_ty <+> ptext SLIT("is not applied to enough type arguments") - - -- Now n_exp_as >= n_act_as. In the next two cases, - -- n_exp_as == 0, and hence so is n_act_as - | exp_kind `eqKind` liftedTypeKind && act_kind `eqKind` unliftedTypeKind - = ptext SLIT("Expecting a lifted type, but") <+> quotes pp_ty - <+> ptext SLIT("is unlifted") - - | exp_kind `eqKind` unliftedTypeKind && act_kind `eqKind` liftedTypeKind - = ptext SLIT("Expecting an unlifted type, but") <+> quotes pp_ty - <+> ptext SLIT("is lifted") - - | otherwise -- E.g. Monad [Int] - = sep [ ptext SLIT("Expecting kind") <+> quotes (ppr exp_kind) <> comma, - ptext SLIT("but") <+> quotes pp_ty <+> - ptext SLIT("has kind") <+> quotes (ppr act_kind)] - in - failWithTc (ptext SLIT("Kind error:") <+> err) - } - ---------------------------- -kc_pred :: RenamedHsPred -> TcM TcKind -- Does *not* check for a saturated - -- application (reason: used from TcDeriv) -kc_pred pred@(HsIParam name ty) - = kcHsType ty - -kc_pred pred@(HsClassP cls tys) - = kcClass cls `thenM` \ kind -> - kcApps (ppr cls) kind tys - ---------------------------- -kcHsContext ctxt = mappM_ kcHsPred ctxt - -kcHsPred pred -- Checks that the result is of kind liftedType - = addErrCtxt (appKindCtxt (ppr pred)) $ - kc_pred pred `thenM` \ kind -> - checkExpectedKind (ppr pred) kind liftedTypeKind - - - --------------------------- -kcTyVar name -- Could be a tyvar or a tycon - = tcLookup name `thenM` \ thing -> - case thing of - AThing kind -> returnM kind - ATyVar tv -> returnM (tyVarKind tv) - AGlobal (ATyCon tc) -> returnM (tyConKind tc) - other -> failWithTc (wrongThingErr "type" thing name) - -kcClass cls -- Must be a class - = tcLookup cls `thenM` \ thing -> - case thing of - AThing kind -> returnM kind - AGlobal (AClass cls) -> returnM (tyConKind (classTyCon cls)) - other -> failWithTc (wrongThingErr "class" thing cls) -\end{code} - -%************************************************************************ -%* * -\subsection{tc_type} -%* * -%************************************************************************ - -tc_type, the main work horse -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ------------------- - *** BIG WARNING *** - ------------------- - -tc_type is used to typecheck the types in the RHS of data -constructors. In the case of recursive data types, that means that -the type constructors themselves are (partly) black holes. e.g. - - data T a = MkT a [T a] - -While typechecking the [T a] on the RHS, T itself is not yet fully -defined. That in turn places restrictions on what you can check in -tcHsType; if you poke on too much you get a black hole. I keep -forgetting this, hence this warning! - -So tc_type does no validity-checking. Instead that's all done -by TcMType.checkValidType - - -------------------------- - *** END OF BIG WARNING *** - -------------------------- - - -\begin{code} -tc_type :: RenamedHsType -> TcM Type - -tc_type ty@(HsTyVar name) - = tc_app ty [] - -tc_type (HsKindSig ty k) - = tc_type ty -- Kind checking done already - -tc_type (HsListTy ty) - = tc_type ty `thenM` \ tau_ty -> - returnM (mkListTy tau_ty) - -tc_type (HsPArrTy ty) - = tc_type ty `thenM` \ tau_ty -> - returnM (mkPArrTy tau_ty) - -tc_type (HsTupleTy (HsTupCon boxity arity) tys) - = ASSERT( tys `lengthIs` arity ) - tc_types tys `thenM` \ tau_tys -> - returnM (mkTupleTy boxity arity tau_tys) - -tc_type (HsFunTy ty1 ty2) - = tc_type ty1 `thenM` \ tau_ty1 -> - tc_type ty2 `thenM` \ tau_ty2 -> - returnM (mkFunTy tau_ty1 tau_ty2) - -tc_type (HsOpTy ty1 HsArrow ty2) - = tc_type ty1 `thenM` \ tau_ty1 -> - tc_type ty2 `thenM` \ tau_ty2 -> - returnM (mkFunTy tau_ty1 tau_ty2) - -tc_type (HsOpTy ty1 (HsTyOp op) ty2) - = tc_type ty1 `thenM` \ tau_ty1 -> - tc_type ty2 `thenM` \ tau_ty2 -> - tc_fun_type op [tau_ty1,tau_ty2] - -tc_type (HsParTy ty) -- Remove the parentheses markers - = tc_type ty - -tc_type (HsNumTy n) - = ASSERT(n== 1) - returnM (mkTyConApp genUnitTyCon []) - -tc_type ty@(HsAppTy ty1 ty2) - = addErrCtxt (appKindCtxt (ppr ty)) $ - tc_app ty1 [ty2] - -tc_type (HsPredTy pred) - = tc_pred pred `thenM` \ pred' -> - returnM (mkPredTy pred') - -tc_type full_ty@(HsForAllTy (Just tv_names) ctxt ty) - = let - kind_check = kcHsContext ctxt `thenM_` kcHsType ty - in - tcHsTyVars tv_names kind_check $ \ tyvars -> - mappM tc_pred ctxt `thenM` \ theta -> - tc_type ty `thenM` \ tau -> - returnM (mkSigmaTy tyvars theta tau) - -tc_types arg_tys = mappM tc_type arg_tys -\end{code} - -Help functions for type applications -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -\begin{code} -tc_app :: RenamedHsType -> [RenamedHsType] -> TcM Type -tc_app (HsAppTy ty1 ty2) tys - = tc_app ty1 (ty2:tys) - -tc_app ty tys - = tc_types tys `thenM` \ arg_tys -> - case ty of - HsTyVar fun -> tc_fun_type fun arg_tys - other -> tc_type ty `thenM` \ fun_ty -> - returnM (mkAppTys fun_ty arg_tys) - --- (tc_fun_type ty arg_tys) returns (mkAppTys ty arg_tys) --- But not quite; for synonyms it checks the correct arity, and builds a SynTy --- hence the rather strange functionality. - -tc_fun_type name arg_tys - = tcLookup name `thenM` \ thing -> - case thing of - ATyVar tv -> returnM (mkAppTys (mkTyVarTy tv) arg_tys) - - AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys) - - other -> failWithTc (wrongThingErr "type constructor" thing name) -\end{code} - - -Contexts -~~~~~~~~ -\begin{code} -tcHsPred pred = kc_pred pred `thenM_` tc_pred pred - -- Is happy with a partial application, e.g. (ST s) - -- Used from TcDeriv - -tc_pred assn@(HsClassP class_name tys) - = addErrCtxt (appKindCtxt (ppr assn)) $ - tc_types tys `thenM` \ arg_tys -> - tcLookupGlobal class_name `thenM` \ thing -> - case thing of - AClass clas -> returnM (ClassP clas arg_tys) - other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name) - -tc_pred assn@(HsIParam name ty) - = addErrCtxt (appKindCtxt (ppr assn)) $ - tc_type ty `thenM` \ arg_ty -> - returnM (IParam name arg_ty) -\end{code} - - - -%************************************************************************ -%* * -\subsection{Type variables, with knot tying!} -%* * -%************************************************************************ - -\begin{code} -mkImmutTyVars :: [(Name,Kind)] -> [TyVar] -mkImmutTyVars pairs = [mkTyVar name kind | (name, kind) <- pairs] - -mkTyClTyVars :: Kind -- Kind of the tycon or class - -> [HsTyVarBndr Name] - -> [TyVar] -mkTyClTyVars kind tyvar_names - = mkImmutTyVars tyvars_w_kinds - where - (tyvars_w_kinds, _) = zipFunTys (hsTyVarNames tyvar_names) kind -\end{code} - - -%************************************************************************ -%* * -\subsection{Signatures} -%* * -%************************************************************************ - -@tcSigs@ checks the signatures for validity, and returns a list of -{\em freshly-instantiated} signatures. That is, the types are already -split up, and have fresh type variables installed. All non-type-signature -"RenamedSigs" are ignored. - -The @TcSigInfo@ contains @TcTypes@ because they are unified with -the variable's type, and after that checked to see whether they've -been instantiated. - -\begin{code} -data TcSigInfo - = TySigInfo - TcId -- *Polymorphic* binder for this value... - -- Has name = N - - [TcTyVar] -- tyvars - TcThetaType -- theta - TcTauType -- tau - - TcId -- *Monomorphic* binder for this value - -- Does *not* have name = N - -- Has type tau - - [Inst] -- Empty if theta is null, or - -- (method mono_id) otherwise - - SrcLoc -- Of the signature - -instance Outputable TcSigInfo where - ppr (TySigInfo id tyvars theta tau _ inst loc) = - ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau - -tcSigPolyId :: TcSigInfo -> TcId -tcSigPolyId (TySigInfo id _ _ _ _ _ _) = id - -tcSigMonoId :: TcSigInfo -> TcId -tcSigMonoId (TySigInfo _ _ _ _ id _ _) = id - -maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo) - -- Search for a particular signature -maybeSig [] name = Nothing -maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name - | name == idName sig_id = Just sig - | otherwise = maybeSig sigs name -\end{code} - - -\begin{code} -tcTySig :: RenamedSig -> TcM TcSigInfo - -tcTySig (Sig v ty src_loc) - = addSrcLoc src_loc $ - tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty -> - mkTcSig (mkLocalId v sigma_tc_ty) `thenM` \ sig -> - returnM sig - -mkTcSig :: TcId -> TcM TcSigInfo -mkTcSig poly_id - = -- Instantiate this type - -- It's important to do this even though in the error-free case - -- we could just split the sigma_tc_ty (since the tyvars don't - -- unified with anything). But in the case of an error, when - -- the tyvars *do* get unified with something, we want to carry on - -- typechecking the rest of the program with the function bound - -- to a pristine type, namely sigma_tc_ty - tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') -> - - getInstLoc SignatureOrigin `thenM` \ inst_loc -> - newMethod inst_loc poly_id - (mkTyVarTys tyvars') - theta' tau' `thenM` \ inst -> - -- We make a Method even if it's not overloaded; no harm - -- But do not extend the LIE! We're just making an Id. - - getSrcLocM `thenM` \ src_loc -> - returnM (TySigInfo poly_id tyvars' theta' tau' - (instToId inst) [inst] src_loc) -\end{code} - - -%************************************************************************ -%* * -\subsection{Errors and contexts} -%* * -%************************************************************************ - - -\begin{code} -hoistForAllTys :: Type -> Type --- Used for user-written type signatures only --- Move all the foralls and constraints to the top --- e.g. T -> forall a. a ==> forall a. T -> a --- T -> (?x::Int) -> Int ==> (?x::Int) -> T -> Int --- --- Also: eliminate duplicate constraints. These can show up --- when hoisting constraints, notably implicit parameters. --- --- We want to 'look through' type synonyms when doing this --- so it's better done on the Type than the HsType - -hoistForAllTys ty - = let - no_shadow_ty = deShadowTy ty - -- Running over ty with an empty substitution gives it the - -- no-shadowing property. This is important. For example: - -- type Foo r = forall a. a -> r - -- foo :: Foo (Foo ()) - -- Here the hoisting should give - -- foo :: forall a a1. a -> a1 -> () - -- - -- What about type vars that are lexically in scope in the envt? - -- We simply rely on them having a different unique to any - -- binder in 'ty'. Otherwise we'd have to slurp the in-scope-tyvars - -- out of the envt, which is boring and (I think) not necessary. - in - case hoist no_shadow_ty of - (tvs, theta, body) -> mkForAllTys tvs (mkFunTys (nubBy tcEqType theta) body) - -- The 'nubBy' eliminates duplicate constraints, - -- notably implicit parameters - where - hoist ty - | (tvs1, body_ty) <- tcSplitForAllTys ty, - not (null tvs1) - = case hoist body_ty of - (tvs2,theta,tau) -> (tvs1 ++ tvs2, theta, tau) - - | Just (arg, res) <- tcSplitFunTy_maybe ty - = let - arg' = hoistForAllTys arg -- Don't forget to apply hoist recursively - in -- to the argument type - if (isPredTy arg') then - case hoist res of - (tvs,theta,tau) -> (tvs, arg':theta, tau) - else - case hoist res of - (tvs,theta,tau) -> (tvs, theta, mkFunTy arg' tau) - - | otherwise = ([], [], ty) -\end{code} - - -%************************************************************************ -%* * -\subsection{Errors and contexts} -%* * -%************************************************************************ - -\begin{code} -typeKindCtxt :: RenamedHsType -> Message -typeKindCtxt ty = sep [ptext SLIT("When checking that"), - nest 2 (quotes (ppr ty)), - ptext SLIT("is a type")] - -appKindCtxt :: SDoc -> Message -appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp - -wrongThingErr expected thing name - = pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected - where - pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor") - pp_thing (AGlobal (AClass _)) = ptext SLIT("Class") - pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier") - pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor") - pp_thing (ATyVar _) = ptext SLIT("Type variable") - pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier") - pp_thing (AThing _) = ptext SLIT("Utterly bogus") -\end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index b0bb16bf9c..8f6840452e 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -30,7 +30,7 @@ import TcType ( TcType, TcTyVar, TcSigmaType, mkClassPred, liftedTypeKind ) import TcUnify ( tcSubOff, Expected(..), readExpectedType, zapExpectedType, unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TysWiredIn ( stringTy ) import CmdLineOpts ( opt_IrrefutableTuples ) @@ -271,8 +271,8 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty -- But in NPat, the literal is used to find identical patterns -- so we must negate the literal when necessary! lit' = case (over_lit, mb_neg) of - (HsIntegral i _, Nothing) -> HsInteger i - (HsIntegral i _, Just _) -> HsInteger (-i) + (HsIntegral i _, Nothing) -> HsInteger i pat_ty' + (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty' (HsFractional f _, Nothing) -> HsRat f pat_ty' (HsFractional f _, Just _) -> HsRat (-f) pat_ty' in diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 60d1d95569..20d0d216c6 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -6,10 +6,10 @@ \begin{code} module TcRnDriver ( #ifdef GHCI - mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr, + mkExportEnv, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr, #endif - tcRnModule, checkOldIface, - importSupportingDecls, tcTopSrcDecls, + tcRnModule, + tcTopSrcDecls, tcRnIface, tcRnExtCore ) where @@ -17,109 +17,103 @@ module TcRnDriver ( #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) -import DsMeta ( templateHaskellNames ) #endif import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import DriverState ( v_MainModIs, v_MainFunIs ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), - Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), - HsGroup(..), SpliceDecl(..), - mkSimpleMatch, placeHolderType, toHsType, andMonoBinds, - isSrcRule, collectStmtsBinders + HsGroup(..), SpliceDecl(..), HsExtCore(..), + andMonoBinds ) -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, - emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual ) - -import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, - returnIOName, runIOName, - rootMainName, itName, mAIN_Name - ) -import RdrName ( RdrName, getRdrName, mkRdrUnqual, - lookupRdrEnv, elemRdrEnv ) - -import RnHsSyn ( RenamedStmt, RenamedTyClDecl, - ruleDeclFVs, instDeclFVs, tyClDeclFVs ) -import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, - zonkTopDecls, mkHsLet, - zonkTopExpr, zonkTopBndrs - ) - -import TcExpr ( tcInferRho, tcCheckRho ) +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, + findSplice, main_RDR_Unqual ) + +import PrelNames ( runIOName, rootMainName, mAIN_Name ) +import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, + plusGlobalRdrEnv ) +import TcHsSyn ( zonkTopDecls ) +import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( Type, - tyVarsOfType, tcFunResultTy, tidyTopType, - mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys - ) -import Inst ( showLIE, tcStdSyntaxName ) -import MkId ( unsafeCoerceId ) +import TcType ( tidyTopType ) +import Inst ( showLIE ) import TcBinds ( tcTopBinds ) -import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, - tcExtendInstEnv, tcExtendRules, - tcLookupTyCon, tcLookupGlobal, - tcLookupId - ) +import TcEnv ( tcExtendGlobalValEnv, tcLookupGlobal ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) -import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds ) -import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 ) -import TcSimplify ( tcSimplifyTop, tcSimplifyInteractive, tcSimplifyInfer ) +import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) +import TcIface ( typecheckIface, tcExtCoreBindings ) +import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) - +import LoadIface ( loadOrphanModules ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, reportUnusedNames ) -import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate ) -import RnHiFiles ( readIface, loadOldIface ) -import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv, - ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) -import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) - -import CoreUnfold ( unfoldingTemplate ) -import CoreSyn ( IdCoreRule, Bind(..) ) +import RnEnv ( lookupSrcOcc_maybe ) +import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) import PprCore ( pprIdRules, pprCoreBindings ) -import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors ) -import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported ) -import Var ( Var, setGlobalIdDetails ) -import Module ( Module, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts ) +import CoreSyn ( IdCoreRule, bindersOfBinds ) +import ErrUtils ( mkDumpDoc, showPass ) +import Id ( mkLocalId, isLocalId, idName, idType, setIdLocalExported ) +import Var ( Var ) +import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, nameOccName ) +import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet -import TyCon ( tyConGenInfo ) -import BasicTypes ( EP(..), RecFlag(..) ) +import TyCon ( tyConHasGenerics ) import Outputable -import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), - ModIface, ModDetails(..), ModGuts(..), - HscEnv(..), - ModIface(..), ModDetails(..), IfaceDecls(..), +import HscTypes ( ModIface, ModDetails(..), ModGuts(..), + HscEnv(..), ModIface(..), ModDetails(..), GhciMode(..), noDependencies, - Deprecations(..), plusDeprecs, - emptyGlobalRdrEnv, - GenAvailInfo(Avail), availsToNameSet, - ForeignStubs(..), - TypeEnv, TyThing, typeEnvTyCons, + Deprecs( NoDeprecs ), plusDeprecs, + GenAvailInfo(Avail), availsToNameSet, availName, + ForeignStubs(NoStubs), TypeEnv, typeEnvTyCons, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, - extendLocalRdrEnv, emptyFixityEnv + emptyFixityEnv ) #ifdef GHCI +import HsSyn ( HsStmtContext(..), + Stmt(..), Pat(VarPat), + collectStmtsBinders, mkSimpleMatch, placeHolderType ) +import RdrHsSyn ( RdrNameHsExpr, RdrNameStmt ) +import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), + Provenance(..), ImportSpec(..), + lookupLocalRdrEnv, extendLocalRdrEnv ) +import RnHsSyn ( RenamedStmt ) +import RnSource ( addTcgDUs ) +import TcHsSyn ( TypecheckedHsExpr, mkHsLet, zonkTopExpr, zonkTopBndrs ) +import TcExpr ( tcCheckRho ) import TcMType ( zonkTcType ) import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) -import RdrName ( rdrEnvElts ) +import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) +import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType ) +import TcEnv ( tcLookupTyCon, tcLookupId ) +import TyCon ( DataConDetails(..) ) +import Inst ( tcStdSyntaxName ) import RnExpr ( rnStmts, rnExpr ) -import RnHiFiles ( loadInterface ) -import RnEnv ( mkGlobalRdrEnv ) +import RnNames ( exportsToAvails ) +import LoadIface ( loadSysInterface ) +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), + tyThingToIfaceDecl ) +import IfaceEnv ( tcIfaceGlobal ) +import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) +import Id ( Id, isImplicitId ) +import MkId ( unsafeCoerceId ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( interactiveSrcLoc ) +import Var ( setGlobalIdDetails ) +import Name ( nameOccName, nameModuleName ) import NameEnv ( delListFromNameEnv ) -import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), - isLocalGRE ) +import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) +import Module ( ModuleName, lookupModuleEnvByName ) +import HscTypes ( InteractiveContext(..), + HomeModInfo(..), typeEnvElts, + TyThing(..), availNames, icPrintUnqual ) +import BasicTypes ( RecFlag(..), Fixity ) +import Panic ( ghcError, GhcException(..) ) #endif import FastString ( mkFastString ) -import Panic ( showException ) -import List ( partition ) import Util ( sortLt ) \end{code} @@ -133,11 +127,11 @@ import Util ( sortLt ) \begin{code} -tcRnModule :: HscEnv -> PersistentCompilerState +tcRnModule :: HscEnv -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe TcGblEnv) + -> IO (Maybe TcGblEnv) -tcRnModule hsc_env pcs +tcRnModule hsc_env (HsModule maybe_mod exports import_decls local_decls mod_deprec loc) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; @@ -145,7 +139,7 @@ tcRnModule hsc_env pcs Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted Just mod -> mod } ; -- The normal case - initTc hsc_env pcs this_mod $ addSrcLoc loc $ + initTc hsc_env this_mod $ addSrcLoc loc $ do { -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, @@ -157,24 +151,19 @@ tcRnModule hsc_env pcs -- of the tcg_env we have now set failIfErrsM ; + -- Load any orphan-module interfaces, so that + -- their rules and instance decls will be found + loadOrphanModules (imp_orphs imports) ; + traceRn (text "rn1a") ; -- Rename and type check the declarations - (tcg_env, src_dus) <- tcRnSrcDecls local_decls ; + tcg_env <- tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { traceRn (text "rn3") ; - -- Check whether the entire module is deprecated - -- This happens only once per module - -- Returns the full new deprecations; a module deprecation - -- over-rides the earlier ones - let { mod_deprecs = checkModDeprec mod_deprec } ; - updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs }) - $ do { -- Process the export list export_avails <- exportsFromAvail maybe_mod exports ; - updGblEnv (\gbl -> gbl { tcg_exports = export_avails }) - $ do { -- Get any supporting decls for the exports that have not already -- been sucked in for the declarations in the body of the module. @@ -183,21 +172,30 @@ tcRnModule hsc_env pcs -- Importing these supporting declarations is required -- *only* to gether usage information -- (see comments with MkIface.mkImportInfo for why) - -- For OneShot compilation we could just throw away the decls - -- but for Batch or Interactive we must put them in the type - -- envt because they've been removed from the holding pen - let { export_fvs = availsToNameSet export_avails } ; - tcg_env <- importSupportingDecls export_fvs ; - setGblEnv tcg_env $ do { + -- We don't need the results, but sucking them in may side-effect + -- the ExternalPackageState, apart from recording usage + mappM (tcLookupGlobal . availName) export_avails ; + + -- Check whether the entire module is deprecated + -- This happens only once per module + let { mod_deprecs = checkModDeprec mod_deprec } ; + + -- Add exports and deprecations to envt + let { export_fvs = availsToNameSet export_avails ; + final_env = tcg_env { tcg_exports = export_avails, + tcg_dus = tcg_dus tcg_env `plusDU` usesOnly export_fvs, + tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` + mod_deprecs } + -- A module deprecation over-rides the earlier ones + } ; -- Report unused names - let { all_dus = src_dus `plusDU` usesOnly export_fvs } ; - reportUnusedNames tcg_env all_dus ; + reportUnusedNames final_env ; -- Dump output and return - tcDump tcg_env ; - return tcg_env - }}}}}}} + tcDump final_env ; + return final_env + }}}} \end{code} @@ -212,42 +210,10 @@ IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they n \begin{code} tcRnIface :: HscEnv - -> PersistentCompilerState -> ModIface -- Get the decls from here - -> IO (PersistentCompilerState, Maybe ModDetails) - -- Nothing <=> errors happened -tcRnIface hsc_env pcs - (ModIface {mi_module = mod, mi_decls = iface_decls}) - = initTc hsc_env pcs mod $ do { - - -- Get the supporting decls, and typecheck them all together - -- so that any mutually recursive types are done right - extra_decls <- slurpImpDecls needed ; - env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ; - - returnM (ModDetails { md_types = tcg_type_env env, - md_insts = tcg_insts env, - md_rules = hsCoreRules (tcg_rules env) - -- All the rules from an interface are of the IfaceRuleOut form - }) } - where - rule_decls = dcl_rules iface_decls - inst_decls = dcl_insts iface_decls - tycl_decls = dcl_tycl iface_decls - group = emptyGroup { hs_ruleds = rule_decls, - hs_instds = inst_decls, - hs_tyclds = tycl_decls } - needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` - unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` - unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets` - ubiquitousNames - -- Data type decls with record selectors, - -- which may appear in the decls, need unpackCString - -- and friends. It's easier to just grab them right now. - -hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule] --- All post-typechecking Iface rules have the form IfaceRuleOut -hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules] + -> IO ModDetails +tcRnIface hsc_env iface + = initIfaceIO hsc_env (typecheckIface iface) \end{code} @@ -259,41 +225,25 @@ hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules] \begin{code} #ifdef GHCI -tcRnStmt :: HscEnv -> PersistentCompilerState +tcRnStmt :: HscEnv -> InteractiveContext -> RdrNameStmt - -> IO (PersistentCompilerState, - Maybe (InteractiveContext, [Name], TypecheckedHsExpr)) + -> IO (Maybe (InteractiveContext, [Name], TypecheckedHsExpr)) -- The returned [Name] is the same as the input except for -- ExprStmt, in which case the returned [Name] is [itName] -- -- The returned TypecheckedHsExpr is of type IO [ () ], -- a list of the bound values, coerced to (). -tcRnStmt hsc_env pcs ictxt rdr_stmt - = initTc hsc_env pcs iNTERACTIVE $ +tcRnStmt hsc_env ictxt rdr_stmt + = initTc hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - ([rn_stmt], fvs) <- initRnInteractive ictxt - (rnStmts DoExpr [rdr_stmt]) ; + ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; - -- Suck in the supporting declarations and typecheck them - tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ; - -- NB: an earlier version deleted (rdrEnvElts local_env) from - -- the fvs. But (a) that isn't necessary, because previously - -- bound things in the local_env will be in the TypeEnv, and - -- the renamer doesn't re-slurp such things, and - -- (b) it's WRONG to delete them. Consider in GHCi: - -- Mod> let x = e :: T - -- Mod> let y = x + 3 - -- We need to pass 'x' among the fvs to slurpImpDecls, so that - -- the latter can see that T is a gate, and hence import the Num T - -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.) - setGblEnv tcg_env $ do { - -- The real work is done here (bound_ids, tc_expr) <- tcUserStmt rn_stmt ; @@ -318,7 +268,7 @@ tcRnStmt hsc_env pcs ictxt rdr_stmt -- a space leak if we leave them there shadowed = [ n | name <- bound_names, let rdr_name = mkRdrUnqual (nameOccName name), - Just n <- [lookupRdrEnv rn_env rdr_name] ] ; + Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; filtered_type_env = delListFromNameEnv type_env shadowed ; new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; @@ -332,7 +282,7 @@ tcRnStmt hsc_env pcs ictxt rdr_stmt text "Typechecked expr" <+> ppr tc_expr]) ; returnM (new_ic, bound_names, tc_expr) - }} + } \end{code} @@ -423,10 +373,10 @@ tc_stmts stmts -- where they will all be in scope ids <- mappM tcLookupId names ; ret_id <- tcLookupId returnIOName ; -- return @ IO - return (ids, [ResultStmt (mk_return ret_id ids) noSrcLoc]) } ; + return (ids, [ResultStmt (mk_return ret_id ids) interactiveSrcLoc]) } ; io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; - return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty noSrcLoc) + return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty interactiveSrcLoc) } ; -- Simplify the context right here, so that we fail @@ -453,21 +403,17 @@ tc_stmts stmts tcRnExpr just finds the type of an expression \begin{code} -tcRnExpr :: HscEnv -> PersistentCompilerState +tcRnExpr :: HscEnv -> InteractiveContext -> RdrNameHsExpr - -> IO (PersistentCompilerState, Maybe Type) -tcRnExpr hsc_env pcs ictxt rdr_expr - = initTc hsc_env pcs iNTERACTIVE $ + -> IO (Maybe Type) +tcRnExpr hsc_env ictxt rdr_expr + = initTc hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { - (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ; + (rn_expr, fvs) <- rnExpr rdr_expr ; failIfErrsM ; - -- Suck in the supporting declarations and typecheck them - tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ; - setGblEnv tcg_env $ do { - -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; @@ -478,24 +424,24 @@ tcRnExpr hsc_env pcs ictxt rdr_expr mkFunTys (map idType dict_ids) $ res_ty } ; zonkTcType all_expr_ty - }} + } where smpl_doc = ptext SLIT("main expression") \end{code} \begin{code} -tcRnThing :: HscEnv -> PersistentCompilerState +tcRnThing :: HscEnv -> InteractiveContext -> RdrName - -> IO (PersistentCompilerState, Maybe [TyThing]) + -> IO (Maybe [(IfaceDecl, Fixity)]) -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace, -- but we want to treat it as *both* a data constructor -- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results -tcRnThing hsc_env pcs ictxt rdr_name - = initTc hsc_env pcs iNTERACTIVE $ +tcRnThing hsc_env ictxt rdr_name + = initTc hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { -- If the identifier is a constructor (begins with an @@ -504,8 +450,7 @@ tcRnThing hsc_env pcs ictxt rdr_name let { rdr_names = dataTcOccs rdr_name } ; -- results :: [(Messages, Maybe Name)] - results <- initRnInteractive ictxt - (mapM (tryTc . lookupOccRn) rdr_names) ; + results <- mapM (tryTc . lookupOccRn) rdr_names ; -- The successful lookups will be (Just name) let { (warns_s, good_names) = unzip [ (msgs, name) @@ -523,30 +468,32 @@ tcRnThing hsc_env pcs ictxt rdr_name else -- Add deprecation warnings mapM_ addMessages warns_s ; - -- Slurp in the supporting declarations - tcg_env <- importSupportingDecls (mkFVs good_names) ; - setGblEnv tcg_env $ do { - -- And lookup up the entities - mapM tcLookupGlobal good_names - }} + mapM do_one good_names + } + where + do_one name = do { thing <- tcLookupGlobal name + ; fixity <- lookupFixityRn name + ; return (toIfaceDecl ictxt thing, fixity) } + +toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl +toIfaceDecl ictxt thing + = tyThingToIfaceDecl True {- Discard IdInfo -} ext_nm thing + where + unqual = icPrintUnqual ictxt + ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack + | otherwise = ExtPkg (nameModuleName n) (nameOccName n) \end{code} \begin{code} -setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a +setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a setInteractiveContext icxt thing_inside = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_` - updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_type_env = ic_type_env icxt }) - thing_inside - -initRnInteractive :: InteractiveContext -> RnM a -> TcM a --- Set the local RdrEnv from the interactive context -initRnInteractive ictxt rn_thing - = initRn CmdLineMode $ - setLocalRdrEnv (ic_rn_local_env ictxt) $ - rn_thing + (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt, + tcg_type_env = ic_type_env icxt}) $ + updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $ + thing_inside) #endif /* GHCI */ \end{code} @@ -557,47 +504,46 @@ initRnInteractive ictxt rn_thing %************************************************************************ \begin{code} -tcRnExtCore :: HscEnv -> PersistentCompilerState - -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe ModGuts) +tcRnExtCore :: HscEnv + -> HsExtCore RdrName + -> IO (Maybe ModGuts) -- Nothing => some error occurred -tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) - -- For external core, the module name is syntactically reqd - -- Rename the (Core) module. It's a bit like an interface - -- file: all names are original names +tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) + -- The decls are IfaceDecls; all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - initTc hsc_env pcs this_mod $ addSrcLoc loc $ do { + initTc hsc_env this_mod $ do { - -- Rename the source, only in interface mode. - -- rnSrcDecls handles fixity decls etc too, which won't occur - -- but that doesn't matter - let { local_group = mkGroup decls } ; - (_, rn_src_decls, dus) <- initRn (InterfaceMode this_mod) - (rnSrcDecls local_group) ; - failIfErrsM ; + -- Deal with the type declarations; first bring their stuff + -- into scope, then rname them, then type check them + (rdr_env, imports) <- importsFromLocalDecls $ + HsGroup { hs_tyclds = decls, hs_valds = EmptyBinds, hs_fords = [] } ; + -- Rather clumsy; lots of unused fields - -- Get the supporting decls - rn_imp_decls <- slurpImpDecls (duUses dus) ; - let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` tcg_imports gbl }) + $ do { + + rn_decls <- rnTyClDecls decls ; + failIfErrsM ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; - rnStats rn_imp_decls ; -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- typecheckIfaceDecls rn_decls ; + tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ; + -- Make the new type env available to stuff slurped from interface files + setGblEnv tcg_env $ do { -- Now the core bindings - core_prs <- tcCoreBinds (hs_coreds rn_decls) ; - tcExtendGlobalValEnv (map fst core_prs) $ do { - + core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ; + -- Wrap up let { - bndrs = map fst core_prs ; + bndrs = bindersOfBinds core_binds ; my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? @@ -610,8 +556,8 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, - mg_rules = hsCoreRules (tcg_rules tcg_env), - mg_binds = [Rec core_prs], + mg_rules = [], + mg_binds = core_binds, -- Stubs mg_rdr_env = emptyGlobalRdrEnv, @@ -634,12 +580,12 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) %************************************************************************ \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses) +tcRnSrcDecls :: [RdrNameHsDecl] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings tcRnSrcDecls decls - = do { -- Do all the declarations - ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ; + = do { -- Do all the declarations + (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ; -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a @@ -648,11 +594,10 @@ tcRnSrcDecls decls -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) traceTc (text "Tc8") ; - setEnvs tc_envs $ do { + inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; -- Setting the global env exposes the instances to tcSimplifyTop - -- Setting the local env exposes the local Ids, so that - -- we get better error messages (monomorphism restriction) - inst_binds <- tcSimplifyTop lie ; + -- Setting the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. @@ -664,19 +609,24 @@ tcRnSrcDecls decls (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds) rules fords ; - return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids, - tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }, - dus) - }} + let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; -tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses) + -- Make the new type env available to stuff slurped from interface files + writeMutVar (tcg_type_env_var tcg_env) final_type_env ; + + return (tcg_env { tcg_type_env = final_type_env, + tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) + } +tc_rn_src_decls :: [RdrNameHsDecl] -> TcM (TcGblEnv, TcLclEnv) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module tc_rn_src_decls ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) -- Type check the decls up to, but not including, the first splice - (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ; + tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ; -- Bale out if errors; for example, error recovery when checking -- the RHS of 'main' can mean that 'main' is not in the envt for @@ -688,9 +638,8 @@ tc_rn_src_decls ds -- If there is no splice, we're nearly done case group_tail of { Nothing -> do { -- Last thing: check for `main' - (tcg_env, main_fvs) <- checkMain ; - return ((tcg_env, tcl_env), - src_dus1 `plusDU` usesOnly main_fvs) + tcg_env <- checkMain ; + return (tcg_env, tcl_env) } ; -- If there's a splice, we must carry on @@ -700,20 +649,14 @@ tc_rn_src_decls ds #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- initRn SourceMode $ - addSrcLoc splice_loc $ + (rn_splice_expr, splice_fvs) <- addSrcLoc splice_loc $ rnExpr splice_expr ; - tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ; - setGblEnv tcg_env $ do { - -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; - - return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2) - } + setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + tc_rn_src_decls (spliced_decls ++ rest_ds) #endif /* GHCI */ }}} \end{code} @@ -737,49 +680,37 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses) +tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) -- Returns the variables free in the decls, for unused-binding reporting tcRnGroup decls = do { -- Rename the declarations - (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ; + (tcg_env, rn_decls) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations - tc_envs <- tcTopSrcDecls rn_decls ; - - return (tc_envs, src_dus) + tcTopSrcDecls rn_decls }} ------------------------------------------------ -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses) +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls group = do { -- Bring top level binders into scope (rdr_env, imports) <- importsFromLocalDecls group ; - updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` - tcg_rdr_env gbl, - tcg_imports = imports `plusImportAvails` - tcg_imports gbl }) - $ do { + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` tcg_imports gbl }) + $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations -- Rename the source decls - (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ; - setGblEnv tcg_env $ do { - + (tcg_env, rn_decls) <- rnSrcDecls group ; failIfErrsM ; - -- Import consquential imports - let { src_fvs = duUses src_dus } ; - rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; - let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; - -- Dump trace of renaming part rnDump (ppr rn_decls) ; - rnStats rn_imp_decls ; - return (tcg_env, rn_decls, src_dus) - }}} + return (tcg_env, rn_decls) + }} ------------------------------------------------ tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) @@ -793,24 +724,27 @@ tcTopSrcDecls = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- tcTyClDecls tycl_decls ; - setGblEnv tcg_env $ do { + tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ; + -- tcTyAndClassDecls recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + + -- Make these type and class decls available to stuff slurped from interface files + writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + + + setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations traceTc (text "Tc3") ; - (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ; - setGblEnv tcg_env $ do { - tcg_env <- importSupportingDecls fvs ; + (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ; setGblEnv tcg_env $ do { -- Foreign import declarations next. No zonking necessary -- here; we can tuck them straight into the global environment. traceTc (text "Tc4") ; (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ - updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls }) - $ do { + tcExtendGlobalValEnv fi_ids $ do { -- Default declarations traceTc (text "Tc4a") ; @@ -819,17 +753,14 @@ tcTopSrcDecls -- Value declarations next -- We also typecheck any extra binds that came out - -- of the "deriving" process + -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ; setLclTypeEnv lcl_env $ do { -- Second pass over class and instance declarations, - -- plus rules and foreign exports, to generate bindings traceTc (text "Tc6") ; - (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ; - tcExtendGlobalValEnv dm_ids $ do { - inst_binds <- tcInstDecls2 inst_infos ; + (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ; showLIE (text "after instDecls2") ; -- Foreign exports @@ -838,192 +769,25 @@ tcTopSrcDecls (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Rules - -- Need to partition them because the source rules - -- must be zonked before adding them to tcg_rules - -- NB: built-in rules come in as IfaceRuleOut's, and - -- get added to tcg_rules right here by tcExtendRules rules <- tcRules rule_decls ; - let { (src_rules, iface_rules) = partition isSrcRule rules } ; - tcExtendRules iface_rules $ do { -- Wrap up + traceTc (text "Tc7a") ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `AndMonoBinds` inst_binds `AndMonoBinds` - cls_dm_binds `AndMonoBinds` foe_binds ; -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds, - tcg_rules = tcg_rules tcg_env ++ src_rules, - tcg_fords = tcg_fords tcg_env ++ foe_decls } } ; - + tcg_rules = tcg_rules tcg_env ++ rules, + tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; return (tcg_env', lcl_env) - }}}}}}}}} -\end{code} - -\begin{code} -tcTyClDecls :: [RenamedTyClDecl] - -> TcM TcGblEnv - --- tcTyClDecls deals with --- type and class decls (some source, some imported) --- interface signatures (checked lazily) --- --- It returns the TcGblEnv for this module, and side-effects the --- persistent compiler state to reflect the things imported from --- other modules - -tcTyClDecls tycl_decls - = checkNoErrs $ - -- tcTyAndClassDecls recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - - traceTc (text "TyCl1") `thenM_` - tcTyAndClassDecls tycl_decls `thenM` \ tcg_env -> - -- Returns the extended environment - setGblEnv tcg_env $ - - traceTc (text "TyCl2") `thenM_` - tcInterfaceSigs tycl_decls `thenM` \ tcg_env -> - -- Returns the extended environment - - returnM tcg_env -\end{code} - - - -%************************************************************************ -%* * - Load the old interface file for this module (unless - we have it aleady), and check whether it is up to date - -%* * -%************************************************************************ - -\begin{code} -checkOldIface :: HscEnv - -> PersistentCompilerState - -> Module - -> FilePath -- Where the interface file is - -> Bool -- Source unchanged - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface)) - -- Nothing <=> errors happened - -checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface - = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ moduleUserString mod) ; - - initTc hsc_env pcs mod - (check_old_iface iface_path source_unchanged maybe_iface) - } - -check_old_iface iface_path source_unchanged maybe_iface - = -- CHECK WHETHER THE SOURCE HAS CHANGED - ifM (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - `thenM_` - - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - getGhciMode `thenM` \ ghci_mode -> - if (ghci_mode == Interactive) && not source_unchanged then - returnM (outOfDate, maybe_iface) - else - - case maybe_iface of { - Just old_iface -> -- Use the one we already have - checkVersions source_unchanged old_iface `thenM` \ recomp -> - returnM (recomp, Just old_iface) - - ; Nothing -> - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - getModule `thenM` \ this_mod -> - readIface this_mod iface_path False `thenM` \ read_result -> - case read_result of { - Left err -> -- Old interface file not found, or garbled; give up - traceHiDiffs (text "FYI: cannot read old interface file:" - $$ nest 4 (text (showException err))) `thenM_` - returnM (outOfDate, Nothing) - - ; Right parsed_iface -> - - -- We found the file and parsed it; now load it - tryTc (initRn (InterfaceMode this_mod) - (loadOldIface parsed_iface)) `thenM` \ ((_,errs), mb_iface) -> - case mb_iface of { - Nothing -> -- Something went wrong in loading. The main likely thing - -- is that the usages mentioned B.f, where B.hi and B.hs no - -- longer exist. Then newGlobalName2 fails with an error message - -- This isn't an error; we just don't have an old iface file to - -- look at. Spit out a traceHiDiffs for info though. - traceHiDiffs (text "FYI: loading old interface file failed" - $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_` - return (outOfDate, Nothing) - - ; Just iface -> - - -- At last, we have got the old iface; check its versions - checkVersions source_unchanged iface `thenM` \ recomp -> - returnM (recomp, Just iface) - }}} -\end{code} - - -%************************************************************************ -%* * - Type-check and rename supporting declarations - This is used to deal with the free vars of a splice, - or derived code: slurp in the necessary declarations, - typecheck them, and add them to the EPS -%* * -%************************************************************************ - -\begin{code} -importSupportingDecls :: FreeVars -> TcM TcGblEnv --- Completely deal with the supporting imports needed --- by the specified free-var set -importSupportingDecls fvs - = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ; - decls <- slurpImpDecls fvs ; - traceRn (text "...namely:" <+> vcat (map ppr decls)) ; - typecheckIfaceDecls (mkGroup decls) } - -typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv - -- The decls are all interface-file declarations - -- Usually they are all from other modules, but when we are reading - -- this module's interface from a file, it's possible that some of - -- them are for the module being compiled. - -- That is why the tcExtendX functions need to do partitioning. - -- - -- If all the decls are from other modules, the returned TcGblEnv - -- will have an empty tc_genv, but its tc_inst_env - -- cache may have been augmented. -typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_ruleds = rule_decls }) - = do { -- Typecheck the type, class, and interface-sig decls - tcg_env <- tcTyClDecls tycl_decls ; - setGblEnv tcg_env $ do { - - -- Typecheck the instance decls, and rules - -- Note that imported dictionary functions are already - -- in scope from the preceding tcTyClDecls - tcIfaceInstDecls inst_decls `thenM` \ dfuns -> - tcExtendInstEnv dfuns $ - tcRules rule_decls `thenM` \ rules -> - tcExtendRules rules $ - - getGblEnv -- Return the environment - }} + }}}}}} \end{code} - %********************************************************* %* * mkGlobalContext: make up an interactive context @@ -1035,83 +799,85 @@ typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls, \begin{code} #ifdef GHCI -mkGlobalContext - :: HscEnv -> PersistentCompilerState - -> [Module] -- Expose these modules' top-level scope - -> [Module] -- Expose these modules' exports only - -> IO (PersistentCompilerState, Maybe GlobalRdrEnv) +mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only + -> IO GlobalRdrEnv -mkGlobalContext hsc_env pcs toplevs exports - = initTc hsc_env pcs iNTERACTIVE $ do { - - toplev_envs <- mappM getTopLevScope toplevs ; +mkExportEnv hsc_env exports + = initIfaceIO hsc_env $ do { export_envs <- mappM getModuleExports exports ; - returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv - (toplev_envs ++ export_envs)) + returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv export_envs) } -getTopLevScope :: Module -> TcRn m GlobalRdrEnv -getTopLevScope mod - = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - case mi_globals iface of - Nothing -> panic "getTopLevScope" - Just env -> returnM env } - -getModuleExports :: Module -> TcRn m GlobalRdrEnv +getModuleExports :: ModuleName -> IfG GlobalRdrEnv getModuleExports mod - = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) } - where - prov_fn n = NonLocalDef ImplicitImport - add env (mod,avails) - = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs) - -contextDoc = text "context for compiling statements" + = do { iface <- load_iface mod + ; avails <- exportsToAvails (mi_exports iface) + ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod, + gre_deprec = mi_dep_fn iface name } + | avail <- avails, name <- availNames avail ] } + ; returnM (mkGlobalRdrEnv gres) } + +vanillaProv :: ModuleName -> Provenance +-- We're building a GlobalRdrEnv as if the user imported +-- all the specified modules into the global interactive module +vanillaProv mod = Imported [ImportSpec mod mod False interactiveSrcLoc] False \end{code} \begin{code} getModuleContents :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state - -> Module -- module to inspect - -> Bool -- grab just the exports, or the whole toplev - -> IO (PersistentCompilerState, Maybe [TyThing]) - -getModuleContents hsc_env pcs mod exports_only - = initTc hsc_env pcs iNTERACTIVE $ do { - - -- Load the interface if necessary (a home module will certainly - -- alraedy be loaded, but a package module might not be) - iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - - let { export_names = availsToNameSet export_avails ; - export_avails = [ avail | (mn, avails) <- mi_exports iface, - avail <- avails ] } ; - - all_names <- if exports_only then - return export_names - else case mi_globals iface of { - Just rdr_env -> - return (get_locals rdr_env) ; - - Nothing -> do { addErr (noRdrEnvErr mod) ; - return export_names } } ; - -- Invariant; we only have (not exports_only) - -- for a home module so it must already be in the HIT - -- So the Nothing case is a bug - - env <- importSupportingDecls all_names ; - setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names)) - } - where - -- Grab all the things from the global env that are locally def'd - get_locals rdr_env = mkNameSet [ gre_name gre - | elts <- rdrEnvElts rdr_env, - gre <- elts, - isLocalGRE gre ] - -- Make a set because a name is often in the envt in - -- both qualified and unqualified forms - + -> InteractiveContext + -> ModuleName -- Module to inspect + -> Bool -- Grab just the exports, or the whole toplev + -> IO [IfaceDecl] + +getModuleContents hsc_env ictxt mod exports_only + = initIfaceIO hsc_env (get_mod_contents exports_only) + where + get_mod_contents exports_only + | not exports_only -- We want the whole top-level type env + -- so it had better be a home module + = do { hpt <- getHpt + ; case lookupModuleEnvByName hpt mod of + Just mod_info -> return (map (toIfaceDecl ictxt) $ + filter wantToSee $ + typeEnvElts $ + md_types (hm_details mod_info)) + Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod))) + -- This is a system error; the module should be in the HPT + } + + | otherwise -- Want the exports only + = do { iface <- load_iface mod + ; avails <- exportsToAvails (mi_exports iface) + ; mappM get_decl avails + } + + get_decl avail + = do { thing <- tcIfaceGlobal (availName avail) + ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) } + +--------------------- +filter_decl occs decl@(IfaceClass {ifSigs = sigs}) + = decl { ifSigs = filter (keep_sig occs) sigs } +filter_decl occs decl@(IfaceData {ifCons = DataCons cons}) + = decl { ifCons = DataCons (filter (keep_con occs) cons) } +filter_decl occs decl + = decl + +keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs +keep_con occs (IfaceConDecl occ _ _ _ _ _) = occ `elem` occs + +availOccs avail = map nameOccName (availNames avail) + +wantToSee (AnId id) = not (isImplicitId id) +wantToSee (ADataCon _) = False -- They'll come via their TyCon +wantToSee _ = True + +--------------------- +load_iface mod = loadSysInterface (text "context for compiling statements") mod + +--------------------- noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") <+> quotes (ppr mod) #endif @@ -1143,54 +909,42 @@ checkMain check_main ghci_mode tcg_env main_mod main_fn -- If we are in module Main, check that 'main' is defined. - -- It may be imported from another module, in which case - -- we have to drag in its. - -- - -- Also form the definition - -- $main = runIO main - -- so we need to slurp in runIO too. + -- It may be imported from another module! -- -- ToDo: We have to return the main_name separately, because it's a -- bona fide 'use', and should be recorded as such, but the others -- aren't -- -- Blimey: a whole page of code to do this... - | mod_name /= main_mod - = return (tcg_env, emptyFVs) - - -- Check that 'main' is in scope - -- It might be imported from another module! - -- - -- We use a guard for this (rather than letting lookupSrcName fail) - -- because it's not an error in ghci) - | not (main_fn `elemRdrEnv` rdr_env) - = do { complain_no_main; return (tcg_env, emptyFVs) } - - | otherwise -- OK, so the appropriate 'main' is in scope - -- - = do { main_name <- lookupSrcName main_fn ; - - tcg_env <- importSupportingDecls (unitFV runIOName) ; - - addSrcLoc (getSrcLoc main_name) $ - addErrCtxt mainCtxt $ - setGblEnv tcg_env $ do { - - -- :Main.main :: IO () = runIO main - let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ; - (main_expr, ty) <- tcInferRho rhs ; - - let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; - main_bind = VarMonoBind root_main_id main_expr ; - tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env - `andMonoBinds` main_bind } } ; - - return (tcg_env', unitFV main_name) - }} + = return tcg_env + + | otherwise + = addErrCtxt mainCtxt $ + do { mb_main <- lookupSrcOcc_maybe main_fn + -- Check that 'main' is in scope + -- It might be imported from another module! + ; case mb_main of { + Nothing -> do { complain_no_main + ; return tcg_env } ; + Just main_name -> do + { let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } + -- :Main.main :: IO () = runIO main + + ; (main_expr, ty) <- addSrcLoc (getSrcLoc main_name) $ + tcInferRho rhs + + ; let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; + main_bind = VarMonoBind root_main_id main_expr } + + ; return (tcg_env { tcg_binds = tcg_binds tcg_env + `andMonoBinds` main_bind, + tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) + }) + }}} where mod_name = moduleName (tcg_mod tcg_env) - rdr_env = tcg_rdr_env tcg_env complain_no_main | ghci_mode == Interactive = return () | otherwise = failWithTc noMainMsg @@ -1211,11 +965,11 @@ check_main ghci_mode tcg_env main_mod main_fn %************************************************************************ \begin{code} -rnDump :: SDoc -> TcRn m () +rnDump :: SDoc -> TcRn () -- Dump, with a banner, if -ddump-rn -rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) +rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) } -tcDump :: TcGblEnv -> TcRn m () +tcDump :: TcGblEnv -> TcRn () tcDump env = do { dflags <- getDOpts ; @@ -1282,16 +1036,11 @@ ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids) ppr_sigs :: [Var] -> SDoc ppr_sigs ids - -- Print type signatures - -- Convert to HsType so that we get source-language style printing - -- And sort by RdrName - = vcat $ map ppr_sig $ sortLt lt_sig $ - [ (getRdrName id, toHsType (tidyTopType (idType id))) - | id <- ids ] + -- Print type signatures; sort by OccName + = vcat (map ppr_sig (sortLt lt_sig ids)) where - lt_sig (n1,_) (n2,_) = n1 < n2 - ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t - + lt_sig id1 id2 = getOccName id1 < getOccName id2 + ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) ppr_rules :: [IdCoreRule] -> SDoc ppr_rules [] = empty @@ -1300,22 +1049,6 @@ ppr_rules rs = vcat [ptext SLIT("{-# RULES"), ptext SLIT("#-}")] ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"), - nest 2 (vcat (map ppr_gen_tycon tcs)) - ] - --- x&y are now Id's, not CoreExpr's -ppr_gen_tycon tycon - | Just ep <- tyConGenInfo tycon - = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep) - - | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable") - -ppr_ep (EP from to) - = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau), - ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)), - ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to)) - ] - where - (_,from_tau) = tcSplitForAllTys (idType from) +ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"), + nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code} diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 835752e0e0..5dce531ac1 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -1,39 +1,44 @@ \begin{code} module TcRnMonad( module TcRnMonad, - module TcRnTypes + module TcRnTypes, + module IOEnv ) where #include "HsVersions.h" +import TcRnTypes -- Re-export all +import IOEnv -- Re-export all + import HsSyn ( MonoBinds(..) ) -import HscTypes ( HscEnv(..), PersistentCompilerState(..), - emptyFixityEnv, emptyGlobalRdrEnv, TyThing, +import HscTypes ( HscEnv(..), + TyThing, ExternalPackageState(..), HomePackageTable, - ModDetails(..), HomeModInfo(..), Deprecations(..), - GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv, + ModDetails(..), HomeModInfo(..), + Deprecs(..), FixityEnv, FixItem, GhciMode, lookupType, unQualInScope ) -import TcRnTypes -import Module ( Module, unitModuleEnv, foldModuleEnv ) +import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv, emptyModuleEnv ) +import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, + LocalRdrEnv, emptyLocalRdrEnv ) import Name ( Name, isInternalName ) import Type ( Type ) import NameEnv ( extendNameEnvList ) -import InstEnv ( InstEnv, extendInstEnv ) -import TysWiredIn ( integerTy, doubleTy ) +import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv ) import VarSet ( emptyVarSet ) import VarEnv ( TidyEnv, emptyTidyEnv ) -import RdrName ( emptyRdrEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, addShortErrLocLine, addShortWarnLocLine, printErrorsAndWarnings ) -import SrcLoc ( SrcLoc, noSrcLoc ) +import SrcLoc ( SrcLoc, mkGeneralSrcLoc ) import NameEnv ( emptyNameEnv ) +import NameSet ( emptyDUs, emptyNameSet ) +import OccName ( emptyOccEnv ) +import Module ( moduleName ) import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) import Unique ( Unique ) import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug ) -import BasicTypes ( FixitySig ) import Bag ( snocBag, unionBags ) import Panic ( showException ) @@ -43,52 +48,6 @@ import DATA_IOREF ( newIORef, readIORef ) import EXCEPTION ( Exception ) \end{code} -%************************************************************************ -%* * - Standard combinators, but specialised for this monad - (for efficiency) -%* * -6%************************************************************************ - -\begin{code} -mappM :: (a -> TcRn m b) -> [a] -> TcRn m [b] -mappM_ :: (a -> TcRn m b) -> [a] -> TcRn m () - -- Funny names to avoid clash with Prelude -sequenceM :: [TcRn m a] -> TcRn m [a] -foldlM :: (a -> b -> TcRn m a) -> a -> [b] -> TcRn m a -mapAndUnzipM :: (a -> TcRn m (b,c)) -> [a] -> TcRn m ([b],[c]) -mapAndUnzip3M :: (a -> TcRn m (b,c,d)) -> [a] -> TcRn m ([b],[c],[d]) -checkM :: Bool -> TcRn m () -> TcRn m () -- Perform arg if bool is False -ifM :: Bool -> TcRn m () -> TcRn m () -- Perform arg if bool is True - -mappM f [] = return [] -mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) } - -mappM_ f [] = return () -mappM_ f (x:xs) = f x >> mappM_ f xs - -sequenceM [] = return [] -sequenceM (x:xs) = do { r <- x; rs <- sequenceM xs; return (r:rs) } - -foldlM k z [] = return z -foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs } - -mapAndUnzipM f [] = return ([],[]) -mapAndUnzipM f (x:xs) = do { (r,s) <- f x; - (rs,ss) <- mapAndUnzipM f xs; - return (r:rs, s:ss) } - -mapAndUnzip3M f [] = return ([],[], []) -mapAndUnzip3M f (x:xs) = do { (r,s,t) <- f x; - (rs,ss,ts) <- mapAndUnzip3M f xs; - return (r:rs, s:ss, t:ts) } - -checkM True err = return () -checkM False err = err - -ifM True do_it = do_it -ifM False do_it = return () -\end{code} %************************************************************************ @@ -98,114 +57,89 @@ ifM False do_it = return () %************************************************************************ \begin{code} -initTc :: HscEnv -> PersistentCompilerState +ioToTcRn :: IO r -> TcRn r +ioToTcRn = ioToIOEnv +\end{code} + +\begin{code} +initTc :: HscEnv -> Module -> TcM r - -> IO (PersistentCompilerState, Maybe r) + -> IO (Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) -initTc (HscEnv { hsc_mode = ghci_mode, - hsc_HPT = hpt, - hsc_dflags = dflags }) - pcs mod do_this - = do { us <- mkSplitUniqSupply 'a' ; - us_var <- newIORef us ; - errs_var <- newIORef (emptyBag, emptyBag) ; - tvs_var <- newIORef emptyVarSet ; - usg_var <- newIORef emptyUsages ; - nc_var <- newIORef (pcs_nc pcs) ; - eps_var <- newIORef eps ; - ie_var <- newIORef (mkImpInstEnv dflags eps hpt) ; +initTc hsc_env mod do_this + = do { errs_var <- newIORef (emptyBag, emptyBag) ; + tvs_var <- newIORef emptyVarSet ; + type_env_var <- newIORef emptyNameEnv ; + dfuns_var <- newIORef emptyNameSet ; let { - env = Env { env_top = top_env, - env_gbl = gbl_env, - env_lcl = lcl_env, - env_loc = noSrcLoc } ; - - top_env = TopEnv { - top_mode = ghci_mode, - top_dflags = dflags, - top_eps = eps_var, - top_hpt = hpt, - top_nc = nc_var, - top_us = us_var, - top_errs = errs_var } ; - gbl_env = TcGblEnv { tcg_mod = mod, - tcg_usages = usg_var, tcg_rdr_env = emptyGlobalRdrEnv, - tcg_fix_env = emptyFixityEnv, - tcg_default = defaultDefaultTys, + tcg_fix_env = emptyNameEnv, + tcg_default = Nothing, tcg_type_env = emptyNameEnv, - tcg_inst_env = ie_var, + tcg_type_env_var = type_env_var, + tcg_inst_env = mkImpInstEnv hsc_env, + tcg_inst_uses = dfuns_var, tcg_exports = [], tcg_imports = init_imports, + tcg_dus = emptyDUs, tcg_binds = EmptyMonoBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], - tcg_fords = [] } ; - + tcg_fords = [] + } ; lcl_env = TcLclEnv { + tcl_errs = errs_var, + tcl_loc = mkGeneralSrcLoc FSLIT("Top level of module"), tcl_ctxt = [], + tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, tcl_arrow_ctxt = topArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, - tcl_lie = panic "initTc:LIE" } ; - -- LIE only valid inside a getLIE + tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE } ; + } ; -- OK, here's the business end! - maybe_res <- catch (do { res <- runTcRn env do_this ; - return (Just res) }) - (\_ -> return Nothing) ; + maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ + do { r <- tryM do_this + ; case r of + Right res -> return (Just res) + Left _ -> return Nothing } ; -- Print any error messages msgs <- readIORef errs_var ; printErrorsAndWarnings msgs ; - -- Get final PCS and return - eps' <- readIORef eps_var ; - nc' <- readIORef nc_var ; - let { pcs' = PCS { pcs_EPS = eps', pcs_nc = nc' } ; - final_res | errorsFound dflags msgs = Nothing + let { dflags = hsc_dflags hsc_env + ; final_res | errorsFound dflags msgs = Nothing | otherwise = maybe_res } ; - return (pcs', final_res) + return final_res } where - eps = pcs_EPS pcs - init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv } -- Initialise tcg_imports with an empty set of bindings for -- this module, so that if we see 'module M' in the export -- list, and there are no bindings in M, we don't bleat -- "unknown module M". -defaultDefaultTys :: [Type] -defaultDefaultTys = [integerTy, doubleTy] - -mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv +mkImpInstEnv :: HscEnv -> InstEnv -- At the moment we (wrongly) build an instance environment from all the --- modules we have already compiled: --- (a) eps_inst_env from the external package state --- (b) all the md_insts in the home package table +-- home-package modules we have already compiled. -- We should really only get instances from modules below us in the -- module import tree. -mkImpInstEnv dflags eps hpt - = foldModuleEnv (add . md_insts . hm_details) - (eps_inst_env eps) - hpt +mkImpInstEnv (HscEnv {hsc_dflags = dflags, hsc_HPT = hpt}) + = foldModuleEnv (add . md_insts . hm_details) emptyInstEnv hpt where - -- We shouldn't get instance conflict errors from - -- the package and home type envs - add dfuns inst_env = WARN( not (null errs), vcat (map snd errs) ) inst_env' - where - (inst_env', errs) = extendInstEnv dflags inst_env dfuns + add dfuns inst_env = foldl extendInstEnv inst_env dfuns -- mkImpTypeEnv makes the imported symbol table mkImpTypeEnv :: ExternalPackageState -> HomePackageTable @@ -220,38 +154,64 @@ mkImpTypeEnv pcs hpt = lookup %************************************************************************ %* * + Initialisation +%* * +%************************************************************************ + + +\begin{code} +initTcRnIf :: Char -- Tag for unique supply + -> HscEnv + -> gbl -> lcl + -> TcRnIf gbl lcl a + -> IO a +initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside + = do { us <- mkSplitUniqSupply uniq_tag ; + ; us_var <- newIORef us ; + + ; let { env = Env { env_top = hsc_env, + env_us = us_var, + env_gbl = gbl_env, + env_lcl = lcl_env } } + + ; runIOEnv env thing_inside + } +\end{code} + +%************************************************************************ +%* * Simple accessors %* * %************************************************************************ \begin{code} -getTopEnv :: TcRn m TopEnv +getTopEnv :: TcRnIf gbl lcl HscEnv getTopEnv = do { env <- getEnv; return (env_top env) } -getGblEnv :: TcRn m TcGblEnv +getGblEnv :: TcRnIf gbl lcl gbl getGblEnv = do { env <- getEnv; return (env_gbl env) } -updGblEnv :: (TcGblEnv -> TcGblEnv) -> TcRn m a -> TcRn m a +updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> env { env_gbl = upd gbl }) -setGblEnv :: TcGblEnv -> TcRn m a -> TcRn m a +setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) -getLclEnv :: TcRn m m +getLclEnv :: TcRnIf gbl lcl lcl getLclEnv = do { env <- getEnv; return (env_lcl env) } -updLclEnv :: (m -> m) -> TcRn m a -> TcRn m a +updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> env { env_lcl = upd lcl }) -setLclEnv :: m -> TcRn m a -> TcRn n a +setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) -getEnvs :: TcRn m (TcGblEnv, m) +getEnvs :: TcRnIf gbl lcl (gbl, lcl) getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } -setEnvs :: (TcGblEnv, m) -> TcRn m a -> TcRn m a +setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) \end{code} @@ -259,74 +219,128 @@ setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = Command-line flags \begin{code} -getDOpts :: TcRn m DynFlags -getDOpts = do { env <- getTopEnv; return (top_dflags env) } +getDOpts :: TcRnIf gbl lcl DynFlags +getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } -doptM :: DynFlag -> TcRn m Bool +doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } -ifOptM :: DynFlag -> TcRn m () -> TcRn m () -- Do it flag is true +ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } -getGhciMode :: TcRn m GhciMode -getGhciMode = do { env <- getTopEnv; return (top_mode env) } +getGhciMode :: TcRnIf gbl lcl GhciMode +getGhciMode = do { env <- getTopEnv; return (hsc_mode env) } \end{code} \begin{code} -getSrcLocM :: TcRn m SrcLoc - -- Avoid clash with Name.getSrcLoc -getSrcLocM = do { env <- getEnv; return (env_loc env) } +getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) +getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } + +getEps :: TcRnIf gbl lcl ExternalPackageState +getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } + +setEps :: ExternalPackageState -> TcRnIf gbl lcl () +setEps eps = do { env <- getTopEnv; writeMutVar (hsc_EPS env) eps } + +updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) + -> TcRnIf gbl lcl a +updateEps upd_fn = do { eps_var <- getEpsVar + ; eps <- readMutVar eps_var + ; let { (eps', val) = upd_fn eps } + ; writeMutVar eps_var eps' + ; return val } + +updateEps_ :: (ExternalPackageState -> ExternalPackageState) + -> TcRnIf gbl lcl () +updateEps_ upd_fn = do { eps_var <- getEpsVar + ; updMutVar eps_var upd_fn } + +getHpt :: TcRnIf gbl lcl HomePackageTable +getHpt = do { env <- getTopEnv; return (hsc_HPT env) } +\end{code} -addSrcLoc :: SrcLoc -> TcRn m a -> TcRn m a -addSrcLoc loc = updEnv (\env -> env { env_loc = loc }) +%************************************************************************ +%* * + Unique supply +%* * +%************************************************************************ + +\begin{code} +newUnique :: TcRnIf gbl lcl Unique +newUnique = do { us <- newUniqueSupply ; + return (uniqFromSupply us) } + +newUniqueSupply :: TcRnIf gbl lcl UniqSupply +newUniqueSupply + = do { env <- getEnv ; + let { u_var = env_us env } ; + us <- readMutVar u_var ; + let { (us1, us2) = splitUniqSupply us } ; + writeMutVar u_var us1 ; + return us2 } \end{code} + +%************************************************************************ +%* * + Debugging +%* * +%************************************************************************ + \begin{code} -getEps :: TcRn m ExternalPackageState -getEps = do { env <- getTopEnv; readMutVar (top_eps env) } +traceTc, traceRn :: SDoc -> TcRn () +traceRn = dumpOptTcRn Opt_D_dump_rn_trace +traceTc = dumpOptTcRn Opt_D_dump_tc_trace +traceSplice = dumpOptTcRn Opt_D_dump_splices + + +traceIf :: SDoc -> TcRnIf m n () +traceIf = dumpOptIf Opt_D_dump_if_trace +traceHiDiffs = dumpOptIf Opt_D_dump_hi_diffs + -setEps :: ExternalPackageState -> TcRn m () -setEps eps = do { env <- getTopEnv; writeMutVar (top_eps env) eps } +dumpOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything +dumpOptIf flag doc = ifOptM flag $ + ioToIOEnv (printForUser stderr alwaysQualify doc) -getHpt :: TcRn m HomePackageTable -getHpt = do { env <- getTopEnv; return (top_hpt env) } +dumpOptTcRn :: DynFlag -> SDoc -> TcRn () +dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) + +dumpTcRn :: SDoc -> TcRn () +dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; + ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } +\end{code} + + +%************************************************************************ +%* * + Typechecker global environment +%* * +%************************************************************************ -getModule :: TcRn m Module +\begin{code} +getModule :: TcRn Module getModule = do { env <- getGblEnv; return (tcg_mod env) } -getGlobalRdrEnv :: TcRn m GlobalRdrEnv +getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } -getImports :: TcRn m ImportAvails +getImports :: TcRn ImportAvails getImports = do { env <- getGblEnv; return (tcg_imports env) } -getFixityEnv :: TcRn m FixityEnv +getFixityEnv :: TcRn FixityEnv getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } -extendFixityEnv :: [(Name,FixitySig Name)] -> RnM a -> RnM a +extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) -getDefaultTys :: TcRn m [Type] +getDefaultTys :: TcRn (Maybe [Type]) getDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} -\begin{code} -getUsageVar :: TcRn m (TcRef EntityUsage) -getUsageVar = do { env <- getGblEnv; return (tcg_usages env) } - -getUsages :: TcRn m EntityUsage -getUsages = do { usg_var <- getUsageVar; readMutVar usg_var } - -updUsages :: (EntityUsage -> EntityUsage) -> TcRn m () -updUsages upd = do { usg_var <- getUsageVar ; - usg <- readMutVar usg_var ; - writeMutVar usg_var (upd usg) } -\end{code} - - %************************************************************************ %* * Error management @@ -334,17 +348,26 @@ updUsages upd = do { usg_var <- getUsageVar ; %************************************************************************ \begin{code} -getErrsVar :: TcRn m (TcRef Messages) -getErrsVar = do { env <- getTopEnv; return (top_errs env) } +getSrcLocM :: TcRn SrcLoc + -- Avoid clash with Name.getSrcLoc +getSrcLocM = do { env <- getLclEnv; return (tcl_loc env) } + +addSrcLoc :: SrcLoc -> TcRn a -> TcRn a +addSrcLoc loc = updLclEnv (\env -> env { tcl_loc = loc }) +\end{code} -setErrsVar :: TcRef Messages -> TcRn m a -> TcRn m a -setErrsVar v = updEnv (\ env@(Env { env_top = top_env }) -> - env { env_top = top_env { top_errs = v }}) -addErr :: Message -> TcRn m () +\begin{code} +getErrsVar :: TcRn (TcRef Messages) +getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } + +setErrsVar :: TcRef Messages -> TcRn a -> TcRn a +setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) + +addErr :: Message -> TcRn () addErr msg = do { loc <- getSrcLocM ; addErrAt loc msg } -addErrAt :: SrcLoc -> Message -> TcRn m () +addErrAt :: SrcLoc -> Message -> TcRn () addErrAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; @@ -352,12 +375,12 @@ addErrAt loc msg (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } -addErrs :: [(SrcLoc,Message)] -> TcRn m () +addErrs :: [(SrcLoc,Message)] -> TcRn () addErrs msgs = mappM_ add msgs where add (loc,msg) = addErrAt loc msg -addWarn :: Message -> TcRn m () +addWarn :: Message -> TcRn () addWarn msg = do { errs_var <- getErrsVar ; loc <- getSrcLocM ; @@ -366,15 +389,15 @@ addWarn msg (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } -checkErr :: Bool -> Message -> TcRn m () +checkErr :: Bool -> Message -> TcRn () -- Add the error if the bool is False checkErr ok msg = checkM ok (addErr msg) -warnIf :: Bool -> Message -> TcRn m () +warnIf :: Bool -> Message -> TcRn () warnIf True msg = addWarn msg warnIf False msg = return () -addMessages :: Messages -> TcRn m () +addMessages :: Messages -> TcRn () addMessages (m_warns, m_errs) = do { errs_var <- getErrsVar ; (warns, errs) <- readMutVar errs_var ; @@ -384,16 +407,16 @@ addMessages (m_warns, m_errs) \begin{code} -recoverM :: TcRn m r -- Recovery action; do this if the main one fails - -> TcRn m r -- Main action: do this first - -> TcRn m r +recoverM :: TcRn r -- Recovery action; do this if the main one fails + -> TcRn r -- Main action: do this first + -> TcRn r recoverM recover thing = do { mb_res <- try_m thing ; case mb_res of Left exn -> recover Right res -> returnM res } -tryTc :: TcRn m a -> TcRn m (Messages, Maybe a) +tryTc :: TcRn a -> TcRn (Messages, Maybe a) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) and caused no errors -- Nothing, if m fails, or caused errors @@ -417,7 +440,7 @@ tryTc m | otherwise -> Just r) } -try_m :: TcRn m r -> TcRn m (Either Exception r) +try_m :: TcRn r -> TcRn (Either Exception r) -- Does try_m, with a debug-trace on failure try_m thing = do { mb_r <- tryM thing ; @@ -425,7 +448,7 @@ try_m thing Left exn -> do { traceTc (exn_msg exn); return mb_r } Right r -> return mb_r } where - exn_msg exn = text "recoverM recovering from" <+> text (showException exn) + exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) tryTcLIE :: TcM a -> TcM (Messages, Maybe a) -- Just like tryTc, except that it ensures that the LIE @@ -461,7 +484,7 @@ checkNoErrs main Nothing -> failM } -ifErrsM :: TcRn m r -> TcRn m r -> TcRn m r +ifErrsM :: TcRn r -> TcRn r -> TcRn r -- ifErrsM bale_out main -- does 'bale_out' if there are errors in errors collection -- otherwise does 'main' @@ -474,108 +497,11 @@ ifErrsM bale_out normal else normal } -failIfErrsM :: TcRn m () +failIfErrsM :: TcRn () -- Useful to avoid error cascades failIfErrsM = ifErrsM failM (return ()) \end{code} -\begin{code} -forkM :: SDoc -> TcM a -> TcM (Maybe a) --- Run thing_inside in an interleaved thread. It gets a separate --- * errs_var, and --- * unique supply, --- * LIE var is set to bottom (should never be used) --- but everything else is shared, so this is DANGEROUS. --- --- It returns Nothing if the computation fails --- --- It's used for lazily type-checking interface --- signatures, which is pretty benign - -forkM doc thing_inside - = do { us <- newUniqueSupply ; - unsafeInterleaveM $ - do { us_var <- newMutVar us ; - (msgs, mb_res) <- tryTc (setLIEVar (panic "forkM: LIE used") $ - setUsVar us_var thing_inside) ; - case mb_res of - Just r -> return (Just r) - Nothing -> do { - - -- Bleat about errors in the forked thread, if -ddump-tc-trace is on - -- Otherwise we silently discard errors. Errors can legitimately - -- happen when compiling interface signatures (see tcInterfaceSigs) - ifOptM Opt_D_dump_tc_trace - (ioToTcRn (do { printErrs (hdr_doc defaultErrStyle) ; - printErrorsAndWarnings msgs })) ; - - return Nothing } - }} - where - hdr_doc = text "forkM failed:" <+> doc -\end{code} - - -%************************************************************************ -%* * - Unique supply -%* * -%************************************************************************ - -\begin{code} -getUsVar :: TcRn m (TcRef UniqSupply) -getUsVar = do { env <- getTopEnv; return (top_us env) } - -setUsVar :: TcRef UniqSupply -> TcRn m a -> TcRn m a -setUsVar v = updEnv (\ env@(Env { env_top = top_env }) -> - env { env_top = top_env { top_us = v }}) - -newUnique :: TcRn m Unique -newUnique = do { us <- newUniqueSupply ; - return (uniqFromSupply us) } - -newUniqueSupply :: TcRn m UniqSupply -newUniqueSupply - = do { u_var <- getUsVar ; - us <- readMutVar u_var ; - let { (us1, us2) = splitUniqSupply us } ; - writeMutVar u_var us1 ; - return us2 } -\end{code} - - -\begin{code} -getNameCache :: TcRn m NameCache -getNameCache = do { TopEnv { top_nc = nc_var } <- getTopEnv; - readMutVar nc_var } - -setNameCache :: NameCache -> TcRn m () -setNameCache nc = do { TopEnv { top_nc = nc_var } <- getTopEnv; - writeMutVar nc_var nc } -\end{code} - - -%************************************************************************ -%* * - Debugging -%* * -%************************************************************************ - -\begin{code} -traceTc, traceRn :: SDoc -> TcRn a () -traceRn = dumpOptTcRn Opt_D_dump_rn_trace -traceTc = dumpOptTcRn Opt_D_dump_tc_trace -traceSplice = dumpOptTcRn Opt_D_dump_splices -traceHiDiffs = dumpOptTcRn Opt_D_dump_hi_diffs - -dumpOptTcRn :: DynFlag -> SDoc -> TcRn a () -dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) - -dumpTcRn :: SDoc -> TcRn a () -dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } -\end{code} - %************************************************************************ %* * @@ -780,23 +706,99 @@ incProcLevel %************************************************************************ \begin{code} -initRn :: RnMode -> RnM a -> TcRn m a -initRn mode thing_inside - = do { let { lcl_env = RnLclEnv { - rn_mode = mode, - rn_lenv = emptyRdrEnv }} ; - setLclEnv lcl_env thing_inside } -\end{code} - -\begin{code} getLocalRdrEnv :: RnM LocalRdrEnv -getLocalRdrEnv = do { env <- getLclEnv; return (rn_lenv env) } +getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a setLocalRdrEnv rdr_env thing_inside - = updLclEnv (\env -> env {rn_lenv = rdr_env}) thing_inside - -getModeRn :: RnM RnMode -getModeRn = do { env <- getLclEnv; return (rn_mode env) } + = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside \end{code} + +%************************************************************************ +%* * + Stuff for interface decls +%* * +%************************************************************************ + +\begin{code} +initIfaceTcRn :: IfG a -> TcRn a +initIfaceTcRn thing_inside + = do { tcg_env <- getGblEnv + ; let { if_env = IfGblEnv { + if_rec_types = Just (tcg_mod tcg_env, get_type_env), + if_is_boot = imp_dep_mods (tcg_imports tcg_env) } + ; get_type_env = readMutVar (tcg_type_env_var tcg_env) } + ; setEnvs (if_env, ()) thing_inside } + +initIfaceExtCore :: IfL a -> TcRn a +initIfaceExtCore thing_inside + = do { tcg_env <- getGblEnv + ; let { mod = tcg_mod tcg_env + ; if_env = IfGblEnv { + if_rec_types = Just (mod, return (tcg_type_env tcg_env)), + if_is_boot = imp_dep_mods (tcg_imports tcg_env) } + ; if_lenv = IfLclEnv { if_mod = moduleName mod, + if_tv_env = emptyOccEnv, + if_id_env = emptyOccEnv } + } + ; setEnvs (if_env, if_lenv) thing_inside } + +initIfaceIO :: HscEnv -> IfG a -> IO a +initIfaceIO hsc_env do_this + = do { let { + gbl_env = IfGblEnv { if_is_boot = emptyModuleEnv, -- Bogus? + if_rec_types = Nothing } ; + } + + -- Run the thing; any exceptions just bubble out from here + ; initTcRnIf 'i' hsc_env gbl_env () do_this + } + +initIfaceLcl :: ModuleName -> IfL a -> IfM lcl a +initIfaceLcl mod thing_inside + = setLclEnv (IfLclEnv { if_mod = mod, + if_tv_env = emptyOccEnv, + if_id_env = emptyOccEnv }) + thing_inside + + +-------------------- +forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) +-- Run thing_inside in an interleaved thread. +-- It shares everything with the parent thread, so this is DANGEROUS. +-- +-- It returns Nothing if the computation fails +-- +-- It's used for lazily type-checking interface +-- signatures, which is pretty benign + +forkM_maybe doc thing_inside + = do { unsafeInterleaveM $ + do { traceIf (text "Starting fork {" <+> doc) + ; mb_res <- tryM thing_inside ; + case mb_res of + Right r -> do { traceIf (text "} ending fork" <+> doc) + ; return (Just r) } + Left exn -> do { + + -- Bleat about errors in the forked thread, if -ddump-if-trace is on + -- Otherwise we silently discard errors. Errors can legitimately + -- happen when compiling interface signatures (see tcInterfaceSigs) + ifOptM Opt_D_dump_if_trace + (print_errs (hang (text "forkM failed:" <+> doc) + 4 (text (show exn)))) + + ; traceIf (text "} ending fork (badly)" <+> doc) + ; return Nothing } + }} + where + print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle)) + +forkM :: SDoc -> IfL a -> IfL a +forkM doc thing_inside + = do { mb_res <- forkM_maybe doc thing_inside + ; return (case mb_res of + Nothing -> pprPanic "forkM" doc + Just r -> r) } +\end{code} diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 47a9ed8a58..01dbce1340 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -3,28 +3,21 @@ % \begin{code} module TcRnTypes( - TcRn, TcM, RnM, -- The monad is opaque outside this module + TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module + TcRef, - -- Standard monadic operations - thenM, thenM_, returnM, failM, - - -- Non-standard operations - runTcRn, fixM, tryM, ioToTcRn, - newMutVar, readMutVar, writeMutVar, - getEnv, setEnv, updEnv, unsafeInterleaveM, zapEnv, - -- The environment types - Env(..), TopEnv(..), TcGblEnv(..), - TcLclEnv(..), RnLclEnv(..), + Env(..), + TcGblEnv(..), TcLclEnv(..), + IfGblEnv(..), IfLclEnv(..), -- Ranamer types - RnMode(..), isInterfaceMode, isCmdLineMode, EntityUsage, emptyUsages, ErrCtxt, ImportAvails(..), emptyImportAvails, plusImportAvails, plusAvail, pruneAvails, AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv, mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail, - WhereFrom(..), + WhereFrom(..), mkModDeps, -- Typechecker types TcTyThing(..), @@ -42,25 +35,27 @@ module TcRnTypes( plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, -- Misc other types - TcRef, TcId, TcIdSet + TcId, TcIdSet ) where #include "HsVersions.h" import HsSyn ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl ) -import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo ) -import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, - NameCache, GlobalRdrEnv, LocalRdrEnv, FixityEnv, - TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo, - availName, IsBootInterface, Deprecations, - ExternalPackageState(..), emptyExternalPackageState ) +import RnHsSyn ( RenamedPat, RenamedArithSeqInfo ) +import HscTypes ( FixityEnv, + HscEnv, TypeEnv, TyThing, + Avails, GenAvailInfo(..), AvailInfo, + availName, IsBootInterface, Deprecations ) import Packages ( PackageName ) import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) import InstEnv ( DFunId, InstEnv ) +import IOEnv +import RdrName ( GlobalRdrEnv, LocalRdrEnv ) import Name ( Name ) import NameEnv -import NameSet ( NameSet, emptyNameSet ) +import NameSet ( NameSet, emptyNameSet, DefUses ) +import OccName ( OccEnv ) import Type ( Type ) import Class ( Class ) import Var ( Id, TyVar ) @@ -69,29 +64,16 @@ import Module import SrcLoc ( SrcLoc ) import VarSet ( IdSet ) import ErrUtils ( Messages, Message ) -import CmdLineOpts ( DynFlags ) import UniqSupply ( UniqSupply ) import BasicTypes ( IPName ) import Util ( thenCmp ) import Bag import Outputable -import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) -import UNSAFE_IO ( unsafeInterleaveIO ) -import FIX_IO ( fixIO ) -import EXCEPTION ( Exception(..) ) -import IO ( isUserError ) import Maybe ( mapMaybe ) import ListSetOps ( unionLists ) -import Panic ( tryJust ) \end{code} -\begin{code} -type TcRef a = IORef a -type TcId = Id -- Type may be a TcType -type TcIdSet = IdSet -\end{code} - %************************************************************************ %* * Standard monad definition for TcRn @@ -99,164 +81,22 @@ type TcIdSet = IdSet %* * %************************************************************************ -The monad itself has to be defined here, -because it is mentioned by ErrCtxt - -\begin{code} -newtype TcRn m a = TcRn (Env m -> IO a) -unTcRn (TcRn f) = f - -type TcM a = TcRn TcLclEnv a -type RnM a = TcRn RnLclEnv a - -returnM :: a -> TcRn m a -returnM a = TcRn (\ env -> return a) - -thenM :: TcRn m a -> (a -> TcRn m b) -> TcRn m b -thenM (TcRn m) f = TcRn (\ env -> do { r <- m env ; - unTcRn (f r) env }) - -thenM_ :: TcRn m a -> TcRn m b -> TcRn m b -thenM_ (TcRn m) f = TcRn (\ env -> do { m env ; unTcRn f env }) - -failM :: TcRn m a -failM = TcRn (\ env -> ioError (userError "TcRn failure")) - -instance Monad (TcRn m) where - (>>=) = thenM - (>>) = thenM_ - return = returnM - fail s = failM -- Ignore the string -\end{code} - - -%************************************************************************ -%* * - Fundmantal combinators specific to the monad -%* * -%************************************************************************ - -Running it - -\begin{code} -runTcRn :: Env m -> TcRn m a -> IO a -runTcRn env (TcRn m) = m env -\end{code} - -The fixpoint combinator - -\begin{code} -{-# NOINLINE fixM #-} - -- Aargh! Not inlining fixTc alleviates a space leak problem. - -- Normally fixTc is used with a lazy tuple match: if the optimiser is - -- shown the definition of fixTc, it occasionally transforms the code - -- in such a way that the code generator doesn't spot the selector - -- thunks. Sigh. - -fixM :: (a -> TcRn m a) -> TcRn m a -fixM f = TcRn (\ env -> fixIO (\ r -> unTcRn (f r) env)) -\end{code} - -Error recovery - -\begin{code} -tryM :: TcRn m r -> TcRn m (Either Exception r) --- Reflect exception into TcRn monad -tryM (TcRn thing) = TcRn (\ env -> tryJust tc_errors (thing env)) - where -#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500 - tc_errors e@(IOException ioe) | isUserError ioe = Just e -#elif __GLASGOW_HASKELL__ == 502 - tc_errors e@(UserError _) = Just e -#else - tc_errors e@(IOException ioe) | isUserError e = Just e -#endif - tc_errors _other = Nothing - -- type checker failures show up as UserErrors only -\end{code} - -Lazy interleave - -\begin{code} -unsafeInterleaveM :: TcRn m a -> TcRn m a -unsafeInterleaveM (TcRn m) = TcRn (\ env -> unsafeInterleaveIO (m env)) -\end{code} - -\end{code} - -Performing arbitrary I/O, plus the read/write var (for efficiency) +The monad itself has to be defined here, because it is mentioned by ErrCtxt \begin{code} -ioToTcRn :: IO a -> TcRn m a -ioToTcRn io = TcRn (\ env -> io) - -newMutVar :: a -> TcRn m (TcRef a) -newMutVar val = TcRn (\ env -> newIORef val) - -writeMutVar :: TcRef a -> a -> TcRn m () -writeMutVar var val = TcRn (\ env -> writeIORef var val) - -readMutVar :: TcRef a -> TcRn m a -readMutVar var = TcRn (\ env -> readIORef var) -\end{code} - -Getting the environment - -\begin{code} -getEnv :: TcRn m (Env m) -{-# INLINE getEnv #-} -getEnv = TcRn (\ env -> return env) - -setEnv :: Env n -> TcRn n a -> TcRn m a -{-# INLINE setEnv #-} -setEnv new_env (TcRn m) = TcRn (\ env -> m new_env) +type TcRef a = IORef a +type TcId = Id -- Type may be a TcType +type TcIdSet = IdSet -updEnv :: (Env m -> Env n) -> TcRn n a -> TcRn m a -{-# INLINE updEnv #-} -updEnv upd (TcRn m) = TcRn (\ env -> m (upd env)) +type TcRnIf a b c = IOEnv (Env a b) c +type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff +type IfG a = IfM () a -- Top level +type IfL a = IfM IfLclEnv a -- Nested +type TcRn a = TcRnIf TcGblEnv TcLclEnv a +type RnM a = TcRn a -- Historical +type TcM a = TcRn a -- Historical \end{code} -\begin{code} -zapEnv :: TcRn m a -> TcRn m a -zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } -> - case top of { - TopEnv{ - top_mode = mode, - top_dflags = dflags, - top_hpt = hpt, - top_eps = eps, - top_us = us - } -> do - - eps_snap <- readIORef eps - ref <- newIORef $! emptyExternalPackageState{ eps_PTE = eps_PTE eps_snap } - - let - top' = TopEnv { - top_mode = mode, - top_dflags = dflags, - top_hpt = hpt, - top_eps = ref, - top_us = us - } - - type_env = tcg_type_env gbl - mod = tcg_mod gbl - gbl' = TcGblEnv { - tcg_mod = mod, - tcg_type_env = type_env - } - - env' = Env { - env_top = top', - env_gbl = gbl', - env_lcl = lcl - -- leave the rest empty - } - - case act of { TcRn f -> f env' } - } -\end{code} %************************************************************************ %* * @@ -265,50 +105,19 @@ zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } -> %************************************************************************ \begin{code} -data Env a -- Changes as we move into an expression +data Env gbl lcl -- Changes as we move into an expression = Env { - env_top :: TopEnv, -- Top-level stuff that never changes - -- Mainly a bunch of updatable refs + env_top :: HscEnv, -- Top-level stuff that never changes -- Includes all info about imported things - env_gbl :: TcGblEnv, -- Info about things defined at the top leve - -- of the module being compiled - env_lcl :: a, -- Different for the type checker - -- and the renamer + env_us :: TcRef UniqSupply, -- Unique supply for local varibles - env_loc :: SrcLoc -- Source location - } + env_gbl :: gbl, -- Info about things defined at the top level + -- of the module being compiled -data TopEnv -- Built once at top level then does not change - -- Concerns imported stuff - -- Exceptions: error recovery points, meta computation points - = TopEnv { - top_mode :: GhciMode, - top_dflags :: DynFlags, - - -- Stuff about imports - top_eps :: TcRef ExternalPackageState, - -- PIT, ImportedModuleInfo - -- DeclsMap, IfaceRules, IfaceInsts, InstGates - -- TypeEnv, InstEnv, RuleBase - -- Mutable, because we demand-load declarations that extend the state - - top_hpt :: HomePackageTable, - -- The home package table that we've accumulated while - -- compiling the home package, - -- *excluding* the module we are compiling right now. - -- (In one-shot mode the current module is the only - -- home-package module, so tc_hpt is empty. All other - -- modules count as "external-package" modules.) - -- tc_hpt is not mutable because we only demand-load - -- external packages; the home package is eagerly - -- loaded by the compilation manager. - - -- The global name supply - top_nc :: TcRef NameCache, -- Maps original names to Names - top_us :: TcRef UniqSupply, -- Unique supply for this module - top_errs :: TcRef Messages - } + env_lcl :: lcl -- Nested stuff -- changes as we go into + -- an expression + } -- TcGblEnv describes the top-level of the module at the -- point at which the typechecker is finished work. @@ -316,12 +125,12 @@ data TopEnv -- Built once at top level then does not change data TcGblEnv = TcGblEnv { - tcg_mod :: Module, -- Module being compiled - tcg_usages :: TcRef EntityUsage, -- What version of what entities - -- have been used from other home-pkg modules + tcg_mod :: Module, -- Module being compiled tcg_rdr_env :: GlobalRdrEnv, -- Top level envt; used during renaming - tcg_fix_env :: FixityEnv, -- Ditto - tcg_default :: [Type], -- Types used for defaulting + tcg_default :: Maybe [Type], -- Types used for defaulting + -- Nothing => no 'default' decl + + tcg_fix_env :: FixityEnv, -- Just for things in this module tcg_type_env :: TypeEnv, -- Global type env for the module we are compiling now -- All TyCons and Classes (for this module) end up in here right away, @@ -329,21 +138,22 @@ data TcGblEnv -- -- (Ids defined in this module start in the local envt, -- though they move to the global envt during zonking) + + tcg_type_env_var :: TcRef TypeEnv, + -- Used only to initialise the interface-file + -- typechecker in initIfaceTcRn, so that it can see stuff + -- bound in this module when dealing with hi-boot recursions + -- Updated at intervals (e.g. after dealing with types and classes) - tcg_inst_env :: TcRef InstEnv, -- Global instance env: a combination of - -- tc_pcs, tc_hpt, *and* tc_insts - -- This field is mutable so that it can be updated inside a - -- Template Haskell splice, which might suck in some new - -- instance declarations. This is a slightly different strategy - -- than for the type envt, where we look up first in tcg_type_env - -- and then in the mutable EPS, because the InstEnv for this module - -- is constructed (in principle at least) only from the modules - -- 'below' this one, so it's this-module-specific - -- - -- On the other hand, a declaration quote [d| ... |] may introduce - -- some new instance declarations that we *don't* want to persist - -- outside the quote, so we tiresomely need to revert the InstEnv - -- after finishing the quote (see TcSplice.tcBracket) + tcg_inst_env :: InstEnv, -- Instance envt for *home-package* modules + -- Includes the dfuns in tcg_insts + tcg_inst_uses :: TcRef NameSet, -- Home-package Dfuns actually used + -- Used to generate version dependencies + -- This records usages, rather like tcg_dus, but it has to + -- be a mutable variable so it can be augmented + -- when we look up an instance. These uses of dfuns are + -- rather like the free variables of the program, but + -- are implicit instead of explicit. -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. @@ -353,6 +163,11 @@ data TcGblEnv tcg_imports :: ImportAvails, -- Information about what was imported -- from where, including things bound -- in this module + tcg_dus :: DefUses, -- What is defined in this module and what is used. + -- The latter is used to generate + -- (a) version tracking; no need to recompile if these + -- things have not changed version stamp + -- (b) unused-import info -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fiels are collected @@ -365,6 +180,46 @@ data TcGblEnv } \end{code} +%************************************************************************ +%* * + The interface environments + Used when dealing with IfaceDecls +%* * +%************************************************************************ + +\begin{code} +data IfGblEnv + = IfGblEnv { + -- The type environment for the module being compiled, + -- in case the interface refers back to it via a reference that + -- was originally a hi-boot file. + -- We need the module name so we can test when it's appropriate + -- to look in this env. + if_rec_types :: Maybe (Module, IfG TypeEnv), + -- Allows a read effect, so it can be in a mutable + -- variable; c.f. handling the external package type env + -- Nothing => interactive stuff, no loops possible + + if_is_boot :: ModuleEnv (ModuleName, IsBootInterface) + -- Tells what we know about boot interface files + -- When we're importing a module we know absolutely + -- nothing about, so we assume it's from + -- another package, where we aren't doing + -- dependency tracking. So it won't be a hi-boot file. + } + +data IfLclEnv + = IfLclEnv { + -- The module for the current IfaceDecl + -- So if we see f = \x -> x + -- it means M.f = \x -> x, where M is the if_mod + if_mod :: ModuleName, + + if_tv_env :: OccEnv TyVar, -- Nested tyvar bindings + if_id_env :: OccEnv Id -- Nested id binding + } +\end{code} + %************************************************************************ %* * @@ -388,21 +243,31 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is b) used in the ModDetails of this module \begin{code} -data TcLclEnv +data TcLclEnv -- Changes as we move inside an expression + -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { - tcl_ctxt :: ErrCtxt, -- Error context + tcl_loc :: SrcLoc, -- Source location + tcl_ctxt :: ErrCtxt, -- Error context + tcl_errs :: TcRef Messages, -- Place to accumulate errors tcl_th_ctxt :: ThStage, -- Template Haskell context tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + tcl_rdr :: LocalRdrEnv, -- Local name envt + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence contructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars -- defined in this module tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" - -- Namely, the in-scope TyVars bound in tcl_lenv, - -- plus the tyvars mentioned in the types of - -- Ids bound in tcl_lenv - -- Why mutable? see notes with tcGetGlobalTyVars + -- Namely, the in-scope TyVars bound in tcl_lenv, + -- plus the tyvars mentioned in the types of Ids bound in tcl_lenv + -- Why mutable? see notes with tcGetGlobalTyVars tcl_lie :: TcRef LIE -- Place to accumulate type constraints } @@ -476,19 +341,15 @@ data TcTyThing = AGlobal TyThing -- Used only in the return type of a lookup | ATcId TcId ThLevel ProcLevel -- Ids defined in this module; may not be fully zonked | ATyVar TyVar -- Type variables - | AThing TcKind -- Used temporarily, during kind checking --- Here's an example of how the AThing guy is used --- Suppose we are checking (forall a. T a Int): --- 1. We first bind (a -> AThink kv), where kv is a kind variable. --- 2. Then we kind-check the (T a Int) part. --- 3. Then we zonk the kind variable. --- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment + | ARecTyCon TcKind -- Used temporarily, during kind checking, for the + | ARecClass TcKind -- tycons and clases in this recursive group instance Outputable TcTyThing where -- Debugging only - ppr (AGlobal g) = text "AGlobal" <+> ppr g - ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl - ppr (ATyVar t) = text "ATyVar" <+> ppr t - ppr (AThing k) = text "AThing" <+> ppr k + ppr (AGlobal g) = text "AGlobal" <+> ppr g + ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl + ppr (ATyVar t) = text "ATyVar" <+> ppr t + ppr (ARecTyCon k) = text "ARecTyCon" <+> ppr k + ppr (ARecClass k) = text "ARecClass" <+> ppr k \end{code} \begin{code} @@ -501,37 +362,6 @@ type ErrCtxt = [TidyEnv -> TcM (TidyEnv, Message)] %************************************************************************ %* * - The local renamer environment -%* * -%************************************************************************ - -\begin{code} -data RnLclEnv - = RnLclEnv { - rn_mode :: RnMode, - rn_lenv :: LocalRdrEnv -- Local name envt - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence contructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - } - -data RnMode = SourceMode -- Renaming source code - | InterfaceMode Module -- Renaming interface declarations from M - | CmdLineMode -- Renaming a command-line expression - -isInterfaceMode (InterfaceMode _) = True -isInterfaceMode _ = False - -isCmdLineMode CmdLineMode = True -isCmdLineMode _ = False -\end{code} - - -%************************************************************************ -%* * EntityUsage %* * %************************************************************************ @@ -563,7 +393,7 @@ emptyUsages = emptyNameSet %************************************************************************ ImportAvails summarises what was imported from where, irrespective -of whether the imported htings are actually used or not +of whether the imported things are actually used or not It is used * when processing the export list * when constructing usage info for the inteface file * to identify the list of directly imported modules @@ -631,6 +461,12 @@ data ImportAvails -- Orphan modules below us in the import tree } +mkModDeps :: [(ModuleName, IsBootInterface)] + -> ModuleEnv (ModuleName, IsBootInterface) +mkModDeps deps = foldl add emptyModuleEnv deps + where + add env elt@(m,_) = extendModuleEnvByName env m elt + emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, imp_qual = emptyModuleEnv, @@ -736,17 +572,11 @@ The @WhereFrom@ type controls where the renamer looks for an interface file \begin{code} data WhereFrom = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) - - | ImportForUsage IsBootInterface -- Import when chasing usage info from an interaface file - -- Failure in this case is not an error - | ImportBySystem -- Non user import. instance Outputable WhereFrom where ppr (ImportByUser is_boot) | is_boot = ptext SLIT("{- SOURCE -}") | otherwise = empty - ppr (ImportForUsage is_boot) | is_boot = ptext SLIT("{- USAGE SOURCE -}") - | otherwise = ptext SLIT("{- USAGE -}") ppr ImportBySystem = ptext SLIT("{- SYSTEM -}") \end{code} @@ -921,10 +751,6 @@ data InstOrigin -- translated term, and so need not be bound. Nor should they -- be abstracted over. - | CCallOrigin String -- CCall label - (Maybe RenamedHsExpr) -- Nothing if it's the result - -- Just arg, for an argument - | UnknownOrigin -- Help! I give up... \end{code} @@ -968,11 +794,6 @@ pprInstLoc (InstLoc orig locn ctxt) quotes (ppr clas), text "type:", ppr ty] pp_orig (ValSpecOrigin name) = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)] - pp_orig (CCallOrigin clabel Nothing{-ccall result-}) - = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)] - pp_orig (CCallOrigin clabel (Just arg_expr)) - = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma, - text "namely", quotes (ppr arg_expr)] pp_orig (UnknownOrigin) = ptext SLIT("...oops -- I don't know where the overloading came from!") \end{code} diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 0367f69689..27072a244c 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -9,17 +9,15 @@ module TcRules ( tcRules ) where #include "HsVersions.h" import HsSyn ( RuleDecl(..), RuleBndr(..), collectRuleBndrSigTys ) -import CoreSyn ( CoreRule(..) ) import RnHsSyn ( RenamedRuleDecl ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcRnMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) import TcMType ( newTyVarTy ) import TcType ( tyVarsOfTypes, openTypeKind ) -import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) import TcExpr ( tcCheckRho ) -import TcEnv ( tcExtendLocalValEnv, tcLookupGlobalId, tcLookupId ) +import TcEnv ( tcExtendLocalValEnv ) import Inst ( instToId ) import Id ( idType, mkLocalId ) import Outputable @@ -30,30 +28,12 @@ tcRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl] tcRules decls = mappM tcRule decls tcRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl -tcRule (IfaceRule name act vars fun args rhs src_loc) - = addSrcLoc src_loc $ - addErrCtxt (ruleCtxt name) $ - tcLookupGlobalId fun `thenM` \ fun' -> - tcCoreLamBndrs vars $ \ vars' -> - mappM tcCoreExpr args `thenM` \ args' -> - tcCoreExpr rhs `thenM` \ rhs' -> - returnM (IfaceRuleOut fun' (Rule name act vars' args' rhs')) - -tcRule (IfaceRuleOut fun rule) -- Built-in rules, and only built-in rules, - -- come this way. Usually IfaceRuleOut is only - -- used for the *output* of the type checker - = tcLookupId fun `thenM` \ fun' -> - -- NB: tcLookupId, not tcLookupGlobalId - -- Reason: when compiling GHC.Base, where eqString is defined, - -- we'll get the builtin rule for eqString, but eqString - -- will be in the *local* type environment. - -- Seems like a bit of a hack - returnM (IfaceRuleOut fun' rule) - tcRule (HsRule name act vars lhs rhs src_loc) = addSrcLoc src_loc $ addErrCtxt (ruleCtxt name) $ - newTyVarTy openTypeKind `thenM` \ rule_ty -> + traceTc (ptext SLIT("---- Rule ------") + <+> ppr name) `thenM_` + newTyVarTy openTypeKind `thenM` \ rule_ty -> -- Deal with the tyvars mentioned in signatures tcAddScopedTyVars (collectRuleBndrSigTys vars) ( diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 1970ab387f..fb8b4bf25a 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -37,11 +37,11 @@ import Inst ( lookupInst, LookupInstResult(..), newDictsFromOld, tcInstClassOp, getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, - Inst, pprInsts, pprInstsInFull, - isIPDict, isInheritableInst + Inst, pprInsts, pprInstsInFull, tcGetInstEnvs, + isIPDict, isInheritableInst, pprDFuns ) -import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupId, findGlobals ) -import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) ) +import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals ) +import InstEnv ( lookupInstEnv, classInstEnv ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv), mkClassPred, isOverloadedTy, mkTyConApp, @@ -54,18 +54,16 @@ import NameSet ( NameSet, mkNameSet, elemNameSet ) import Class ( classBigSig, classKey ) import FunDeps ( oclose, grow, improve, pprEquationDoc ) import PrelInfo ( isNumericClass ) -import PrelNames ( splitName, fstName, sndName, showClassKey, eqClassKey, ordClassKey) -import HscTypes ( GhciMode(Interactive) ) - +import PrelNames ( splitName, fstName, sndName, integerTyConName, + showClassKey, eqClassKey, ordClassKey ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) -import TysWiredIn ( unitTy, pairTyCon ) +import TysWiredIn ( pairTyCon, doubleTy ) import ErrUtils ( Message ) import VarSet import VarEnv ( TidyEnv ) import FiniteMap import Outputable import ListSetOps ( equivClasses ) -import Unique ( hasKey ) import Util ( zipEqual, isSingleton ) import List ( partition ) import CmdLineOpts @@ -729,13 +727,18 @@ tcSimplCheck doc get_qtvs givens wanted_lie = check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) -> -- Complain about any irreducible ones - complainCheck doc givens irreds `thenM_` + mappM zonkInst given_dicts_and_ips `thenM` \ givens' -> + groupErrs (addNoInstanceErrs (Just doc) givens') irreds `thenM_` -- Done - extendLIEs frees `thenM_` + extendLIEs frees `thenM_` returnM (qtvs, binds) where + given_dicts_and_ips = filter (not . isMethod) givens + -- For error reporting, filter out methods, which are + -- only added to the given set as an optimisation + ip_set = mkNameSet (ipNamesOfInsts givens) check_loop givens wanteds @@ -1328,8 +1331,10 @@ reduceContext doc try_me givens wanteds returnM (no_improvement, frees, binds, irreds) +tcImprove :: Avails -> TcM Bool -- False <=> no change +-- Perform improvement using all the predicates in Avails tcImprove avails - = tcGetInstEnv `thenM` \ inst_env -> + = tcGetInstEnvs `thenM` \ (home_ie, pkg_ie) -> let preds = [ (pred, pp_loc) | inst <- keysFM avails, @@ -1341,7 +1346,8 @@ tcImprove avails -- It does not have duplicates (good) -- NB that (?x::t1) and (?x::t2) will be held separately in avails -- so that improve will see them separate - eqns = improve (classInstEnv inst_env) preds + eqns = improve get_insts preds + get_insts clas = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas in if null eqns then returnM True @@ -1689,8 +1695,7 @@ tc_simplify_top is_interactive wanteds -- Collect together all the bad guys bad_guys = non_stds ++ concat std_bads - (tidy_env, tidy_dicts) = tidyInsts bad_guys - (bad_ips, non_ips) = partition isIPDict tidy_dicts + (bad_ips, non_ips) = partition isIPDict bad_guys (no_insts, ambigs) = partition no_inst non_ips no_inst d = not (isTyVarDict d) -- Previously, there was a more elaborate no_inst definition: @@ -1701,8 +1706,8 @@ tc_simplify_top is_interactive wanteds in -- Report definite errors - addTopInstanceErrs tidy_env no_insts `thenM_` - addTopIPErrs tidy_env bad_ips `thenM_` + groupErrs (addNoInstanceErrs Nothing []) no_insts `thenM_` + addTopIPErrs bad_ips `thenM_` -- Deal with ambiguity errors, but only if -- if there has not been an error so far; errors often @@ -1715,7 +1720,7 @@ tc_simplify_top is_interactive wanteds -- e.g. Num (IO a) and Eq (Int -> Int) -- and ambiguous dictionaries -- e.g. Num a - addTopAmbigErrs (tidy_env, ambigs) `thenM_` + addTopAmbigErrs ambigs `thenM_` -- Disambiguate the ones that look feasible mappM (disambigGroup is_interactive) std_oks @@ -1778,7 +1783,7 @@ disambigGroup is_interactive dicts -- default list which can satisfy all the ambiguous classes. -- For example, if Real a is reqd, but the only type in the -- default list is Int. - getDefaultTys `thenM` \ default_tys -> + get_default_tys `thenM` \ default_tys -> let try_default [] -- No defaults work, so fail = failM @@ -1821,8 +1826,17 @@ disambigGroup is_interactive dicts warnDefault dicts default_ty `thenM_` returnM binds - bomb_out = addTopAmbigErrs (tidyInsts dicts) `thenM_` + bomb_out = addTopAmbigErrs dicts `thenM_` returnM EmptyMonoBinds + +get_default_tys + = do { mb_defaults <- getDefaultTys + ; case mb_defaults of + Just tys -> return tys + Nothing -> -- No use-supplied default; + -- use [Integer, Double] + do { integer_ty <- tcMetaTy integerTyConName + ; return [integer_ty, doubleTy] } } \end{code} [Aside - why the defaulting mechanism is turned off when @@ -1995,28 +2009,89 @@ addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts))) plural [x] = empty plural xs = char 's' - -addTopIPErrs tidy_env tidy_dicts +addTopIPErrs dicts = groupErrs report tidy_dicts where + (tidy_env, tidy_dicts) = tidyInsts dicts report dicts = addErrTcM (tidy_env, mk_msg dicts) mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <> plural tidy_dicts <+> pprInsts tidy_dicts) --- Used for top-level irreducibles -addTopInstanceErrs tidy_env tidy_dicts - = groupErrs report tidy_dicts +addNoInstanceErrs :: Maybe SDoc -- Nothing => top level + -- Just d => d describes the construct + -> [Inst] -- What is given by the context or type sig + -> [Inst] -- What is wanted + -> TcM () +addNoInstanceErrs mb_what givens [] + = returnM () +addNoInstanceErrs mb_what givens dicts + = -- Some of the dicts are here because there is no instances + -- and some because there are too many instances (overlap) + -- The first thing we do is separate them + getDOpts `thenM` \ dflags -> + tcGetInstEnvs `thenM` \ inst_envs -> + let + (tidy_env1, tidy_givens) = tidyInsts givens + (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts + + -- Run through the dicts, generating a message for each + -- overlapping one, but simply accumulating all the + -- no-instance ones so they can be reported as a group + (overlap_doc, no_inst_dicts) = foldl check_overlap (empty, []) tidy_dicts + check_overlap (overlap_doc, no_inst_dicts) dict + | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts) + | otherwise + = case lookupInstEnv dflags inst_envs clas tys of + ([], _) -> (overlap_doc, dict : no_inst_dicts) -- No matches + inst_res -> (mk_overlap_msg dict inst_res $$ overlap_doc, no_inst_dicts) + where + (clas,tys) = getDictClassTys dict + in + mk_probable_fix tidy_env2 mb_what no_inst_dicts `thenM` \ (tidy_env3, probable_fix) -> + let + no_inst_doc | null no_inst_dicts = empty + | otherwise = vcat [addInstLoc no_inst_dicts heading, probable_fix] + heading | null givens = ptext SLIT("No instance") <> plural no_inst_dicts <+> + ptext SLIT("for") <+> pprInsts no_inst_dicts + | otherwise = sep [ptext SLIT("Could not deduce") <+> pprInsts no_inst_dicts, + nest 2 $ ptext SLIT("from the context") <+> pprInsts tidy_givens] + in + addErrTcM (tidy_env3, no_inst_doc $$ overlap_doc) + where - report dicts = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) -> - addErrTcM (tidy_env, mk_msg dicts $$ mono_msg) - mk_msg dicts = addInstLoc dicts (ptext SLIT("No instance") <> plural tidy_dicts <+> - ptext SLIT("for") <+> pprInsts tidy_dicts) - + mk_overlap_msg dict (matches, unifiers) + = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") <+> ppr dict)), + sep [ptext SLIT("Matching instances") <> colon, + nest 2 (pprDFuns (dfuns ++ unifiers))], + if null unifiers + then empty + else parens (ptext SLIT("The choice depends on the instantiation of") <+> + quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))))] + where + dfuns = [df | (_, (_,_,df)) <- matches] + + mk_probable_fix tidy_env Nothing dicts -- Top level + = mkMonomorphismMsg tidy_env dicts + mk_probable_fix tidy_env (Just what) dicts -- Nested (type signatures, instance decls) + = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 fix1, nest 2 fix2]) + where + fix1 = sep [ptext SLIT("Add") <+> pprInsts dicts, + ptext SLIT("to the") <+> what] + + fix2 | null instance_dicts = empty + | otherwise = ptext SLIT("Or add an instance declaration for") + <+> pprInsts instance_dicts + instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)] + -- Insts for which it is worth suggesting an adding an instance declaration + -- Exclude implicit parameters, and tyvar dicts + -addTopAmbigErrs (tidy_env, tidy_dicts) +addTopAmbigErrs dicts -- Divide into groups that share a common set of ambiguous tyvars = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts]) where + (tidy_env, tidy_dicts) = tidyInsts dicts + tvs_of :: Inst -> [TcTyVar] tvs_of d = varSetElems (tyVarsOfInst d) cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 @@ -2066,72 +2141,6 @@ warnDefault dicts default_ty quotes (ppr default_ty), pprInstsInFull tidy_dicts] -complainCheck doc givens irreds - = mappM zonkInst given_dicts_and_ips `thenM` \ givens' -> - groupErrs (addNoInstanceErrs doc givens') irreds `thenM_` - returnM () - where - given_dicts_and_ips = filter (not . isMethod) givens - -- Filter out methods, which are only added to - -- the given set as an optimisation - -addNoInstanceErrs what_doc givens dicts - = getDOpts `thenM` \ dflags -> - tcGetInstEnv `thenM` \ inst_env -> - let - (tidy_env1, tidy_givens) = tidyInsts givens - (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts - - doc = vcat [addInstLoc dicts $ - sep [herald <+> pprInsts tidy_dicts, - nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens], - ambig_doc, - ptext SLIT("Probable fix:"), - nest 4 fix1, - nest 4 fix2] - - herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce") - unambig_doc | ambig_overlap = ptext SLIT("unambiguously") - | otherwise = empty - - -- The error message when we don't find a suitable instance - -- is complicated by the fact that sometimes this is because - -- there is no instance, and sometimes it's because there are - -- too many instances (overlap). See the comments in TcEnv.lhs - -- with the InstEnv stuff. - - ambig_doc - | not ambig_overlap = empty - | otherwise - = vcat [ptext SLIT("The choice of (overlapping) instance declaration"), - nest 4 (ptext SLIT("depends on the instantiation of") <+> - quotes (pprWithCommas ppr (varSetElems (tyVarsOfInsts tidy_dicts))))] - - fix1 = sep [ptext SLIT("Add") <+> pprInsts tidy_dicts, - ptext SLIT("to the") <+> what_doc] - - fix2 | null instance_dicts - = empty - | otherwise - = ptext SLIT("Or add an instance declaration for") <+> pprInsts instance_dicts - - instance_dicts = [d | d <- tidy_dicts, isClassDict d, not (isTyVarDict d)] - -- Insts for which it is worth suggesting an adding an instance declaration - -- Exclude implicit parameters, and tyvar dicts - - -- Checks for the ambiguous case when we have overlapping instances - ambig_overlap = any ambig_overlap1 dicts - ambig_overlap1 dict - | isClassDict dict - = case lookupInstEnv dflags inst_env clas tys of - NoMatch ambig -> ambig - other -> False - | otherwise = False - where - (clas,tys) = getDictClassTys dict - in - addErrTcM (tidy_env2, doc) - -- Used for the ...Thetas variants; all top level noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred) diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 53586be63b..45d071cada 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -9,13 +9,13 @@ module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where #include "HsVersions.h" import HscMain ( compileExpr ) -import TcRnDriver ( importSupportingDecls, tcTopSrcDecls ) +import TcRnDriver ( tcTopSrcDecls ) -- These imports are the reason that TcSplice -- is very high up the module hierarchy import qualified Language.Haskell.THSyntax as Meta -import HscTypes ( HscEnv(..), PersistentCompilerState(..) ) +import HscTypes ( HscEnv(..) ) import HsSyn ( HsBracket(..), HsExpr(..) ) import Convert ( convertToHsExpr, convertToHsDecls ) import RnExpr ( rnExpr ) @@ -26,10 +26,9 @@ import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) import TcType ( TcType, openTypeKind, mkAppTy ) -import TcEnv ( spliceOK, tcMetaTy, tcWithTempInstEnv, bracketOK ) -import TcRnTypes ( TopEnv(..) ) +import TcEnv ( spliceOK, tcMetaTy, bracketOK ) import TcMType ( newTyVarTy, UserTypeCtxt(ExprSigCtxt) ) -import TcMonoType ( tcHsSigType ) +import TcHsType ( tcHsSigType ) import Name ( Name ) import TcRnMonad @@ -109,14 +108,12 @@ tc_bracket (TypBr typ) -- Result type is Type (= Q Typ) tc_bracket (DecBr decls) - = tcWithTempInstEnv (tcTopSrcDecls decls) `thenM_` - -- Typecheck the declarations, dicarding any side effects - -- on the instance environment (which is in a mutable variable) - -- and the extended environment. We'll get all that stuff - -- later, when we splice it in - - tcMetaTy decTyConName `thenM` \ decl_ty -> - tcMetaTy qTyConName `thenM` \ q_ty -> + = tcTopSrcDecls decls `thenM_` + -- Typecheck the declarations, dicarding the result + -- We'll get all that stuff later, when we splice it in + + tcMetaTy decTyConName `thenM` \ decl_ty -> + tcMetaTy qTyConName `thenM` \ q_ty -> returnM (mkAppTy q_ty (mkListTy decl_ty)) -- Result type is Q [Dec] \end{code} @@ -186,10 +183,9 @@ tcTopSplice expr res_ty showSplice "expression" zonked_q_expr (ppr expr2) `thenM_` - initRn SourceMode (rnExpr expr2) `thenM` \ (exp3, fvs) -> - importSupportingDecls fvs `thenM` \ env -> + rnExpr expr2 `thenM` \ (exp3, fvs) -> - setGblEnv env (tcMonoExpr exp3 res_ty) + tcMonoExpr exp3 res_ty tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr @@ -265,19 +261,10 @@ runMetaD e = runMeta e runMeta :: TypecheckedHsExpr -- Of type X -> TcM t -- Of type t runMeta expr - = getTopEnv `thenM` \ top_env -> + = getTopEnv `thenM` \ hsc_env -> getGblEnv `thenM` \ tcg_env -> - getEps `thenM` \ eps -> - getNameCache `thenM` \ name_cache -> getModule `thenM` \ this_mod -> let - ghci_mode = top_mode top_env - - hsc_env = HscEnv { hsc_mode = ghci_mode, hsc_HPT = top_hpt top_env, - hsc_dflags = top_dflags top_env } - - pcs = PCS { pcs_nc = name_cache, pcs_EPS = eps } - type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env in @@ -286,7 +273,7 @@ runMeta expr -- Running might fail if it throws an exception tryM (ioToTcRn (do hval <- HscMain.compileExpr - hsc_env pcs this_mod + hsc_env this_mod rdr_env type_env expr Meta.runQ (unsafeCoerce# hval) -- Coerce it to Q t, and run it )) `thenM` \ either_tval -> diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 378dc35943..d41de58800 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -10,46 +10,43 @@ module TcTyClsDecls ( #include "HsVersions.h" -import HsSyn ( TyClDecl(..), - ConDecl(..), Sig(..), HsPred(..), - tyClDeclName, hsTyVarNames, tyClDeclTyVars, - isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig +import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), + ConDecl(..), Sig(..), BangType(..), HsBang(..), + tyClDeclTyVars, getBangType, getBangStrictness ) -import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs ) -import RnEnv ( lookupSysName ) -import BasicTypes ( RecFlag(..), NewOrData(..) ) +import RnHsSyn ( RenamedTyClDecl, RenamedConDecl ) +import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) ) import HscTypes ( implicitTyThings ) - +import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon ) import TcRnMonad -import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..), - tcExtendKindEnv, tcLookup, tcLookupGlobal, tcExtendGlobalEnv, - isLocalThing ) -import TcTyDecls ( tcTyDecl, kcConDetails ) -import TcClassDcl ( tcClassDecl1 ) -import TcInstDcls ( tcAddDeclCtxt ) -import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars ) -import TcMType ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass ) +import TcEnv ( TcTyThing(..), TyThing(..), + tcLookup, tcLookupGlobal, tcExtendGlobalEnv, + tcExtendRecEnv, tcLookupTyVar ) +import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcCycleErrs ) +import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) +import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcCheckHsType, + kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext ) +import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, + UserTypeCtxt(..), SourceTyCtxt(..), pprUserTypeCtxt ) import TcUnify ( unifyKind ) -import TcType ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys ) +import TcType ( TcKind, ThetaType, TcType, + mkArrowKind, liftedTypeKind, + tcSplitSigmaTy, tcEqType ) import Type ( splitTyConApp_maybe ) -import Variance ( calcTyConArgVrcs ) -import Class ( Class, mkClass, classTyCon ) -import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons, - tyConKind, tyConTyVars, tyConDataCons, isNewTyCon, - mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon - ) -import TysWiredIn ( unitTy ) -import Subst ( substTyWith ) -import DataCon ( dataConOrigArgTys ) -import Var ( varName ) -import OccName ( mkClassTyConOcc ) -import FiniteMap -import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( Name ) -import NameEnv -import NameSet +import PprType ( pprThetaArrow, pprParendType ) +import FieldLabel ( fieldLabelName, fieldLabelType ) +import Generics ( validGenericMethodType, canDoGenerics ) +import Class ( Class, className, classTyCon, DefMeth(..), classBigSig ) +import TyCon ( TyCon, ArgVrcs, DataConDetails(..), + tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, + tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName ) +import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) +import Var ( TyVar, idType, idName ) +import Name ( Name, getSrcLoc ) import Outputable -import Maybes ( mapMaybe, orElse, catMaybes ) +import Util ( zipLazy, isSingleton, notNull ) +import ListSetOps ( equivClasses ) +import CmdLineOpts ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) ) \end{code} @@ -59,27 +56,6 @@ import Maybes ( mapMaybe, orElse, catMaybes ) %* * %************************************************************************ -The main function -~~~~~~~~~~~~~~~~~ -\begin{code} -tcTyAndClassDecls :: [RenamedTyClDecl] - -> TcM TcGblEnv -- Returns extended environment - -tcTyAndClassDecls decls - = do { edge_map <- mkEdgeMap tc_decls ; - let { edges = mkEdges edge_map tc_decls } ; - tcGroups edge_map (stronglyConnComp edges) } - where - tc_decls = filter isTypeOrClassDecl decls - -tcGroups edge_map [] = getGblEnv - -tcGroups edge_map (group:groups) - = tcGroup edge_map group `thenM` \ env -> - setGblEnv env $ - tcGroups edge_map groups -\end{code} - Dealing with a group ~~~~~~~~~~~~~~~~~~~~ Consider a mutually-recursive group, binding @@ -124,111 +100,73 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. \begin{code} -tcGroup :: EdgeMap -> SCC RenamedTyClDecl - -> TcM TcGblEnv -- Input env extended by types and classes - -- and their implicit Ids,DataCons - -tcGroup edge_map scc - = -- Step 1 - mappM getInitialKind decls `thenM` \ initial_kinds -> - - -- Step 2 - tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls) `thenM_` - - -- Step 3 - zonkKindEnv initial_kinds `thenM` \ final_kinds -> - - -- Check for loops; if any are found, bale out now - -- because the compiler itself will loop otherwise! - checkNoErrs (checkLoops edge_map scc) `thenM` \ is_rec_tycon -> - - -- Tie the knot - traceTc (text "starting" <+> ppr final_kinds) `thenM_` - fixM ( \ ~(rec_details_list, _, _) -> - -- Step 4 - let - kind_env = mkNameEnv final_kinds - rec_details = mkNameEnv rec_details_list - - -- Calculate variances, and feed into buildTyConOrClass - rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- tyclss] - - build_one = buildTyConOrClass is_rec_tycon kind_env - rec_vrcs rec_details - tyclss = map build_one decls - - in - -- Step 5 - -- Extend the environment with the final - -- TyCons/Classes and check the decls - tcExtendGlobalEnv tyclss $ - mappM tcTyClDecl1 decls `thenM` \ tycls_details -> - - -- Return results - getGblEnv `thenM` \ env -> - returnM (tycls_details, env, tyclss) - ) `thenM` \ (_, env, tyclss) -> - - -- Step 7: Check validity - setGblEnv env $ - - traceTc (text "ready for validity check") `thenM_` - getModule `thenM` \ mod -> - mappM_ (checkValidTyCl mod) decls `thenM_` - traceTc (text "done") `thenM_` +tcTyAndClassDecls :: [RenamedTyClDecl] + -> TcM TcGblEnv -- Input env extended by types and classes + -- and their implicit Ids,DataCons +tcTyAndClassDecls decls + = do { -- First check for cyclic type synonysm or classes + -- See notes with checkCycleErrs + checkCycleErrs decls + + ; tyclss <- fixM (\ rec_tyclss -> + do { lcl_things <- mappM getInitialKind decls + -- Extend the local env with kinds, and + -- the global env with the knot-tied results + ; let { gbl_things = mkGlobalThings decls rec_tyclss } + ; tcExtendRecEnv gbl_things lcl_things $ do + + -- The local type environment is populated with + -- {"T" -> ARecTyCon k, ...} + -- and the global type envt with + -- {"T" -> ATyCon T, ...} + -- where k is T's (unzonked) kind + -- T is the loop-tied TyCon itself + -- We must populate the environment with the loop-tied T's right + -- away, because the kind checker may "fault in" some type + -- constructors that recursively mention T + + -- Kind-check the declarations, returning kind-annotated decls + { kc_decls <- mappM kcTyClDecl decls + + -- Calculate variances and rec-flag + ; let { calc_vrcs = calcTyConArgVrcs rec_tyclss + ; calc_rec = calcRecFlags rec_tyclss } + + ; mappM (tcTyClDecl calc_vrcs calc_rec) kc_decls + }}) + -- Finished with knot-tying now + -- Extend the environment with the finished things + ; tcExtendGlobalEnv tyclss $ do + + -- Perform the validity check + { traceTc (text "ready for validity check") + ; mappM_ checkValidTyCl decls + ; traceTc (text "done") - let -- Add the tycons that come from the classes - -- We want them in the environment because - -- they are mentioned in interface files - implicit_things = implicitTyThings tyclss - in - traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) `thenM_` - tcExtendGlobalEnv implicit_things getGblEnv - + -- Add the implicit things; + -- we want them in the environment because + -- they may be mentioned in interface files + ; let { implicit_things = concatMap implicitTyThings tyclss } + ; traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) + ; tcExtendGlobalEnv implicit_things getGblEnv + }} + +mkGlobalThings :: [RenamedTyClDecl] -- The decls + -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls + -> [(Name,TyThing)] +-- Driven by the Decls, and treating the TyThings lazily +-- make a TypeEnv for the new things +mkGlobalThings decls things + = map mk_thing (decls `zipLazy` things) where - decls = case scc of - AcyclicSCC decl -> [decl] - CyclicSCC decls -> decls - -tcTyClDecl1 decl - | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl) - | otherwise = tcAddDeclCtxt decl (tcTyDecl decl) - --- We do the validity check over declarations, rather than TyThings --- only so that we can add a nice context with tcAddDeclCtxt -checkValidTyCl this_mod decl - = tcLookupGlobal (tcdName decl) `thenM` \ thing -> - if not (isLocalThing this_mod thing) then - -- Don't bother to check validity for non-local things - returnM () - else - tcAddDeclCtxt decl $ - case thing of - ATyCon tc -> checkValidTyCon tc - AClass cl -> checkValidClass cl -\end{code} - - -%************************************************************************ -%* * -\subsection{Step 1: Initial environment} -%* * -%************************************************************************ - -\begin{code} -getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind) -getInitialKind decl - = kcHsTyVars (tyClDeclTyVars decl) `thenM` \ arg_kinds -> - newKindVar `thenM` \ result_kind -> - returnM (tcdName decl, mk_kind arg_kinds result_kind) - -mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds + mk_thing (ClassDecl {tcdName = name}, ~(AClass cl)) = (name, AClass cl) + mk_thing (decl, ~(ATyCon tc)) = (tcdName decl, ATyCon tc) \end{code} %************************************************************************ %* * -\subsection{Step 2: Kind checking} + Kind checking %* * %************************************************************************ @@ -246,190 +184,214 @@ depends on *all the uses of class D*. For example, the use of Monad c in bop's type signature means that D must have kind Type->Type. \begin{code} -kcTyClDecl :: RenamedTyClDecl -> TcM () +------------------------------------------------------------------------ +getInitialKind :: TyClDecl Name -> TcM (Name, TcTyThing) -kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs}) - = kcTyClDeclBody decl $ \ result_kind -> - kcHsType rhs `thenM` \ rhs_kind -> - unifyKind result_kind rhs_kind +-- Note the lazy pattern match on the ATyCon etc +-- Exactly the same reason as the zipLay above + +getInitialKind (TyData {tcdName = name}) + = newKindVar `thenM` \ kind -> + returnM (name, ARecTyCon kind) + +getInitialKind (TySynonym {tcdName = name}) + = newKindVar `thenM` \ kind -> + returnM (name, ARecTyCon kind) + +getInitialKind (ClassDecl {tcdName = name}) + = newKindVar `thenM` \ kind -> + returnM (name, ARecClass kind) -kcTyClDecl (ForeignType {}) = returnM () -kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls}) - = kcTyClDeclBody decl $ \ result_kind -> - kcHsContext context `thenM_` - mappM_ kc_con_decl (visibleDataCons con_decls) +------------------------------------------------------------------------ +kcTyClDecl :: RenamedTyClDecl -> TcM RenamedTyClDecl + +kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs}) + = do { res_kind <- newKindVar + ; kcTyClDeclBody decl res_kind $ \ tvs' -> + do { rhs' <- kcCheckHsType rhs res_kind + ; return (decl {tcdTyVars = tvs', tcdSynRhs = rhs'}) } } + +kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) + = kcTyClDeclBody decl liftedTypeKind $ \ tvs' -> + do { ctxt' <- kcHsContext ctxt + ; cons' <- mappM kc_con_decl cons + ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) } where - kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc) - = kcHsTyVars ex_tvs `thenM` \ kind_env -> - tcExtendKindEnv kind_env $ - kcConDetails new_or_data ex_ctxt details - -kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs}) - = kcTyClDeclBody decl $ \ result_kind -> - kcHsContext context `thenM_` - mappM_ kc_sig (filter isClassOpSig class_sigs) + kc_con_decl (ConDecl name ex_tvs ex_ctxt details loc) + = kcHsTyVars ex_tvs $ \ ex_tvs' -> + do { ex_ctxt' <- kcHsContext ex_ctxt + ; details' <- kc_con_details details + ; return (ConDecl name ex_tvs' ex_ctxt' details' loc)} + + kc_con_details (PrefixCon btys) + = do { btys' <- mappM kc_arg_ty btys ; return (PrefixCon btys') } + kc_con_details (InfixCon bty1 bty2) + = do { bty1' <- kc_arg_ty bty1; bty2' <- kc_arg_ty bty2; return (InfixCon bty1' bty2') } + kc_con_details (RecCon fields) + = do { fields' <- mappM kc_field fields; return (RecCon fields') } + + kc_field (fld, bty) = do { bty' <- kc_arg_ty bty ; return (fld, bty') } + + kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') } + kc_arg_ty_body = case new_or_data of + DataType -> kcHsSigType + NewType -> kcHsLiftedSigType + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + +kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) + = kcTyClDeclBody decl liftedTypeKind $ \ tvs' -> + do { ctxt' <- kcHsContext ctxt + ; sigs' <- mappM kc_sig sigs + ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } where - kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty - -kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a --- Extend the env with bindings for the tyvars, taken from --- the kind of the tycon/class. Give it to the thing inside, and --- check the result kind matches -kcTyClDeclBody decl thing_inside + kc_sig (Sig nm op_ty loc) = do { op_ty' <- kcHsLiftedSigType op_ty + ; return (Sig nm op_ty' loc) } + kc_sig other_sig = return other_sig + +kcTyClDecl decl@(ForeignType {}) + = return decl + +kcTyClDeclBody :: RenamedTyClDecl -> TcKind + -> ([HsTyVarBndr Name] -> TcM a) + -> TcM a + -- Extend the env with bindings for the tyvars, taken from + -- the kind of the tycon/class. Give it to the thing inside, and + -- check the result kind matches +kcTyClDeclBody decl res_kind thing_inside = tcAddDeclCtxt decl $ - tcLookup (tcdName decl) `thenM` \ thing -> - let - kind = case thing of - AGlobal (ATyCon tc) -> tyConKind tc - AGlobal (AClass cl) -> tyConKind (classTyCon cl) - AThing kind -> kind - -- For some odd reason, a class doesn't include its kind - - (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind - in - tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind) + kcHsTyVars (tyClDeclTyVars decl) $ \ kinded_tvs -> + do { tc_ty_thing <- tcLookup (tcdName decl) + ; let { tc_kind = case tc_ty_thing of + ARecClass k -> k + ARecTyCon k -> k + } + ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) + res_kind kinded_tvs) + ; thing_inside kinded_tvs } + +kindedTyVarKind (KindedTyVar _ k) = k \end{code} - %************************************************************************ %* * -\subsection{Step 4: Building the tycon/class} +\subsection{Type checking} %* * %************************************************************************ \begin{code} -buildTyConOrClass - :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive - -> NameEnv Kind - -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails - -> RenamedTyClDecl -> TyThing - -buildTyConOrClass rec_tycon kenv rec_vrcs rec_details - (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names}) - = ATyCon tycon +tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) + -> RenamedTyClDecl -> TcM TyThing + +tcTyClDecl calc_vrcs calc_isrec decl + = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl) + +tcTyClDecl1 calc_vrcs calc_isrec + (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { rhs_ty' <- tcHsKindedType rhs_ty + ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) } where - tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs - tycon_kind = lookupNameEnv_NF kenv tycon_name - arity = length tyvar_names - tyvars = mkTyClTyVars tycon_kind tyvar_names - SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name - argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon - -buildTyConOrClass rec_tycon kenv rec_vrcs rec_details - (TyData {tcdND = data_or_new, tcdName = tycon_name, - tcdTyVars = tyvar_names}) - = ATyCon tycon + arg_vrcs = calc_vrcs tc_name + +tcTyClDecl1 calc_vrcs calc_isrec + (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, + tcdName = tc_name, tcdCons = cons}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { ctxt' <- tcHsKindedContext ctxt + ; want_generic <- doptM Opt_Generics + ; tycon <- fixM (\ tycon -> do + { cons' <- mappM (tcConDecl new_or_data tycon tvs' ctxt') cons + ; buildAlgTyCon new_or_data tc_name tvs' ctxt' + (DataCons cons') arg_vrcs is_rec + (want_generic && canDoGenerics cons') + }) + ; return (ATyCon tycon) + } where - tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs - data_cons sel_ids flavour - (rec_tycon tycon_name flavour) gen_info - - DataTyDetails ctxt data_cons sel_ids gen_info = lookupNameEnv_NF rec_details tycon_name - - tycon_kind = lookupNameEnv_NF kenv tycon_name - tyvars = mkTyClTyVars tycon_kind tyvar_names - argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon - - -- Watch out! mkTyConApp asks whether the tycon is a NewType, - -- so flavour has to be able to answer this question without consulting rec_details - flavour = case data_or_new of - NewType -> NewTyCon (mkNewTyConRep tycon) - DataType | all_nullary data_cons -> EnumTyCon - | otherwise -> DataTyCon - - all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons - all_nullary other = False -- Safe choice for unknown data types - -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon - -- but that looks at the *representation* arity, and that in turn - -- depends on deciding whether to unpack the args, and that - -- depends on whether it's a data type or a newtype --- so - -- in the recursive case we can get a loop. This version is simple! - -buildTyConOrClass rec_tycon kenv rec_vrcs rec_details - (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name}) - = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 []) - -buildTyConOrClass rec_tycon kenv rec_vrcs rec_details - (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} ) - = AClass clas + arg_vrcs = calc_vrcs tc_name + is_rec = calc_isrec tc_name + +tcTyClDecl1 calc_vrcs calc_isrec + (ClassDecl {tcdName = class_name, tcdTyVars = tvs, + tcdCtxt = ctxt, tcdMeths = meths, + tcdFDs = fundeps, tcdSigs = sigs} ) + = tcTyVarBndrs tvs $ \ tvs' -> do + { ctxt' <- tcHsKindedContext ctxt + ; fds' <- mappM tc_fundep fundeps + ; sig_stuff <- tcClassSigs class_name sigs meths + ; clas <- fixM (\ clas -> + let -- This little knot is just so we can get + -- hold of the name of the class TyCon, which we + -- need to look up its recursiveness and variance + tycon_name = tyConName (classTyCon clas) + tc_isrec = calc_isrec tycon_name + tc_vrcs = calc_vrcs tycon_name + in + buildClass class_name tvs' ctxt' fds' + sig_stuff tc_isrec tc_vrcs) + ; return (AClass clas) } where - clas = mkClass class_name tyvars fds - sc_theta sc_sel_ids op_items - tycon - - tycon = mkClassTyCon tycon_name class_kind tyvars - argvrcs dict_con - clas -- Yes! It's a dictionary - flavour - (rec_tycon class_name flavour) - -- A class can be recursive, and in the case of newtypes - -- this matters. For example - -- class C a where { op :: C b => a -> b -> Int } - -- Because C has only one operation, it is represented by - -- a newtype, and it should be a *recursive* newtype. - -- [If we don't make it a recursive newtype, we'll expand the - -- newtype like a synonym, but that will lead toan inifinite type - - ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name - = lookupNameEnv_NF rec_details class_name - - class_kind = lookupNameEnv_NF kenv class_name - tyvars = mkTyClTyVars class_kind tyvar_names - argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon - - flavour = case dataConOrigArgTys dict_con of - -- The tyvars in the datacon are the same as in the class - [rep_ty] -> NewTyCon rep_ty - other -> DataTyCon - - -- We can find the functional dependencies right away, - -- and it is vital to do so. Why? Because in the next pass - -- we check for ambiguity in all the type signatures, and we - -- need the functional dependcies to be done by then - fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps] - tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars] - lookup = lookupNameEnv_NF tyvar_env - -bogusVrcs = panic "Bogus tycon arg variances" -\end{code} - -\begin{code} -mkNewTyConRep :: TyCon -- The original type constructor - -> Type -- Chosen representation type - -- (guaranteed not to be another newtype) - --- Find the representation type for this newtype TyCon --- Remember that the representation type is the ultimate representation --- type, looking through other newtypes. --- --- The non-recursive newtypes are easy, because they look transparent --- to splitTyConApp_maybe, but recursive ones really are represented as --- TyConApps (see TypeRep). --- --- The trick is to to deal correctly with recursive newtypes --- such as newtype T = MkT T - --- a newtype with no data constructors -- appears in External Core programs -mkNewTyConRep tc | (null (tyConDataCons tc)) = unitTy -mkNewTyConRep tc - = go [] tc + tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; + ; tvs2' <- mappM tcLookupTyVar tvs2 ; + ; return (tvs1', tvs2') } + + +tcTyClDecl1 calc_vrcs calc_isrec + (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name}) + = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 [])) + +----------------------------------- +tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType + -> RenamedConDecl -> TcM DataCon + +tcConDecl new_or_data tycon tyvars ctxt + (ConDecl name ex_tvs ex_ctxt details src_loc) + = addSrcLoc src_loc $ + tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do + { ex_ctxt' <- tcHsKindedContext ex_ctxt + ; unbox_strict <- doptM Opt_UnboxStrictFields + ; let + tc_datacon field_lbls btys + = do { arg_tys <- mappM (tcHsKindedType . getBangType) btys + ; buildDataCon name + (argStrictness unbox_strict tycon btys arg_tys) + field_lbls + tyvars ctxt ex_tvs' ex_ctxt' + arg_tys tycon } + ; case details of + PrefixCon btys -> tc_datacon [] btys + InfixCon bty1 bty2 -> tc_datacon [] [bty1,bty2] + RecCon fields -> do { checkTc (null ex_tvs') (exRecConErr name) + ; let { (field_names, btys) = unzip fields } + ; tc_datacon field_names btys } } + +argStrictness :: Bool -- True <=> -funbox-strict_fields + -> TyCon -> [BangType Name] + -> [TcType] -> [StrictnessMark] +argStrictness unbox_strict tycon btys arg_tys + = zipWith (chooseBoxingStrategy unbox_strict tycon) + arg_tys + (map getBangStrictness btys ++ repeat HsNoBang) + +-- We attempt to unbox/unpack a strict field when either: +-- (i) The field is marked '!!', or +-- (ii) The field is marked '!', and the -funbox-strict-fields flag is on. + +chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang + = case bang of + HsNoBang -> NotMarkedStrict + HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed + HsUnbox | can_unbox -> MarkedUnboxed + other -> MarkedStrict where - -- Invariant: tc is a NewTyCon - -- tcs have been seen before - go tcs tc - | tc `elem` tcs = unitTy - | otherwise - = let - rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc))) - in - case splitTyConApp_maybe rep_ty of - Nothing -> rep_ty - Just (tc', tys) | not (isNewTyCon tc') -> rep_ty - | otherwise -> go1 (tc:tcs) tc' tys - - go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc) + can_unbox = case splitTyConApp_maybe arg_ty of + Nothing -> False + Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) && + isProductTyCon arg_tycon \end{code} %************************************************************************ @@ -438,129 +400,204 @@ mkNewTyConRep tc %* * %************************************************************************ -Dependency analysis -~~~~~~~~~~~~~~~~~~~ +Validity checking is done once the mutually-recursive knot has been +tied, so we can look at things freely. + \begin{code} -checkLoops :: EdgeMap -> SCC RenamedTyClDecl - -> TcM (Name -> AlgTyConFlavour -> RecFlag) --- Check for illegal loops in a single strongly-connected component --- a) type synonyms --- b) superclass hierarchy --- --- Also return a function that says which tycons are recursive. --- Remember: --- a newtype is recursive if it is part of a recursive --- group consisting only of newtype and synonyms - -checkLoops edge_map (AcyclicSCC _) - = returnM (\ _ _ -> NonRecursive) - -checkLoops edge_map (CyclicSCC decls) - = let -- CHECK FOR CLASS CYCLES - cls_edges = mapMaybe mkClassEdges decls - cls_cycles = findCycles cls_edges - in - mapM_ (cycleErr "class") cls_cycles `thenM_` - - let -- CHECK FOR SYNONYM CYCLES - syn_edges = mkEdges edge_map (filter isSynDecl decls) - syn_cycles = findCycles syn_edges - in - mapM_ (cycleErr "type synonym") syn_cycles `thenM_` - - let -- CHECK FOR NEWTYPE CYCLES - newtype_edges = mkEdges edge_map (filter is_nt_cycle_decl decls) - newtype_cycles = findCycles newtype_edges - rec_newtypes = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds] - - rec_tycon name (NewTyCon _) - | name `elemNameSet` rec_newtypes = Recursive - | otherwise = NonRecursive - rec_tycon name other_flavour = Recursive - in - returnM rec_tycon - ----------------------------------------------------- --- A class with one op and no superclasses, or vice versa, --- is treated just like a newtype. --- It's a bit unclean that this test is repeated in buildTyConOrClass -is_nt_cycle_decl (TySynonym {}) = True -is_nt_cycle_decl (TyData {tcdND = NewType}) = True -is_nt_cycle_decl (ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = length ctxt + length sigs == 1 -is_nt_cycle_decl other = False - ----------------------------------------------------- -findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges] - ----------------------------------------------------- --- Building edges for SCC analysis --- --- When building the edges, we treat the 'main name' of the declaration as the --- key for the node, but when dealing with External Core we may come across --- references to one of the implicit names for the declaration. For example: --- class Eq a where .... --- data :TSig a = :TSig (:TEq a) .... --- The first decl is sucked in from an interface file; the second --- is in an External Core file, generated from a class decl for Sig. --- We have to recognise that the reference to :TEq represents a --- dependency on the class Eq declaration, else the SCC stuff won't work right. --- --- This complication can only happen when consuming an External Core file --- --- Solution: keep an "EdgeMap" (bad name) that maps :TEq -> Eq. --- Don't worry about data constructors, because we're only building --- SCCs for type and class declarations here. So the tiresome mapping --- is need only to map [class tycon -> class] - -type EdgeMap = NameEnv Name - -mkEdgeMap :: [RenamedTyClDecl] -> TcM EdgeMap -mkEdgeMap decls = do { mb_pairs <- mapM mk_mb_pair decls ; - return (mkNameEnv (catMaybes mb_pairs)) } - where - mk_mb_pair (ClassDecl { tcdName = cls_name }) - = do { tc_name <- lookupSysName cls_name mkClassTyConOcc ; - return (Just (tc_name, cls_name)) } - mk_mb_pair other = return Nothing - -mkEdges :: EdgeMap -> [RenamedTyClDecl] -> [(RenamedTyClDecl, Name, [Name])] --- We use the EdgeMap to map any implicit names to --- the 'main name' for the declaration -mkEdges edge_map decls - = [ (decl, tyClDeclName decl, get_refs decl) | decl <- decls ] +checkCycleErrs :: [TyClDecl Name] -> TcM () +checkCycleErrs tyclss + | null syn_cycles && null cls_cycles + = return () + | otherwise + = do { mappM_ recSynErr syn_cycles + ; mappM_ recClsErr cls_cycles + ; failM } -- Give up now, because later checkValidTyCl + -- will loop if the synonym is recursive where - get_refs decl = [ lookupNameEnv edge_map n `orElse` n - | n <- nameSetToList (tyClDeclFVs decl) ] + (syn_cycles, cls_cycles) = calcCycleErrs tyclss ----------------------------------------------------- --- mk_cls_edges looks only at the context of class decls --- Its used when we are figuring out if there's a cycle in the --- superclass hierarchy +checkValidTyCl :: RenamedTyClDecl -> TcM () +-- We do the validity check over declarations, rather than TyThings +-- only so that we can add a nice context with tcAddDeclCtxt +checkValidTyCl decl + = tcAddDeclCtxt decl $ + do { thing <- tcLookupGlobal (tcdName decl) + ; traceTc (text "Validity of" <+> ppr thing) + ; case thing of + ATyCon tc -> checkValidTyCon tc + AClass cl -> checkValidClass cl + ; traceTc (text "Done validity of" <+> ppr thing) + } + +------------------------- +checkValidTyCon :: TyCon -> TcM () +checkValidTyCon tc + | isSynTyCon tc + = addErrCtxt (checkTypeCtxt syn_ctxt syn_rhs) $ + checkValidType syn_ctxt syn_rhs + | otherwise + = -- Check the context on the data decl + checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_` + + -- Check arg types of data constructors + mappM_ checkValidDataCon data_cons `thenM_` -mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name]) -mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt]) -mkClassEdges other_decl = Nothing -\end{code} + -- Check that fields with the same name share a type + mappM_ check_fields groups + where + syn_ctxt = TySynCtxt name + name = tyConName tc + (_, syn_rhs) = getSynTyConDefn tc + data_cons = tyConDataCons tc + + fields = [field | con <- data_cons, field <- dataConFieldLabels con] + groups = equivClasses cmp_name fields + cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2 + + check_fields fields@(first_field_label : other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + = -- Check that all the fields in the group have the same type + -- NB: this check assumes that all the constructors of a given + -- data type use the same type variables + checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name) + where + field_ty = fieldLabelType first_field_label + field_name = fieldLabelName first_field_label + other_tys = map fieldLabelType other_fields + +------------------------------- +checkValidDataCon :: DataCon -> TcM () +checkValidDataCon con + = addErrCtxt (dataConCtxt con) ( + checkValidType ctxt (idType (dataConWrapId con)) `thenM_` + -- This checks the argument types and + -- ambiguity of the existential context (if any) + checkFreeness ex_tvs ex_theta) + where + ctxt = ConArgCtxt (dataConName con) + (_, _, ex_tvs, ex_theta, _, _) = dataConSig con -%************************************************************************ -%* * -\subsection{Error management -%* * -%************************************************************************ -\begin{code} -cycleErr :: String -> [RenamedTyClDecl] -> TcM () +------------------------------- +checkValidClass :: Class -> TcM () +checkValidClass cls + = do { -- CHECK ARITY 1 FOR HASKELL 1.4 + gla_exts <- doptM Opt_GlasgowExts + + -- Check that the class is unary, unless GlaExs + ; checkTc (notNull tyvars) (nullaryClassErr cls) + ; checkTc (gla_exts || unary) (classArityErr cls) + + -- Check the super-classes + ; checkValidTheta (ClassSCCtxt (className cls)) theta + + -- Check the class operations + ; mappM_ check_op op_stuff -cycleErr kind_of_decl decls - = addErrAt loc (ppr_cycle kind_of_decl decls) + -- Check that if the class has generic methods, then the + -- class has only one parameter. We can't do generic + -- multi-parameter type classes! + ; checkTc (unary || no_generics) (genericMultiParamErr cls) + } where - loc = tcdLoc (head decls) + (tyvars, theta, _, op_stuff) = classBigSig cls + unary = isSingleton tyvars + no_generics = null [() | (_, GenDefMeth) <- op_stuff] -ppr_cycle kind_of_decl decls - = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:")) - 4 (vcat (map pp_decl decls)) + check_op (sel_id, dm) + = addErrCtxt (classOpCtxt sel_id) ( + checkValidTheta SigmaCtxt (tail theta) `thenM_` + -- The 'tail' removes the initial (C a) from the + -- class itself, leaving just the method type + + checkValidType (FunSigCtxt op_name) tau `thenM_` + + -- Check that for a generic method, the type of + -- the method is sufficiently simple + checkTc (dm /= GenDefMeth || validGenericMethodType op_ty) + (badGenericMethodType op_name op_ty) + ) + where + op_name = idName sel_id + op_ty = idType sel_id + (_,theta,tau) = tcSplitSigmaTy op_ty + + + +--------------------------------------------------------------------- +fieldTypeMisMatch field_name + = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)] + +checkTypeCtxt ctxt ty + = vcat [ptext SLIT("In the type:") <+> ppr_ty, + ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ] + where + -- Hack alert. If there are no tyvars, (ppr sigma_ty) will print + -- something strange like {Eq k} -> k -> k, because there is no + -- ForAll at the top of the type. Since this is going to the user + -- we want it to look like a proper Haskell type even then; hence the hack + -- + -- This shows up in the complaint about + -- case C a where + -- op :: Eq a => a -> a + ppr_ty | null forall_tvs = pprThetaArrow theta <+> ppr tau + | otherwise = ppr ty + + (forall_tvs, theta, tau) = tcSplitSigmaTy ty + +dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"), + nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)] where - pp_decl decl = hsep [quotes (ppr (tcdName decl)), - ptext SLIT("at"), ppr (tcdLoc decl)] + (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con + ex_part | null ex_tvs = empty + | otherwise = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot + -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote + -- data T a = Eq a => T a a + -- So we make sure to print it + + fields = dataConFieldLabels con + arg_part | null fields = sep (map pprParendType arg_tys) + | otherwise = braces (sep (punctuate comma + [ ppr n <+> dcolon <+> ppr ty + | (n,ty) <- fields `zip` arg_tys])) + +classOpCtxt sel_id = sep [ptext SLIT("When checking the class method:"), + nest 2 (ppr sel_id <+> dcolon <+> ppr (idType sel_id))] + +nullaryClassErr cls + = ptext SLIT("No parameters for class") <+> quotes (ppr cls) + +classArityErr cls + = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls), + parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))] + +genericMultiParamErr clas + = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> + ptext SLIT("cannot have generic methods") + +badGenericMethodType op op_ty + = hang (ptext SLIT("Generic method type is too complex")) + 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, + ptext SLIT("You can only use type variables, arrows, and tuples")]) + +recSynErr tcs + = addSrcLoc (getSrcLoc (head tcs)) $ + addErr (sep [ptext SLIT("Cycle in type synonym declarations:"), + nest 2 (vcat (map ppr_thing tcs))]) + +recClsErr clss + = addSrcLoc (getSrcLoc (head clss)) $ + addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"), + nest 2 (vcat (map ppr_thing clss))]) + +ppr_thing :: Name -> SDoc +ppr_thing n = ppr n <+> parens (ppr (getSrcLoc n)) + + +exRecConErr name + = ptext SLIT("Can't combine named fields with locally-quantified type variables") + $$ + (ptext SLIT("In the declaration of data constructor") <+> ppr name) \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index bc339cc4bd..e67cabe487 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -1,225 +1,483 @@ % -% (c) The AQUA Project, Glasgow University, 1996-1998 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 % -\section[TcTyDecls]{Typecheck type declarations} + +Analysis functions over data types. Specficially + a) detecting recursive types + b) computing argument variances + +This stuff is only used for source-code decls; it's recorded in interface +files for imported data types. + \begin{code} -module TcTyDecls ( tcTyDecl, kcConDetails, tcMkDataCon ) where +module TcTyDecls( + calcTyConArgVrcs, tyVarVrc, + calcRecFlags, calcCycleErrs, + newTyConRhs + ) where #include "HsVersions.h" -import HsSyn ( TyClDecl(..), ConDecl(..), HsConDetails(..), BangType, - getBangType, getBangStrictness, conDetailsTys - ) -import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) -import BasicTypes ( NewOrData(..), StrictnessMark(..) ) - -import TcMonoType ( tcHsTyVars, tcHsTheta, tcHsType, - kcHsContext, kcHsSigType, kcHsLiftedSigType - ) -import TcEnv ( tcExtendTyVarEnv, tcLookupTyCon, TyThingDetails(..) ) -import TcType ( Type, tyVarsOfTypes, tyVarsOfPred, ThetaType ) -import RnEnv ( lookupSysName ) -import TcRnMonad - -import DataCon ( DataCon, mkDataCon, dataConFieldLabels ) -import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel ) -import MkId ( mkDataConWorkId, mkDataConWrapId, mkRecordSelId ) -import Var ( TyVar ) -import Name ( Name ) -import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 ) +import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend +import HsSyn ( TyClDecl(..), HsPred(..) ) +import RnHsSyn ( extractHsTyNames ) +import Type ( predTypeRep ) +import BuildTyCl ( newTyConRhs ) +import HscTypes ( TyThing(..) ) +import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars, + getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon, + tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs ) +import Class ( classTyCon ) +import DataCon ( dataConRepArgTys, dataConOrigArgTys ) +import Var ( TyVar ) +import VarSet +import Name ( Name, isTyVarName ) +import NameEnv +import NameSet +import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR ) +import Maybe ( isNothing ) +import BasicTypes ( RecFlag(..) ) import Outputable -import TyCon ( TyCon, DataConDetails(..), visibleDataCons, - tyConTyVars, tyConName ) -import VarSet ( intersectVarSet, isEmptyVarSet ) -import Generics ( mkTyConGenInfo ) -import CmdLineOpts ( DynFlag(..) ) -import List ( nubBy ) \end{code} + %************************************************************************ %* * -\subsection{Type checking} + Cycles in class and type synonym declarations %* * %************************************************************************ -\begin{code} -tcTyDecl :: RenamedTyClDecl -> TcM (Name, TyThingDetails) -tcTyDecl (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs}) - = tcLookupTyCon tycon_name `thenM` \ tycon -> - tcExtendTyVarEnv (tyConTyVars tycon) $ - tcHsType rhs `thenM` \ rhs_ty -> - returnM (tycon_name, SynTyDetails rhs_ty) - -tcTyDecl (TyData {tcdND = new_or_data, tcdCtxt = context, - tcdName = tycon_name, tcdCons = con_decls, - tcdGeneric = generic}) - = tcLookupTyCon tycon_name `thenM` \ tycon -> - let - tyvars = tyConTyVars tycon - in - tcExtendTyVarEnv tyvars $ - tcHsTheta context `thenM` \ ctxt -> - tcConDecls new_or_data tycon tyvars ctxt con_decls `thenM` \ data_cons -> - let - sel_ids = mkRecordSelectors tycon data_cons - in - tcGenericInfo tycon generic `thenM` \ gen_info -> - returnM (tycon_name, DataTyDetails ctxt data_cons sel_ids gen_info) - -tcTyDecl (ForeignType {tcdName = tycon_name}) - = returnM (tycon_name, ForeignTyDetails) - - -tcGenericInfo tycon generics -- Source code decl: consult the flag - = do_we_want generics `thenM` \ want_generics -> - if want_generics then - mapM (lookupSysName (tyConName tycon)) - [mkGenOcc1, mkGenOcc2] `thenM` \ gen_sys_names -> - returnM (mkTyConGenInfo tycon gen_sys_names) - else - returnM Nothing +We check for type synonym and class cycles on the *source* code. +Main reasons: + + a) Otherwise we'd need a special function to extract type-synonym tycons + from a type, whereas we have extractHsTyNames already + + b) If we checked for type synonym loops after building the TyCon, we + can't do a hoistForAllTys on the type synonym rhs, (else we fall into + a black hole) which seems unclean. Apart from anything else, it'd mean + that a type-synonym rhs could have for-alls to the right of an arrow, + which means adding new cases to the validity checker + + Indeed, in general, checking for cycles beforehand means we need to + be less careful about black holes through synonym cycles. + +The main disadvantage is that a cycle that goes via a type synonym in an +.hi-boot file can lead the compiler into a loop, because it assumes that cycles +only occur in source code. But hi-boot files are trusted anyway, so this isn't +much worse than (say) a kind error. + +[ NOTE ---------------------------------------------- +If we reverse this decision, this comment came from tcTyDecl1, and should + go back there + -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting, + -- which requires looking through synonyms... and therefore goes into a loop + -- on (erroneously) recursive synonyms. + -- Solution: do not hoist synonyms, because they'll be hoisted soon enough + -- when they are substituted + +We'd also need to add back in this definition + +synTyConsOfType :: Type -> [TyCon] +-- Does not look through type synonyms at all +-- Return a list of synonym tycons +synTyConsOfType ty + = nameEnvElts (go ty) where - do_we_want (Just g) = returnM g -- Interface file decl - -- so look at decl - do_we_want Nothing = doptM Opt_Generics -- Source code decl - -- so look at flag - -mkRecordSelectors tycon data_cons - = -- We'll check later that fields with the same name - -- from different constructors have the same type. - [ mkRecordSelId tycon field - | field <- nubBy eq_name fields ] + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go (TyVarTy v) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc tys -- See note (a) + go (NewTcApp tc tys) = go_s tys -- Ignore tycon + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy a b) = go a `plusNameEnv` go b + go (PredTy (IParam _ ty)) = go ty + go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class + go (NoteTy (SynNote ty) _) = go ty -- Don't look through it! + go (NoteTy other ty) = go ty + go (ForAllTy _ ty) = go ty + + -- Note (a): the unexpanded branch of a SynNote has a + -- TyConApp for the synonym, so the tc of + -- a TyConApp must be tested for possible synonyms + + go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc + | otherwise = go_s tys + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys +---------------------------------------- END NOTE ] + +\begin{code} +calcCycleErrs :: [TyClDecl Name] -> ([[Name]], -- Recursive type synonym groups + [[Name]]) -- Ditto classes +calcCycleErrs decls + = (findCyclics syn_edges, findCyclics cls_edges) where - fields = [ field | con <- visibleDataCons data_cons, - field <- dataConFieldLabels con ] - eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2 + --------------- Type synonyms ---------------------- + syn_edges = [ (name, mk_syn_edges rhs) | TySynonym { tcdName = name, tcdSynRhs = rhs } <- decls ] + mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), not (isTyVarName tc) ] + + --------------- Classes ---------------------- + cls_edges = [ (name, mk_cls_edges ctxt) | ClassDecl { tcdName = name, tcdCtxt = ctxt } <- decls ] + mk_cls_edges ctxt = [ cls | HsClassP cls _ <- ctxt ] \end{code} %************************************************************************ %* * -\subsection{Kind and type check constructors} + Deciding which type constructors are recursive %* * %************************************************************************ +A newtype M.T is defined to be "recursive" iff + (a) its rhs mentions an abstract (hi-boot) TyCon + or (b) one can get from T's rhs to T via type + synonyms, or non-recursive newtypes *in M* + e.g. newtype T = MkT (T -> Int) + +(a) is conservative; it assumes that the hi-boot type can loop + around to T. That's why in (b) we can restrict attention + to tycons in M, because any loops through newtypes outside M + will be broken by those newtypes + +An algebraic data type M.T is "recursive" iff + it has just one constructor, and + (a) its arg types mention an abstract (hi-boot) TyCon + or (b) one can get from its arg types to T via type synonyms, + or by non-recursive newtypes or non-recursive product types in M + e.g. data T = MkT (T -> Int) Bool + +A type synonym is recursive if one can get from its +right hand side back to it via type synonyms. (This is +reported as an error.) + +A class is recursive if one can get from its superclasses +back to it. (This is an error too.) + +Hi-boot types +~~~~~~~~~~~~~ +A data type read from an hi-boot file will have an Unknown in its data constructors, +and will respond True to isHiBootTyCon. The idea is that we treat these as if one +could get from these types to anywhere. So when we see + + module Baz where + import {-# SOURCE #-} Foo( T ) + newtype S = MkS T + +then we mark S as recursive, just in case. What that means is that if we see + + import Baz( S ) + newtype R = MkR S + +then we don't need to look inside S to compute R's recursiveness. Since S is imported +(not from an hi-boot file), one cannot get from R back to S except via an hi-boot file, +and that means that some data type will be marked recursive along the way. So R is +unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary) + +This in turn means that we grovel through fewer interface files when computing +recursiveness, because we need only look at the type decls in the module being +compiled, plus the outer structure of directly-mentioned types. + \begin{code} -kcConDetails :: NewOrData -> RenamedContext - -> HsConDetails Name (BangType Name) -> TcM () -kcConDetails new_or_data ex_ctxt details - = kcHsContext ex_ctxt `thenM_` - mappM_ kc_sig_type (conDetailsTys details) - where - kc_sig_type = case new_or_data of - DataType -> kcHsSigType - NewType -> kcHsLiftedSigType - -- Can't allow an unlifted type here, because we're effectively - -- going to remove the constructor while coercing it to a lifted type. - - -tcConDecls :: NewOrData -> TyCon -> [TyVar] -> ThetaType - -> DataConDetails RenamedConDecl -> TcM (DataConDetails DataCon) - -tcConDecls new_or_data tycon tyvars ctxt con_decls - = case con_decls of - Unknown -> returnM Unknown - HasCons n -> returnM (HasCons n) - DataCons cs -> mappM tc_con_decl cs `thenM` \ data_cons -> - returnM (DataCons data_cons) +calcRecFlags :: [TyThing] -> (Name -> RecFlag) +calcRecFlags tyclss + = is_rec where - tc_con_decl (ConDecl name ex_tvs ex_ctxt details src_loc) - = addSrcLoc src_loc $ - tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars -> - tcHsTheta ex_ctxt `thenM` \ ex_theta -> - case details of - PrefixCon btys -> tc_datacon ex_tyvars ex_theta btys - InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2] - RecCon fields -> tc_rec_con ex_tyvars ex_theta fields - where + is_rec n | n `elemNameSet` rec_names = Recursive + | otherwise = NonRecursive + + rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers + + all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types + -- can happen via the class TyCon + + ------------------------------------------------- + -- NOTE + -- These edge-construction loops rely on + -- every loop going via tyclss, the types and classes + -- in the module being compiled. Stuff in interface + -- files should be correctly marked. If not (e.g. a + -- type synonym in a hi-boot file) we can get an infinite + -- loop. We could program round this, but it'd make the code + -- rather less nice, so I'm not going to do that yet. + + --------------- Newtypes ---------------------- + new_tycons = filter isNewTyCon all_tycons + nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges) + is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers + -- is_rec_nt is a locally-used helper function + + nt_edges = [(t, mk_nt_edges t) | t <- new_tycons] + + mk_nt_edges nt -- Invariant: nt is a newtype + = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt)) + -- tyConsOfType looks through synonyms + + mk_nt_edges1 nt tc + | tc `elem` new_tycons = [tc] -- Loop + | isHiBootTyCon tc = [nt] -- Make it self-recursive if + -- it mentions an hi-boot TyCon + -- At this point we know that either it's a local data type, + -- or it's imported. Either way, it can't form part of a cycle + | otherwise = [] + + --------------- Product types ---------------------- + -- The "prod_tycons" are the non-newtype products + prod_tycons = [tc | tc <- all_tycons, + not (isNewTyCon tc), isProductTyCon tc] + prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges) + + prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons] - tc_datacon ex_tyvars ex_theta btys - = mappM tcHsType (map getBangType btys) `thenM` \ arg_tys -> - tcMkDataCon name - (map getBangStrictness btys) - [{- No field labels -}] - tyvars ctxt ex_tyvars ex_theta - arg_tys tycon - - tc_rec_con ex_tyvars ex_theta fields - = checkTc (null ex_tyvars) (exRecConErr name) `thenM_` - mappM tc_field (fields `zip` allFieldLabelTags) `thenM` \ field_labels -> - let - arg_stricts = [getBangStrictness bty | (n, bty) <- fields] - arg_tys = map fieldLabelType field_labels - in - tcMkDataCon name arg_stricts field_labels - tyvars ctxt ex_tyvars ex_theta - arg_tys tycon - - tc_field ((field_label_name, bty), tag) - = tcHsType (getBangType bty) `thenM` \ field_ty -> - returnM (mkFieldLabel field_label_name tycon field_ty tag) - -tcMkDataCon :: Name - -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> ThetaType - -> [TyVar] -> ThetaType - -> [Type] -> TyCon - -> TcM DataCon --- A wrapper for DataCon.mkDataCon that --- a) makes the worker Id --- b) makes the wrapper Id if necessary, including --- allocating its unique (hence monadic) -tcMkDataCon src_name arg_stricts fields - tyvars ctxt ex_tyvars ex_theta - arg_tys tycon - = lookupSysName src_name mkDataConWrapperOcc `thenM` \ wrap_name -> - lookupSysName src_name mkDataConWorkerOcc `thenM` \ work_name -> - -- This last one takes the name of the data constructor in the source - -- code, which (for Haskell source anyway) will be in the SrcDataName name - -- space, and makes it into a "real data constructor name" - - doptM Opt_UnboxStrictFields `thenM` \ unbox_strict_fields -> - - let - real_stricts - | unbox_strict_fields = map unboxUserStrict arg_stricts - | otherwise = arg_stricts - - unboxUserStrict MarkedUserStrict = MarkedUserUnboxed - unboxUserStrict other = other - - data_con = mkDataCon src_name real_stricts fields - tyvars (thinContext arg_tys ctxt) - ex_tyvars ex_theta - arg_tys tycon - data_con_work_id data_con_wrap_id - data_con_work_id = mkDataConWorkId work_name data_con - data_con_wrap_id = mkDataConWrapId wrap_name data_con - in - returnM data_con - --- The context for a data constructor should be limited to --- the type variables mentioned in the arg_tys -thinContext arg_tys ctxt - = filter in_arg_tys ctxt + mk_prod_edges tc -- Invariant: tc is a product tycon + = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc))) + + mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty) + + mk_prod_edges2 ptc tc + | tc `elem` prod_tycons = [tc] -- Local product + | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype + then [] + else mk_prod_edges1 ptc (newTyConRhs tc) + | isHiBootTyCon tc = [ptc] -- Make it self-recursive if + -- it mentions an hi-boot TyCon + -- At this point we know that either it's a local non-product data type, + -- or it's imported. Either way, it can't form part of a cycle + | otherwise = [] + +getTyCon (ATyCon tc) = tc +getTyCon (AClass cl) = classTyCon cl + +findLoopBreakers :: [(TyCon, [TyCon])] -> [Name] +-- Finds a set of tycons that cut all loops +findLoopBreakers deps + = go [(tc,tc,ds) | (tc,ds) <- deps] + where + go edges = [ name + | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges, + name <- tyConName tc : go edges'] + +findCyclics :: [(Name,[Name])] -> [[Name]] +findCyclics deps + = [names | CyclicSCC names <- stronglyConnComp edges] + where + edges = [(name,name,ds) | (name,ds) <- deps] +\end{code} + +These two functions know about type representations, so they could be +in Type or TcType -- but they are very specialised to this module, so +I've chosen to put them here. + +\begin{code} +tcTyConsOfType :: Type -> [TyCon] +-- tcTyConsOfType looks through all synonyms, but not through any newtypes. +-- When it finds a Class, it returns the class TyCon. The reaons it's here +-- (not in Type.lhs) is because it is newtype-aware. +tcTyConsOfType ty + = nameEnvElts (go ty) where - arg_tyvars = tyVarsOfTypes arg_tys - in_arg_tys pred = not $ isEmptyVarSet $ - tyVarsOfPred pred `intersectVarSet` arg_tyvars + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go (TyVarTy v) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc tys + go (NewTcApp tc tys) = go_tc tc tys + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy a b) = go a `plusNameEnv` go b + go (PredTy (IParam _ ty)) = go ty + go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys + go (NoteTy _ ty) = go ty + go (ForAllTy _ ty) = go ty + + go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys \end{code} %************************************************************************ %* * -\subsection{Errors and contexts} + Compuing TyCon argument variances %* * %************************************************************************ +Computing the tyConArgVrcs info +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each +tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed +separately. Note that this is information about occurrences of type +variables, not usages of term variables. + +The function @calcTyConArgVrcs@ must be passed a list of *algebraic or +syntycons only* such that all tycons referred to (by mutual recursion) +appear in the list. The fixpointing will be done on this set of +tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to +be (knot-tyingly?) stuck back into the appropriate fields. + +\begin{code} +calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs +-- Gives arg variances for TyCons, +-- including the class TyCon of a class +calcTyConArgVrcs tyclss + = get_vrc + where + tycons = map getTyCon tyclss + + -- We should only look up things that are in the map + get_vrc n = case lookupNameEnv final_oi n of + Just (_, pms) -> pms + Nothing -> pprPanic "calcVrcs" (ppr n) + + -- We are going to fold over this map, + -- so we need the TyCon in the range + final_oi :: NameEnv (TyCon, ArgVrcs) + final_oi = tcaoFix initial_oi + + initial_oi :: NameEnv (TyCon, ArgVrcs) + initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc)) + | tc <- tycons] + initial tc = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then + -- make pessimistic assumption (and warn) + abstractVrcs tc + else + replicate (tyConArity tc) (False,False) + + tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon + -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon + tcaoFix oi + | changed = tcaoFix oi' + | otherwise = oi' + where + (changed,oi') = foldNameEnv iterate (False,oi) oi + + iterate (tc, pms) (changed,oi') + = (changed || (pms /= pms'), + extendNameEnv oi' (tyConName tc) (tc, pms')) + where + pms' = tcaoIter oi' tc -- seq not simult + + tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial) + -> TyCon -- tycon to update + -> ArgVrcs -- new ArgVrcs for tycon + + tcaoIter oi tc | isAlgTyCon tc + = if null data_cons then + abstractVrcs tc -- Data types with no constructors + else + map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs + where + data_cons = tyConDataCons tc + vs = tyConTyVars tc + argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig? + + tcaoIter oi tc | isSynTyCon tc + = let (tyvs,ty) = getSynTyConDefn tc + -- we use the already-computed result for tycons not in this SCC + in map (\v -> vrcInTy (lookup oi) v ty) tyvs + + lookup oi tc = case lookupNameEnv oi (tyConName tc) of + Just (_, pms) -> pms + Nothing -> tyConArgVrcs tc + -- We use the already-computed result for tycons not in this SCC + + +abstractVrcs :: TyCon -> ArgVrcs +abstractVrcs tc = +#ifdef DEBUG + pprTrace "Vrc: abstract tycon:" (ppr tc) $ +#endif + warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True) + +warn_abstract_vrcs +-- we pull the message out as a CAF so the warning only appears *once* + = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n" + ++ " Use -fno-prune-tydecls to fix.") $ + () +\end{code} + + +Variance of tyvars in a type +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A general variance-check function. We pass a function for determining +the @ArgVrc@s of a tycon; when fixpointing this refers to the current +value; otherwise this should be looked up from the tycon's own +tyConArgVrcs. Again, it knows the representation of Types. + +\begin{code} +vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion) + -> TyVar -- tyvar to check Vrcs of + -> Type -- type to check for occ in + -> (Bool,Bool) -- (occurs positively, occurs negatively) + +vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty + -- SynTyCon doesn't neccessarily have vrcInfo at this point, + -- so don't try and use it + +vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv + then vrcInTy fao v ty + else (False,False) + -- note that ftv cannot be calculated as occPos||occNeg, + -- since if a tyvar occurs only as unused tyconarg, + -- occPos==occNeg==False, but ftv=True + +vrcInTy fao v (TyVarTy v') = if v==v' + then (True,False) + else (False,False) + +vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False) + then (True,True) + else vrcInTy fao v ty1 + -- ty1 is probably unknown (or it would have been beta-reduced); + -- hence if v occurs in ty2 at all then it could occur with + -- either variance. Otherwise it occurs as it does in ty1. + +vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1) + `orVrc` + vrcInTy fao v ty2 + +vrcInTy fao v (ForAllTy v' ty) = if v==v' + then (False,False) + else vrcInTy fao v ty + +vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys + pms2 = fao tc + in orVrcs (zipWith timesVrc pms1 pms2) + +vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys + pms2 = fao tc + in orVrcs (zipWith timesVrc pms1 pms2) + +vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st) +\end{code} + + +External entry point: assumes tyconargvrcs already computed. + +\begin{code} +tyVarVrc :: TyVar -- tyvar to check Vrc of + -> Type -- type to check for occ in + -> (Bool,Bool) -- (occurs positively, occurs negatively) + +tyVarVrc = vrcInTy tyConArgVrcs +\end{code} + + +Variance algebra +~~~~~~~~~~~~~~~~ \begin{code} -exRecConErr name - = ptext SLIT("Can't combine named fields with locally-quantified type variables") - $$ - (ptext SLIT("In the declaration of data constructor") <+> ppr name) +orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) +orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2) + +orVrcs :: [(Bool,Bool)] -> (Bool,Bool) +orVrcs = foldl orVrc (False,False) + +negVrc :: (Bool,Bool) -> (Bool,Bool) +negVrc (p1,m1) = (m1,p1) + +anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool) +anyVrc p as = foldl (\ pm a -> pm `orVrc` p a) + (False,False) as + +timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) +timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2, + p1 && m2 || m1 && p2) \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 079f225dfe..6f7fdde7a3 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -16,10 +16,6 @@ is the principal client. \begin{code} module TcType ( -------------------------------- - -- TyThing - TyThing(..), -- instance NamedThing - - -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcKind, @@ -54,14 +50,14 @@ module TcType ( --------------------------------- -- Misc type manipulators - deNoteType, classNamesOfTheta, + deNoteType, classesOfTheta, tyClsNamesOfType, tyClsNamesOfDFunHead, getDFunTyKey, --------------------------------- -- Predicate types getClassPredTys_maybe, getClassPredTys, - isPredTy, isClassPred, isTyVarClassPred, + isClassPred, isTyVarClassPred, mkDictTy, tcSplitPredTy_maybe, isDictTy, tcSplitDFunTy, predTyUnique, mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, @@ -92,7 +88,7 @@ module TcType ( superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, isTypeKind, isAnyTypeKind, - Type, SourceType(..), PredType, ThetaType, + Type, PredType(..), ThetaType, mkForAllTy, mkForAllTys, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, @@ -100,7 +96,7 @@ module TcType ( isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto - isPrimitiveType, isTyVarTy, + isPrimitiveType, isTyVarTy, isPredTy, tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, @@ -120,8 +116,8 @@ import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - tyVarsOfTheta, Kind, Type, SourceType(..), - PredType, ThetaType, unliftedTypeKind, + tyVarsOfTheta, Kind, Type, PredType(..), + ThetaType, unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind, @@ -129,7 +125,7 @@ import Type ( -- Re-exports mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, - mkPredTys, isUnLiftedType, + mkPredTys, isUnLiftedType, isPredTy, isUnboxedTupleType, isPrimitiveType, splitTyConApp_maybe, tidyTopType, tidyType, tidyPred, tidyTypes, @@ -139,10 +135,9 @@ import Type ( -- Re-exports hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind, repType ) -import DataCon ( DataCon ) import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique ) -import Class ( classHasFDs, Class ) -import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails ) +import Class ( Class ) +import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails ) import ForeignCall ( Safety, playSafe , DNType(..) ) @@ -152,8 +147,8 @@ import VarSet -- others: import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc ) -import OccName ( OccName, mkDictOcc ) import NameSet +import OccName ( OccName, mkDictOcc ) import PrelNames -- Lots (e.g. in isFFIArgumentTy) import TysWiredIn ( unitTyCon, charTyCon, listTyCon ) import BasicTypes ( IPName(..), ipNameName ) @@ -167,26 +162,6 @@ import Outputable %************************************************************************ %* * - TyThing -%* * -%************************************************************************ - -\begin{code} -data TyThing = AnId Id - | ADataCon DataCon - | ATyCon TyCon - | AClass Class - -instance NamedThing TyThing where - getName (AnId id) = getName id - getName (ATyCon tc) = getName tc - getName (AClass cl) = getName cl - getName (ADataCon dc) = getName dc -\end{code} - - -%************************************************************************ -%* * \subsection{Types} %* * %************************************************************************ @@ -220,13 +195,6 @@ tau ::= tyvar -- In all cases, a (saturated) type synonym application is legal, -- provided it expands to the required form. - -\begin{code} -type SigmaType = Type -type RhoType = Type -type TauType = Type -\end{code} - \begin{code} type TcTyVar = TyVar -- Might be a mutable tyvar type TcTyVarSet = TyVarSet @@ -273,10 +241,6 @@ data TyVarDetails | InstTv -- Ditto, but instance decl - | PatSigTv -- Scoped type variable, introduced by a pattern - -- type signature - -- \ x::a -> e - | VanillaTv -- Everything else isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible @@ -302,7 +266,6 @@ tyVarBindingInfo tv details SigTv = ptext SLIT("type signature") details ClsTv = ptext SLIT("class declaration") details InstTv = ptext SLIT("instance declaration") - details PatSigTv = ptext SLIT("pattern type signature") details VanillaTv = ptext SLIT("//vanilla//") -- Ditto \end{code} @@ -316,20 +279,20 @@ tyVarBindingInfo tv \begin{code} mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) -mkPhiTy :: [SourceType] -> Type -> Type +mkPhiTy :: [PredType] -> Type -> Type mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta \end{code} - @isTauTy@ tests for nested for-alls. \begin{code} isTauTy :: Type -> Bool isTauTy (TyVarTy v) = True isTauTy (TyConApp _ tys) = all isTauTy tys +isTauTy (NewTcApp _ tys) = all isTauTy tys isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (SourceTy p) = True -- Don't look through source types +isTauTy (PredTy p) = True -- Don't look through source types isTauTy (NoteTy _ ty) = isTauTy ty isTauTy other = False \end{code} @@ -337,15 +300,15 @@ isTauTy other = False \begin{code} getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to -- construct a dictionary function name -getDFunTyKey (TyVarTy tv) = getOccName tv -getDFunTyKey (TyConApp tc _) = getOccName tc -getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (NoteTy _ t) = getDFunTyKey t -getDFunTyKey (FunTy arg _) = getOccName funTyCon -getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey (SourceTy (NType tc _)) = getOccName tc -- Newtypes are quite reasonable -getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) --- SourceTy shouldn't happen +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (NewTcApp tc _) = getOccName tc +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (NoteTy _ t) = getDFunTyKey t +getDFunTyKey (FunTy arg _) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) +-- PredTy shouldn't happen \end{code} @@ -400,10 +363,10 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty -tcSplitTyConApp_maybe (SourceTy (NType tc tys)) = Just (tc,tys) +tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (NewTcApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty -- Newtypes are opaque, so they may be split -- However, predicates are not treated -- as tycon applications by the type checker @@ -426,16 +389,16 @@ tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res } tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) -tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty -tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys --- Don't forget that newtype! -tcSplitAppTy_maybe (TyConApp tc tys) = tc_split_app tc tys -tcSplitAppTy_maybe other = Nothing - -tc_split_app tc tys = case snocView tys of - Just (tys',ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing +tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) +tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty +tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of + Just (tys', ty') -> Just (TyConApp tc tys', ty') + Nothing -> Nothing +tcSplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of + Just (tys', ty') -> Just (NewTcApp tc tys', ty') + Nothing -> Nothing +tcSplitAppTy_maybe other = Nothing tcSplitAppTy ty = case tcSplitAppTy_maybe ty of Just stuff -> stuff @@ -478,7 +441,7 @@ tcSplitMethodTy ty = split ty split (NoteTy n ty) = split ty split _ = panic "splitMethodTy" -tcSplitDFunTy :: Type -> ([TyVar], [SourceType], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type]) -- Split the type of a dictionary function tcSplitDFunTy ty = case tcSplitSigmaTy ty of { (tvs, theta, tau) -> @@ -518,30 +481,18 @@ allDistinctTyVars (ty:tys) acc %* * %************************************************************************ -"Predicates" are particular source types, namelyClassP or IParams - \begin{code} -isPred :: SourceType -> Bool -isPred (ClassP _ _) = True -isPred (IParam _ _) = True -isPred (NType _ _) = False - -isPredTy :: Type -> Bool -isPredTy (NoteTy _ ty) = isPredTy ty -isPredTy (SourceTy sty) = isPred sty -isPredTy _ = False - tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only -tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty -tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p -tcSplitPredTy_maybe other = Nothing +tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty +tcSplitPredTy_maybe (PredTy p) = Just p +tcSplitPredTy_maybe other = Nothing predTyUnique :: PredType -> Unique predTyUnique (IParam n _) = getUnique (ipNameName n) predTyUnique (ClassP clas tys) = getUnique clas -mkPredName :: Unique -> SrcLoc -> SourceType -> Name +mkPredName :: Unique -> SrcLoc -> PredType -> Name mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc \end{code} @@ -552,14 +503,14 @@ mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameNa \begin{code} mkClassPred clas tys = ClassP clas tys -isClassPred :: SourceType -> Bool +isClassPred :: PredType -> Bool isClassPred (ClassP clas tys) = True isClassPred other = False isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys isTyVarClassPred other = False -getClassPredTys_maybe :: SourceType -> Maybe (Class, [Type]) +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) getClassPredTys_maybe _ = Nothing @@ -570,7 +521,7 @@ mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = mkPredTy (ClassP clas tys) isDictTy :: Type -> Bool -isDictTy (SourceTy p) = isClassPred p +isDictTy (PredTy p) = isClassPred p isDictTy (NoteTy _ ty) = isDictTy ty isDictTy other = False \end{code} @@ -578,7 +529,7 @@ isDictTy other = False --------------------- Implicit parameters --------------------------------- \begin{code} -isIPPred :: SourceType -> Bool +isIPPred :: PredType -> Bool isIPPred (IParam _ _) = True isIPPred other = False @@ -607,7 +558,6 @@ isLinearPred other = False %************************************************************************ Comparison, taking note of newtypes, predicates, etc, -But ignoring usage types \begin{code} tcEqType :: Type -> Type -> Bool @@ -625,7 +575,7 @@ tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2 tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2 -tcCmpPred p1 p2 = cmpSourceTy emptyVarEnv p1 p2 +tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2 ------------- cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2 @@ -644,13 +594,14 @@ cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of Just tv1a -> tv1a `compare` tv2 Nothing -> tv1 `compare` tv2 -cmpTy env (SourceTy p1) (SourceTy p2) = cmpSourceTy env p1 p2 +cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) +cmpTy env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2 - -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < SourceTy + -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < NewTcApp < ForAllTy < PredTy cmpTy env (AppTy _ _) (TyVarTy _) = GT cmpTy env (FunTy _ _) (TyVarTy _) = GT @@ -660,38 +611,39 @@ cmpTy env (TyConApp _ _) (TyVarTy _) = GT cmpTy env (TyConApp _ _) (AppTy _ _) = GT cmpTy env (TyConApp _ _) (FunTy _ _) = GT +cmpTy env (NewTcApp _ _) (TyVarTy _) = GT +cmpTy env (NewTcApp _ _) (AppTy _ _) = GT +cmpTy env (NewTcApp _ _) (FunTy _ _) = GT +cmpTy env (NewTcApp _ _) (TyConApp _ _) = GT + cmpTy env (ForAllTy _ _) (TyVarTy _) = GT cmpTy env (ForAllTy _ _) (AppTy _ _) = GT cmpTy env (ForAllTy _ _) (FunTy _ _) = GT cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT +cmpTy env (ForAllTy _ _) (NewTcApp _ _) = GT -cmpTy env (SourceTy _) t2 = GT +cmpTy env (PredTy _) t2 = GT cmpTy env _ _ = LT \end{code} \begin{code} -cmpSourceTy :: TyVarEnv TyVar -> SourceType -> SourceType -> Ordering -cmpSourceTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2) +cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering +cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2) -- Compare types as well as names for implicit parameters -- This comparison is used exclusively (I think) for the -- finite map built in TcSimplify -cmpSourceTy env (IParam _ _) sty = LT - -cmpSourceTy env (ClassP _ _) (IParam _ _) = GT -cmpSourceTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) -cmpSourceTy env (ClassP _ _) (NType _ _) = LT - -cmpSourceTy env (NType tc1 tys1) (NType tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) -cmpSourceTy env (NType _ _) sty = GT +cmpPredTy env (IParam _ _) (ClassP _ _) = LT +cmpPredTy env (ClassP _ _) (IParam _ _) = GT +cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) \end{code} PredTypes are used as a FM key in TcSimplify, so we take the easy path and make them an instance of Ord \begin{code} -instance Eq SourceType where { (==) = tcEqPred } -instance Ord SourceType where { compare = tcCmpPred } +instance Eq PredType where { (==) = tcEqPred } +instance Ord PredType where { compare = tcCmpPred } \end{code} @@ -744,19 +696,19 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of \begin{code} deNoteType :: Type -> Type - -- Remove synonyms, but not source types + -- Remove synonyms, but not predicate types deNoteType ty@(TyVarTy tyvar) = ty deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) -deNoteType (SourceTy p) = SourceTy (deNoteSourceType p) +deNoteType (NewTcApp tycon tys) = NewTcApp tycon (map deNoteType tys) +deNoteType (PredTy p) = PredTy (deNotePredType p) deNoteType (NoteTy _ ty) = deNoteType ty deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) -deNoteSourceType :: SourceType -> SourceType -deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys) -deNoteSourceType (IParam n ty) = IParam n (deNoteType ty) -deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys) +deNotePredType :: PredType -> PredType +deNotePredType (ClassP c tys) = ClassP c (map deNoteType tys) +deNotePredType (IParam n ty) = IParam n (deNoteType ty) \end{code} Find the free tycons and classes of a type. This is used in the front @@ -766,11 +718,11 @@ end of the compiler. tyClsNamesOfType :: Type -> NameSet tyClsNamesOfType (TyVarTy tv) = emptyNameSet tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (NewTcApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1 tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2 -tyClsNamesOfType (SourceTy (IParam n ty)) = tyClsNamesOfType ty -tyClsNamesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys -tyClsNamesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty +tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty @@ -788,9 +740,9 @@ tyClsNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of (tvs,_,head_ty) -> tyClsNamesOfType head_ty -classNamesOfTheta :: ThetaType -> [Name] +classesOfTheta :: ThetaType -> [Class] -- Looks just for ClassP things; maybe it should check -classNamesOfTheta preds = [ getName c | ClassP c _ <- preds ] +classesOfTheta preds = [ c | ClassP c _ <- preds ] \end{code} @@ -1023,18 +975,18 @@ uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_) = uVarX tyvar2 ty1 k subst -- Predicates -uTysX (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) k subst +uTysX (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) k subst | n1 == n2 = uTysX t1 t2 k subst -uTysX (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) k subst +uTysX (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) k subst | c1 == c2 = uTyListsX tys1 tys2 k subst -uTysX (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) k subst - | tc1 == tc2 = uTyListsX tys1 tys2 k subst -- Functions; just check the two parts uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst -- Type constructors must match +uTysX (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) k subst + | tc1 == tc2 = uTyListsX tys1 tys2 k subst uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst | (con1 == con2 && equalLength tys1 tys2) = uTyListsX tys1 tys2 k subst @@ -1172,12 +1124,10 @@ match (TyVarTy v) ty tmpls k senv -- expect, due to an intervening Note. KSW 2000-06. -- Predicates -match (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) tmpls k senv +match (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) tmpls k senv | n1 == n2 = match t1 t2 tmpls k senv -match (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) tmpls k senv +match (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) tmpls k senv | c1 == c2 = match_list_exactly tys1 tys2 tmpls k senv -match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv - | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -- Functions; just check the two parts match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv @@ -1188,11 +1138,10 @@ match (AppTy fun1 arg1) ty2 tmpls k senv Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv Nothing -> Nothing -- Fail -match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv +-- Newtypes are opaque; predicate types should not happen +match (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) tmpls k senv | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv - --- Newtypes are opaque; other source types should not happen -match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv +match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -- With type synonyms, we have to be careful for the exact diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index d5323d82b9..cb4f73b32d 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -11,7 +11,7 @@ module TcUnify ( -- Various unifications unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyKind, unifyKinds, unifyOpenTypeKind, unifyFunKind, + unifyKind, unifyKinds, unifyTypeKind, unifyFunKind, -------------------------------- -- Holes @@ -30,12 +30,12 @@ module TcUnify ( import HsSyn ( HsExpr(..) ) import TcHsSyn ( mkHsLet, ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) ) -import TypeRep ( Type(..), SourceType(..), TyNote(..), openKindCon ) +import TypeRep ( Type(..), PredType(..), TyNote(..), typeCon, openKindCon ) import TcRnMonad -- TcType, amongst others import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, TcTyVarSet, TcThetaType, TyVarDetails(SigTv), - isTauTy, isSigmaTy, mkFunTys, + isTauTy, isSigmaTy, mkFunTys, mkTyConApp, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcGetTyVar_maybe, tcGetTyVar, mkFunTy, tyVarsOfType, mkPhiTy, @@ -47,12 +47,12 @@ import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, ) import Inst ( newDicts, instToId, tcInstCall ) import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar, - newTyVarTy, newTyVarTys, newOpenTypeKind, + newTyVarTy, newTyVarTys, newBoxityVar, zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV ) import TcSimplify ( tcSimplifyCheck ) -import TysWiredIn ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy ) +import TysWiredIn ( listTyCon, parrTyCon, tupleTyCon ) import TcEnv ( tcGetGlobalTyVars, findGlobals ) -import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity ) +import TyCon ( TyCon, tyConArity, isTupleTyCon, tupleTyConBoxity ) import PprType ( pprType ) import Id ( Id, mkSysLocal ) import Var ( Var, varName, tyVarKind ) @@ -185,60 +185,46 @@ unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification \end{code} \begin{code} -zapToListTy :: Expected TcType -- expected list type - -> TcM TcType -- list element type - -zapToListTy (Check ty) = unifyListTy ty -zapToListTy (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ; - writeMutVar hole (mkListTy elt_ty) ; +---------------------- +zapToListTy, zapToPArrTy :: Expected TcType -- expected list type + -> TcM TcType -- list element type +unifyListTy, unifyPArrTy :: TcType -> TcM TcType +zapToListTy = zapToXTy listTyCon +unifyListTy = unifyXTy listTyCon +zapToPArrTy = zapToXTy parrTyCon +unifyPArrTy = unifyXTy parrTyCon + +---------------------- +zapToXTy :: TyCon -- T :: *->* + -> Expected TcType -- Expected type (T a) + -> TcM TcType -- Element type, a + +zapToXTy tc (Check ty) = unifyXTy tc ty +zapToXTy tc (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ; + writeMutVar hole (mkTyConApp tc [elt_ty]) ; return elt_ty } -unifyListTy :: TcType -> TcM TcType -unifyListTy ty@(TyVarTy tyvar) +---------------------- +unifyXTy :: TyCon -> TcType -> TcM TcType +unifyXTy tc ty@(TyVarTy tyvar) = getTcTyVar tyvar `thenM` \ maybe_ty -> case maybe_ty of - Just ty' -> unifyListTy ty' - other -> unify_list_ty_help ty - -unifyListTy ty - = case tcSplitTyConApp_maybe ty of - Just (tycon, [arg_ty]) | tycon == listTyCon -> returnM arg_ty - other -> unify_list_ty_help ty - -unify_list_ty_help ty -- Revert to ordinary unification - = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> - unifyTauTy ty (mkListTy elt_ty) `thenM_` - returnM elt_ty - --- variant for parallel arrays --- -zapToPArrTy :: Expected TcType -- Expected list type - -> TcM TcType -- List element type - -zapToPArrTy (Check ty) = unifyPArrTy ty -zapToPArrTy (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ; - writeMutVar hole (mkPArrTy elt_ty) ; - return elt_ty } + Just ty' -> unifyXTy tc ty' + other -> unify_x_ty_help tc ty -unifyPArrTy :: TcType -> TcM TcType - -unifyPArrTy ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyPArrTy ty' - _ -> unify_parr_ty_help ty -unifyPArrTy ty +unifyXTy tc ty = case tcSplitTyConApp_maybe ty of - Just (tycon, [arg_ty]) | tycon == parrTyCon -> returnM arg_ty - _ -> unify_parr_ty_help ty + Just (tycon, [arg_ty]) | tycon == tc -> returnM arg_ty + other -> unify_x_ty_help tc ty -unify_parr_ty_help ty -- Revert to ordinary unification - = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> - unifyTauTy ty (mkPArrTy elt_ty) `thenM_` +unify_x_ty_help tc ty -- Revert to ordinary unification + = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> + unifyTauTy ty (mkTyConApp tc [elt_ty]) `thenM_` returnM elt_ty \end{code} \begin{code} +---------------------- zapToTupleTy :: Boxity -> Arity -> Expected TcType -> TcM [TcType] zapToTupleTy boxity arity (Check ty) = unifyTupleTy boxity arity ty zapToTupleTy boxity arity (Infer hole) = do { (tup_ty, arg_tys) <- new_tuple_ty boxity arity ; @@ -267,8 +253,9 @@ unify_tuple_ty_help boxity arity ty new_tuple_ty boxity arity = newTyVarTys arity kind `thenM` \ arg_tys -> - return (mkTupleTy boxity arity arg_tys, arg_tys) + return (mkTyConApp tup_tc arg_tys, arg_tys) where + tup_tc = tupleTyCon boxity arity kind | isBoxed boxity = liftedTypeKind | otherwise = openTypeKind \end{code} @@ -626,18 +613,20 @@ uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 -- "True" means args swapped -- Predicates -uTys _ (SourceTy (IParam n1 t1)) _ (SourceTy (IParam n2 t2)) +uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2)) | n1 == n2 = uTys t1 t1 t2 t2 -uTys _ (SourceTy (ClassP c1 tys1)) _ (SourceTy (ClassP c2 tys2)) +uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (ClassP c2 tys2)) | c1 == c2 = unifyTauTyLists tys1 tys2 -uTys _ (SourceTy (NType tc1 tys1)) _ (SourceTy (NType tc2 tys2)) - | tc1 == tc2 = unifyTauTyLists tys1 tys2 -- Functions; just check the two parts uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) = uTys fun1 fun1 fun2 fun2 `thenM_` uTys arg1 arg1 arg2 arg2 - -- Type constructors must match + -- NewType constructors must match +uTys _ (NewTcApp tc1 tys1) _ (NewTcApp tc2 tys2) + | tc1 == tc2 = unifyTauTyLists tys1 tys2 + + -- Ordinary type constructors must match uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) | con1 == con2 && equalLength tys1 tys2 = unifyTauTyLists tys1 tys2 @@ -646,7 +635,7 @@ uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) -- When we are doing kind checking, we might match a kind '?' -- against a kind '*' or '#'. Notably, CCallable :: ? -> *, and -- (CCallable Int) and (CCallable Int#) are both OK - = unifyOpenTypeKind ps_ty2 + = unifyTypeKind ps_ty2 -- Applications need a bit of care! -- They can match FunTy and TyConApp, so use splitAppTy_maybe @@ -887,8 +876,9 @@ okToUnifyWith tv ty ok (AppTy t1 t2) = ok t1 `and` ok t2 ok (FunTy t1 t2) = ok t1 `and` ok t2 ok (TyConApp _ ts) = oks ts + ok (NewTcApp _ ts) = oks ts ok (ForAllTy _ _) = Just NotMonoType - ok (SourceTy st) = ok_st st + ok (PredTy st) = ok_st st ok (NoteTy (FTVNote _) t) = ok t ok (NoteTy (SynNote t1) t2) = ok t1 `and` ok t2 -- Type variables may be free in t1 but not t2 @@ -898,7 +888,6 @@ okToUnifyWith tv ty ok_st (ClassP _ ts) = oks ts ok_st (IParam _ t) = ok t - ok_st (NType _ ts) = oks ts Nothing `and` m = m Just p `and` m = Just p @@ -924,23 +913,23 @@ unifyKinds _ _ = panic "unifyKinds: length mis-match" \end{code} \begin{code} -unifyOpenTypeKind :: TcKind -> TcM () --- Ensures that the argument kind is of the form (Type bx) --- for some boxity bx +unifyTypeKind :: TcKind -> TcM () +-- Ensures that the argument kind is a liftedTypeKind or unliftedTypeKind +-- If it's a kind variable, make it (Type bx), for a fresh boxity variable bx -unifyOpenTypeKind ty@(TyVarTy tyvar) +unifyTypeKind ty@(TyVarTy tyvar) = getTcTyVar tyvar `thenM` \ maybe_ty -> case maybe_ty of - Just ty' -> unifyOpenTypeKind ty' - other -> unify_open_kind_help ty - -unifyOpenTypeKind ty + Just ty' -> unifyTypeKind ty' + Nothing -> newBoxityVar `thenM` \ bx_var -> + putTcTyVar tyvar (mkTyConApp typeCon [bx_var]) `thenM_` + returnM () + +unifyTypeKind ty | isTypeKind ty = returnM () - | otherwise = unify_open_kind_help ty - -unify_open_kind_help ty -- Revert to ordinary unification - = newOpenTypeKind `thenM` \ open_kind -> - unifyKind ty open_kind + | otherwise -- Failure + = zonkTcType ty `thenM` \ ty1 -> + failWithTc (ptext SLIT("Type expected but") <+> quotes (ppr ty1) <+> ptext SLIT("found")) \end{code} \begin{code} diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 3a37d16176..71654f87da 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -57,15 +57,14 @@ data Class type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ... -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] -type ClassOpItem = (Id, DefMeth Name) +type ClassOpItem = (Id, DefMeth) -- Selector function; contains unfolding -- Default-method info -data DefMeth id = NoDefMeth -- No default method - | DefMeth id -- A polymorphic default method (named id) - -- (Only instantiated to RdrName and Name, never Id) - | GenDefMeth -- A generic default method - deriving Eq +data DefMeth = NoDefMeth -- No default method + | DefMeth -- A polymorphic default method + | GenDefMeth -- A generic default method + deriving Eq \end{code} The @mkClass@ function fills in the indirect superclasses. @@ -155,6 +154,11 @@ instance Outputable Class where instance Show Class where showsPrec p c = showsPrecSDoc p (ppr c) + +instance Outputable DefMeth where + ppr DefMeth = text "{- has default method -}" + ppr GenDefMeth = text "{- has generic method -}" + ppr NoDefMeth = empty -- No default method \end{code} diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index 6fd587a205..e3023aee27 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -17,7 +17,7 @@ import Name ( getSrcLoc ) import Var ( Id, TyVar ) import Class ( Class, FunDep, classTvsFds ) import Subst ( mkSubst, emptyInScopeSet, substTy ) -import TcType ( Type, ThetaType, SourceType(..), PredType, +import TcType ( Type, ThetaType, PredType(..), predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred, unifyTyListsX, unifyExtendTysX, tcEqType ) @@ -177,7 +177,7 @@ improve :: InstEnv Id -- Gives instances for given class type InstEnv a = Class -> [(TyVarSet, [Type], a)] -- This is a bit clumsy, because InstEnv is really -- defined in module InstEnv. However, we don't want --- to define it (and ClsInstEnv) here because InstEnv +-- to define it here because InstEnv -- is their home. Nor do we want to make a recursive -- module group (InstEnv imports stuff from FunDeps). \end{code} diff --git a/ghc/compiler/types/Generics.hi-boot-5 b/ghc/compiler/types/Generics.hi-boot-5 deleted file mode 100644 index 6325080257..0000000000 --- a/ghc/compiler/types/Generics.hi-boot-5 +++ /dev/null @@ -1,4 +0,0 @@ -__interface Generics 1 0 where -__export Generics mkTyConGenInfo ; - -2 mkTyConGenInfo :: TyCon.TyCon -> [Name.Name] -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ; diff --git a/ghc/compiler/types/Generics.hi-boot-6 b/ghc/compiler/types/Generics.hi-boot-6 deleted file mode 100644 index e0c5c6b58c..0000000000 --- a/ghc/compiler/types/Generics.hi-boot-6 +++ /dev/null @@ -1,4 +0,0 @@ -module Generics where - -mkTyConGenInfo :: TyCon.TyCon -> [Name.Name] - -> Data.Maybe.Maybe (BasicTypes.EP Var.Id) diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 20bc33af6e..11f2a23a4b 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -1,43 +1,32 @@ \begin{code} -module Generics ( mkTyConGenInfo, mkGenericRhs, +module Generics ( canDoGenerics, mkGenericBinds, + mkGenericRhs, validGenericInstanceType, validGenericMethodType ) where -import RnHsSyn ( RenamedHsExpr ) -import HsSyn ( HsExpr(..), Pat(..), mkSimpleMatch, placeHolderType ) - +import HsSyn import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, - mkTyVarTys, mkForAllTys, mkTyConApp, - mkFunTy, isTyVarTy, getTyVar_maybe, - funTyCon + isTyVarTy, getTyVar_maybe, funTyCon ) -import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy ) -import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, isExistentialDataCon ) +import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy ) +import DataCon ( DataCon, dataConOrigArgTys, isExistentialDataCon, + dataConSourceArity ) -import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe, - tyConGenInfo, isNewTyCon, isBoxedTupleTyCon +import TyCon ( TyCon, tyConName, tyConDataCons, + tyConHasGenerics, isBoxedTupleTyCon ) -import Name ( Name, mkSystemName ) -import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), - mkConApp, Alt, mkTyApps, mkVarApps ) -import CoreUtils ( exprArity ) +import Name ( nameModuleName, nameOccName, getSrcLoc ) +import OccName ( mkGenOcc1, mkGenOcc2 ) +import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig ) import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) import VarSet ( varSetElems ) -import Id ( Id, mkGlobalId, idType, idName, mkSysLocal ) -import MkId ( mkReboxingAlt, mkNewTypeBody ) -import TysWiredIn ( genericTyCons, - genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, - inlDataCon, crossTyCon, crossDataCon - ) -import IdInfo ( GlobalIdDetails(..), noCafIdInfo, setUnfoldingInfo, setArityInfo ) -import CoreUnfold ( mkTopUnfolding ) - -import Maybe ( isNothing ) -import SrcLoc ( noSrcLoc ) -import Unique ( Unique, builtinUniques, mkBuiltinUnique ) -import Util ( takeList, dropList ) +import Id ( Id, idType ) +import PrelNames + +import SrcLoc ( generatedSrcLoc ) +import Util ( takeList ) import Outputable import FastString @@ -191,7 +180,7 @@ validGenericInstanceType :: Type -> Bool validGenericInstanceType inst_ty = case tcSplitTyConApp_maybe inst_ty of - Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons + Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames Nothing -> False validGenericMethodType :: Type -> Bool @@ -228,102 +217,67 @@ validGenericMethodType ty %************************************************************************ \begin{code} -mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id) --- mkTyConGenInfo is called twice --- once from TysWiredIn for Tuples --- once the typechecker TcTyDecls --- to generate generic types and conversion functions for all datatypes. --- --- Must only be called with an algebraic type. --- --- The two names are the names constructed by the renamer --- for the fromT and toT conversion functions. - -mkTyConGenInfo tycon [] - = Nothing -- This happens when we deal with the interface-file type - -- decl for a module compiled without -fgenerics - -mkTyConGenInfo tycon [from_name, to_name] - | isNothing maybe_datacons -- Abstractly imported types don't have - = Nothing -- to/from operations, (and should not need them) - - -- If any of the constructor has an unboxed type as argument, +canDoGenerics :: [DataCon] -> Bool +-- Called on source-code data types, to see if we should generate +-- generic functions for them. (This info is recorded in the interface file for +-- imported data types.) + +canDoGenerics data_cons + = not (any bad_con data_cons) -- See comment below + && not (null data_cons) -- No values of the type + where + bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || isExistentialDataCon dc + -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors + -- Nor can we do the job if it's an existential data constructor, - | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc - | dc <- datacons ] - = Nothing - | null datacons -- There are no constructors; - = Nothing -- there are no values of this type + -- Nor if the args are polymorphic types (I don't think) + bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) +\end{code} - | otherwise - = ASSERT( not (null datacons) ) -- mk_sum_stuff loops if no datacons - Just (EP { fromEP = mk_id from_name from_ty from_id_info, - toEP = mk_id to_name to_ty to_id_info }) +%************************************************************************ +%* * +\subsection{Generating the RHS of a generic default method} +%* * +%************************************************************************ + +\begin{code} +type US = Int -- Local unique supply, just a plain Int +type FromAlt = (Pat RdrName, HsExpr RdrName) + +mkGenericBinds :: [TyCon] -> MonoBinds RdrName +mkGenericBinds tcs = andMonoBindList [ mkTyConGenBinds tc + | tc <- tcs, tyConHasGenerics tc] + +mkTyConGenBinds :: TyCon -> MonoBinds RdrName +mkTyConGenBinds tycon + = FunMonoBind to_RDR False {- Not infix -} + [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] + loc + `AndMonoBinds` + FunMonoBind from_RDR False + [mkSimpleHsAlt (VarPat to_arg) to_body] loc where - mk_id = mkGlobalId (GenericOpId tycon) - - maybe_datacons = tyConDataCons_maybe tycon - Just datacons = maybe_datacons -- [C, D] - - tyvars = tyConTyVars tycon -- [a, b, c] - tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c - tyvar_tys = mkTyVarTys tyvars - - from_id_info = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn - `setArityInfo` exprArity from_fn - to_id_info = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn - `setArityInfo` exprArity to_fn - -- It's important to set the arity info, so that - -- the calling convention (gotten from arity) - -- matches reality. - - from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty) - to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty) - - (from_fn, to_fn, rep_ty) - | isNewTyCon tycon - = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon the_arg_ty (Var x), - Var (dataConWrapId the_datacon), - the_arg_ty ) - - | otherwise - = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts, - mkLams tyvars $ Lam rep_var to_inner, - idType rep_var ) - - -- x :: T a b c - x = mkGenericLocal u1 tycon_ty - (u1 : uniqs) = builtinUniques - - ---------------------- - -- Newtypes only - [the_datacon] = datacons - the_arg_ty = head (dataConOrigArgTys the_datacon) - -- NB: we use the arg type of the data constructor, rather than - -- the representation type of the newtype; in degnerate (recursive) - -- cases the rep type might be (), but the arg type is still T: - -- newtype T = MkT T - - ---------------------- - -- Non-newtypes only + loc = getSrcLoc tycon + datacons = tyConDataCons tycon + (from_RDR, to_RDR) = mkGenericNames tycon + -- Recurse over the sum first - -- The "2" is the first free unique - (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons - -mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names) - + from_alts :: [FromAlt] + (from_alts, to_arg, to_body) = mk_sum_stuff init_us datacons + init_us = 1::Int -- Unique supply ---------------------------------------------------- -- Dealing with sums ---------------------------------------------------- -mk_sum_stuff :: [Unique] -- Base for generating unique names - -> [TyVar] -- Type variables over which the tycon is abstracted - -> [DataCon] -- The data constructors - -> ([Alt Id], CoreExpr, Id) + +mk_sum_stuff :: US -- Base for generating unique names + -> [DataCon] -- The data constructors + -> ([FromAlt], -- Alternatives for the T->Trep "from" function + RdrName, HsExpr RdrName) -- Arg and body of the Trep->T "to" function -- For example, given -- data T = C | D Int Int Int @@ -335,93 +289,85 @@ mk_sum_stuff :: [Unique] -- Base for generating unique names -- D a b c }} }, -- cd) -mk_sum_stuff us tyvars [datacon] - = ([from_alt], to_body_fn app_exp, rep_var) +mk_sum_stuff us [datacon] + = ([from_alt], to_arg, to_body_fn app_exp) where - types = dataConOrigArgTys datacon -- Existentials already excluded - datacon_vars = zipWith mkGenericLocal us types - us' = dropList types us - - app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars) - from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs - -- We are talking about *user* datacons here; hence - -- dataConWrapId - -- mkReboxingAlt - - (_,args',_) = from_alt - us'' = dropList args' us' -- Conservative, but safe - - (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars - -mk_sum_stuff (u:us) tyvars datacons - = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts, - Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body), - (DataAlt inrDataCon, [r_rep_var], r_to_body)], - rep_var) + n_args = dataConSourceArity datacon -- Existentials already excluded + + datacon_vars = map mkGenericLocal [us .. us+n_args-1] + us' = us + n_args + + datacon_rdr = getRdrName datacon + app_exp = mkHsVarApps datacon_rdr datacon_vars + from_alt = (mkConPat datacon_rdr datacon_vars, from_alt_rhs) + + (_, from_alt_rhs, to_arg, to_body_fn) = mk_prod_stuff us' datacon_vars + +mk_sum_stuff us datacons + = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, + to_arg, + HsCase (HsVar to_arg) + [mkSimpleHsAlt (mkConPat inlDataCon_RDR [l_to_arg]) l_to_body, + mkSimpleHsAlt (mkConPat inrDataCon_RDR [r_to_arg]) r_to_body] + generatedSrcLoc) where - (l_datacons, r_datacons) = splitInHalf datacons - (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons - (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons - rep_tys = [idType l_rep_var, idType r_rep_var] - rep_ty = mkTyConApp plusTyCon rep_tys - rep_var = mkGenericLocal u rep_ty - - wrap :: DataCon -> [Alt Id] -> [Alt Id] + (l_datacons, r_datacons) = splitInHalf datacons + (l_from_alts, l_to_arg, l_to_body) = mk_sum_stuff us' l_datacons + (r_from_alts, r_to_arg, r_to_body) = mk_sum_stuff us' r_datacons + + to_arg = mkGenericLocal us + us' = us+1 + + wrap :: RdrName -> [FromAlt] -> [FromAlt] -- Wrap an application of the Inl or Inr constructor round each alternative - wrap datacon alts - = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts] - where - datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys + wrap dc alts = [(pat, HsApp (HsVar dc) rhs) | (pat,rhs) <- alts] + ---------------------------------------------------- -- Dealing with products ---------------------------------------------------- -mk_prod_stuff :: [Unique] -- Base for unique names - -> [Id] -- arg-ids; args of the original user-defined constructor +mk_prod_stuff :: US -- Base for unique names + -> [RdrName] -- arg-ids; args of the original user-defined constructor -- They are bound enclosing from_rhs -- Please bind these in the to_body_fn - -> ([Unique], -- Depleted unique-name supply - CoreExpr, -- from-rhs: puts together the representation from the arg_ids - CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation - Id) -- The rep-id; please bind this to the representation + -> (US, -- Depleted unique-name supply + HsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids + RdrName, -- to_arg: + HsExpr RdrName -> HsExpr RdrName) -- to_body_fn: takes apart the representation -- For example: --- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c), --- \x -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- x, --- abc ) +-- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c), +-- \x -> case abc of { a :*: bc -> +-- case bc of { b :*: c -> +-- x) --- We need to use different uqiques in the branches +-- We need to use different uniques in the branches -- because the returned to_body_fns are nested. -- Hence the returned unqique-name supply -mk_prod_stuff (u:us) [] -- Unit case - = (us, - Var (dataConWrapId genUnitDataCon), - \x -> x, - mkGenericLocal u (mkTyConApp genUnitTyCon [])) +mk_prod_stuff us [] -- Unit case + = (us+1, + HsVar genUnitDataCon_RDR, + mkGenericLocal us, + \x -> x) mk_prod_stuff us [arg_var] -- Singleton case - = (us, Var arg_var, \x -> x, arg_var) + = (us, HsVar arg_var, arg_var, \x -> x) -mk_prod_stuff (u:us) arg_vars -- Two or more +mk_prod_stuff us arg_vars -- Two or more = (us'', - mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]), - \x -> Case (Var rep_var) rep_var - [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))], - rep_var) + HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs, + to_arg, + \x -> HsCase (HsVar to_arg) + [mkSimpleHsAlt (mkConPat crossDataCon_RDR [l_to_arg, r_to_arg]) + (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc) where - (l_arg_vars, r_arg_vars) = splitInHalf arg_vars - (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars - (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars - rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys) - rep_tys = [idType l_rep_var, idType r_rep_var] -\end{code} + to_arg = mkGenericLocal us + (l_arg_vars, r_arg_vars) = splitInHalf arg_vars + (us', l_alt_rhs, l_to_arg, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars + (us'', r_alt_rhs, r_to_arg, r_to_body_fn) = mk_prod_stuff us' r_arg_vars -A little utility function -\begin{code} splitInHalf :: [a] -> ([a],[a]) splitInHalf list = (left, right) where @@ -429,8 +375,17 @@ splitInHalf list = (left, right) left = take half list right = drop half list -mkGenericLocal :: Unique -> Type -> Id -mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty +mkGenericLocal :: US -> RdrName +mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) + +mkGenericNames tycon + = (from_RDR, to_RDR) + where + tc_name = tyConName tycon + tc_occ = nameOccName tc_name + tc_mod = nameModuleName tc_name + from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) + to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) \end{code} %************************************************************************ @@ -488,14 +443,13 @@ By the time the type checker has done its stuff we'll get op = \b. \dict::Ord b. toOp b (op Trep b dict) \begin{code} -mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr +mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName mkGenericRhs sel_id tyvar tycon - = HsApp (toEP bimap) (HsVar (idName sel_id)) + = HsApp (toEP bimap) (HsVar (getRdrName sel_id)) where -- Initialising the "Environment" with the from/to functions -- on the datatype (actually tycon) in question - Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed - ep = EP (HsVar (idName from)) (HsVar (idName to)) + (from_RDR, to_RDR) = mkGenericNames tycon -- Takes out the ForAll and the Class restrictions -- in front of the type of the method. @@ -507,17 +461,18 @@ mkGenericRhs sel_id tyvar tycon -- Now we probably have a tycon in front -- of us, quite probably a FunTyCon. + ep = EP (HsVar from_RDR) (HsVar to_RDR) bimap = generate_bimap (tyvar, ep, local_tvs) final_ty -type EPEnv = (TyVar, -- The class type variable - EP RenamedHsExpr, -- The EP it maps to - [TyVar] -- Other in-scope tyvars; they have an identity EP +type EPEnv = (TyVar, -- The class type variable + EP (HsExpr RdrName), -- The EP it maps to + [TyVar] -- Other in-scope tyvars; they have an identity EP ) ------------------- generate_bimap :: EPEnv -> Type - -> EP RenamedHsExpr + -> EP (HsExpr RdrName) -- Top level case - splitting the TyCon. generate_bimap env@(tv,ep,local_tvs) ty = case getTyVar_maybe ty of @@ -527,7 +482,7 @@ generate_bimap env@(tv,ep,local_tvs) ty Nothing -> bimapApp env (tcSplitTyConApp_maybe ty) ------------------- -bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr +bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (HsExpr RdrName) bimapApp env Nothing = panic "TcClassDecl: Type Application!" bimapApp env (Just (tycon, ty_args)) | tycon == funTyCon = bimapArrow arg_eps @@ -543,32 +498,32 @@ bimapApp env (Just (tycon, ty_args)) ------------------- -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b') bimapArrow [ep1, ep2] - = EP { fromEP = mk_hs_lam [VarPat g1, VarPat g2] from_body, - toEP = mk_hs_lam [VarPat g1, VarPat g2] to_body } + = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body, + toEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body } where - from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2)) - to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2)) + from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar b_RDR)) + to_body = toEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR)) ------------------- bimapTuple eps = EP { fromEP = mk_hs_lam [tuple_pat] from_body, toEP = mk_hs_lam [tuple_pat] to_body } where - names = takeList eps genericNames + names = takeList eps gs_RDR tuple_pat = TuplePat (map VarPat names) Boxed eps_w_names = eps `zip` names to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed ------------------- -genericNames :: [Name] -genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]] -(g1:g2:g3:_) = genericNames +a_RDR = mkVarUnqual FSLIT("a") +b_RDR = mkVarUnqual FSLIT("b") +gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ] -mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType noSrcLoc)) +mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc)) -idEP :: EP RenamedHsExpr +idEP :: EP (HsExpr RdrName) idEP = EP idexpr idexpr where - idexpr = mk_hs_lam [VarPat g3] (HsVar g3) + idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR) \end{code} diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index 73a6ce9734..64591bcbb0 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -7,35 +7,31 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - DFunId, ClsInstEnv, InstEnv, + DFunId, InstEnv, emptyInstEnv, extendInstEnv, pprInstEnv, - lookupInstEnv, InstLookupResult(..), - classInstEnv, simpleDFunClassTyCon + lookupInstEnv, + classInstEnv, simpleDFunClassTyCon, checkFunDeps ) where #include "HsVersions.h" import Class ( Class, classTvsFds ) -import Var ( TyVar, Id ) +import Var ( Id ) import VarSet import VarEnv -import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) -import Name ( getSrcLoc, nameModule ) -import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import TcType ( Type, tcTyConAppTyCon, mkTyVarTy, +import TcType ( Type, tcTyConAppTyCon, tcSplitDFunTy, tyVarsOfTypes, - matchTys, unifyTyListsX, allDistinctTyVars + matchTys, unifyTyListsX ) -import PprType ( pprClassPred ) import FunDeps ( checkClsFD ) import TyCon ( TyCon ) import Outputable -import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM ) -import Id ( idType, idName ) -import ErrUtils ( Message ) +import UniqFM ( UniqFM, lookupWithDefaultUFM, emptyUFM, eltsUFM, addToUFM_C ) +import Id ( idType ) import CmdLineOpts import Util ( notNull ) +import Maybe ( isJust ) \end{code} @@ -47,15 +43,25 @@ import Util ( notNull ) \begin{code} type DFunId = Id +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class +type ClsInstEnv = [InstEnvElt] -- The instances for a particular class +type InstEnvElt = (TyVarSet, [Type], DFunId) + -- INVARIANTs: see notes below -type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUFM -simpleDFunClassTyCon :: DFunId -> (Class, TyCon) -simpleDFunClassTyCon dfun - = (clas, tycon) +classInstEnv :: InstEnv -> Class -> ClsInstEnv +classInstEnv env cls = lookupWithDefaultUFM env [] cls + +extendInstEnv :: InstEnv -> DFunId -> InstEnv +extendInstEnv inst_env dfun_id + = addToUFM_C add inst_env clas [ins_item] where - (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun) - tycon = tcTyConAppTyCon ty + add old _ = ins_item : old + (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) + ins_tv_set = mkVarSet ins_tvs + ins_item = (ins_tv_set, ins_tys, dfun_id) pprInstEnv :: InstEnv -> SDoc pprInstEnv env @@ -64,6 +70,14 @@ pprInstEnv env | cls_inst_env <- eltsUFM env , (tyvars, tys, dfun) <- cls_inst_env ] + + +simpleDFunClassTyCon :: DFunId -> (Class, TyCon) +simpleDFunClassTyCon dfun + = (clas, tycon) + where + (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun) + tycon = tcTyConAppTyCon ty \end{code} %************************************************************************ @@ -72,17 +86,6 @@ pprInstEnv env %* * %************************************************************************ -\begin{code} -type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class - -- INVARIANTs: see notes below - -emptyInstEnv :: InstEnv -emptyInstEnv = emptyUFM - -classInstEnv :: InstEnv -> Class -> ClsInstEnv -classInstEnv env cls = lookupWithDefaultUFM env [] cls -\end{code} - A @ClsInstEnv@ all the instances of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for that instance. @@ -247,152 +250,91 @@ thing we are looking up can have an arbitrary "flexi" part. \begin{code} lookupInstEnv :: DynFlags - -> InstEnv -- The envt - -> Class -> [Type] -- What we are looking for - -> InstLookupResult - -data InstLookupResult - = FoundInst -- There is a (template,substitution) pair - -- that makes the template match the key, - -- and no template is an instance of the key - TyVarSubstEnv Id - - | NoMatch Bool -- Boolean is true iff there is at least one - -- template that matches the key. - -- (but there are other template(s) that are - -- instances of the key, so we don't report - -- FoundInst) - -- The NoMatch True case happens when we look up + -> (InstEnv, -- Home-package inst-env + InstEnv) -- External package inst-env + -> Class -> [Type] -- What we are looking for + -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches + [Id]) -- These don't match but do unify + -- The second component of the tuple happens when we look up -- Foo [a] -- in an InstEnv that has entries for -- Foo [Int] -- Foo [b] -- Then which we choose would depend on the way in which 'a' - -- is instantiated. So we say there is no match, but identify - -- it as ambiguous case in the hope of giving a better error msg. - -- See the notes above from Jeff Lewis - -lookupInstEnv dflags env key_cls key_tys - = find (classInstEnv env key_cls) + -- is instantiated. So we report that Foo [b] is a match (mapping b->a) + -- but Foo [Int] is a unifier. This gives the caller a better chance of + -- giving a suitable error messagen + +lookupInstEnv dflags (home_ie, pkg_ie) cls tys + | not (null all_unifs) = (all_matches, all_unifs) -- This is always an error situation, + -- so don't attempt to pune the matches + | otherwise = (pruned_matches, []) + where + incoherent_ok = dopt Opt_AllowIncoherentInstances dflags + overlap_ok = dopt Opt_AllowOverlappingInstances dflags + (home_matches, home_unifs) = lookup_inst_env incoherent_ok home_ie cls tys + (pkg_matches, pkg_unifs) = lookup_inst_env incoherent_ok pkg_ie cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + + pruned_matches | overlap_ok = foldr insert_overlapping [] all_matches + | otherwise = all_matches + +lookup_inst_env :: Bool + -> InstEnv -- The envt + -> Class -> [Type] -- What we are looking for + -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches + [Id]) -- These don't match but do unify +lookup_inst_env incoherent_ok env key_cls key_tys + = find (classInstEnv env key_cls) [] [] where key_vars = tyVarsOfTypes key_tys - find [] = NoMatch False - find ((tpl_tyvars, tpl, dfun_id) : rest) + find [] ms us = (ms, us) + find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us = case matchTys tpl_tyvars tpl key_tys of - Nothing -> - -- Check whether the things unify, so that - -- we bale out if a later instantiation of this - -- predicate might match this instance - -- [see notes about overlapping instances above] - case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of - Just _ | not (dopt Opt_AllowIncoherentInstances dflags) - -> NoMatch (any_match rest) + Just (subst, leftovers) -> ASSERT( null leftovers ) + find rest ((subst,item):ms) us + Nothing + | incoherent_ok -> find rest ms us -- If we allow incoherent instances we don't worry about the -- test and just blaze on anyhow. Requested by John Hughes. - other -> find rest - - Just (subst, leftovers) -> ASSERT( null leftovers ) - FoundInst subst dfun_id + | otherwise + -- Does not match, so next check whether the things unify + -- [see notes about overlapping instances above] + -> case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of + Just _ -> find rest ms (dfun_id:us) + Nothing -> find rest ms us + +insert_overlapping :: (TyVarSubstEnv, InstEnvElt) -> [(TyVarSubstEnv, InstEnvElt)] + -> [(TyVarSubstEnv, InstEnvElt)] +-- Add a new solution, knocking out strictly less specific ones +insert_overlapping new_item [] = [new_item] +insert_overlapping new_item (item:items) + | new_beats_old && old_beats_new = item : insert_overlapping new_item items + -- Duplicate => keep both for error report + | new_beats_old = insert_overlapping new_item items + -- Keep new one + | old_beats_new = item : items + -- Keep old one + | otherwise = item : insert_overlapping new_item items + -- Keep both + where + new_beats_old = new_item `beats` item + old_beats_new = item `beats` new_item - any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys) - | (tvs,tpl,_) <- rest - ] + (_, (tvs1, tys1, _)) `beats` (_, (tvs2, tys2, _)) + = isJust (matchTys tvs2 tys2 tys1) -- A beats B if A is more specific than B + -- I.e. if B can be instantiated to match A \end{code} %************************************************************************ %* * -\subsection{Extending an instance environment} + Functional dependencies %* * %************************************************************************ -@extendInstEnv@ extends a @ClsInstEnv@, checking for overlaps. - -A boolean flag controls overlap reporting. - -True => overlap is permitted, but only if one template matches the other; - not if they unify but neither is - -\begin{code} -extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [(SrcLoc,Message)]) - -- Similar, but all we have is the DFuns -extendInstEnv dflags env dfun_ids = foldl (addToInstEnv dflags) (env, []) dfun_ids - - -addToInstEnv :: DynFlags - -> (InstEnv, [(SrcLoc,Message)]) - -> DFunId - -> (InstEnv, [(SrcLoc,Message)]) -- Resulting InstEnv and augmented error messages - -addToInstEnv dflags (inst_env, errs) dfun_id - -- Check first that the new instance doesn't - -- conflict with another. See notes below about fundeps. - | notNull bad_fundeps - = (inst_env, fundep_err : errs) -- Bad fundeps; report the first only - - | otherwise - = case insert_into cls_inst_env of - Failed err -> (inst_env, err : errs) - Succeeded new_env -> (addToUFM inst_env clas new_env, errs) - - where - cls_inst_env = classInstEnv inst_env clas - (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) - bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys - fundep_err = fundepErr dfun_id (head bad_fundeps) - - ins_tv_set = mkVarSet ins_tvs - ins_item = (ins_tv_set, ins_tys, dfun_id) - - insert_into [] = returnMaB [ins_item] - insert_into env@(cur_item@(tpl_tvs, tpl_tys, tpl_dfun_id) : rest) - = case unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys of - Just subst -> insert_unifiable env subst - Nothing -> carry_on cur_item rest - - carry_on cur_item rest = insert_into rest `thenMaB` \ rest' -> - returnMaB (cur_item : rest') - - -- The two templates unify. This is acceptable iff - -- (a) -fallow-overlapping-instances is on - -- (b) one is strictly more specific than the other - -- [It's bad if they are identical or incomparable] - insert_unifiable env@(cur_item@(tpl_tvs, tpl_tys, tpl_dfun_id) : rest) subst - | ins_item_more_specific && cur_item_more_specific - = -- Duplicates - failMaB (dupInstErr dfun_id tpl_dfun_id) - - | not (dopt Opt_AllowOverlappingInstances dflags) - || not (ins_item_more_specific || cur_item_more_specific) - = -- Overlap illegal, or the two are incomparable - failMaB (overlapErr dfun_id tpl_dfun_id) - - | otherwise - = -- OK, it's acceptable. Remaining question is whether - -- we drop it here or compare it with others - if ins_item_more_specific then - -- New item is an instance of current item, so drop it here - returnMaB (ins_item : env) - else - carry_on cur_item rest - - where - ins_item_more_specific = allVars subst ins_tvs - cur_item_more_specific = allVars subst (varSetElems tpl_tvs) - -allVars :: TyVarSubstEnv -> [TyVar] -> Bool --- True iff all the type vars are mapped to distinct type vars -allVars subst tvs - = allDistinctTyVars (map lookup tvs) emptyVarSet - where - lookup tv = case lookupSubstEnv subst tv of - Just (DoneTy ty) -> ty - Nothing -> mkTyVarTy tv -\end{code} - -Functional dependencies -~~~~~~~~~~~~~~~~~~~~~~~ Here is the bad case: class C a b | a->b where ... instance C Int Bool where ... @@ -419,9 +361,20 @@ them separate. But we want to make sure that given any constraint if s1 matches - - \begin{code} +checkFunDeps :: (InstEnv, InstEnv) -> DFunId + -> Maybe [DFunId] -- Nothing <=> ok + -- Just dfs <=> conflict with dfs +-- Check wheher adding DFunId would break functional-dependency constraints +checkFunDeps (home_ie, pkg_ie) dfun + | null bad_fundeps = Nothing + | otherwise = Just bad_fundeps + where + (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun) + ins_tv_set = mkVarSet ins_tvs + cls_inst_env = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas + bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys + badFunDeps :: ClsInstEnv -> Class -> TyVarSet -> [Type] -- Proposed new instance type -> [DFunId] @@ -433,27 +386,3 @@ badFunDeps cls_inst_env clas ins_tv_set ins_tys where (clas_tvs, fds) = classTvsFds clas \end{code} - - -\begin{code} -dupInstErr dfun1 dfun2 = addInstErr (ptext SLIT("Duplicate instance declarations:")) dfun1 dfun2 -overlapErr dfun1 dfun2 = addInstErr (ptext SLIT("Overlapping instance declarations:")) dfun1 dfun2 -fundepErr dfun1 dfun2 = addInstErr (ptext SLIT("Functional dependencies conflict between instance declarations:")) - dfun1 dfun2 - -addInstErr :: SDoc -> DFunId -> DFunId -> (SrcLoc, Message) -addInstErr what dfun1 dfun2 - = (getSrcLoc dfun1, hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)) - where - - ppr_dfun dfun = pp_loc <> colon <+> pprClassPred clas tys - where - (_,_,clas,tys) = tcSplitDFunTy (idType dfun) - loc = getSrcLoc dfun - mod = nameModule (idName dfun) - - -- Worth trying to print a good location... imported dfuns - -- don't have a useful SrcLoc but we can say which module they come from - pp_loc | isGoodSrcLoc loc = ppr loc - | otherwise = ptext SLIT("In module") <+> ppr mod -\end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 4a04bffb55..a5a523cf3c 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -7,7 +7,7 @@ module PprType( pprKind, pprParendKind, pprType, pprParendType, - pprSourceType, pprPred, pprTheta, pprClassPred, + pprPred, pprTheta, pprThetaArrow, pprClassPred, pprTyVarBndr, pprTyVarBndrs, -- Junk @@ -18,26 +18,25 @@ module PprType( -- friends: -- (PprType can see all the representations it's trying to print) -import TypeRep ( Type(..), TyNote(..), Kind ) -- friend -import Type ( SourceType(..) ) -import TcType ( ThetaType, PredType, TyThing(..), - tcSplitSigmaTy, isPredTy, isDictTy, +import TypeRep ( Type(..), TyNote(..), PredType(..), TyThing(..), Kind, superKind ) -- friend +import Type ( typeKind, eqKind ) +import IfaceType ( toIfaceType, toIfacePred, pprParendIfaceType, + toIfaceKind, pprParendIfaceKind, + getIfaceExt ) + +import TcType ( ThetaType, PredType, + tcSplitSigmaTy, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe ) import Var ( TyVar, tyVarKind ) import Class ( Class ) -import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity, - maybeTyConSingleCon, isEnumerationTyCon, tyConArity - ) +import TyCon ( isPrimTyCon, isTupleTyCon, maybeTyConSingleCon, isEnumerationTyCon ) -- others: import Maybes ( maybeToBool ) -import Name ( getOccString, getOccName ) -import OccName ( occNameUserString ) +import Name ( NamedThing(..), getOccString ) import Outputable -import Unique ( Uniquable(..) ) -import Util ( lengthIs ) -import BasicTypes ( IPName(..), tupleParens, ipNameName ) +import BasicTypes ( IPName(..), ipNameName ) import PrelNames -- quite a few *Keys \end{code} @@ -54,20 +53,20 @@ works just by setting the initial context precedence very high. \begin{code} pprType, pprParendType :: Type -> SDoc -pprType ty = ppr_ty tOP_PREC ty -pprParendType ty = ppr_ty tYCON_PREC ty +-- To save duplicating type-printing machinery, +-- we print a type by converting to an IfaceType and printing that +pprType ty = getIfaceExt $ \ ext -> + ppr (toIfaceType ext ty) +pprParendType ty = getIfaceExt $ \ ext -> + pprParendIfaceType (toIfaceType ext ty) pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType +pprKind k = ppr (toIfaceKind k) +pprParendKind k = pprParendIfaceKind (toIfaceKind k) pprPred :: PredType -> SDoc -pprPred = pprSourceType - -pprSourceType :: SourceType -> SDoc -pprSourceType (ClassP clas tys) = pprClassPred clas tys -pprSourceType (IParam n ty) = hsep [ppr n, dcolon, ppr ty] -pprSourceType (NType tc tys) = ppr tc <+> sep (map pprParendType tys) +pprPred pred = getIfaceExt $ \ ext -> + ppr (toIfacePred ext pred) pprClassPred :: Class -> [Type] -> SDoc pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys) @@ -75,16 +74,18 @@ pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys) pprTheta :: ThetaType -> SDoc pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) +pprThetaArrow :: ThetaType -> SDoc +pprThetaArrow theta + | null theta = empty + | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>") + instance Outputable Type where - ppr ty = pprType ty + ppr ty | typeKind ty `eqKind` superKind = pprKind ty + | otherwise = pprType ty -instance Outputable SourceType where +instance Outputable PredType where ppr = pprPred -instance Outputable name => Outputable (IPName name) where - ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters - ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters - instance Outputable name => OutputableBndr (IPName name) where pprBndr _ n = ppr n -- Simple for now @@ -93,119 +94,14 @@ instance Outputable TyThing where ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr dc -\end{code} - - -%************************************************************************ -%* * -\subsection{Pretty printing} -%* * -%************************************************************************ - -Precedence -~~~~~~~~~~ -@ppr_ty@ takes an @Int@ that is the precedence of the context. -The precedence levels are: -\begin{description} -\item[tOP_PREC] No parens required. -\item[fUN_PREC] Left hand argument of a function arrow. -\item[tYCON_PREC] Argument of a type constructor. -\end{description} - - -\begin{code} -tOP_PREC = (0 :: Int) -- type in ParseIface.y -fUN_PREC = (1 :: Int) -- btype in ParseIface.y -tYCON_PREC = (2 :: Int) -- atype in ParseIface.y -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (AClass cl) = getName cl + getName (ADataCon dc) = getName dc \end{code} -\begin{code} -ppr_ty :: Int -> Type -> SDoc -ppr_ty ctxt_prec (TyVarTy tyvar) - = ppr tyvar - -ppr_ty ctxt_prec ty@(TyConApp tycon tys) - -- KIND CASE; it's of the form (Type x) - | tycon `hasKey` typeConKey, - [ty] <- tys - = -- For kinds, print (Type x) as just x if x is a - -- type constructor (must be Boxed, Unboxed, AnyBox) - -- Otherwise print as (Type x) - case ty of - TyConApp bx [] -> ppr (getOccName bx) -- Always unqualified - other -> maybeParen ctxt_prec tYCON_PREC - (ppr tycon <+> ppr_ty tYCON_PREC ty) - - -- TUPLE CASE (boxed and unboxed) - | isTupleTyCon tycon, - tys `lengthIs` tyConArity tycon -- No magic if partially applied - = tupleParens (tupleTyConBoxity tycon) - (sep (punctuate comma (map (ppr_ty tOP_PREC) tys))) - - -- LIST CASE - | tycon `hasKey` listTyConKey, - [ty] <- tys - = brackets (ppr_ty tOP_PREC ty) - - -- PARALLEL ARRAY CASE - | tycon `hasKey` parrTyConKey, - [ty] <- tys - = pabrackets (ppr_ty tOP_PREC ty) - - -- GENERAL CASE - | otherwise - = ppr_tc_app ctxt_prec tycon tys - - where - pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") - - -ppr_ty ctxt_prec ty@(ForAllTy _ _) - = getPprStyle $ \ sty -> - maybeParen ctxt_prec fUN_PREC $ - sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), - ppr_theta theta, - ppr_ty tOP_PREC tau - ] - where - (tyvars, theta, tau) = tcSplitSigmaTy ty - pp_tyvars sty = sep (map pprTyVarBndr tyvars) - - ppr_theta [] = empty - ppr_theta theta = pprTheta theta <+> ptext SLIT("=>") - - -ppr_ty ctxt_prec (FunTy ty1 ty2) - -- we don't want to lose usage annotations or synonyms, - -- so we mustn't use splitFunTys here. - = maybeParen ctxt_prec fUN_PREC $ - sep [ ppr_ty fUN_PREC ty1 - , ptext arrow <+> ppr_ty tOP_PREC ty2 - ] - where arrow | isPredTy ty1 = SLIT("=>") - | otherwise = SLIT("->") - -ppr_ty ctxt_prec (AppTy ty1 ty2) - = maybeParen ctxt_prec tYCON_PREC $ - ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2 - -ppr_ty ctxt_prec (NoteTy (SynNote ty) expansion) - = ppr_ty ctxt_prec ty --- = ppr_ty ctxt_prec expansion -- if we don't want to see syntys - -ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty - -ppr_ty ctxt_prec (SourceTy (NType tc tys)) = ppr_tc_app ctxt_prec tc tys -ppr_ty ctxt_prec (SourceTy pred) = braces (pprPred pred) - -ppr_tc_app ctxt_prec tc [] = ppr tc -ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC - (sep [ppr tc, nest 4 (sep (map (ppr_ty tYCON_PREC) tys))]) -\end{code} %************************************************************************ @@ -251,19 +147,19 @@ getTyDescription ty TyVarTy _ -> "*" AppTy fun _ -> getTyDescription fun FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> occNameUserString (getOccName tycon) + NewTcApp tycon _ -> getOccString tycon + TyConApp tycon _ -> getOccString tycon NoteTy (FTVNote _) ty -> getTyDescription ty NoteTy (SynNote ty1) _ -> getTyDescription ty1 - SourceTy sty -> getSourceTyDescription sty + PredTy sty -> getPredTyDescription sty ForAllTy _ ty -> getTyDescription ty } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other -getSourceTyDescription (ClassP cl tys) = getOccString cl -getSourceTyDescription (NType tc tys) = getOccString tc -getSourceTyDescription (IParam ip ty) = getOccString (ipNameName ip) +getPredTyDescription (ClassP cl tys) = getOccString cl +getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 6f1ac543aa..9b40a448d7 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -14,7 +14,7 @@ module TyCon( isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, + isRecursiveTyCon, newTyConRep, isHiBootTyCon, mkForeignTyCon, isForeignTyCon, @@ -34,7 +34,7 @@ module TyCon( tyConKind, tyConUnique, tyConTyVars, - tyConArgVrcs_maybe, + tyConArgVrcs_maybe, tyConArgVrcs, tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, tyConSelIds, tyConTheta, @@ -42,13 +42,14 @@ module TyCon( tyConArity, isClassTyCon, tyConClass_maybe, getSynTyConDefn, + tyConExtName, -- External name for foreign types maybeTyConSingleCon, matchesTyCon, -- Generics - tyConGenIds, tyConGenInfo + tyConHasGenerics ) where #include "HsVersions.h" @@ -62,12 +63,11 @@ import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) import Var ( TyVar, Id ) import Class ( Class ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), - isBoxed, EP(..) ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..), anyBoxConKey ) import PrimRep ( PrimRep(..), isFollowableRep ) -import Maybes ( orElse ) +import Maybes ( orElse, expectJust ) import Outputable import FastString \end{code} @@ -99,7 +99,7 @@ data TyCon tyConArity :: Arity, tyConTyVars :: [TyVar], - tyConArgVrcs :: ArgVrcs, + argVrcs :: ArgVrcs, algTyConTheta :: [PredType], dataCons :: DataConDetails DataCon, @@ -110,10 +110,8 @@ data TyCon algTyConRec :: RecFlag, -- Tells whether the data type is part of -- a mutually-recursive group or not - genInfo :: Maybe (EP Id), -- Convert T <-> Tring - -- Some TyCons don't have it; - -- e.g. the TyCon for a Class dictionary, - -- and TyCons with unboxed arguments + hasGenerics :: Bool, -- True <=> generic to/from functions are available + -- (in the exports of the data type's source module) algTyConClass :: Maybe Class -- Just cl if this tycon came from a class declaration @@ -125,13 +123,13 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - tyConArgVrcs :: ArgVrcs, + argVrcs :: ArgVrcs, primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are -- boxed (represented by pointers). The PrimRep tells. isUnLifted :: Bool, -- Most primitive tycons are unlifted, -- but foreign-imported ones may not be - tyConExtName :: Maybe FastString + tyConExtName :: Maybe FastString -- Just xx for foreign-imported types } | TupleTyCon { @@ -143,7 +141,7 @@ data TyCon tyConBoxed :: Boxity, tyConTyVars :: [TyVar], dataCon :: DataCon, - genInfo :: Maybe (EP Id) -- Generic type and conv funs + hasGenerics :: Bool } | SynTyCon { @@ -156,7 +154,7 @@ data TyCon synTyConDefn :: Type, -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. - tyConArgVrcs :: ArgVrcs + argVrcs :: ArgVrcs } | KindCon { -- Type constructor at the kind level @@ -172,11 +170,10 @@ data TyCon } type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] + -- [] means "no information, assume the worst" data AlgTyConFlavour - = DataTyCon -- Data type - - | EnumTyCon -- Special sort of enumeration type + = DataTyCon Bool -- Data type; True <=> an enumeration type | NewTyCon Type -- Newtype, with its *ultimate* representation type -- By 'ultimate' I mean that the rep type is not itself @@ -201,10 +198,6 @@ data DataConDetails datacon | Unknown -- We're importing this data type from an hi-boot file -- and we don't know what its constructors are - | HasCons Int -- In a quest for compilation speed we have imported - -- only the number of constructors (to get return - -- conventions right) but not the constructors themselves - visibleDataCons (DataCons cs) = cs visibleDataCons other = [] \end{code} @@ -247,53 +240,41 @@ mkFunTyCon name kind tyConArity = 2 } -tyConGenInfo :: TyCon -> Maybe (EP Id) -tyConGenInfo (AlgTyCon { genInfo = info }) = info -tyConGenInfo (TupleTyCon { genInfo = info }) = info -tyConGenInfo other = Nothing - -tyConGenIds :: TyCon -> [Id] --- Returns the generic-programming Ids; these Ids need bindings -tyConGenIds tycon = case tyConGenInfo tycon of - Nothing -> [] - Just (EP from to) -> [from,to] - -- 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) -mkAlgTyCon name kind tyvars theta argvrcs cons sels flavour is_rec - gen_info +mkAlgTyCon name kind tyvars theta argvrcs cons sels flavour is_rec gen_info = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - tyConArgVrcs = argvrcs, - algTyConTheta = theta, - dataCons = cons, - selIds = sels, - algTyConClass = Nothing, - algTyConFlavour = flavour, - algTyConRec = is_rec, - genInfo = gen_info + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTyConTheta = theta, + dataCons = cons, + selIds = sels, + algTyConClass = Nothing, + algTyConFlavour = flavour, + algTyConRec = is_rec, + hasGenerics = gen_info } mkClassTyCon name kind tyvars argvrcs con clas flavour is_rec = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - tyConArgVrcs = argvrcs, - algTyConTheta = [], - dataCons = DataCons [con], - selIds = [], - algTyConClass = Just clas, - algTyConFlavour = flavour, - algTyConRec = is_rec, - genInfo = Nothing + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTyConTheta = [], + dataCons = DataCons [con], + selIds = [], + algTyConClass = Just clas, + algTyConFlavour = flavour, + algTyConRec = is_rec, + hasGenerics = False } @@ -306,7 +287,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info tyConBoxed = boxed, tyConTyVars = tyvars, dataCon = con, - genInfo = gen_info + hasGenerics = gen_info } -- Foreign-imported (.NET) type constructors are represented @@ -320,7 +301,7 @@ mkForeignTyCon name ext_name kind arity arg_vrcs tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - tyConArgVrcs = arg_vrcs, + argVrcs = arg_vrcs, primTyConRep = PtrRep, isUnLifted = False, tyConExtName = ext_name @@ -341,21 +322,21 @@ mkPrimTyCon' name kind arity arg_vrcs rep is_unlifted tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - tyConArgVrcs = arg_vrcs, + argVrcs = arg_vrcs, primTyConRep = rep, isUnLifted = is_unlifted, tyConExtName = Nothing } -mkSynTyCon name kind arity tyvars rhs argvrcs +mkSynTyCon name kind tyvars rhs argvrcs = SynTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, - tyConArity = arity, + tyConArity = length tyvars, tyConTyVars = tyvars, synTyConDefn = rhs, - tyConArgVrcs = argvrcs + argVrcs = argvrcs } setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} @@ -426,8 +407,8 @@ isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False isEnumerationTyCon :: TyCon -> Bool -isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTyConFlavour = DataTyCon is_enum}) = is_enum +isEnumerationTyCon other = False isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon @@ -450,6 +431,11 @@ isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True isRecursiveTyCon other = False +isHiBootTyCon :: TyCon -> Bool +-- Used for knot-tying in hi-boot files +isHiBootTyCon (AlgTyCon {dataCons = Unknown}) = True +isHiBootTyCon other = False + isForeignTyCon :: TyCon -> Bool -- isForeignTyCon identifies foreign-imported type constructors -- For the moment, they are primitive but lifted, but that may change @@ -458,6 +444,11 @@ isForeignTyCon other = False \end{code} \begin{code} +tyConHasGenerics :: TyCon -> Bool +tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg +tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg +tyConHasGenerics other = False -- Synonyms + tyConDataConDetails :: TyCon -> DataConDetails DataCon tyConDataConDetails (AlgTyCon {dataCons = cons}) = cons tyConDataConDetails (TupleTyCon {dataCon = con}) = DataCons [con] @@ -475,7 +466,6 @@ tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int tyConFamilySize (AlgTyCon {dataCons = DataCons cs}) = length cs -tyConFamilySize (AlgTyCon {dataCons = HasCons n}) = n tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) @@ -510,14 +500,16 @@ each tyvar, if available. See @calcAlgTyConArgVrcs@ for how this is actually computed (in another file). \begin{code} -tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs +tyConArgVrcs :: TyCon -> ArgVrcs +tyConArgVrcs tc = expectJust "tyConArgVrcs" (tyConArgVrcs_maybe tc) -tyConArgVrcs_maybe (FunTyCon {} ) = Just [(False,True),(True,False)] -tyConArgVrcs_maybe (AlgTyCon {tyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (PrimTyCon {tyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity }) = Just (replicate arity (True,False)) -tyConArgVrcs_maybe (SynTyCon {tyConArgVrcs = oi }) = Just oi -tyConArgVrcs_maybe _ = Nothing +tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs +tyConArgVrcs_maybe (FunTyCon {}) = Just [(False,True),(True,False)] +tyConArgVrcs_maybe (AlgTyCon {argVrcs = oi}) = Just oi +tyConArgVrcs_maybe (PrimTyCon {argVrcs = oi}) = Just oi +tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity}) = Just (replicate arity (True,False)) +tyConArgVrcs_maybe (SynTyCon {argVrcs = oi}) = Just oi +tyConArgVrcs_maybe _ = Nothing \end{code} \begin{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 96528379c4..333b589403 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -6,7 +6,8 @@ \begin{code} module Type ( -- re-exports from TypeRep: - Type, PredType, ThetaType, + TyThing(..), + Type, PredType(..), ThetaType, Kind, TyVarSubst, superKind, superBoxity, -- KX and BX respectively @@ -40,13 +41,14 @@ module Type ( applyTy, applyTys, isForAllTy, dropForAlls, -- Source types - SourceType(..), sourceTypeRep, mkPredTy, mkPredTys, + isPredTy, predTypeRep, mkPredTy, mkPredTys, -- Newtypes - splitNewType_maybe, + splitRecNewType_maybe, -- Lifting and boxity - isUnLiftedType, isUnboxedTupleType, isAlgType, isStrictType, isPrimitiveType, + isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType, + isStrictType, isStrictPred, -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, @@ -76,11 +78,10 @@ import TypeRep -- Other imports: -import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages import {-# SOURCE #-} Subst ( substTyWith ) -- friends: -import Var ( Id, TyVar, tyVarKind, tyVarName, setTyVarName ) +import Var ( TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet @@ -156,22 +157,19 @@ mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy getTyVar :: String -> Type -> TyVar -getTyVar msg (TyVarTy tv) = tv -getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p) -getTyVar msg (NoteTy _ t) = getTyVar msg t -getTyVar msg other = panic ("getTyVar: " ++ msg) - -getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t -getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p) -getTyVar_maybe other = Nothing +getTyVar msg ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> panic ("getTyVar: " ++ msg) isTyVarTy :: Type -> Bool -isTyVarTy (TyVarTy tv) = True -isTyVarTy (NoteTy _ ty) = isTyVarTy ty -isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p) -isTyVarTy other = False +isTyVarTy ty = isJust (getTyVar_maybe ty) + +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe (TyVarTy tv) = Just tv +getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t +getTyVar_maybe (PredTy p) = getTyVar_maybe (predTypeRep p) +getTyVar_maybe (NewTcApp tc tys) = getTyVar_maybe (newTypeRep tc tys) +getTyVar_maybe other = Nothing \end{code} @@ -184,10 +182,11 @@ invariant: use it. \begin{code} mkAppTy orig_ty1 orig_ty2 - = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * + = ASSERT2( not (isPredTy orig_ty1), crudePprType orig_ty1 ) -- Source types are of kind * mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ [orig_ty2]) mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2]) mk_app ty1 = AppTy orig_ty1 orig_ty2 -- We call mkGenTyConApp because the TyConApp could be an @@ -207,21 +206,26 @@ mkAppTys orig_ty1 [] = orig_ty1 -- returns to (Ratio Integer), which has needlessly lost -- the Rational part. mkAppTys orig_ty1 orig_tys2 - = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * + = ASSERT( not (isPredTy orig_ty1) ) -- Source types are of kind * mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ orig_tys2) mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) + -- Use mkTyConApp in case tc is (->) mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 splitAppTy_maybe :: Type -> Maybe (Type, Type) splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty -splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) +splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predTypeRep p) +splitAppTy_maybe (NewTcApp tc tys) = splitAppTy_maybe (newTypeRep tc tys) splitAppTy_maybe (TyConApp tc tys) = case snocView tys of Nothing -> Nothing - Just (tys',ty') -> Just (TyConApp tc tys', ty') + Just (tys',ty') -> Just (mkGenTyConApp tc tys', ty') + -- mkGenTyConApp just in case the tc is a newtype + splitAppTy_maybe other = Nothing splitAppTy :: Type -> (Type, Type) @@ -234,10 +238,12 @@ splitAppTys ty = split ty ty [] where split orig_ty (AppTy ty arg) args = split ty ty (arg:args) split orig_ty (NoteTy _ ty) args = split orig_ty ty args - split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args + split orig_ty (PredTy p) args = split orig_ty (predTypeRep p) args + split orig_ty (NewTcApp tc tc_args) args = split orig_ty (newTypeRep tc tc_args) args + split orig_ty (TyConApp tc tc_args) args = (mkGenTyConApp tc [], tc_args ++ args) + -- mkGenTyConApp just in case the tc is a newtype split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) - split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) split orig_ty ty args = (orig_ty, args) \end{code} @@ -257,51 +263,58 @@ isFunTy :: Type -> Bool isFunTy ty = isJust (splitFunTy_maybe ty) splitFunTy :: Type -> (Type, Type) -splitFunTy (FunTy arg res) = (arg, res) -splitFunTy (NoteTy _ ty) = splitFunTy ty -splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p) +splitFunTy (FunTy arg res) = (arg, res) +splitFunTy (NoteTy _ ty) = splitFunTy ty +splitFunTy (PredTy p) = splitFunTy (predTypeRep p) +splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys) +splitFunTy other = pprPanic "splitFunTy" (crudePprType other) splitFunTy_maybe :: Type -> Maybe (Type, Type) -splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty -splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p) -splitFunTy_maybe other = Nothing +splitFunTy_maybe (FunTy arg res) = Just (arg, res) +splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty +splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predTypeRep p) +splitFunTy_maybe (NewTcApp tc tys) = splitFunTy_maybe (newTypeRep tc tys) +splitFunTy_maybe other = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where - split args orig_ty (FunTy arg res) = split (arg:args) res res - split args orig_ty (NoteTy _ ty) = split args orig_ty ty - split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p) - split args orig_ty ty = (reverse args, orig_ty) + split args orig_ty (FunTy arg res) = split (arg:args) res res + split args orig_ty (NoteTy _ ty) = split args orig_ty ty + split args orig_ty (PredTy p) = split args orig_ty (predTypeRep p) + split args orig_ty (NewTcApp tc tys) = split args orig_ty (newTypeRep tc tys) + split args orig_ty ty = (reverse args, orig_ty) zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty where - split acc [] nty ty = (reverse acc, nty) - split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res - split acc xs nty (NoteTy _ ty) = split acc xs nty ty - split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p) - split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) + split acc [] nty ty = (reverse acc, nty) + split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res + split acc xs nty (NoteTy _ ty) = split acc xs nty ty + split acc xs nty (PredTy p) = split acc xs nty (predTypeRep p) + split acc xs nty (NewTcApp tc tys) = split acc xs nty (newTypeRep tc tys) + split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> crudePprType orig_ty) funResultTy :: Type -> Type -funResultTy (FunTy arg res) = res -funResultTy (NoteTy _ ty) = funResultTy ty -funResultTy (SourceTy p) = funResultTy (sourceTypeRep p) -funResultTy ty = pprPanic "funResultTy" (pprType ty) +funResultTy (FunTy arg res) = res +funResultTy (NoteTy _ ty) = funResultTy ty +funResultTy (PredTy p) = funResultTy (predTypeRep p) +funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys) +funResultTy ty = pprPanic "funResultTy" (crudePprType ty) funArgTy :: Type -> Type -funArgTy (FunTy arg res) = arg -funArgTy (NoteTy _ ty) = funArgTy ty -funArgTy (SourceTy p) = funArgTy (sourceTypeRep p) -funArgTy ty = pprPanic "funArgTy" (pprType ty) +funArgTy (FunTy arg res) = arg +funArgTy (NoteTy _ ty) = funArgTy ty +funArgTy (PredTy p) = funArgTy (predTypeRep p) +funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys) +funArgTy ty = pprPanic "funArgTy" (crudePprType ty) \end{code} --------------------------------------------------------------------- TyConApp ~~~~~~~~ -@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy, +@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy, as apppropriate. \begin{code} @@ -316,18 +329,15 @@ mkTyConApp tycon tys | isFunTyCon tycon, [ty1,ty2] <- tys = FunTy ty1 ty2 - | isNewTyCon tycon, -- A saturated newtype application; - not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them) - tys `lengthIs` tyConArity tycon -- use the SourceType form - = SourceTy (NType tycon tys) + | isNewTyCon tycon + = NewTcApp tycon tys | otherwise = ASSERT(not (isSynTyCon tycon)) TyConApp tycon tys mkTyConTy :: TyCon -> Type -mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) - TyConApp tycon [] +mkTyConTy tycon = mkTyConApp tycon [] -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications @@ -342,13 +352,14 @@ tyConAppArgs ty = snd (splitTyConApp ty) splitTyConApp :: Type -> (TyCon, [Type]) splitTyConApp ty = case splitTyConApp_maybe ty of Just stuff -> stuff - Nothing -> pprPanic "splitTyConApp" (pprType ty) + Nothing -> pprPanic "splitTyConApp" (crudePprType ty) splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty -splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p) +splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predTypeRep p) +splitTyConApp_maybe (NewTcApp tc tys) = splitTyConApp_maybe (newTypeRep tc tys) splitTyConApp_maybe other = Nothing \end{code} @@ -408,17 +419,14 @@ repType looks through (e) [recursive] newtypes It's useful in the back end. -Remember, non-recursive newtypes get expanded as part of the SourceTy case, -but recursive ones are represented by TyConApps and have to be expanded -by steam. - \begin{code} repType :: Type -> Type +-- Only applied to types of kind *; hence tycons are saturated repType (ForAllTy _ ty) = repType ty repType (NoteTy _ ty) = repType ty -repType (SourceTy p) = repType (sourceTypeRep p) -repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc - = repType (newTypeRep tc tys) +repType (PredTy p) = repType (predTypeRep p) +repType (NewTcApp tc tys) = ASSERT( tys `lengthIs` tyConArity tc ) + repType (new_type_rep tc tys) repType ty = ty @@ -428,6 +436,7 @@ typePrimRep ty = case repType ty of FunTy _ _ -> PtrRep AppTy _ _ -> PtrRep -- ?? TyVarTy _ -> PtrRep + other -> pprPanic "typePrimRep" (crudePprType ty) \end{code} @@ -453,17 +462,19 @@ splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) splitForAllTy_maybe ty = splitFAT_m ty where splitFAT_m (NoteTy _ ty) = splitFAT_m ty - splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p) + splitFAT_m (PredTy p) = splitFAT_m (predTypeRep p) + splitFAT_m (NewTcApp tc tys) = splitFAT_m (newTypeRep tc tys) splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) splitFAT_m _ = Nothing splitForAllTys :: Type -> ([TyVar], Type) splitForAllTys ty = split ty ty [] where - split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs - split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs + split orig_ty (PredTy p) tvs = split orig_ty (predTypeRep p) tvs + split orig_ty (NewTcApp tc tys) tvs = split orig_ty (newTypeRep tc tys) tvs + split orig_ty t tvs = (reverse tvs, orig_ty) dropForAlls :: Type -> Type dropForAlls ty = snd (splitForAllTys ty) @@ -481,10 +492,11 @@ the expression. \begin{code} applyTy :: Type -> Type -> Type -applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg -applyTy (NoteTy _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty -applyTy other arg = panic "applyTy" +applyTy (PredTy p) arg = applyTy (predTypeRep p) arg +applyTy (NewTcApp tc tys) arg = applyTy (newTypeRep tc tys) arg +applyTy (NoteTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty +applyTy other arg = panic "applyTy" applyTys :: Type -> [Type] -> Type -- This function is interesting because @@ -506,7 +518,7 @@ applyTys orig_fun_ty arg_tys = substTyWith (take n_args tvs) arg_tys (mkForAllTys (drop n_args tvs) rho_ty) | otherwise -- Too many type args - = ASSERT2( n_tvs > 0, pprType orig_fun_ty ) -- Zero case gives infnite loop! + = ASSERT2( n_tvs > 0, crudePprType orig_fun_ty ) -- Zero case gives infnite loop! applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty) (drop n_tvs arg_tys) where @@ -527,46 +539,75 @@ concerned, but which has low-level representation as far as the back end is conc Source types are always lifted. -The key function is sourceTypeRep which gives the representation of a source type: +The key function is predTypeRep which gives the representation of a source type: \begin{code} mkPredTy :: PredType -> Type -mkPredTy pred = SourceTy pred +mkPredTy pred = PredTy pred mkPredTys :: ThetaType -> [Type] -mkPredTys preds = map SourceTy preds - -sourceTypeRep :: SourceType -> Type --- Convert a predicate to its "representation type"; --- the type of evidence for that predicate, which is actually passed at runtime -sourceTypeRep (IParam _ ty) = ty -sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys - -- Note the mkTyConApp; the classTyCon might be a newtype! -sourceTypeRep (NType tc tys) = newTypeRep tc tys - -- ToDo: Consider caching this substitution in a NType - -isSourceTy :: Type -> Bool -isSourceTy (NoteTy _ ty) = isSourceTy ty -isSourceTy (SourceTy sty) = True -isSourceTy _ = False +mkPredTys preds = map PredTy preds + +predTypeRep :: PredType -> Type +-- Convert a PredType to its "representation type"; +-- the post-type-checking type used by all the Core passes of GHC. +predTypeRep (IParam _ ty) = ty +predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys + -- Result might be a NewTcApp, but the consumer will + -- look through that too if necessary + +isPredTy :: Type -> Bool +isPredTy (NoteTy _ ty) = isPredTy ty +isPredTy (PredTy sty) = True +isPredTy _ = False +\end{code} -splitNewType_maybe :: Type -> Maybe Type --- Newtypes that are recursive are reprsented by TyConApp, just --- as they always were. Occasionally we want to find their representation type. --- NB: remember that in this module, non-recursive newtypes are transparent +%************************************************************************ +%* * + NewTypes +%* * +%************************************************************************ -splitNewType_maybe ty - = case splitTyConApp_maybe ty of - Just (tc,tys) | isNewTyCon tc -> ASSERT( tys `lengthIs` tyConArity tc ) - -- The assert should hold because repType should - -- only be applied to *types* (of kind *) - Just (newTypeRep tc tys) - other -> Nothing +\begin{code} +splitRecNewType_maybe :: Type -> Maybe Type +-- Newtypes are always represented by a NewTcApp +-- Sometimes we want to look through a recursive newtype, and that's what happens here +-- Only applied to types of kind *, hence the newtype is always saturated +splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty +splitRecNewType_maybe (NewTcApp tc tys) + | isRecursiveTyCon tc + = ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc ) + -- The assert should hold because repType should + -- only be applied to *types* (of kind *) + Just (new_type_rep tc tys) +splitRecNewType_maybe other = Nothing +----------------------------- +newTypeRep :: TyCon -> [Type] -> Type -- A local helper function (not exported) -newTypeRep new_tycon tys = case newTyConRep new_tycon of - (tvs, rep_ty) -> substTyWith tvs tys rep_ty +-- Expands a newtype application to +-- *either* a vanilla TyConApp (recursive newtype, or non-saturated) +-- *or* the newtype representation (otherwise) +-- Either way, the result is not a NewTcApp +-- +-- NB: the returned TyConApp is always deconstructed immediately by the +-- caller... a TyConApp with a newtype type constructor never lives +-- in an ordinary type +newTypeRep tc tys + | not (isRecursiveTyCon tc), -- Not recursive and saturated + tys `lengthIs` tyConArity tc -- treat as equivalent to expansion + = new_type_rep tc tys + | otherwise + = TyConApp tc tys + -- ToDo: Consider caching this substitution in a NType + +---------------------------- +-- new_type_rep doesn't ask any questions: +-- it just expands newtype, whether recursive or not +new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) + case newTyConRep new_tycon of + (tvs, rep_ty) -> substTyWith tvs tys rep_ty \end{code} @@ -584,8 +625,9 @@ typeKind :: Type -> Kind typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys +typeKind (NewTcApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys typeKind (NoteTy _ ty) = typeKind ty -typeKind (SourceTy _) = liftedTypeKind -- Predicates are always +typeKind (PredTy _) = liftedTypeKind -- Predicates are always -- represented by lifted types typeKind (AppTy fun arg) = funResultTy (typeKind fun) @@ -613,9 +655,10 @@ typeKind (ForAllTy tv ty) = typeKind ty tyVarsOfType :: Type -> TyVarSet tyVarsOfType (TyVarTy tv) = unitVarSet tv tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys +tyVarsOfType (NewTcApp tycon tys) = tyVarsOfTypes tys tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty2 -- See note [Syn] below -tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty +tyVarsOfType (PredTy sty) = tyVarsOfPred sty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar @@ -639,15 +682,11 @@ tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred = tyVarsOfSourceType -- Just a subtype - -tyVarsOfSourceType :: SourceType -> TyVarSet -tyVarsOfSourceType (IParam _ ty) = tyVarsOfType ty -tyVarsOfSourceType (ClassP _ tys) = tyVarsOfTypes tys -tyVarsOfSourceType (NType _ tys) = tyVarsOfTypes tys +tyVarsOfPred (IParam _ ty) = tyVarsOfType ty +tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys tyVarsOfTheta :: ThetaType -> TyVarSet -tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet +tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet -- Add a Note with the free tyvars to the top of the type addFreeTyVars :: Type -> Type @@ -705,8 +744,10 @@ tidyType env@(tidy_env, subst) ty Just tv' -> TyVarTy tv' go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args + go (NewTcApp tycon tys) = let args = map go tys + in args `seqList` NewTcApp tycon args go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty) - go (SourceTy sty) = SourceTy (tidySourceType env sty) + go (PredTy sty) = PredTy (tidyPred env sty) go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) @@ -718,13 +759,9 @@ tidyType env@(tidy_env, subst) ty tidyTypes env tys = map (tidyType env) tys -tidyPred :: TidyEnv -> SourceType -> SourceType -tidyPred = tidySourceType - -tidySourceType :: TidyEnv -> SourceType -> SourceType -tidySourceType env (IParam n ty) = IParam n (tidyType env ty) -tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys) -tidySourceType env (NType tc tys) = NType tc (tidyTypes env tys) +tidyPred :: TidyEnv -> PredType -> PredType +tidyPred env (IParam n ty) = IParam n (tidyType env ty) +tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys) \end{code} @@ -761,11 +798,12 @@ isUnLiftedType :: Type -> Bool -- They are pretty bogus types, mind you. It would be better never to -- construct them -isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty -isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty -isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc -isUnLiftedType (SourceTy _) = False -- All source types are lifted -isUnLiftedType other = False +isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty +isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty +isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc +isUnLiftedType (PredTy _) = False -- All source types are lifted +isUnLiftedType (NewTcApp tc tys) = isUnLiftedType (newTypeRep tc tys) +isUnLiftedType other = False isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case splitTyConApp_maybe ty of @@ -788,15 +826,19 @@ this function should be in TcType, but isStrictType is used by DataCon, which is below TcType in the hierarchy, so it's convenient to put it here. \begin{code} -isStrictType (ForAllTy tv ty) = isStrictType ty -isStrictType (NoteTy _ ty) = isStrictType ty -isStrictType (TyConApp tc _) = isUnLiftedTyCon tc -isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) +isStrictType (ForAllTy tv ty) = isStrictType ty +isStrictType (NoteTy _ ty) = isStrictType ty +isStrictType (TyConApp tc _) = isUnLiftedTyCon tc +isStrictType (NewTcApp tc tys) = isStrictType (newTypeRep tc tys) +isStrictType (PredTy pred) = isStrictPred pred +isStrictType other = False + +isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) +isStrictPred other = False -- We may be strict in dictionary types, but only if it -- has more than one component. -- [Being strict in a single-component dictionary risks -- poking the dictionary component, which is wrong.] -isStrictType other = False \end{code} \begin{code} @@ -823,8 +865,9 @@ seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 seqType (NoteTy note t2) = seqNote note `seq` seqType t2 -seqType (SourceTy p) = seqPred p +seqType (PredTy p) = seqPred p seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (NewTcApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty seqTypes :: [Type] -> () @@ -835,9 +878,8 @@ seqNote :: TyNote -> () seqNote (SynNote ty) = seqType ty seqNote (FTVNote set) = sizeUniqSet set `seq` () -seqPred :: SourceType -> () +seqPred :: PredType -> () seqPred (ClassP c tys) = c `seq` seqTypes tys -seqPred (NType tc tys) = tc `seq` seqTypes tys seqPred (IParam n ty) = n `seq` seqType ty \end{code} @@ -869,9 +911,31 @@ eqKind = eqType -- No worries about looking eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2 eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2 --- Look through SourceTy. This is where the looping danger comes from -eq_ty env (SourceTy sty1) t2 = eq_ty env (sourceTypeRep sty1) t2 -eq_ty env t1 (SourceTy sty2) = eq_ty env t1 (sourceTypeRep sty2) +-- Look through PredTy and NewTcApp. This is where the looping danger comes from. +-- We don't bother to check for the PredType/PredType case, no good reason +-- Hmm: maybe there is a good reason: see the notes below about newtypes +eq_ty env (PredTy sty1) t2 = eq_ty env (predTypeRep sty1) t2 +eq_ty env t1 (PredTy sty2) = eq_ty env t1 (predTypeRep sty2) + +-- NB: we *cannot* short-cut the newtype comparison thus: +-- eq_ty env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) +-- | (tc1 == tc2) = (eq_tys env tys1 tys2) +-- +-- Consider: +-- newtype T a = MkT [a] +-- newtype Foo m = MkFoo (forall a. m a -> Int) +-- w1 :: Foo [] +-- w1 = ... +-- +-- w2 :: Foo T +-- w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) +-- +-- We end up with w2 = w1; so we need that Foo T = Foo [] +-- but we can only expand saturated newtypes, so just comparing +-- T with [] won't do. + +eq_ty env (NewTcApp tc1 tys1) t2 = eq_ty env (newTypeRep tc1 tys1) t2 +eq_ty env t1 (NewTcApp tc2 tys2) = eq_ty env t1 (newTypeRep tc2 tys2) -- The rest is plain sailing eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of diff --git a/ghc/compiler/types/TypeRep.hi-boot-6 b/ghc/compiler/types/TypeRep.hi-boot-6 index 5fdbdf5bf2..c66df6f552 100644 --- a/ghc/compiler/types/TypeRep.hi-boot-6 +++ b/ghc/compiler/types/TypeRep.hi-boot-6 @@ -2,6 +2,8 @@ module TypeRep where data Type data SourceType +data TyThing + type PredType = SourceType type Kind = Type type SuperKind = Type diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 7447e88fd6..1c74dc1b3e 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -5,10 +5,11 @@ \begin{code} module TypeRep ( + TyThing(..), Type(..), TyNote(..), -- Representation visible - SourceType(..), -- to friends + PredType(..), -- to friends - Kind, PredType, ThetaType, -- Synonyms + Kind, ThetaType, -- Synonyms TyVarSubst, superKind, superBoxity, -- KX and BX respectively @@ -19,25 +20,32 @@ module TypeRep ( mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX funTyCon +#ifdef DEBUG + , crudePprType +#endif ) where #include "HsVersions.h" +import {-# SOURCE #-} DataCon( DataCon ) + -- friends: -import Var ( TyVar ) +import Var ( Id, TyVar, tyVarKind ) import VarEnv ( TyVarEnv ) import VarSet ( TyVarSet ) -import Name ( Name ) +import Name ( Name, mkWiredInName, mkInternalName ) +import OccName ( mkOccFS, mkKindOccFS, tcName ) import BasicTypes ( IPName ) -import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon ) +import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon ) import Class ( Class ) -import Binary -- others -import PrelNames ( superKindName, superBoxityName, liftedConName, - unliftedConName, typeConName, openKindConName, - funTyConName +import PrelNames ( gHC_PRIM, kindConKey, boxityConKey, liftedConKey, + unliftedConKey, typeConKey, anyBoxConKey, + funTyConKey ) +import SrcLoc ( noSrcLoc ) +import Outputable \end{code} %************************************************************************ @@ -109,22 +117,28 @@ Here the 'implicit expansion' we get from treating P and Q as transparent would give rise to infinite types, which in turn makes eqType diverge. Similarly splitForAllTys and splitFunTys can get into a loop. -Solution: for recursive newtypes use a coerce, and treat the newtype -and its representation as distinct right through the compiler. That's -what you get if you use recursive newtypes. (They are rare, so who -cares if they are a tiny bit less efficient.) +Solution: + +* Newtypes are always represented using NewTcApp, never as TyConApp. -So: non-recursive newtypes are represented using a SourceTy (see below) - recursive newtypes are represented using a TyConApp +* For non-recursive newtypes, P, treat P just like a type synonym after + type-checking is done; i.e. it's opaque during type checking (functions + from TcType) but transparent afterwards (functions from Type). + "Treat P as a type synonym" means "all functions expand NewTcApps + on the fly". -The TyCon still says "I'm a newtype", but we do not represent the -newtype application as a SourceType; instead as a TyConApp. + Applications of the data constructor P simply vanish: + P x = x + +* For recursive newtypes Q, treat the Q and its representation as + distinct right through the compiler. Applications of the data consructor + use a coerce: + Q = \(x::Q->Q). coerce Q x + They are rare, so who cares if they are a tiny bit less efficient. -NOTE: currently [March 02] we regard a newtype as 'recursive' if it's in a -mutually recursive group. That's a bit conservative: only if there's a loop -consisting only of newtypes do we need consider it as recursive. But it's -not so easy to discover that, and the situation isn't that common. +The typechecker (TcTyDecls) identifies enough type construtors as 'recursive' +to cut all loops. The other members of the loop may be marked 'non-recursive'. %************************************************************************ @@ -152,6 +166,19 @@ data Type -- synonyms have their own constructors, below. [Type] -- Might not be saturated. + | NewTcApp -- Application of a NewType TyCon. All newtype applications + TyCon -- show up like this until they are fed through newTypeRep, + -- which returns + -- * an ordinary TyConApp for non-saturated, + -- or recursive newtypes + -- + -- * the representation type of the newtype for satuarted, + -- non-recursive ones + -- [But the result of a call to newTypeRep is always consumed + -- immediately; it never lives on in another type. So in any + -- type, newtypes are always represented with NewTcApp.] + [Type] -- Might not be saturated. + | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2] Type Type @@ -160,8 +187,8 @@ data Type TyVar Type - | SourceTy -- A high level source type - SourceType -- ...can be expanded to a representation type... + | PredTy -- A high level source type + PredType -- ...can be expanded to a representation type... | NoteTy -- A type with a note attached TyNote @@ -173,24 +200,20 @@ data TyNote | SynNote Type -- Used for type synonyms -- The Type is always a TyConApp, and is the un-expanded form. -- The type to which the note is attached is the expanded form. - \end{code} ------------------------------------- Source types A type of the form - SourceTy sty -represents a value whose type is the Haskell source type sty. + PredTy p +represents a value whose type is the Haskell predicate p, +where a predicate is what occurs before the '=>' in a Haskell type. It can be expanded into its representation, but: * The type checker must treat it as opaque * The rest of the compiler treats it as transparent -There are two main uses - a) Haskell predicates - b) newtypes - Consider these examples: f :: (Eq a) => a -> Int g :: (?x :: Int -> Int) => a -> Int @@ -200,13 +223,10 @@ Here the "Eq a" and "?x :: Int -> Int" and "r\l" are all called *predicates* Predicates are represented inside GHC by PredType: \begin{code} -data SourceType +data PredType = ClassP Class [Type] -- Class predicate | IParam (IPName Name) Type -- Implicit parameter - | NType TyCon [Type] -- A *saturated*, *non-recursive* newtype application - -- [See notes at top about newtypes] -type PredType = SourceType -- A subtype for predicates type ThetaType = [PredType] \end{code} @@ -274,6 +294,20 @@ Define KX, the type of a kind BX, the type of a boxity \begin{code} +superKindName = kindQual FSLIT("KX") kindConKey +superBoxityName = kindQual FSLIT("BX") boxityConKey +liftedConName = kindQual FSLIT("*") liftedConKey +unliftedConName = kindQual FSLIT("#") unliftedConKey +openKindConName = kindQual FSLIT("?") anyBoxConKey +typeConName = kindQual FSLIT("Type") typeConKey + +kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) noSrcLoc + -- Kinds are not z-encoded in interface file, hence mkKindOccFS + -- And they don't come from any particular module; indeed we always + -- want to print them unqualified. Hence the InternalName. +\end{code} + +\begin{code} superKind :: SuperKind -- KX, the type of all kinds superKind = TyConApp (mkSuperKindCon superKindName) [] @@ -320,28 +354,25 @@ mkArrowKinds :: [Kind] -> Kind -> Kind mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds \end{code} ------------------------------------------------------------------------------ -Binary kinds for interface files + +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. \begin{code} -instance Binary Kind where - put_ bh k@(TyConApp tc []) - | tc == openKindCon = putByte bh 0 - put_ bh k@(TyConApp tc [TyConApp bc _]) - | tc == typeCon && bc == liftedBoxityCon = putByte bh 2 - | tc == typeCon && bc == unliftedBoxityCon = putByte bh 3 - put_ bh (FunTy f a) = do putByte bh 4; put_ bh f; put_ bh a - put_ bh _ = error "Binary.put(Kind): strange-looking Kind" - - get bh = do - b <- getByte bh - case b of - 0 -> return openTypeKind - 2 -> return liftedTypeKind - 3 -> return unliftedTypeKind - _ -> do f <- get bh; a <- get bh; return (FunTy f a) +data TyThing = AnId Id + | ADataCon DataCon + | ATyCon TyCon + | AClass Class \end{code} + %************************************************************************ %* * \subsection{Wired-in type constructors @@ -359,6 +390,45 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind -- expected/actual stuff in the unifier does not go contra-variant, whereas -- the kind sub-typing does. Sigh. It really only matters if you use (->) in -- a prefix way, thus: (->) Int# Int#. And this is unusual. + +funTyConName = mkWiredInName gHC_PRIM + (mkOccFS tcName FSLIT("(->)")) + funTyConKey + Nothing -- No parent object + (ATyCon funTyCon) -- Relevant TyCon \end{code} + +%************************************************************************ +%* * + Crude printing + For debug purposes, we may want to print a type directly +%* * +%************************************************************************ + +\begin{code} +#ifdef DEBUG +crudePprType :: Type -> SDoc +crudePprType (TyVarTy tv) = ppr tv +crudePprType (AppTy t1 t2) = crudePprType t1 <+> (parens (crudePprType t2)) +crudePprType (FunTy t1 t2) = crudePprType t1 <+> (parens (crudePprType t2)) +crudePprType (TyConApp tc tys) = ppr_tc_app (ppr tc <> pp_nt tc) tys +crudePprType (NewTcApp tc tys) = ptext SLIT("<nt>") <+> ppr_tc_app (ppr tc <> pp_nt tc) tys +crudePprType (ForAllTy tv ty) = sep [ptext SLIT("forall") <+> + parens (ppr tv <+> crudePprType (tyVarKind tv)) <> dot, + crudePprType ty] +crudePprType (PredTy st) = braces (crudePprPredTy st) +crudePprType (NoteTy (SynNote ty1) ty2) = crudePprType ty1 +crudePprType (NoteTy other ty) = crudePprType ty + +crudePprPredTy (ClassP cls tys) = ppr_tc_app (ppr cls) tys +crudePprPredTy (IParam ip ty) = ppr ip <> dcolon <> crudePprType ty + +ppr_tc_app :: SDoc -> [Type] -> SDoc +ppr_tc_app tc tys = tc <+> sep (map (parens . crudePprType) tys) + +pp_nt tc | isNewTyCon tc = ptext SLIT("(nt)") + | otherwise = empty +#endif +\end{code}
\ No newline at end of file diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs deleted file mode 100644 index 9b6ad508aa..0000000000 --- a/ghc/compiler/types/Variance.lhs +++ /dev/null @@ -1,190 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 -% -\section[Variance]{Variance in @Type@ and @TyCon@} - -\begin{code} -module Variance( - calcTyConArgVrcs, - tyVarVrc - ) where - -#include "HsVersions.h" - -import TypeRep ( Type(..), TyNote(..) ) -- friend -import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars, - tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon ) -import DataCon ( dataConRepArgTys ) - -import FiniteMap -import Var ( TyVar ) -import VarSet -import Maybes ( expectJust ) -import Maybe ( isNothing ) -import Outputable -\end{code} - - -Computing the tyConArgVrcs info -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each -tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed -separately. Note that this is information about occurrences of type -variables, not usages of term variables. - -The function @calcTyConArgVrcs@ must be passed a list of *algebraic or -syntycons only* such that all tycons referred to (by mutual recursion) -appear in the list. The fixpointing will be done on this set of -tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to -be (knot-tyingly?) stuck back into the appropriate fields. - -\begin{code} -calcTyConArgVrcs :: [TyCon] -> FiniteMap TyCon ArgVrcs - -calcTyConArgVrcs tycons - = tcaoFix initial_oi - where - - initial_oi :: FiniteMap TyCon ArgVrcs - initial_oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons - initial tc = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then - -- make pessimistic assumption (and warn) - abstractVrcs tc - else - replicate (tyConArity tc) (False,False) - - tcaoFix :: FiniteMap TyCon ArgVrcs -- initial ArgVrcs per tycon - -> FiniteMap TyCon ArgVrcs -- fixpointed ArgVrcs per tycon - - tcaoFix oi = let (changed,oi') = foldFM (\ tc pms - (changed,oi') - -> let pms' = tcaoIter oi' tc -- seq not simult - in (changed || (pms /= pms'), - addToFM oi' tc pms')) - (False,oi) -- seq not simult for faster fixpting - oi - in if changed - then tcaoFix oi' - else oi' - - tcaoIter :: FiniteMap TyCon ArgVrcs -- reference ArgVrcs (initial) - -> TyCon -- tycon to update - -> ArgVrcs -- new ArgVrcs for tycon - - tcaoIter oi tc | isAlgTyCon tc - = if null data_cons then - -- Abstract types get uninformative variances - abstractVrcs tc - else - map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys) - vs - where - data_cons = tyConDataCons tc - vs = tyConTyVars tc - argtys = concatMap dataConRepArgTys data_cons - myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $ - tyConArgVrcs_maybe tc) - tc - -- we use the already-computed result for tycons not in this SCC - - tcaoIter oi tc | isSynTyCon tc - = let (tyvs,ty) = getSynTyConDefn tc - myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Syn)" $ - tyConArgVrcs_maybe tc) - tc - -- we use the already-computed result for tycons not in this SCC - in map (\v -> vrcInTy myfao v ty) tyvs - - -abstractVrcs :: TyCon -> ArgVrcs -abstractVrcs tc = -#ifdef DEBUG - pprTrace "Vrc: abstract tycon:" (ppr tc) $ -#endif - replicate (tyConArity tc) (True,True) -\end{code} - - -Variance of tyvars in a type -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A general variance-check function. We pass a function for determining -the @ArgVrc@s of a tycon; when fixpointing this refers to the current -value; otherwise this should be looked up from the tycon's own -tyConArgVrcs. - -\begin{code} -vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion) - -> TyVar -- tyvar to check Vrcs of - -> Type -- type to check for occ in - -> (Bool,Bool) -- (occurs positively, occurs negatively) - -vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty - -- SynTyCon doesn't neccessarily have vrcInfo at this point, - -- so don't try and use it - -vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv - then vrcInTy fao v ty - else (False,False) - -- note that ftv cannot be calculated as occPos||occNeg, - -- since if a tyvar occurs only as unused tyconarg, - -- occPos==occNeg==False, but ftv=True - -vrcInTy fao v (TyVarTy v') = if v==v' - then (True,False) - else (False,False) - -vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False) - then (True,True) - else vrcInTy fao v ty1 - -- ty1 is probably unknown (or it would have been beta-reduced); - -- hence if v occurs in ty2 at all then it could occur with - -- either variance. Otherwise it occurs as it does in ty1. - -vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1) - `orVrc` - vrcInTy fao v ty2 - -vrcInTy fao v (ForAllTy v' ty) = if v==v' - then (False,False) - else vrcInTy fao v ty - -vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys - pms2 = fao tc - in orVrcs (zipWith timesVrc pms1 pms2) -\end{code} - - -External entry point: assumes tyconargvrcs already computed. - -\begin{code} -tyVarVrc :: TyVar -- tyvar to check Vrc of - -> Type -- type to check for occ in - -> (Bool,Bool) -- (occurs positively, occurs negatively) - -tyVarVrc = vrcInTy (expectJust "tyVarVrcs" . tyConArgVrcs_maybe) -\end{code} - - -Variance algebra -~~~~~~~~~~~~~~~~ - -\begin{code} -orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) -orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2) - -orVrcs :: [(Bool,Bool)] -> (Bool,Bool) -orVrcs = foldl orVrc (False,False) - -negVrc :: (Bool,Bool) -> (Bool,Bool) -negVrc (p1,m1) = (m1,p1) - -anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool) -anyVrc p as = foldl (\ pm a -> pm `orVrc` p a) - (False,False) as - -timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) -timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2, - p1 && m2 || m1 && p2) -\end{code} diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs index 690fb56614..90c7e53a7e 100644 --- a/ghc/compiler/utils/Binary.hs +++ b/ghc/compiler/utils/Binary.hs @@ -19,8 +19,6 @@ module Binary openBinMem, -- closeBin, - getUserData, - seekBin, tellBin, castBin, @@ -44,7 +42,7 @@ module Binary putByteArray, getBinFileWithDict, -- :: Binary a => FilePath -> IO a - putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO () + putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO () ) where @@ -53,7 +51,6 @@ module Binary -- The *host* architecture version: #include "MachDeps.h" -import {-# SOURCE #-} Module import FastString import Unique import Panic @@ -143,9 +140,13 @@ eofErrorType = EOF type BinArray = IOUArray Int Word8 #endif +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + data BinHandle = BinMem { -- binary data stored in an unboxed array - state :: BinHandleState, -- sigh, need parameterized modules :-) + bh_usr :: UserData, -- sigh, need parameterized modules :-) off_r :: !FastMutInt, -- the current offset sz_r :: !FastMutInt, -- size of the array (cached) arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) @@ -154,7 +155,7 @@ data BinHandle -- the binary data to a file. | BinIO { -- binary data stored in a file - state :: BinHandleState, + bh_usr :: UserData, off_r :: !FastMutInt, -- the current offset (cached) hdl :: !IO.Handle -- the file handle (must be seekable) } @@ -162,12 +163,27 @@ data BinHandle -- to call repeatedly. If anyone else is modifying this Handle -- at the same time, we'll be screwed. +getUserData :: BinHandle -> UserData +getUserData bh = bh_usr bh + +setUserData :: BinHandle -> UserData -> BinHandle +setUserData bh us = bh { bh_usr = us } + + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + newtype Bin a = BinPtr Int deriving (Eq, Ord, Show, Bounded) castBin :: Bin a -> Bin b castBin (BinPtr i) = BinPtr i +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + class Binary a where put_ :: BinHandle -> a -> IO () put :: BinHandle -> a -> IO (Bin a) @@ -186,17 +202,16 @@ getAt :: Binary a => BinHandle -> Bin a -> IO a getAt bh p = do seekBin bh p; get bh openBinIO_ :: IO.Handle -> IO BinHandle -openBinIO_ h = openBinIO h noBinHandleUserData +openBinIO_ h = openBinIO h -openBinIO :: IO.Handle -> Module -> IO BinHandle -openBinIO h mod = do +openBinIO :: IO.Handle -> IO BinHandle +openBinIO h = do r <- newFastMutInt writeFastMutInt r 0 - state <- newWriteState mod - return (BinIO state r h) + return (BinIO noUserData r h) -openBinMem :: Int -> Module -> IO BinHandle -openBinMem size mod +openBinMem :: Int -> IO BinHandle +openBinMem size | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- newArray_ (0,size-1) @@ -205,13 +220,7 @@ openBinMem size mod writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r size - state <- newWriteState mod - return (BinMem state ix_r sz_r arr_r) - -noBinHandleUserData = error "Binary.BinHandle: no user data" - -getUserData :: BinHandle -> BinHandleState -getUserData bh = state bh + return (BinMem noUserData ix_r sz_r arr_r) tellBin :: BinHandle -> IO (Bin a) tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) @@ -250,6 +259,7 @@ writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do hClose h readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State readBinMem filename = do h <- openBinaryFile filename ReadMode filesize' <- hFileSize h @@ -264,7 +274,7 @@ readBinMem filename = do writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r filesize - return (BinMem initReadState ix_r sz_r arr_r) + return (BinMem noUserData ix_r sz_r arr_r) -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () @@ -596,66 +606,110 @@ lazyGet bh = do seekBin bh p -- skip over the object for now return a --- ----------------------------------------------------------------------------- --- BinHandleState - -type BinHandleState = - (Module, - IORef Int, - IORef (UniqFM (Int,FastString)), - Array Int FastString) - -initReadState :: BinHandleState -initReadState = (undef, undef, undef, undef) - -newWriteState :: Module -> IO BinHandleState -newWriteState m = do - j_r <- newIORef 0 - out_r <- newIORef emptyUFM - return (m,j_r,out_r,undef) - -undef = error "Binary.BinHandleState" +-- -------------------------------------------------------------- +-- Main wrappers: getBinFileWithDict, putBinFileWithDict +-- +-- This layer is built on top of the stuff above, +-- and should not know anything about BinHandles +-- -------------------------------------------------------------- --- ----------------------------------------------------------------------------- --- FastString binary interface +initBinMemSize = (1024*1024) :: Int +binaryInterfaceMagic = 0x1face :: Word32 getBinFileWithDict :: Binary a => FilePath -> IO a getBinFileWithDict file_path = do bh <- Binary.readBinMem file_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) magic <- get bh when (magic /= binaryInterfaceMagic) $ throwDyn (ProgramError ( "magic number mismatch: old/corrupt interface file?")) - dict_p <- Binary.get bh -- get the dictionary ptr - data_p <- tellBin bh + + -- Read the dictionary + -- The next word in the file is a pointer to where the dictionary is + -- (probably at the end of the file) + dict_p <- Binary.get bh -- Get the dictionary ptr + data_p <- tellBin bh -- Remember where we are now seekBin bh dict_p dict <- getDictionary bh - seekBin bh data_p - let (mod, j_r, out_r, _) = state bh - get bh{ state = (mod,j_r,out_r,dict) } - -initBinMemSize = (1024*1024) :: Int + seekBin bh data_p -- Back to where we were before -binaryInterfaceMagic = 0x1face :: Word32 + -- Initialise the user-data field of bh + let bh' = setUserData bh (initReadState dict) + + -- At last, get the thing + get bh' -putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO () -putBinFileWithDict file_path mod a = do - bh <- openBinMem initBinMemSize mod +putBinFileWithDict :: Binary a => FilePath -> a -> IO () +putBinFileWithDict file_path the_thing = do + bh <- openBinMem initBinMemSize put_ bh binaryInterfaceMagic - p <- tellBin bh - put_ bh p -- placeholder for ptr to dictionary - put_ bh a - let (_, j_r, fm_r, _) = state bh - j <- readIORef j_r - fm <- readIORef fm_r - dict_p <- tellBin bh - putAt bh p dict_p -- fill in the placeholder - seekBin bh dict_p -- seek back to the end of the file + + -- Remember where the dictionary pointer will go + dict_p_p <- tellBin bh + put_ bh dict_p_p -- Placeholder for ptr to dictionary + + -- Make some intial state + usr_state <- newWriteState + + -- Put the main thing, + put_ (setUserData bh usr_state) the_thing + + -- Get the final-state + j <- readIORef (ud_next usr_state) + fm <- readIORef (ud_map usr_state) + dict_p <- tellBin bh -- This is where the dictionary will start + + -- Write the dictionary pointer at the fornt of the file + putAt bh dict_p_p dict_p -- Fill in the placeholder + seekBin bh dict_p -- Seek back to the end of the file + + -- Write the dictionary itself putDictionary bh j (constructDictionary j fm) + + -- And send the result to the file writeBinMem bh file_path -type Dictionary = Array Int FastString - -- should be 0-indexed +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +data UserData = + UserData { -- This field is used only when reading + ud_dict :: Dictionary, + + -- The next two fields are only used when writing + ud_next :: IORef Int, -- The next index to use + ud_map :: IORef (UniqFM (Int,FastString)) + } + +noUserData = error "Binary.UserData: no user data" + +initReadState :: Dictionary -> UserData +initReadState dict = UserData{ ud_dict = dict, + ud_next = undef "next", + ud_map = undef "map" } + +newWriteState :: IO UserData +newWriteState = do + j_r <- newIORef 0 + out_r <- newIORef emptyUFM + return (UserData { ud_dict = panic "dict", + ud_next = j_r, + ud_map = out_r }) + + +undef s = panic ("Binary.UserData: no " ++ s) + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +type Dictionary = Array Int FastString -- The dictionary + -- Should be 0-indexed putDictionary :: BinHandle -> Int -> Dictionary -> IO () putDictionary bh sz dict = do @@ -671,6 +725,10 @@ getDictionary bh = do constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary constructDictionary j fm = array (0,j-1) (eltsUFM fm) +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + putFS bh (FastString id l ba) = do put_ bh (I# l) putByteArray bh ba l @@ -693,7 +751,8 @@ getFS bh = do instance Binary FastString where put_ bh f@(FastString id l ba) = - case getUserData bh of { (_, j_r, out_r, dict) -> do + case getUserData bh of { + UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do out <- readIORef out_r let uniq = getUnique f case lookupUFM out uniq of @@ -708,4 +767,4 @@ instance Binary FastString where get bh = do j <- get bh - case getUserData bh of (_, _, _, arr) -> return $! (arr ! j) + return $! (ud_dict (getUserData bh) ! j) diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index d8f6220658..cd0e17d50a 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -32,8 +32,6 @@ module Digraph( ------------------------------------------------------------------------------ -#define ARR_ELT (COMMA) - import Util ( sortLt ) -- Extensions @@ -80,7 +78,8 @@ stronglyConnComp => [(node, key, [key])] -- The graph; its ok for the -- out-list to contain keys which arent -- a vertex key, they are ignored - -> [SCC node] + -> [SCC node] -- Returned in topologically sorted order + -- Later components depend on earlier ones, but not vice versa stronglyConnComp edges = map get_node (stronglyConnCompR edges) @@ -307,9 +306,6 @@ preorder (Node a ts) = a : preorderF ts preorderF :: Forest a -> [a] preorderF ts = concat (map preorder ts) -preOrd :: Graph -> [Vertex] -preOrd = preorderF . dff - tabulate :: Bounds -> [Vertex] -> Table Int tabulate bnds vs = array bnds (zipWith (,) vs [1..]) @@ -363,12 +359,6 @@ scc g = dfs g (reverse (postOrd (transposeG g))) ------------------------------------------------------------ \begin{code} -tree :: Bounds -> Forest Vertex -> Graph -tree bnds ts = buildG bnds (concat (map flat ts)) - where - flat (Node v rs) = [ (v, w) | Node w us <- ts ] ++ - concat (map flat ts) - back :: Graph -> Table Int -> Graph back g post = mapT select g where select v ws = [ w | w <- ws, post!v < post!w ] diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs index 61750aabdb..d46b775996 100644 --- a/ghc/compiler/utils/FastString.lhs +++ b/ghc/compiler/utils/FastString.lhs @@ -106,6 +106,7 @@ instance Eq FastString where a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True } instance Ord FastString where + -- Compares lexicographically, not by unique a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 353c3b5a5c..961da188e8 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -5,16 +5,18 @@ \begin{code} module Maybes ( + module Maybe, -- Re-export all of Maybe + MaybeErr(..), orElse, - mapMaybe, + mapCatMaybes, allMaybes, firstJust, expectJust, maybeToBool, - thenMaybe, seqMaybe, returnMaybe, failMaybe, catMaybes, + thenMaybe, seqMaybe, returnMaybe, failMaybe, thenMaB, returnMaB, failMaB @@ -22,7 +24,7 @@ module Maybes ( #include "HsVersions.h" -import Maybe( catMaybes, mapMaybe ) +import Maybe infixr 4 `orElse` @@ -66,20 +68,20 @@ firstJust (Nothing : ms) = firstJust ms \end{code} \begin{code} -findJust :: (a -> Maybe b) -> [a] -> Maybe b -findJust f [] = Nothing -findJust f (a:as) = case f a of - Nothing -> findJust f as - b -> b -\end{code} - -\begin{code} expectJust :: String -> Maybe a -> a {-# INLINE expectJust #-} expectJust err (Just x) = x expectJust err Nothing = error ("expectJust " ++ err) \end{code} +\begin{code} +mapCatMaybes :: (a -> Maybe b) -> [a] -> [b] +mapCatMaybes f [] = [] +mapCatMaybes f (x:xs) = case f x of + Just y -> y : mapCatMaybes f xs + Nothing -> mapCatMaybes f xs +\end{code} + The Maybe monad ~~~~~~~~~~~~~~~ \begin{code} diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 2ef0adffe3..dcfe8c2dbc 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -26,7 +26,7 @@ module Outputable ( text, char, ftext, ptext, int, integer, float, double, rational, parens, brackets, braces, quotes, doubleQuotes, angleBrackets, - semi, comma, colon, dcolon, space, equals, dot, + semi, comma, colon, dcolon, space, equals, dot, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, @@ -82,8 +82,6 @@ data PprStyle -- must be very close to Haskell -- syntax, etc. - | PprInterface PrintUnqualified -- Interface generation - | PprCode CodeStyle -- Print code; either C or assembler | PprDebug -- Standard debugging output @@ -156,7 +154,6 @@ getPprStyle df sty = df sty sty \begin{code} unqualStyle :: PprStyle -> Name -> Bool unqualStyle (PprUser unqual _) n = unqual n -unqualStyle (PprInterface unqual) n = unqual n unqualStyle other n = False codeStyle :: PprStyle -> Bool @@ -201,7 +198,7 @@ printDump doc = do better_doc = doc $$ text "" -- We used to always print in debug style, but I want -- to try the effect of a more user-ish style (unless you - -- say -dppr-debug + -- say -dppr-debug) printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc @@ -282,6 +279,7 @@ rbrack sty = Pretty.rbrack lbrace sty = Pretty.lbrace rbrace sty = Pretty.rbrace dcolon sty = Pretty.ptext SLIT("::") +arrow sty = Pretty.ptext SLIT("->") underscore = char '_' dot = char '.' diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index ab9864b68b..a3cb5325cf 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -1013,7 +1013,7 @@ spaces n = ' ' : spaces (n MINUS ILIT(1)) \end{code} \begin{code} -pprCols = (100 :: Int) -- could make configurable +pprCols = (120 :: Int) -- could make configurable printDoc :: Mode -> Handle -> Doc -> IO () printDoc mode hdl doc diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 28880a2446..bb22d4e9be 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -527,13 +527,13 @@ balancedFold' :: (a -> a -> a) -> [a] -> [a] balancedFold' f (x:y:xs) = f x y : balancedFold' f xs balancedFold' f xs = xs -generalMergeSort p [] = [] -generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs - generalNaturalMergeSort p [] = [] generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs #if NOT_USED +generalMergeSort p [] = [] +generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs + mergeSort, naturalMergeSort :: Ord a => [a] -> [a] mergeSort = generalMergeSort (<=) @@ -772,11 +772,6 @@ applyToFst f (x,y) = (f x,y) applyToSnd :: (b -> d) -> (a,b) -> (a,d) applyToSnd f (x,y) = (x,f y) #endif - -foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) -foldPair fg ab [] = ab -foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v) - where (u,v) = foldPair fg ab abs \end{code} \begin{code} |