diff options
Diffstat (limited to 'compiler/basicTypes')
30 files changed, 1336 insertions, 837 deletions
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs index ba6db1d9c8..cefa934ab1 100644 --- a/compiler/basicTypes/Avail.hs +++ b/compiler/basicTypes/Avail.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} -- -- (c) The University of Glasgow -- @@ -15,6 +16,8 @@ module Avail ( availName, availNames, availNonFldNames, availNamesWithSelectors, availFlds, + availsNamesWithOccs, + availNamesWithOccs, stableAvailCmp, plusAvail, trimAvail, @@ -25,6 +28,8 @@ module Avail ( ) where +import GhcPrelude + import Name import NameEnv import NameSet @@ -35,6 +40,7 @@ import ListSetOps import Outputable import Util +import Data.Data ( Data ) import Data.List ( find ) import Data.Function @@ -59,7 +65,7 @@ data AvailInfo = Avail Name -- ^ An ordinary identifier in scope -- to be in scope, it must be -- *first* in this list. Thus, -- typically: @AvailTC Eq [Eq, ==, \/=]@ - deriving( Eq ) + deriving( Eq, Data ) -- Equality used when deciding if the -- interface has changed @@ -76,7 +82,7 @@ datatype like gives rise to the AvailInfo - AvailTC T [T, MkT] [FieldLabel "foo" False foo], + AvailTC T [T, MkT] [FieldLabel "foo" False foo] whereas if -XDuplicateRecordFields is enabled it gives @@ -94,8 +100,9 @@ multiple distinct fields with the same label. For example, gives rise to - AvailTC F [F, MkFInt, MkFBool] - [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" True $sel:foo:MkFBool]. + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" True $sel:foo:MkFBool ] Moreover, note that the flIsOverloaded flag need not be the same for all the elements of the list. In the example above, this occurs if @@ -103,8 +110,9 @@ the two data instances are defined in different modules, one with `-XDuplicateRecordFields` enabled and one with it disabled. Thus it is possible to have - AvailTC F [F, MkFInt, MkFBool] - [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" False foo]. + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" False foo ] If the two data instances are defined in different modules, both without `-XDuplicateRecordFields`, it will be impossible to export @@ -169,6 +177,22 @@ availFlds :: AvailInfo -> [FieldLabel] availFlds (AvailTC _ _ fs) = fs availFlds _ = [] +availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] +availsNamesWithOccs = concatMap availNamesWithOccs + +-- | 'Name's made available by the availability information, paired with +-- the 'OccName' used to refer to each one. +-- +-- When @DuplicateRecordFields@ is in use, the 'Name' may be the +-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the +-- 'OccName' will be the label of the field (e.g. @foo@). +-- +-- See Note [Representing fields in AvailInfo]. +availNamesWithOccs :: AvailInfo -> [(Name, OccName)] +availNamesWithOccs (Avail n) = [(n, nameOccName n)] +availNamesWithOccs (AvailTC _ ns fs) + = [ (n, nameOccName n) | n <- ns ] ++ + [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] -- ----------------------------------------------------------------------------- -- Utility @@ -225,7 +249,7 @@ filterAvail keep ie rest = -- will give Ix(Ix,index,range) and Ix(index) -- We want to combine these; addAvail does that nubAvails :: [AvailInfo] -> [AvailInfo] -nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails) +nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) where add env avail = extendNameEnv_C plusAvail env (availName avail) avail diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 90a043de76..151a040393 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -45,14 +45,12 @@ module BasicTypes( TopLevelFlag(..), isTopLevel, isNotTopLevel, - DerivStrategy(..), - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, Boxity(..), isBoxed, - TyPrec(..), maybeParen, + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, TupleSort(..), tupleSortBoxity, boxityTupleSort, tupleParens, @@ -83,9 +81,10 @@ module BasicTypes( Activation(..), isActive, isActiveIn, competesWith, isNeverActive, isAlwaysActive, isEarlyActive, + activeAfterInitial, activeDuringFinal, RuleMatchInfo(..), isConLike, isFunLike, - InlineSpec(..), isEmptyInlineSpec, + InlineSpec(..), noUserInlineSpec, InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, isDefaultInlinePragma, @@ -109,6 +108,8 @@ module BasicTypes( SpliceExplicitFlag(..) ) where +import GhcPrelude + import FastString import Outputable import SrcLoc ( Located,unLoc ) @@ -440,7 +441,7 @@ compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) -- |Captures the fixity of declarations as they are parsed. This is not -- necessarily the same as the fixity declaration, as the normal fixity may be -- overridden using parens or backticks. -data LexicalFixity = Prefix | Infix deriving (Typeable,Data,Eq) +data LexicalFixity = Prefix | Infix deriving (Data,Eq) instance Outputable LexicalFixity where ppr Prefix = text "Prefix" @@ -543,31 +544,6 @@ instance Outputable Origin where {- ************************************************************************ * * - Deriving strategies -* * -************************************************************************ --} - --- | Which technique the user explicitly requested when deriving an instance. -data DerivStrategy - -- See Note [Deriving strategies] in TcDeriv - = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a - -- custom instance for the data type. This only works - -- for certain types that GHC knows about (e.g., 'Eq', - -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, - -- etc.) - | AnyclassStrategy -- ^ @-XDeriveAnyClass@ - | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ - deriving (Eq, Data) - -instance Outputable DerivStrategy where - ppr StockStrategy = text "stock" - ppr AnyclassStrategy = text "anyclass" - ppr NewtypeStrategy = text "newtype" - -{- -************************************************************************ -* * Instance overlap flag * * ************************************************************************ @@ -690,40 +666,25 @@ pprSafeOverlap False = empty {- ************************************************************************ * * - Type precedence + Precedence * * ************************************************************************ -} -data TyPrec -- See Note [Precedence in types] in TyCoRep.hs - = TopPrec -- No parens - | FunPrec -- Function args; no parens for tycon apps - | TyOpPrec -- Infix operator - | TyConPrec -- Tycon args; no parens for atomic - -instance Eq TyPrec where - (==) a b = case compare a b of - EQ -> True - _ -> False - -instance Ord TyPrec where - compare TopPrec TopPrec = EQ - compare TopPrec _ = LT - - compare FunPrec TopPrec = GT - compare FunPrec FunPrec = EQ - compare FunPrec TyOpPrec = EQ -- See Note [Type operator precedence] - compare FunPrec TyConPrec = LT +-- | A general-purpose pretty-printing precedence type. +newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) +-- See Note [Precedence in types] - compare TyOpPrec TopPrec = GT - compare TyOpPrec FunPrec = EQ -- See Note [Type operator precedence] - compare TyOpPrec TyOpPrec = EQ - compare TyOpPrec TyConPrec = LT +topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec +topPrec = PprPrec 0 -- No parens +sigPrec = PprPrec 1 -- Explicit type signatures +funPrec = PprPrec 2 -- Function args; no parens for constructor apps + -- See [Type operator precedence] for why both + -- funPrec and opPrec exist. +opPrec = PprPrec 2 -- Infix operator +appPrec = PprPrec 3 -- Constructor args; no parens for atomic - compare TyConPrec TyConPrec = EQ - compare TyConPrec _ = GT - -maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc +maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc maybeParen ctxt_prec inner_prec pretty | ctxt_prec < inner_prec = pretty | otherwise = parens pretty @@ -731,12 +692,12 @@ maybeParen ctxt_prec inner_prec pretty {- Note [Precedence in types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Many pretty-printing functions have type - ppr_ty :: TyPrec -> Type -> SDoc + ppr_ty :: PprPrec -> Type -> SDoc -The TyPrec gives the binding strength of the context. For example, in +The PprPrec gives the binding strength of the context. For example, in T ty1 ty2 we will pretty-print 'ty1' and 'ty2' with the call - (ppr_ty TyConPrec ty) + (ppr_ty appPrec ty) to indicate that the context is that of an argument of a TyConApp. We use this consistently for Type and HsType. @@ -749,16 +710,16 @@ pretty printer follows the following precedence order: TyConPrec Type constructor application TyOpPrec/FunPrec Operator application and function arrow -We have FunPrec and TyOpPrec to represent the precedence of function +We have funPrec and opPrec to represent the precedence of function arrow and type operators respectively, but currently we implement -FunPred == TyOpPrec, so that we don't distinguish the two. Reason: +funPrec == opPrec, so that we don't distinguish the two. Reason: it's hard to parse a type like a ~ b => c * d -> e - f -By treating TyOpPrec = FunPrec we end up with more parens +By treating opPrec = funPrec we end up with more parens (a ~ b) => (c * d) -> (e - f) -But the two are different constructors of TyPrec so we could make +But the two are different constructors of PprPrec so we could make (->) bind more or less tightly if we wanted. -} @@ -789,9 +750,8 @@ tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple p = parens p tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) - = sdocWithPprDebug $ \dbg -> if dbg - then text "(%" <+> p <+> ptext (sLit "%)") - else parens p + = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) + (parens p) {- ************************************************************************ @@ -1183,6 +1143,15 @@ instance Outputable CompilerPhase where ppr (Phase n) = int n ppr InitialPhase = text "InitialPhase" +activeAfterInitial :: Activation +-- Active in the first phase after the initial phase +-- Currently we have just phases [2,1,0] +activeAfterInitial = ActiveAfter NoSourceText 2 + +activeDuringFinal :: Activation +-- Active in the final simplification phase (which is repeated) +activeDuringFinal = ActiveAfter NoSourceText 0 + -- See note [Pragma source text] data Activation = NeverActive | AlwaysActive @@ -1219,11 +1188,11 @@ data InlinePragma -- Note [InlinePragma] -- | Inline Specification data InlineSpec -- What the user's INLINE pragma looked like - = Inline - | Inlinable - | NoInline - | EmptyInlineSpec -- Used in a place-holder InlinePragma in SpecPrag or IdInfo, - -- where there isn't any real inline pragma at all + = Inline -- User wrote INLINE + | Inlinable -- User wrote INLINABLE + | NoInline -- User wrote NOINLINE + | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE + -- e.g. in `defaultInlinePragma` or when created by CSE deriving( Eq, Data, Show ) -- Show needed for Lexer.x @@ -1233,7 +1202,7 @@ This data type mirrors what you can write in an INLINE or NOINLINE pragma in the source program. If you write nothing at all, you get defaultInlinePragma: - inl_inline = EmptyInlineSpec + inl_inline = NoUserInline inl_act = AlwaysActive inl_rule = FunLike @@ -1306,16 +1275,16 @@ isFunLike :: RuleMatchInfo -> Bool isFunLike FunLike = True isFunLike _ = False -isEmptyInlineSpec :: InlineSpec -> Bool -isEmptyInlineSpec EmptyInlineSpec = True -isEmptyInlineSpec _ = False +noUserInlineSpec :: InlineSpec -> Bool +noUserInlineSpec NoUserInline = True +noUserInlineSpec _ = False defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_act = AlwaysActive , inl_rule = FunLike - , inl_inline = EmptyInlineSpec + , inl_inline = NoUserInline , inl_sat = Nothing } alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } @@ -1335,7 +1304,7 @@ isDefaultInlinePragma :: InlinePragma -> Bool isDefaultInlinePragma (InlinePragma { inl_act = activation , inl_rule = match_info , inl_inline = inline }) - = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info + = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info isInlinePragma :: InlinePragma -> Bool isInlinePragma prag = case inl_inline prag of @@ -1380,10 +1349,10 @@ instance Outputable RuleMatchInfo where ppr FunLike = text "FUNLIKE" instance Outputable InlineSpec where - ppr Inline = text "INLINE" - ppr NoInline = text "NOINLINE" - ppr Inlinable = text "INLINABLE" - ppr EmptyInlineSpec = empty + ppr Inline = text "INLINE" + ppr NoInline = text "NOINLINE" + ppr Inlinable = text "INLINABLE" + ppr NoUserInline = text "NOUSERINLINE" -- what is better? instance Outputable InlinePragma where ppr = pprInline @@ -1394,7 +1363,9 @@ pprInline = pprInline' True pprInlineDebug :: InlinePragma -> SDoc pprInlineDebug = pprInline' False -pprInline' :: Bool -> InlinePragma -> SDoc +pprInline' :: Bool -- True <=> do not display the inl_inline field + -> InlinePragma + -> SDoc pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation , inl_rule = info, inl_sat = mb_arity }) = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info @@ -1475,9 +1446,12 @@ data IntegralLit deriving (Data, Show) mkIntegralLit :: Integral a => a -> IntegralLit -mkIntegralLit i = IL { il_text = SourceText (show (fromIntegral i :: Int)) +mkIntegralLit i = IL { il_text = SourceText (show i_integer) , il_neg = i < 0 - , il_value = toInteger i } + , il_value = i_integer } + where + i_integer :: Integer + i_integer = toInteger i negateIntegralLit :: IntegralLit -> IntegralLit negateIntegralLit (IL text neg value) @@ -1502,6 +1476,13 @@ data FractionalLit mkFractionalLit :: Real a => a -> FractionalLit mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) + -- Converting to a Double here may technically lose + -- precision (see #15502). We could alternatively + -- convert to a Rational for the most accuracy, but + -- it would cause Floats and Doubles to be displayed + -- strangely, so we opt not to do this. (In contrast + -- to mkIntegralLit, where we always convert to an + -- Integer for the highest accuracy.) , fl_neg = r < 0 , fl_value = toRational r } diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs index aa6a362f68..a9d7548b8a 100644 --- a/compiler/basicTypes/ConLike.hs +++ b/compiler/basicTypes/ConLike.hs @@ -12,7 +12,7 @@ module ConLike ( , conLikeArity , conLikeFieldLabels , conLikeInstOrigArgTys - , conLikeExTyVars + , conLikeExTyCoVars , conLikeName , conLikeStupidTheta , conLikeWrapId_maybe @@ -26,6 +26,8 @@ module ConLike ( #include "HsVersions.h" +import GhcPrelude + import DataCon import PatSyn import Outputable @@ -111,10 +113,10 @@ conLikeInstOrigArgTys (RealDataCon data_con) tys = conLikeInstOrigArgTys (PatSynCon pat_syn) tys = patSynInstArgTys pat_syn tys --- | Existentially quantified type variables -conLikeExTyVars :: ConLike -> [TyVar] -conLikeExTyVars (RealDataCon dcon1) = dataConExTyVars dcon1 -conLikeExTyVars (PatSynCon psyn1) = patSynExTyVars psyn1 +-- | Existentially quantified type/coercion variables +conLikeExTyCoVars :: ConLike -> [TyCoVar] +conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 +conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 conLikeName :: ConLike -> Name conLikeName (RealDataCon data_con) = dataConName data_con @@ -150,7 +152,7 @@ conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys -- -- 1) The universally quantified type variables -- --- 2) The existentially quantified type variables +-- 2) The existentially quantified type/coercion variables -- -- 3) The equality specification -- @@ -163,7 +165,9 @@ conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys -- -- 7) The original result type conLikeFullSig :: ConLike - -> ([TyVar], [TyVar], [EqSpec] + -> ([TyVar], [TyCoVar], [EqSpec] + -- Why tyvars for universal but tycovars for existential? + -- See Note [Existential coercion variables] in DataCon , ThetaType, ThetaType, [Type], Type) conLikeFullSig (RealDataCon con) = let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 73bbf2cf57..b7435e5b54 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -31,9 +31,8 @@ module DataCon ( dataConName, dataConIdentity, dataConTag, dataConTagZ, dataConTyCon, dataConOrigTyCon, dataConUserType, - dataConUnivTyVars, dataConUnivTyVarBinders, - dataConExTyVars, dataConExTyVarBinders, - dataConAllTyVars, + dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, + dataConUserTyVars, dataConUserTyVarBinders, dataConEqSpec, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, @@ -52,8 +51,9 @@ module DataCon ( isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, isUnboxedSumCon, isVanillaDataCon, classDataCon, dataConCannotMatch, + dataConUserTyVarsArePermuted, isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, - specialPromotedDc, isLegacyPromotableDataCon, isLegacyPromotableTyCon, + specialPromotedDc, -- ** Promotion related functions promoteDataCon @@ -61,6 +61,8 @@ module DataCon ( #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} MkId( DataConBoxer ) import Type import ForeignCall ( CType ) @@ -73,7 +75,6 @@ import Name import PrelNames import Var import Outputable -import ListSetOps import Util import BasicTypes import FastString @@ -85,7 +86,7 @@ import Unique( mkAlphaTyVarUnique ) import qualified Data.Data as Data import Data.Char import Data.Word -import Data.List( mapAccumL, find ) +import Data.List( find ) {- Data constructor representation @@ -275,33 +276,43 @@ data DataCon -- Running example: -- -- *** As declared by the user - -- data T a where - -- MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y) + -- data T a b c where + -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c -- *** As represented internally - -- data T a where - -- MkT :: forall a. forall x y. (a~(x,y),x~y,Ord x) => x -> y -> T a + -- data T a b c where + -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) + -- => x -> y -> T a b c -- -- The next six fields express the type of the constructor, in pieces -- e.g. -- - -- dcUnivTyVars = [a] - -- dcExTyVars = [x,y] - -- dcEqSpec = [a~(x,y)] - -- dcOtherTheta = [x~y, Ord x] - -- dcOrigArgTys = [x,y] - -- dcRepTyCon = T - - -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS - -- FOR THE PARENT TyCon. (This is a change (Oct05): previously, vanilla - -- datacons guaranteed to have the same type variables as their parent TyCon, - -- but that seems ugly.) + -- dcUnivTyVars = [a,b,c] + -- dcExTyCoVars = [x,y] + -- dcUserTyVarBinders = [c,y,x,b] + -- dcEqSpec = [a~(x,y)] + -- dcOtherTheta = [x~y, Ord x] + -- dcOrigArgTys = [x,y] + -- dcRepTyCon = T + + -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE + -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, + -- vanilla datacons guaranteed to have the same type variables as their + -- parent TyCon, but that seems ugly.) They can be different in the case + -- where a GADT constructor uses different names for the universal + -- tyvars than does the tycon. For example: + -- + -- data H a where + -- MkH :: b -> H b + -- + -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH + -- will be [b]. dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor -- Its type is of form -- forall a1..an . t1 -> ... tm -> T a1..an -- No existentials, no coercions, nothing. - -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = [] + -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] -- NB 1: newtypes always have a vanilla data con -- NB 2: a vanilla constructor can still be declared in GADT-style -- syntax, provided its type looks like the above. @@ -310,16 +321,30 @@ data DataCon -- Universally-quantified type vars [a,b,c] -- INVARIANT: length matches arity of the dcRepTyCon -- INVARIANT: result type of data con worker is exactly (T a b c) - dcUnivTyVars :: [TyVarBinder], + -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with + -- the tyConTyVars of the parent TyCon + dcUnivTyVars :: [TyVar], - -- Existentially-quantified type vars [x,y] - dcExTyVars :: [TyVarBinder], + -- Existentially-quantified type and coercion vars [x,y] + -- For an example involving coercion variables, + -- Why tycovars? See Note [Existential coercion variables] + dcExTyCoVars :: [TyCoVar], - -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames + -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames -- Reason: less confusing, and easier to generate IfaceSyn + -- The type/coercion vars in the order the user wrote them [c,y,x,b] + -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set + -- of tyvars (*not* covars) of dcExTyCoVars unioned with the + -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec + -- See Note [DataCon user type variable binders] + dcUserTyVarBinders :: [TyVarBinder], + dcEqSpec :: [EqSpec], -- Equalities derived from the result type, - -- _as written by the programmer_ + -- _as written by the programmer_. + -- Only non-dependent GADT equalities (dependent + -- GADT equalities are in the covars of + -- dcExTyCoVars). -- This field allows us to move conveniently between the two ways -- of representing a GADT constructor's type: @@ -383,7 +408,7 @@ data DataCon dcRep :: DataConRep, -- Cached; see Note [DataCon arities] - -- INVARIANT: dcRepArity == length dataConRepArgTys + -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) -- INVARIANT: dcSourceArity == length dcOrigArgTys dcRepArity :: Arity, dcSourceArity :: Arity, @@ -421,13 +446,36 @@ For the TyVarBinders in a DataCon and PatSyn: * Each argument flag is Inferred or Specified. None are Required. (A DataCon is a term-level function; see - Note [No Required TyBinder in terms] in TyCoRep.) + Note [No Required TyCoBinder in terms] in TyCoRep.) Why do we need the TyVarBinders, rather than just the TyVars? So that we can construct the right type for the DataCon with its foralls attributed the correct visibility. That in turn governs whether you can use visible type application at a call of the data constructor. +See also [DataCon user type variable binders] for an extended discussion on the +order in which TyVarBinders appear in a DataCon. + +Note [Existential coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For now (Aug 2018) we can't write coercion quantifications in source Haskell, but +we can in Core. Consider having: + + data T :: forall k. k -> k -> Constraint where + MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) + => T k a b + + dcUnivTyVars = [k,a,b] + dcExTyCoVars = [k',c,co] + dcUserTyVarBinders = [k,a,k',c] + dcEqSpec = [b~(c|>co)] + dcOtherTheta = [] + dcOrigArgTys = [] + dcRepTyCon = T + + Function call 'dataConKindEqSpec' returns [k'~k] + Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~ dcSourceArity does not take constraints into account, @@ -435,6 +483,85 @@ but dcRepArity does. For example: MkT :: Ord a => a -> T a dcSourceArity = 1 dcRepArity = 2 + +Note [DataCon user type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In System FC, data constructor type signatures always quantify over all of +their universal type variables, followed by their existential type variables. +Normally, this isn't a problem, as most datatypes naturally quantify their type +variables in this order anyway. For example: + + data T a b = forall c. MkT b c + +Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, +where k, a, and b are universal and c is existential. (The inferred variable k +isn't available for TypeApplications, hence why it's in braces.) This is a +perfectly reasonable order to use, as the syntax of H98-style datatypes +(+ ExistentialQuantification) suggests it. + +Things become more complicated when GADT syntax enters the picture. Consider +this example: + + data X a where + MkX :: forall b a. b -> Proxy a -> X a + +If we adopt the earlier approach of quantifying all the universal variables +followed by all the existential ones, GHC would come up with this type +signature for MkX: + + MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a + +But this is not what we want at all! After all, if a user were to use +TypeApplications on MkX, they would expect to instantiate `b` before `a`, +as that's the order in which they were written in the `forall`. (See #11721.) +Instead, we'd like GHC to come up with this type signature: + + MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a + +In fact, even if we left off the explicit forall: + + data X a where + MkX :: b -> Proxy a -> X a + +Then a user should still expect `b` to be quantified before `a`, since +according to the rules of TypeApplications, in the absence of `forall` GHC +performs a stable topological sort on the type variables in the user-written +type signature, which would place `b` before `a`. + +But as noted above, enacting this behavior is not entirely trivial, as System +FC demands the variables go in universal-then-existential order under the hood. +Our solution is thus to equip DataCon with two different sets of type +variables: + +* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential + type/coercion variables, respectively. Their order is irrelevant for the + purposes of TypeApplications, and as a consequence, they do not come equipped + with visibilities (that is, they are TyVars/TyCoVars instead of + TyCoVarBinders). +* dcUserTyVarBinders, for the type variables binders in the order in which they + originally arose in the user-written type signature. Their order *does* matter + for TypeApplications, so they are full TyVarBinders, complete with + visibilities. + +This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders +consists precisely of: + +* The set of tyvars in dcUnivTyVars whose type variables do not appear in + dcEqSpec, unioned with: +* The set of tyvars (*not* covars) in dcExTyCoVars + No covars here because because they're not user-written + +The word "set" is used above because the order in which the tyvars appear in +dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or +dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of +(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the +ordering, they in fact share the same type variables (with the same Uniques). We +sometimes refer to this as "the dcUserTyVarBinders invariant". + +dcUserTyVarBinders, as the name suggests, is the one that users will see most of +the time. It's used when computing the type signature of a data constructor (see +dataConUserType), and as a result, it's what matters from a TypeApplications +perspective. -} -- | Data Constructor Representation @@ -540,7 +667,7 @@ data StrictnessMark = MarkedStrict | NotMarkedStrict data EqSpec = EqSpec TyVar Type --- | Make an 'EqSpec' +-- | Make a non-dependent 'EqSpec' mkEqSpec :: TyVar -> Type -> EqSpec mkEqSpec tv ty = EqSpec tv ty @@ -566,13 +693,12 @@ substEqSpec subst (EqSpec tv ty) where tv' = getTyVar "substEqSpec" (substTyVar subst tv) --- | Filter out any TyBinders mentioned in an EqSpec -filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder] +-- | Filter out any 'TyVar's mentioned in an 'EqSpec'. +filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] filterEqSpec eq_spec = filter not_in_eq_spec where - not_in_eq_spec bndr = let var = binderVar bndr in - all (not . (== var) . eqSpecTyVar) eq_spec + not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec instance Outputable EqSpec where ppr (EqSpec tv ty) = ppr (tv, ty) @@ -750,44 +876,49 @@ mkDataCon :: Name -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user -> [FieldLabel] -- ^ Field labels for the constructor, -- if it is a record, otherwise empty - -> [TyVarBinder] -- ^ Universals. See Note [TyVarBinders in DataCons] - -> [TyVarBinder] -- ^ Existentials. - -- (These last two must be Named and Inferred/Specified) + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. + -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. + -- These must be Inferred/Specified. + -- See @Note [TyVarBinders in DataCons]@ -> [EqSpec] -- ^ GADT equalities - -> ThetaType -- ^ Theta-type occuring before the arguments proper - -> [Type] -- ^ Original argument types - -> Type -- ^ Original result type - -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' - -> TyCon -- ^ Representation type constructor - -> ThetaType -- ^ The "stupid theta", context of the data - -- declaration e.g. @data Eq a => T a ...@ - -> Id -- ^ Worker Id - -> DataConRep -- ^ Representation + -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper + -> [KnotTied Type] -- ^ Original argument types + -> KnotTied Type -- ^ Original result type + -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' + -> KnotTied TyCon -- ^ Representation type constructor + -> ConTag -- ^ Constructor tag + -> ThetaType -- ^ The "stupid theta", context of the data + -- declaration e.g. @data Eq a => T a ...@ + -> Id -- ^ Worker Id + -> DataConRep -- ^ Representation -> DataCon -- Can get the tag from the TyCon mkDataCon name declared_infix prom_info arg_stricts -- Must match orig_arg_tys 1-1 fields - univ_tvs ex_tvs + univ_tvs ex_tvs user_tvbs eq_spec theta - orig_arg_tys orig_res_ty rep_info rep_tycon + orig_arg_tys orig_res_ty rep_info rep_tycon tag stupid_theta work_id rep --- Warning: mkDataCon is not a good place to check invariants. +-- Warning: mkDataCon is not a good place to check certain invariants. -- If the programmer writes the wrong result type in the decl, thus: -- data T a where { MkT :: S } -- then it's possible that the univ_tvs may hit an assertion failure -- if you pull on univ_tvs. This case is checked by checkValidDataCon, --- so the error is detected properly... it's just that asaertions here +-- so the error is detected properly... it's just that assertions here -- are a little dodgy. = con where is_vanilla = null ex_tvs && null eq_spec && null theta + con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs, + dcExTyCoVars = ex_tvs, + dcUserTyVarBinders = user_tvbs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcStupidTheta = stupid_theta, @@ -798,23 +929,29 @@ mkDataCon name declared_infix prom_info dcWorkId = work_id, dcRep = rep, dcSourceArity = length orig_arg_tys, - dcRepArity = length rep_arg_tys, + dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, dcPromoted = promoted } -- The 'arg_stricts' passed to mkDataCon are simply those for the -- source-language arguments. We add extra ones for the -- dictionary arguments right here. - tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con rep_arg_tys = dataConRepArgTys con - rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ - mkFunTys rep_arg_tys $ - mkTyConApp rep_tycon (mkTyVarTys (binderVars univ_tvs)) + rep_ty = + case rep of + -- If the DataCon has no wrapper, then the worker's type *is* the + -- user-facing type, so we can simply use dataConUserType. + NoDataConRep -> dataConUserType con + -- If the DataCon has a wrapper, then the worker's type is never seen + -- by the user. The visibilities we pick do not matter here. + DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ + mkFunTys rep_arg_tys $ + mkTyConApp rep_tycon (mkTyVarTys univ_tvs) -- See Note [Promoted data constructors] in TyCon prom_tv_bndrs = [ mkNamedTyConBinder vis tv - | TvBndr tv vis <- filterEqSpec eq_spec univ_tvs ++ ex_tvs ] + | Bndr tv vis <- user_tvbs ] prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys) prom_res_kind = orig_res_ty @@ -822,8 +959,9 @@ mkDataCon name declared_infix prom_info (prom_tv_bndrs ++ prom_arg_bndrs) prom_res_kind roles rep_info - roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ - map (const Representational) orig_arg_tys + roles = map (\tv -> if isTyVar tv then Nominal else Phantom) + (univ_tvs ++ ex_tvs) + ++ map (const Representational) orig_arg_tys mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder] -- Make sure that the "anonymous" tyvars don't clash in @@ -888,31 +1026,36 @@ dataConIsInfix = dcInfix -- | The universally-quantified type variables of the constructor dataConUnivTyVars :: DataCon -> [TyVar] -dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = binderVars tvbs +dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs --- | 'TyBinder's for the universally-quantified type variables -dataConUnivTyVarBinders :: DataCon -> [TyVarBinder] -dataConUnivTyVarBinders = dcUnivTyVars +-- | The existentially-quantified type/coercion variables of the constructor +-- including dependent (kind-) GADT equalities +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs --- | The existentially-quantified type variables of the constructor -dataConExTyVars :: DataCon -> [TyVar] -dataConExTyVars (MkData { dcExTyVars = tvbs }) = binderVars tvbs +-- | Both the universal and existential type/coercion variables of the constructor +dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] +dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) + = univ_tvs ++ ex_tvs --- | 'TyBinder's for the existentially-quantified type variables -dataConExTyVarBinders :: DataCon -> [TyVarBinder] -dataConExTyVarBinders = dcExTyVars +-- See Note [DataCon user type variable binders] +-- | The type variables of the constructor, in the order the user wrote them +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs --- | Both the universal and existentiatial type variables of the constructor -dataConAllTyVars :: DataCon -> [TyVar] -dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) - = binderVars (univ_tvs ++ ex_tvs) +-- See Note [DataCon user type variable binders] +-- | 'TyCoVarBinder's for the type variables of the constructor, in the order the +-- user wrote them +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConUserTyVarBinders = dcUserTyVarBinders -- | Equalities derived from the result type of the data constructor, as written -- by the programmer in any GADT declaration. This includes *all* GADT-like -- equalities, including those written in by hand by the programmer. dataConEqSpec :: DataCon -> [EqSpec] -dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = eq_spec ++ +dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = dataConKindEqSpec con + ++ eq_spec ++ [ spec -- heterogeneous equality | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta , tc `hasKey` heqTyConKey @@ -930,11 +1073,29 @@ dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) _ -> [] ] +-- | Dependent (kind-level) equalities in a constructor. +-- There are extracted from the existential variables. +-- See Note [Existential coercion variables] +dataConKindEqSpec :: DataCon -> [EqSpec] +dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) + -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), + -- which are frequently used functions. + -- For now (Aug 2018) this function always return empty set as we don't really + -- have coercion variables. + -- In the future when we do, we might want to cache this information in DataCon + -- so it won't be computed every time when aforementioned functions are called. + = [ EqSpec tv ty + | cv <- ex_tcvs + , isCoVar cv + , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv + tv = getTyVar "dataConKindEqSpec" ty1 + ] --- | The *full* constraints on the constructor type. +-- | The *full* constraints on the constructor type, including dependent GADT +-- equalities. dataConTheta :: DataCon -> ThetaType -dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = eqSpecPreds eq_spec ++ theta +dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta -- | Get the Id of the 'DataCon' worker: a function that is the "actual" -- constructor and has no top level binding in the program. The type may @@ -944,9 +1105,11 @@ dataConWorkId :: DataCon -> Id dataConWorkId dc = dcWorkId dc -- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" --- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'. --- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor --- and also for a newtype (whose constructor is inlined compulsorily) +-- constructor so it has the type visible in the source program: c.f. +-- 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data +-- constructor and also for a newtype (whose constructor is inlined +-- compulsorily) dataConWrapId_maybe :: DataCon -> Maybe Id dataConWrapId_maybe dc = case dcRep dc of NoDataConRep -> Nothing @@ -1035,58 +1198,65 @@ dataConBoxer _ = Nothing -- | The \"signature\" of the 'DataCon' returns, in order: -- --- 1) The result of 'dataConAllTyVars', +-- 1) The result of 'dataConUnivAndExTyCoVars', -- --- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit --- parameter - whatever) +-- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, +-- implicit parameter - whatever), including dependent GADT equalities. +-- Dependent GADT equalities are *also* listed in return value (1), so be +-- careful! -- -- 3) The type arguments to the constructor -- -- 4) The /original/ result type of the 'DataCon' -dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) +dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type) dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (dataConAllTyVars con, dataConTheta con, arg_tys, res_ty) + = (dataConUnivAndExTyCoVars con, dataConTheta con, arg_tys, res_ty) dataConInstSig :: DataCon -> [Type] -- Instantiate the *universal* tyvars with these types - -> ([TyVar], ThetaType, [Type]) -- Return instantiated existentials - -- theta and arg tys + -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials + -- theta and arg tys -- ^ Instantiate the universal tyvars of a data con, --- returning the instantiated existentials, constraints, and args -dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs - , dcEqSpec = eq_spec, dcOtherTheta = theta - , dcOrigArgTys = arg_tys }) +-- returning +-- ( instantiated existentials +-- , instantiated constraints including dependent GADT equalities +-- which are *also* listed in the instantiated existentials +-- , instantiated args) +dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs + , dcOrigArgTys = arg_tys }) univ_tys = ( ex_tvs' - , substTheta subst (eqSpecPreds eq_spec ++ theta) + , substTheta subst (dataConTheta con) , substTys subst arg_tys) where - univ_subst = zipTvSubst (binderVars univ_tvs) univ_tys - (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst $ - binderVars ex_tvs + univ_subst = zipTvSubst univ_tvs univ_tys + (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs -- | The \"full signature\" of the 'DataCon' returns, in order: -- -- 1) The result of 'dataConUnivTyVars' -- --- 2) The result of 'dataConExTyVars' +-- 2) The result of 'dataConExTyCoVars' -- --- 3) The GADT equalities +-- 3) The non-dependent GADT equalities. +-- Dependent GADT equalities are implied by coercion variables in +-- return value (2). -- --- 4) The result of 'dataConDictTheta' +-- 4) The other constraints of the data constructor type, excluding GADT +-- equalities -- -- 5) The original argument types to the 'DataCon' (i.e. before -- any change of the representation of the type) -- -- 6) The original result type of the 'DataCon' dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type) -dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (binderVars univ_tvs, binderVars ex_tvs, eq_spec, theta, arg_tys, res_ty) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) dataConOrigResTy :: DataCon -> Type dataConOrigResTy dc = dcOrigResTy dc @@ -1107,19 +1277,21 @@ dataConUserType :: DataCon -> Type -- -- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c -- +-- The type variables are quantified in the order that the user wrote them. +-- See @Note [DataCon user type variable binders]@. +-- -- NB: If the constructor is part of a data instance, the result type -- mentions the family tycon, not the internal one. -dataConUserType (MkData { dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs, dcEqSpec = eq_spec, +dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty }) - = mkForAllTys (filterEqSpec eq_spec univ_tvs) $ - mkForAllTys ex_tvs $ + = mkForAllTys user_tvbs $ mkFunTys theta $ mkFunTys arg_tys $ res_ty --- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation +-- | Finds the instantiated types of the arguments required to construct a +-- 'DataCon' representation -- NB: these INCLUDE any dictionary args -- but EXCLUDE the data-declaration context, which is discarded -- It's all post-flattening etc; this is a representation type @@ -1129,11 +1301,11 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality -> [Type] -- ^ Instantiated at these types -> [Type] dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys + dcExTyCoVars = ex_tvs}) inst_tys = ASSERT2( univ_tvs `equalLength` inst_tys , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) ASSERT2( null ex_tvs, ppr dc ) - map (substTyWith (binderVars univ_tvs) inst_tys) (dataConRepArgTys dc) + map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) -- | Returns just the instantiated /value/ argument types of a 'DataCon', -- (excluding dictionary args) @@ -1146,19 +1318,20 @@ dataConInstOrigArgTys -- But for the call in MatchCon, we really do want just the value args dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys + dcExTyCoVars = ex_tvs}) inst_tys = ASSERT2( tyvars `equalLength` inst_tys - , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys + , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + map (substTy subst) arg_tys where - tyvars = binderVars (univ_tvs ++ ex_tvs) + tyvars = univ_tvs ++ ex_tvs + subst = zipTCvSubst tyvars inst_tys -- | Returns the argument types of the wrapper, excluding all dictionary arguments -- and without substituting for any type variables dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys dc = dcOrigArgTys dc --- | Returns the arg types of the worker, including *all* +-- | Returns the arg types of the worker, including *all* non-dependent -- evidence, after any flattening has been done and without substituting for -- any type variables dataConRepArgTys :: DataCon -> [Type] @@ -1198,26 +1371,6 @@ isVanillaDataCon dc = dcVanilla dc specialPromotedDc :: DataCon -> Bool specialPromotedDc = isKindTyCon . dataConTyCon --- | Was this datacon promotable before GHC 8.0? That is, is it promotable --- without -XTypeInType -isLegacyPromotableDataCon :: DataCon -> Bool -isLegacyPromotableDataCon dc - = null (dataConEqSpec dc) -- no GADTs - && null (dataConTheta dc) -- no context - && not (isFamInstTyCon (dataConTyCon dc)) -- no data instance constructors - && uniqSetAll isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc)) - --- | Was this tycon promotable before GHC 8.0? That is, is it promotable --- without -XTypeInType -isLegacyPromotableTyCon :: TyCon -> Bool -isLegacyPromotableTyCon tc - = isVanillaAlgTyCon tc || - -- This returns True more often than it should, but it's quite painful - -- to make this fully accurate. And no harm is caused; we just don't - -- require -XTypeInType every time we need to. (We'll always require - -- -XDataKinds, though, so there's no standards-compliance issue.) - isFunTyCon tc || isKindTyCon tc - classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr @@ -1241,6 +1394,23 @@ dataConCannotMatch tys con | eq `hasKey` eqTyConKey -> [(ty1, ty2)] _ -> [] +-- | Were the type variables of the data con written in a different order +-- than the regular order (universal tyvars followed by existential tyvars)? +-- +-- This is not a cheap test, so we minimize its use in GHC as much as possible. +-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in +-- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once +-- during a data constructor's lifetime. + +-- See Note [DataCon user type variable binders], as well as +-- Note [Data con wrappers and GADT syntax] for an explanation of what +-- mkDataConRep is doing with this function. +dataConUserTyVarsArePermuted :: DataCon -> Bool +dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec + , dcUserTyVarBinders = user_tvbs }) = + (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs + {- %************************************************************************ %* * @@ -1319,8 +1489,8 @@ buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs where binders = mkTyConBindersPreferAnon ktvs liftedTypeKind -buildSynTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> Type -> TyCon +buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> KnotTied Type -> TyCon buildSynTyCon name binders res_kind roles rhs = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free where diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot index 0938b9b963..a69133463b 100644 --- a/compiler/basicTypes/DataCon.hs-boot +++ b/compiler/basicTypes/DataCon.hs-boot @@ -1,5 +1,7 @@ module DataCon where -import Var( TyVar, TyVarBinder ) + +import GhcPrelude +import Var( TyVar, TyCoVar, TyVarBinder ) import Name( Name, NamedThing ) import {-# SOURCE #-} TyCon( TyCon ) import FieldLabel ( FieldLabel ) @@ -11,19 +13,19 @@ import {-# SOURCE #-} TyCoRep ( Type, ThetaType ) data DataCon data DataConRep data EqSpec -filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder] dataConName :: DataCon -> Name dataConTyCon :: DataCon -> TyCon -dataConUnivTyVarBinders :: DataCon -> [TyVarBinder] -dataConExTyVars :: DataCon -> [TyVar] -dataConExTyVarBinders :: DataCon -> [TyVarBinder] +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConSourceArity :: DataCon -> Arity dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] dataConStupidTheta :: DataCon -> ThetaType dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type) + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +isUnboxedSumCon :: DataCon -> Bool instance Eq DataCon instance Uniquable DataCon diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index dfff0a2c92..071945386e 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -39,7 +39,7 @@ module Demand ( nopSig, botSig, exnSig, cprProdSig, isTopSig, hasDemandEnvSig, splitStrictSig, strictSigDmdEnv, - increaseStrictSigArity, + increaseStrictSigArity, etaExpandStrictSig, seqDemand, seqDemandList, seqDmdType, seqStrictSig, @@ -62,6 +62,8 @@ module Demand ( #include "HsVersions.h" +import GhcPrelude + import DynFlags import Outputable import Var ( Var ) @@ -1440,6 +1442,7 @@ postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) postProcessDmdResult :: Str () -> DmdResult -> DmdResult postProcessDmdResult Lazy _ = topRes postProcessDmdResult (Str ExnStr _) ThrowsExn = topRes -- Key point! +-- Note that only ThrowsExn results can be caught, not Diverges postProcessDmdResult _ res = res postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv @@ -1734,8 +1737,23 @@ splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) increaseStrictSigArity :: Int -> StrictSig -> StrictSig -- Add extra arguments to a strictness signature -increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) - = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res) +increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) + | isTopDmdType dmd_ty = sig + | arity_increase <= 0 = sig + | otherwise = StrictSig (DmdType env dmds' res) + where + dmds' = replicate arity_increase topDmd ++ dmds + +etaExpandStrictSig :: Arity -> StrictSig -> StrictSig +-- We are expanding (\x y. e) to (\x y z. e z) +-- Add exta demands to the /end/ of the arg demands if necessary +etaExpandStrictSig arity sig@(StrictSig dmd_ty@(DmdType env dmds res)) + | isTopDmdType dmd_ty = sig + | arity_increase <= 0 = sig + | otherwise = StrictSig (DmdType env dmds' res) + where + arity_increase = arity - length dmds + dmds' = dmds ++ replicate arity_increase topDmd isTopSig :: StrictSig -> Bool isTopSig (StrictSig ty) = isTopDmdType ty diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs index 8548fd2b72..d73dbd3ad3 100644 --- a/compiler/basicTypes/FieldLabel.hs +++ b/compiler/basicTypes/FieldLabel.hs @@ -69,6 +69,8 @@ module FieldLabel ( FieldLabelString , mkFieldLabelOccs ) where +import GhcPrelude + import OccName import Name diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 290e26291d..c1d281edd6 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -5,7 +5,7 @@ \section[Id]{@Ids@: Value and constructor identifiers} -} -{-# LANGUAGE ImplicitParams, CPP #-} +{-# LANGUAGE CPP #-} -- | -- #name_types# @@ -116,8 +116,11 @@ module Id ( #include "HsVersions.h" +import GhcPrelude + import DynFlags -import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding, Unfolding( NoUnfolding ) ) +import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding, + isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) import IdInfo import BasicTypes @@ -201,7 +204,7 @@ setIdNotExported :: Id -> Id setIdNotExported = Var.setIdNotExported localiseId :: Id -> Id --- Make an with the same unique and type as the +-- Make an Id with the same unique and type as the -- incoming Id, but with an *Internal* Name and *LocalId* flavour localiseId id | ASSERT( isId id ) isLocalId id && isInternalName name @@ -216,9 +219,9 @@ lazySetIdInfo = Var.lazySetIdInfo setIdInfo :: Id -> IdInfo -> Id setIdInfo id info = info `seq` (lazySetIdInfo id info) - -- Try to avoid spack leaks by seq'ing + -- Try to avoid space leaks by seq'ing -modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) -- maybeModifyIdInfo tries to avoid unnecessary thrashing @@ -513,7 +516,8 @@ hasNoBinding id = case Var.idDetails id of PrimOpId _ -> True -- See Note [Primop wrappers] FCallId _ -> True DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc - _ -> False + _ -> isCompulsoryUnfolding (idUnfolding id) + -- See Note [Levity-polymorphic Ids] isImplicitId :: Id -> Bool -- ^ 'isImplicitId' tells whether an 'Id's info is implied by other @@ -535,7 +539,25 @@ isImplicitId id idIsFrom :: Module -> Id -> Bool idIsFrom mod id = nameIsLocalOrFrom mod (idName id) -{- +{- Note [Levity-polymorphic Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some levity-polymorphic Ids must be applied and and inlined, not left +un-saturated. Example: + unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b + +This has a compulsory unfolding because we can't lambda-bind those +arguments. But the compulsory unfolding may leave levity-polymorphic +lambdas if it is not applied to enough arguments; e.g. (Trac #14561) + bad :: forall (a :: TYPE r). a -> a + bad = unsafeCoerce# + +The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop. +And we want that magic to apply to levity-polymorphic compulsory-inline things. +The easiest way to do this is for hasNoBinding to return True of all things +that have compulsory unfolding. A very Ids with a compulsory unfolding also +have a binding, but it does not harm to say they don't here, and its a very +simple way to fix Trac #14561. + Note [Primop wrappers] ~~~~~~~~~~~~~~~~~~~~~~ Currently hasNoBinding claims that PrimOpIds don't have a curried @@ -715,7 +737,7 @@ setIdCafInfo :: Id -> CafInfo -> Id setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id --------------------------------- - -- Occcurrence INFO + -- Occurrence INFO idOccInfo :: Id -> OccInfo idOccInfo id = occInfo (idInfo id) diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index bd6ec8f293..12ea490a53 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -29,7 +29,7 @@ module IdInfo ( -- ** Zapping various forms of Info zapLamInfo, zapFragileInfo, zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, - zapTailCallInfo, zapCallArityInfo, + zapTailCallInfo, zapCallArityInfo, zapUnfolding, -- ** The ArityInfo type ArityInfo, @@ -82,6 +82,8 @@ module IdInfo ( #include "HsVersions.h" +import GhcPrelude + import CoreSyn import Class @@ -261,7 +263,7 @@ setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } setOccInfo :: IdInfo -> OccInfo -> IdInfo setOccInfo info oc = oc `seq` info { occInfo = oc } - -- Try to avoid spack leaks by seq'ing + -- Try to avoid space leaks by seq'ing setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo setUnfoldingInfo info uf @@ -545,6 +547,11 @@ zapFragileUnfolding unf | isFragileUnfolding unf = noUnfolding | otherwise = unf +zapUnfolding :: Unfolding -> Unfolding +-- Squash all unfolding info, preserving only evaluated-ness +zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding + | otherwise = noUnfolding + zapTailCallInfo :: IdInfo -> Maybe IdInfo zapTailCallInfo info = case occInfo info of diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot index 0fabad3bbb..cacfe6af2e 100644 --- a/compiler/basicTypes/IdInfo.hs-boot +++ b/compiler/basicTypes/IdInfo.hs-boot @@ -1,4 +1,5 @@ module IdInfo where +import GhcPrelude import Outputable data IdInfo data IdDetails diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs index dadc79ce21..d397deaea8 100644 --- a/compiler/basicTypes/Lexeme.hs +++ b/compiler/basicTypes/Lexeme.hs @@ -2,7 +2,7 @@ -- -- Functions to evaluate whether or not a string is a valid identifier. -- There is considerable overlap between the logic here and the logic --- in Lexer.x, but sadly there seems to be way to merge them. +-- in Lexer.x, but sadly there seems to be no way to merge them. module Lexeme ( -- * Lexical characteristics of Haskell names @@ -27,6 +27,8 @@ module Lexeme ( ) where +import GhcPrelude + import FastString import Data.Char diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index f14606e8cf..21f4a92290 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -5,26 +5,30 @@ \section[Literal]{@Literal@: Machine literals (unboxed, of course)} -} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} module Literal ( -- * Main data type Literal(..) -- Exported to ParseIface + , LitNumType(..) -- ** Creating Literals - , mkMachInt, mkMachIntWrap - , mkMachWord, mkMachWordWrap + , mkMachInt, mkMachIntWrap, mkMachIntWrapC + , mkMachWord, mkMachWordWrap, mkMachWordWrapC , mkMachInt64, mkMachInt64Wrap , mkMachWord64, mkMachWord64Wrap , mkMachFloat, mkMachDouble , mkMachChar, mkMachString - , mkLitInteger + , mkLitInteger, mkLitNatural + , mkLitNumber, mkLitNumberWrap -- ** Operations on Literals , literalType , absentLiteralOf , pprLiteral + , litNumIsSigned + , litNumCheckRange -- ** Predicates on Literals and their contents , litIsDupable, litIsTrivial, litIsLifted @@ -35,6 +39,7 @@ module Literal -- ** Coercions , word2IntLit, int2WordLit + , narrowLit , narrow8IntLit, narrow16IntLit, narrow32IntLit , narrow8WordLit, narrow16WordLit, narrow32WordLit , char2IntLit, int2CharLit @@ -44,6 +49,8 @@ module Literal #include "HsVersions.h" +import GhcPrelude + import TysPrim import PrelNames import Type @@ -64,6 +71,7 @@ import Data.Word import Data.Char import Data.Maybe ( isJust ) import Data.Data ( Data ) +import Data.Proxy import Numeric ( fromRat ) {- @@ -93,6 +101,10 @@ data Literal -- First the primitive guys MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar' + | LitNumber !LitNumType !Integer Type + -- ^ Any numeric literal that can be + -- internally represented with an Integer + | MachStr ByteString -- ^ A string-literal: stored and emitted -- UTF-8 encoded, we'll arrange to decode it -- at runtime. Also emitted with a @'\0'@ @@ -102,11 +114,6 @@ data Literal -- that can be represented as a Literal. Create -- with 'nullAddrLit' - | MachInt Integer -- ^ @Int#@ - according to target machine - | MachInt64 Integer -- ^ @Int64#@ - exactly 64 bits - | MachWord Integer -- ^ @Word#@ - according to target machine - | MachWord64 Integer -- ^ @Word64#@ - exactly 64 bits - | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat' | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble' @@ -121,11 +128,28 @@ data Literal -- the label expects. Only applicable with -- @stdcall@ labels. @Just x@ => @\<x\>@ will -- be appended to label name when emitting assembly. - - | LitInteger Integer Type -- ^ Integer literals - -- See Note [Integer literals] deriving Data +-- | Numeric literal type +data LitNumType + = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) + | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) + | LitNumInt -- ^ @Int#@ - according to target machine + | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits + | LitNumWord -- ^ @Word#@ - according to target machine + | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits + deriving (Data,Enum,Eq,Ord) + +-- | Indicate if a numeric literal type supports negative numbers +litNumIsSigned :: LitNumType -> Bool +litNumIsSigned nt = case nt of + LitNumInteger -> True + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> False + LitNumWord64 -> False + {- Note [Integer literals] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -144,26 +168,33 @@ below), we don't have convenient access to the mkInteger Id. So we just use an error thunk, and fill in the real Id when we do tcIfaceLit in TcIface. +Note [Natural literals] +~~~~~~~~~~~~~~~~~~~~~~~ +Similar to Integer literals. -Binary instance -} +instance Binary LitNumType where + put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) + get bh = do + h <- getByte bh + return (toEnum (fromIntegral h)) + instance Binary Literal where put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab put_ bh (MachNullAddr) = do putByte bh 2 - put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad - put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae - put_ bh (MachWord af) = do putByte bh 5; put_ bh af - put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag - put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah - put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai + put_ bh (MachFloat ah) = do putByte bh 3; put_ bh ah + put_ bh (MachDouble ai) = do putByte bh 4; put_ bh ai put_ bh (MachLabel aj mb fod) - = do putByte bh 9 + = do putByte bh 5 put_ bh aj put_ bh mb put_ bh fod - put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i + put_ bh (LitNumber nt i _) + = do putByte bh 6 + put_ bh nt + put_ bh i get bh = do h <- getByte bh case h of @@ -176,32 +207,31 @@ instance Binary Literal where 2 -> do return (MachNullAddr) 3 -> do - ad <- get bh - return (MachInt ad) - 4 -> do - ae <- get bh - return (MachInt64 ae) - 5 -> do - af <- get bh - return (MachWord af) - 6 -> do - ag <- get bh - return (MachWord64 ag) - 7 -> do ah <- get bh return (MachFloat ah) - 8 -> do + 4 -> do ai <- get bh return (MachDouble ai) - 9 -> do + 5 -> do aj <- get bh mb <- get bh fod <- get bh return (MachLabel aj mb fod) _ -> do - i <- get bh - -- See Note [Integer literals] - return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger") + nt <- get bh + i <- get bh + let t = case nt of + LitNumInt -> intPrimTy + LitNumInt64 -> int64PrimTy + LitNumWord -> wordPrimTy + LitNumWord64 -> word64PrimTy + -- See Note [Integer literals] + LitNumInteger -> + panic "Evaluated the place holder for mkInteger" + -- and Note [Natural literals] + LitNumNatural -> + panic "Evaluated the place holder for mkNatural" + return (LitNumber nt i t) instance Outputable Literal where ppr lit = pprLiteral (\d -> d) lit @@ -240,55 +270,116 @@ doesn't yield a warning. Instead we simply squash the value into the *target* Int/Word range. -} +-- | Wrap a literal number according to its type +wrapLitNumber :: DynFlags -> Literal -> Literal +wrapLitNumber dflags v@(LitNumber nt i t) = case nt of + LitNumInt -> case platformWordSize (targetPlatform dflags) of + 4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t + 8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w) + LitNumWord -> case platformWordSize (targetPlatform dflags) of + 4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t + 8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w) + LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + LitNumInteger -> v + LitNumNatural -> v +wrapLitNumber _ x = x + +-- | Create a numeric 'Literal' of the given type +mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal +mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t) + +-- | Check that a given number is in the range of a numeric literal +litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool +litNumCheckRange dflags nt i = case nt of + LitNumInt -> inIntRange dflags i + LitNumWord -> inWordRange dflags i + LitNumInt64 -> inInt64Range i + LitNumWord64 -> inWord64Range i + LitNumNatural -> i >= 0 + LitNumInteger -> True + +-- | Create a numeric 'Literal' of the given type +mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal +mkLitNumber dflags nt i t = + ASSERT2(litNumCheckRange dflags nt i, integer i) + (LitNumber nt i t) + -- | Creates a 'Literal' of type @Int#@ mkMachInt :: DynFlags -> Integer -> Literal mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x ) - MachInt x + (mkMachIntUnchecked x) -- | Creates a 'Literal' of type @Int#@. -- If the argument is out of the (target-dependent) range, it is wrapped. -- See Note [Word/Int underflow/overflow] mkMachIntWrap :: DynFlags -> Integer -> Literal -mkMachIntWrap dflags i - = MachInt $ case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (fromIntegral i :: Int32) - 8 -> toInteger (fromIntegral i :: Int64) - w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w) +mkMachIntWrap dflags i = wrapLitNumber dflags $ mkMachIntUnchecked i + +-- | Creates a 'Literal' of type @Int#@ without checking its range. +mkMachIntUnchecked :: Integer -> Literal +mkMachIntUnchecked i = LitNumber LitNumInt i intPrimTy + +-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating +-- overflow. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the overflow flag will be set. +-- See Note [Word/Int underflow/overflow] +mkMachIntWrapC :: DynFlags -> Integer -> (Literal, Bool) +mkMachIntWrapC dflags i = (n, i /= i') + where + n@(LitNumber _ i' _) = mkMachIntWrap dflags i -- | Creates a 'Literal' of type @Word#@ mkMachWord :: DynFlags -> Integer -> Literal mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x ) - MachWord x + (mkMachWordUnchecked x) -- | Creates a 'Literal' of type @Word#@. -- If the argument is out of the (target-dependent) range, it is wrapped. -- See Note [Word/Int underflow/overflow] mkMachWordWrap :: DynFlags -> Integer -> Literal -mkMachWordWrap dflags i - = MachWord $ case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (fromInteger i :: Word32) - 8 -> toInteger (fromInteger i :: Word64) - w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w) +mkMachWordWrap dflags i = wrapLitNumber dflags $ mkMachWordUnchecked i + +-- | Creates a 'Literal' of type @Word#@ without checking its range. +mkMachWordUnchecked :: Integer -> Literal +mkMachWordUnchecked i = LitNumber LitNumWord i wordPrimTy + +-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating +-- carry. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the carry flag will be set. +-- See Note [Word/Int underflow/overflow] +mkMachWordWrapC :: DynFlags -> Integer -> (Literal, Bool) +mkMachWordWrapC dflags i = (n, i /= i') + where + n@(LitNumber _ i' _) = mkMachWordWrap dflags i -- | Creates a 'Literal' of type @Int64#@ mkMachInt64 :: Integer -> Literal -mkMachInt64 x = ASSERT2( inInt64Range x, integer x ) - MachInt64 x +mkMachInt64 x = ASSERT2( inInt64Range x, integer x ) (mkMachInt64Unchecked x) -- | Creates a 'Literal' of type @Int64#@. -- If the argument is out of the range, it is wrapped. -mkMachInt64Wrap :: Integer -> Literal -mkMachInt64Wrap i = MachInt64 (toInteger (fromIntegral i :: Int64)) +mkMachInt64Wrap :: DynFlags -> Integer -> Literal +mkMachInt64Wrap dflags i = wrapLitNumber dflags $ mkMachInt64Unchecked i + +-- | Creates a 'Literal' of type @Int64#@ without checking its range. +mkMachInt64Unchecked :: Integer -> Literal +mkMachInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy -- | Creates a 'Literal' of type @Word64#@ mkMachWord64 :: Integer -> Literal -mkMachWord64 x = ASSERT2( inWord64Range x, integer x ) - MachWord64 x +mkMachWord64 x = ASSERT2( inWord64Range x, integer x ) (mkMachWord64Unchecked x) -- | Creates a 'Literal' of type @Word64#@. -- If the argument is out of the range, it is wrapped. -mkMachWord64Wrap :: Integer -> Literal -mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64)) +mkMachWord64Wrap :: DynFlags -> Integer -> Literal +mkMachWord64Wrap dflags i = wrapLitNumber dflags $ mkMachWord64Unchecked i + +-- | Creates a 'Literal' of type @Word64#@ without checking its range. +mkMachWord64Unchecked :: Integer -> Literal +mkMachWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy -- | Creates a 'Literal' of type @Float#@ mkMachFloat :: Rational -> Literal @@ -309,12 +400,19 @@ mkMachString :: String -> Literal mkMachString s = MachStr (fastStringToByteString $ mkFastString s) mkLitInteger :: Integer -> Type -> Literal -mkLitInteger = LitInteger +mkLitInteger x ty = LitNumber LitNumInteger x ty + +mkLitNatural :: Integer -> Type -> Literal +mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) + (LitNumber LitNumNatural x ty) inIntRange, inWordRange :: DynFlags -> Integer -> Bool inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags +inNaturalRange :: Integer -> Bool +inNaturalRange x = x >= 0 + inInt64Range, inWord64Range :: Integer -> Bool inInt64Range x = x >= toInteger (minBound :: Int64) && x <= toInteger (maxBound :: Int64) @@ -326,49 +424,39 @@ inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR -- | Tests whether the literal represents a zero of whatever type it is isZeroLit :: Literal -> Bool -isZeroLit (MachInt 0) = True -isZeroLit (MachInt64 0) = True -isZeroLit (MachWord 0) = True -isZeroLit (MachWord64 0) = True -isZeroLit (MachFloat 0) = True -isZeroLit (MachDouble 0) = True -isZeroLit _ = False +isZeroLit (LitNumber _ 0 _) = True +isZeroLit (MachFloat 0) = True +isZeroLit (MachDouble 0) = True +isZeroLit _ = False -- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'. +-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. litValue :: Literal -> Integer litValue l = case isLitValue_maybe l of Just x -> x Nothing -> pprPanic "litValue" (ppr l) -- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'. +-- sense, i.e. for 'Char' and numbers. isLitValue_maybe :: Literal -> Maybe Integer -isLitValue_maybe (MachChar c) = Just $ toInteger $ ord c -isLitValue_maybe (MachInt i) = Just i -isLitValue_maybe (MachInt64 i) = Just i -isLitValue_maybe (MachWord i) = Just i -isLitValue_maybe (MachWord64 i) = Just i -isLitValue_maybe (LitInteger i _) = Just i -isLitValue_maybe _ = Nothing +isLitValue_maybe (MachChar c) = Just $ toInteger $ ord c +isLitValue_maybe (LitNumber _ i _) = Just i +isLitValue_maybe _ = Nothing -- | Apply a function to the 'Integer' contained in the 'Literal', for when that --- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For --- fixed-size integral literals, the result will be wrapped in --- accordance with the semantics of the target type. +-- makes sense, e.g. for 'Char' and numbers. +-- For fixed-size integral literals, the result will be wrapped in accordance +-- with the semantics of the target type. -- See Note [Word/Int underflow/overflow] mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal -mapLitValue _ f (MachChar c) = mkMachChar (fchar c) +mapLitValue _ f (MachChar c) = mkMachChar (fchar c) where fchar = chr . fromInteger . f . toInteger . ord -mapLitValue dflags f (MachInt i) = mkMachIntWrap dflags (f i) -mapLitValue _ f (MachInt64 i) = mkMachInt64Wrap (f i) -mapLitValue dflags f (MachWord i) = mkMachWordWrap dflags (f i) -mapLitValue _ f (MachWord64 i) = mkMachWord64Wrap (f i) -mapLitValue _ f (LitInteger i t) = mkLitInteger (f i) t -mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) +mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags + (LitNumber nt (f i) t) +mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) -- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', --- 'Int', 'Word' and 'LitInteger'. +-- 'Int', 'Word', 'LitInteger' and 'LitNatural'. isLitValue :: Literal -> Bool isLitValue = isJust . isLitValue_maybe @@ -385,43 +473,42 @@ narrow8IntLit, narrow16IntLit, narrow32IntLit, :: Literal -> Literal word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal -word2IntLit dflags (MachWord w) - | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1) - | otherwise = MachInt w +word2IntLit dflags (LitNumber LitNumWord w _) + | w > tARGET_MAX_INT dflags = mkMachInt dflags (w - tARGET_MAX_WORD dflags - 1) + | otherwise = mkMachInt dflags w word2IntLit _ l = pprPanic "word2IntLit" (ppr l) -int2WordLit dflags (MachInt i) - | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD - | otherwise = MachWord i +int2WordLit dflags (LitNumber LitNumInt i _) + | i < 0 = mkMachWord dflags (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD + | otherwise = mkMachWord dflags i int2WordLit _ l = pprPanic "int2WordLit" (ppr l) -narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) -narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l) -narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16)) -narrow16IntLit l = pprPanic "narrow16IntLit" (ppr l) -narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32)) -narrow32IntLit l = pprPanic "narrow32IntLit" (ppr l) -narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8)) -narrow8WordLit l = pprPanic "narrow8WordLit" (ppr l) -narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16)) -narrow16WordLit l = pprPanic "narrow16WordLit" (ppr l) -narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32)) -narrow32WordLit l = pprPanic "narrow32WordLit" (ppr l) - -char2IntLit (MachChar c) = MachInt (toInteger (ord c)) +-- | Narrow a literal number (unchecked result range) +narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal +narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t +narrowLit _ l = pprPanic "narrowLit" (ppr l) + +narrow8IntLit = narrowLit (Proxy :: Proxy Int8) +narrow16IntLit = narrowLit (Proxy :: Proxy Int16) +narrow32IntLit = narrowLit (Proxy :: Proxy Int32) +narrow8WordLit = narrowLit (Proxy :: Proxy Word8) +narrow16WordLit = narrowLit (Proxy :: Proxy Word16) +narrow32WordLit = narrowLit (Proxy :: Proxy Word32) + +char2IntLit (MachChar c) = mkMachIntUnchecked (toInteger (ord c)) char2IntLit l = pprPanic "char2IntLit" (ppr l) -int2CharLit (MachInt i) = MachChar (chr (fromInteger i)) -int2CharLit l = pprPanic "int2CharLit" (ppr l) +int2CharLit (LitNumber _ i _) = MachChar (chr (fromInteger i)) +int2CharLit l = pprPanic "int2CharLit" (ppr l) -float2IntLit (MachFloat f) = MachInt (truncate f) +float2IntLit (MachFloat f) = mkMachIntUnchecked (truncate f) float2IntLit l = pprPanic "float2IntLit" (ppr l) -int2FloatLit (MachInt i) = MachFloat (fromInteger i) -int2FloatLit l = pprPanic "int2FloatLit" (ppr l) +int2FloatLit (LitNumber _ i _) = MachFloat (fromInteger i) +int2FloatLit l = pprPanic "int2FloatLit" (ppr l) -double2IntLit (MachDouble f) = MachInt (truncate f) +double2IntLit (MachDouble f) = mkMachIntUnchecked (truncate f) double2IntLit l = pprPanic "double2IntLit" (ppr l) -int2DoubleLit (MachInt i) = MachDouble (fromInteger i) -int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) +int2DoubleLit (LitNumber _ i _) = MachDouble (fromInteger i) +int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) float2DoubleLit (MachFloat f) = MachDouble f float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) @@ -472,24 +559,41 @@ nullAddrLit = MachNullAddr litIsTrivial :: Literal -> Bool -- c.f. CoreUtils.exprIsTrivial litIsTrivial (MachStr _) = False -litIsTrivial (LitInteger {}) = False +litIsTrivial (LitNumber nt _ _) = case nt of + LitNumInteger -> False + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True litIsTrivial _ = True -- | True if code space does not go bad if we duplicate this literal --- Currently we treat it just like 'litIsTrivial' litIsDupable :: DynFlags -> Literal -> Bool -- c.f. CoreUtils.exprIsDupable litIsDupable _ (MachStr _) = False -litIsDupable dflags (LitInteger i _) = inIntRange dflags i +litIsDupable dflags (LitNumber nt i _) = case nt of + LitNumInteger -> inIntRange dflags i + LitNumNatural -> inIntRange dflags i + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True litIsDupable _ _ = True litFitsInChar :: Literal -> Bool -litFitsInChar (MachInt i) = i >= toInteger (ord minBound) - && i <= toInteger (ord maxBound) -litFitsInChar _ = False +litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False litIsLifted :: Literal -> Bool -litIsLifted (LitInteger {}) = True +litIsLifted (LitNumber nt _ _) = case nt of + LitNumInteger -> True + LitNumNatural -> True + LitNumInt -> False + LitNumInt64 -> False + LitNumWord -> False + LitNumWord64 -> False litIsLifted _ = False {- @@ -499,32 +603,29 @@ litIsLifted _ = False -- | Find the Haskell 'Type' the literal occupies literalType :: Literal -> Type -literalType MachNullAddr = addrPrimTy -literalType (MachChar _) = charPrimTy -literalType (MachStr _) = addrPrimTy -literalType (MachInt _) = intPrimTy -literalType (MachWord _) = wordPrimTy -literalType (MachInt64 _) = int64PrimTy -literalType (MachWord64 _) = word64PrimTy -literalType (MachFloat _) = floatPrimTy -literalType (MachDouble _) = doublePrimTy +literalType MachNullAddr = addrPrimTy +literalType (MachChar _) = charPrimTy +literalType (MachStr _) = addrPrimTy +literalType (MachFloat _) = floatPrimTy +literalType (MachDouble _) = doublePrimTy literalType (MachLabel _ _ _) = addrPrimTy -literalType (LitInteger _ t) = t +literalType (LitNumber _ _ t) = t absentLiteralOf :: TyCon -> Maybe Literal --- Return a literal of the appropriate primtive +-- Return a literal of the appropriate primitive -- TyCon, to use as a placeholder when it doesn't matter absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) absent_lits :: UniqFM Literal absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr) , (charPrimTyConKey, MachChar 'x') - , (intPrimTyConKey, MachInt 0) - , (int64PrimTyConKey, MachInt64 0) + , (intPrimTyConKey, mkMachIntUnchecked 0) + , (int64PrimTyConKey, mkMachInt64Unchecked 0) + , (wordPrimTyConKey, mkMachWordUnchecked 0) + , (word64PrimTyConKey, mkMachWord64Unchecked 0) , (floatPrimTyConKey, MachFloat 0) , (doublePrimTyConKey, MachDouble 0) - , (wordPrimTyConKey, MachWord 0) - , (word64PrimTyConKey, MachWord64 0) ] + ] {- Comparison @@ -532,32 +633,27 @@ absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr) -} cmpLit :: Literal -> Literal -> Ordering -cmpLit (MachChar a) (MachChar b) = a `compare` b -cmpLit (MachStr a) (MachStr b) = a `compare` b -cmpLit (MachNullAddr) (MachNullAddr) = EQ -cmpLit (MachInt a) (MachInt b) = a `compare` b -cmpLit (MachWord a) (MachWord b) = a `compare` b -cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b -cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b -cmpLit (MachFloat a) (MachFloat b) = a `compare` b -cmpLit (MachDouble a) (MachDouble b) = a `compare` b +cmpLit (MachChar a) (MachChar b) = a `compare` b +cmpLit (MachStr a) (MachStr b) = a `compare` b +cmpLit (MachNullAddr) (MachNullAddr) = EQ +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 (LitInteger a _) (LitInteger b _) = a `compare` b -cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT - | otherwise = GT +cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) + | nt1 == nt2 = a `compare` b + | otherwise = nt1 `compare` nt2 +cmpLit lit1 lit2 + | litTag lit1 < litTag lit2 = LT + | otherwise = GT litTag :: Literal -> Int litTag (MachChar _) = 1 litTag (MachStr _) = 2 litTag (MachNullAddr) = 3 -litTag (MachInt _) = 4 -litTag (MachWord _) = 5 -litTag (MachInt64 _) = 6 -litTag (MachWord64 _) = 7 -litTag (MachFloat _) = 8 -litTag (MachDouble _) = 9 -litTag (MachLabel _ _ _) = 10 -litTag (LitInteger {}) = 11 +litTag (MachFloat _) = 4 +litTag (MachDouble _) = 5 +litTag (MachLabel _ _ _) = 6 +litTag (LitNumber {}) = 7 {- Printing @@ -569,13 +665,16 @@ pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc pprLiteral _ (MachChar c) = pprPrimChar c pprLiteral _ (MachStr s) = pprHsBytes s pprLiteral _ (MachNullAddr) = text "__NULL" -pprLiteral _ (MachInt i) = pprPrimInt i -pprLiteral _ (MachInt64 i) = pprPrimInt64 i -pprLiteral _ (MachWord w) = pprPrimWord w -pprLiteral _ (MachWord64 w) = pprPrimWord64 w pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix -pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i +pprLiteral add_par (LitNumber nt i _) + = case nt of + LitNumInteger -> pprIntegerVal add_par i + LitNumNatural -> pprIntegerVal add_par i + LitNumInt -> pprPrimInt i + LitNumInt64 -> pprPrimInt64 i + LitNumWord -> pprPrimWord i + LitNumWord64 -> pprPrimWord64 i pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod) where b = case mb of Nothing -> pprHsString l diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index a404e74e12..5a6f1fbf96 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -19,17 +19,14 @@ module MkId ( mkPrimOpId, mkFCallId, - wrapNewTypeBody, unwrapNewTypeBody, - wrapFamInstBody, unwrapFamInstScrut, - wrapTypeUnbranchedFamInstBody, unwrapTypeUnbranchedFamInstScrut, - + unwrapNewTypeBody, wrapFamInstBody, DataConBoxer(..), mkDataConRep, mkDataConWorkId, -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, unsafeCoerceName, unsafeCoerceId, realWorldPrimId, voidPrimId, voidArgId, - nullAddrId, seqId, lazyId, lazyIdKey, runRWId, + nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, magicDictId, coerceId, proxyHashId, noinlineId, noinlineIdName, @@ -39,6 +36,8 @@ module MkId ( #include "HsVersions.h" +import GhcPrelude + import Rules import TysPrim import TysWiredIn @@ -52,7 +51,6 @@ import CoreUtils ( exprType, mkCast ) import CoreUnfold import Literal import TyCon -import CoAxiom import Class import NameSet import Name @@ -86,59 +84,75 @@ import Data.Maybe ( maybeToList ) Note [Wired-in Ids] ~~~~~~~~~~~~~~~~~~~ +A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') +rather than by looking it up its name in some environment or fetching +it from an interface file. + There are several reasons why an Id might appear in the wiredInIds: -(1) The ghcPrimIds are wired in because they can't be defined in - Haskell at all, although the can be defined in Core. They have - compulsory unfoldings, so they are always inlined and they have - no definition site. Their home module is GHC.Prim, so they - also have a description in primops.txt.pp, where they are called - 'pseudoops'. +* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] + +* magicIds: see Note [magicIds] + +* errorIds, defined in coreSyn/MkCore.hs. + These error functions (e.g. rUNTIME_ERROR_ID) are wired in + because the desugarer generates code that mentions them directly + +In all cases except ghcPrimIds, there is a definition site in a +library module, which may be called (e.g. in higher order situations); +but the wired-in version means that the details are never read from +that module's interface file; instead, the full definition is right +here. + +Note [ghcPrimIds (aka pseudoops)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ghcPrimIds + + * Are exported from GHC.Prim + + * Can't be defined in Haskell, and hence no Haskell binding site, + but have perfectly reasonable unfoldings in Core + + * Either have a CompulsoryUnfolding (hence always inlined), or + of an EvaldUnfolding and void representation (e.g. void#) -(2) The 'error' function, eRROR_ID, is wired in because we don't yet have - a way to express in an interface file that the result type variable - is 'open'; that is can be unified with an unboxed type + * Are (or should be) defined in primops.txt.pp as 'pseudoop' + Reason: that's how we generate documentation for them - [The interface file format now carry such information, but there's - no way yet of expressing at the definition site for these - error-reporting functions that they have an 'open' - result type. -- sof 1/99] +Note [magicIds] +~~~~~~~~~~~~~~~ +The magicIds -(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because - the desugarer generates code that mentions them directly, and - (b) for the same reason as eRROR_ID + * Are exported from GHC.Magic -(4) lazyId is wired in because the wired-in version overrides the - strictness of the version defined in GHC.Base + * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). + This definition at least generates Haddock documentation for them. -(5) noinlineId is wired in because when we serialize to interfaces - we may insert noinline statements. + * May or may not have a CompulsoryUnfolding. -In cases (2-4), the function has a definition in a library module, and -can be called; but the wired-in version means that the details are -never read from that module's interface file; instead, the full definition -is right here. + * But have some special behaviour that can't be done via an + unfolding from an interface file -} wiredInIds :: [Id] wiredInIds - = [lazyId, dollarId, oneShotId, runRWId, noinlineId] - ++ errorIds -- Defined in MkCore + = magicIds ++ ghcPrimIds + ++ errorIds -- Defined in MkCore + +magicIds :: [Id] -- See Note [magicIds] +magicIds = [lazyId, oneShotId, noinlineId] --- These Ids are exported from GHC.Prim -ghcPrimIds :: [Id] +ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds - = [ -- These can't be defined in Haskell, but they have - -- perfectly reasonable unfoldings in Core - realWorldPrimId, - voidPrimId, - unsafeCoerceId, - nullAddrId, - seqId, - magicDictId, - coerceId, - proxyHashId + = [ realWorldPrimId + , voidPrimId + , unsafeCoerceId + , nullAddrId + , seqId + , magicDictId + , coerceId + , proxyHashId ] {- @@ -232,6 +246,47 @@ Hence we translate to -- Coercion from family type to representation type Co7T a :: T [a] ~ :R7T a +Newtype instances through an additional wrinkle into the mix. Consider the +following example (adapted from #15318, comment:2): + + data family T a + newtype instance T [a] = MkT [a] + +Within the newtype instance, there are three distinct types at play: + +1. The newtype's underlying type, [a]. +2. The instance's representation type, TList a (where TList is the + representation tycon). +3. The family type, T [a]. + +We need two coercions in order to cast from (1) to (3): + +(a) A newtype coercion axiom: + + axiom coTList a :: TList a ~ [a] + + (Where TList is the representation tycon of the newtype instance.) + +(b) A data family instance coercion axiom: + + axiom coT a :: T [a] ~ TList a + +When we translate the newtype instance to Core, we obtain: + + -- Wrapper + $WMkT :: forall a. [a] -> T [a] + $WMkT a x = MkT a x |> Sym (coT a) + + -- Worker + MkT :: forall a. [a] -> TList [a] + MkT a x = x |> Sym (coTList a) + +Unlike for data instances, the worker for a newtype instance is actually an +executable function which expands to a cast, but otherwise, the general +strategy is essentially the same as for data instances. Also note that we have +a wrapper, which is unusual for a newtype, but we make GHC produce one anyway +for symmetry with the way data instances are handled. + Note [Newtype datacons] ~~~~~~~~~~~~~~~~~~~~~~~ The "data constructor" for a newtype should always be vanilla. At one @@ -276,7 +331,7 @@ mkDictSelId name clas sel_names = map idName (classAllSelIds clas) new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVarBinders data_con + tyvars = dataConUserTyVarBinders data_con n_ty_args = length tyvars arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name @@ -339,7 +394,8 @@ mkDictSelRhs clas val_index dict_id = mkTemplateLocal 1 pred arg_ids = mkTemplateLocalsNum 2 arg_tys - rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id) + rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) + (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] -- varToCoreExpr needed for equality superclass selectors @@ -390,17 +446,19 @@ mkDataConWorkId wkr_name data_con wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con) -- Note [Data-con worker strictness] - -- Notice that we do *not* say the worker is strict + -- Notice that we do *not* say the worker Id 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 - -- expressions 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 + -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has + -- case expressions that do the evals) but the *worker* MkT itself is + -- not. If we pretend it is strict then when we see + -- case x of y -> MkT y -- the simplifier thinks that y is "sure to be evaluated" (because - -- $wMkT is strict) and drops the case. No, $wMkT is not strict. + -- the worker MkT is strict) and drops the case. No, the workerId + -- MkT is not strict. -- - -- When the simplifier sees a pattern + -- However, the worker does have StrictnessMarks. When the simplifier + -- 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 @@ -408,7 +466,7 @@ mkDataConWorkId wkr_name data_con ----------- Workers for newtypes -------------- (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con - res_ty_args = mkTyVarTys nt_tvs + res_ty_args = mkTyCoVarTys nt_tvs nt_wrap_ty = dataConUserType data_con nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 @@ -427,7 +485,7 @@ dataConCPR :: DataCon -> DmdResult dataConCPR con | isDataTyCon tycon -- Real data types only; that is, -- not unboxed tuples or newtypes - , null (dataConExTyVars con) -- No existentials + , null (dataConExTyCoVars con) -- No existentials , wkr_arity > 0 , wkr_arity <= mAX_CPR_SIZE = if is_prod then vanillaCprProdRes (dataConRepArity con) @@ -528,12 +586,16 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con) - wrap_arg_dmds = map mk_dmd arg_ibangs + wrap_arg_dmds = + replicate (length theta) topDmd ++ map mk_dmd arg_ibangs + -- Don't forget the dictionary arguments when building + -- the strictness signature (#14290). + mk_dmd str | isBanged str = evalDmd | otherwise = topDmd wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` - ActiveAfter NoSourceText 2 + activeAfterInitial -- See Note [Activation for data constructor wrappers] -- The wrapper will usually be inlined (see wrap_unf), so its @@ -545,7 +607,6 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con -- Passing Nothing here allows the wrapper to inline when -- unsaturated. wrap_unf = mkInlineUnfolding wrap_rhs - wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs wrap_rhs = mkLams wrap_tvs $ mkLams wrap_args $ wrapFamInstBody tycon res_ty_args $ @@ -560,6 +621,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) = dataConFullSig data_con + wrap_tvs = dataConUserTyVars data_con res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs tycon = dataConTyCon data_con -- The representation TyCon (not family) @@ -570,7 +632,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con orig_bangs = dataConSrcBangs data_con wrap_arg_tys = theta ++ orig_arg_tys - wrap_arity = length wrap_arg_tys + wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys -- The wrap_args are the arguments *other than* the eq_spec -- Because we are going to apply the eq_spec args manually in the -- wrapper @@ -587,11 +649,20 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con (unboxers, boxers) = unzip wrappers (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) - wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker - && (any isBanged (ev_ibangs ++ arg_ibangs) - -- Some forcing/unboxing (includes eq_spec) - || isFamInstTyCon tycon -- Cast result - || (not $ null eq_spec)) -- GADT + wrapper_reqd = + (not (isNewTyCon tycon) + -- (Most) newtypes have only a worker, with the exception + -- of some newtypes written with GADT syntax. See below. + && (any isBanged (ev_ibangs ++ arg_ibangs) + -- Some forcing/unboxing (includes eq_spec) + || (not $ null eq_spec))) -- GADT + || isFamInstTyCon tycon -- Cast result + || dataConUserTyVarsArePermuted data_con + -- If the data type was written with GADT syntax and + -- orders the type variables differently from what the + -- worker expects, it needs a data con wrapper to reorder + -- the type variables. + -- See Note [Data con wrappers and GADT syntax]. initial_wrap_app = Var (dataConWorkId data_con) `mkTyApps` res_ty_args @@ -602,8 +673,8 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con mk_boxer boxers = DCB (\ ty_args src_vars -> do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars subst1 = zipTvSubst univ_tvs ty_args - subst2 = extendTvSubstList subst1 ex_tvs - (mkTyVarTys ex_vars) + subst2 = extendTCvSubstList subst1 ex_tvs + (mkTyCoVarTys ex_vars) ; (rep_ids, binds) <- go subst2 boxers term_vars ; return (ex_vars ++ rep_ids, binds) } ) @@ -669,6 +740,40 @@ For a start, it's still to generate a no-op. But worse, since wrappers are currently injected at TidyCore, we don't even optimise it away! So the stupid case expression stays there. This actually happened for the Integer data type (see Trac #1600 comment:66)! + +Note [Data con wrappers and GADT syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two very similar data types: + + data T1 a b = MkT1 b + + data T2 a b where + MkT2 :: forall b a. b -> T2 a b + +Despite their similar appearance, T2 will have a data con wrapper but T1 will +not. What sets them apart? The types of their constructors, which are: + + MkT1 :: forall a b. b -> T1 a b + MkT2 :: forall b a. b -> T2 a b + +MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` +would normally appear. See Note [DataCon user type variable binders] in DataCon +for further discussion on this topic. + +The worker data cons for T1 and T2, however, both have types such that `a` is +expected to come before `b` as arguments. Because MkT2 permutes this order, it +needs a data con wrapper to swizzle around the type variables to be in the +order the worker expects. + +A somewhat surprising consequence of this is that *newtypes* can have data con +wrappers! After all, a newtype can also be written with GADT syntax: + + newtype T3 a b where + MkT3 :: forall b a. b -> T3 a b + +Again, this needs a wrapper data con to reorder the type variables. It does +mean that this newtype constructor requires another level of indirection when +being called, but the inliner should make swift work of that. -} ------------------------- @@ -788,7 +893,8 @@ dataConArgUnpack arg_ty -- A recursive newtype might mean that -- 'arg_ty' is a newtype , let rep_tys = dataConInstArgTys con tc_args - = ASSERT( isVanillaDataCon con ) + = ASSERT( null (dataConExTyCoVars con) ) + -- Note [Unpacking GADTs and existentials] ( rep_tys `zip` dataConRepStrictness con ,( \ arg_id -> do { rep_ids <- mapM newLocal rep_tys @@ -812,31 +918,33 @@ isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool -- we encounter on the way, because otherwise we might well -- end up relying on ourselves! isUnpackableType dflags fam_envs ty - | Just (tc, _) <- splitTyConApp_maybe ty - , Just con <- tyConSingleAlgDataCon_maybe tc - , isVanillaDataCon con - = ok_con_args (unitNameSet (getName tc)) con + | Just data_con <- unpackable_type ty + = ok_con_args emptyNameSet data_con | otherwise = False where - ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty - where - norm_ty = topNormaliseType fam_envs ty - ok_ty tcs ty - | Just (tc, _) <- splitTyConApp_maybe ty - , let tc_name = getName tc - = not (tc_name `elemNameSet` tcs) - && case tyConSingleAlgDataCon_maybe tc of - Just con | isVanillaDataCon con - -> ok_con_args (tcs `extendNameSet` getName tc) con - _ -> True + ok_con_args dcs con + | dc_name `elemNameSet` dcs + = False + | otherwise + = all (ok_arg dcs') + (dataConOrigArgTys con `zip` dataConSrcBangs con) + -- NB: dataConSrcBangs gives the *user* request; + -- We'd get a black hole if we used dataConImplBangs + where + dc_name = getName con + dcs' = dcs `extendNameSet` dc_name + + ok_arg dcs (ty, bang) + = not (attempt_unpack bang) || ok_ty dcs norm_ty + where + norm_ty = topNormaliseType fam_envs ty + + ok_ty dcs ty + | Just data_con <- unpackable_type ty + = ok_con_args dcs data_con | otherwise - = True - - ok_con_args tcs con - = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con) - -- NB: dataConSrcBangs gives the *user* request; - -- We'd get a black hole if we used dataConImplBangs + = True -- NB True here, in contrast to False at top level attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) = xopt LangExt.StrictData dflags @@ -848,7 +956,31 @@ isUnpackableType dflags fam_envs ty = xopt LangExt.StrictData dflags -- Be conservative attempt_unpack _ = False + unpackable_type :: Type -> Maybe DataCon + -- Works just on a single level + unpackable_type ty + | Just (tc, _) <- splitTyConApp_maybe ty + , Just data_con <- tyConSingleAlgDataCon_maybe tc + , null (dataConExTyCoVars data_con) + -- See Note [Unpacking GADTs and existentials] + = Just data_con + | otherwise + = Nothing + {- +Note [Unpacking GADTs and existentials] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is nothing stopping us unpacking a data type with equality +components, like + data Equal a b where + Equal :: Equal a a + +And it'd be fine to unpack a product type with existential components +too, but that would require a bit more plumbing, so currently we don't. + +So for now we require: null (dataConExTyCoVars data_con) +See Trac #14978 + Note [Unpack one-wide fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The flag UnboxSmallStrictFields ensures that any field that can @@ -920,15 +1052,9 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- -- If a coercion constructor is provided in the newtype, then we use -- it, otherwise the wrap/unwrap are both no-ops --- --- If the we are dealing with a newtype *instance*, we have a second coercion --- identifying the family instance with the constructor of the newtype --- instance. This coercion is applied in any case (ie, composed with the --- coercion constructor of the newtype or applied by itself). wrapNewTypeBody tycon args result_expr = ASSERT( isNewTyCon tycon ) - wrapFamInstBody tycon args $ mkCast result_expr (mkSymCo co) where co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] @@ -955,35 +1081,6 @@ wrapFamInstBody tycon args body | otherwise = body --- Same as `wrapFamInstBody`, but for type family instances, which are --- represented by a `CoAxiom`, and not a `TyCon` -wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> [Coercion] - -> CoreExpr -> CoreExpr -wrapTypeFamInstBody axiom ind args cos body - = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args cos)) - -wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> [Coercion] - -> CoreExpr -> CoreExpr -wrapTypeUnbranchedFamInstBody axiom - = wrapTypeFamInstBody axiom 0 - -unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr -unwrapFamInstScrut tycon args scrut - | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args []) -- data instances only - | otherwise - = scrut - -unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> [Coercion] - -> CoreExpr -> CoreExpr -unwrapTypeFamInstScrut axiom ind args cos scrut - = mkCast scrut (mkAxInstCo Representational axiom ind args cos) - -unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> [Coercion] - -> CoreExpr -> CoreExpr -unwrapTypeUnbranchedFamInstScrut axiom - = unwrapTypeFamInstScrut axiom 0 - {- ************************************************************************ * * @@ -1042,7 +1139,7 @@ mkFCallId dflags uniq fcall ty `setLevityInfoWithType` ty (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyBinder bndrs + arity = count isAnonTyCoBinder bndrs strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes -- the call does not claim to be strict in its arguments, since they -- may be lifted (foreign import prim) and the called code doesn't @@ -1107,36 +1204,23 @@ they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. -} -lazyIdName, unsafeCoerceName, nullAddrName, seqName, +unsafeCoerceName, nullAddrName, seqName, realWorldName, voidPrimIdName, coercionTokenName, - magicDictName, coerceName, proxyName, dollarName, oneShotName, - runRWName, noinlineIdName :: Name + magicDictName, coerceName, proxyName :: Name 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 voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId -lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId -dollarName = mkWiredInIdName gHC_BASE (fsLit "$") dollarIdKey dollarId -oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId -runRWName = mkWiredInIdName gHC_MAGIC (fsLit "runRW#") runRWKey runRWId -noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId -dollarId :: Id -- Note [dollarId magic] -dollarId = pcMiscPrelId dollarName ty - (noCafIdInfo `setUnfoldingInfo` unf) - where - fun_ty = mkFunTy alphaTy openBetaTy - ty = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $ - mkFunTy fun_ty fun_ty - unf = mkInlineUnfoldingWithArity 2 rhs - [f,x] = mkTemplateLocals [fun_ty, alphaTy] - rhs = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $ - App (Var f) (Var x) +lazyIdName, oneShotName, noinlineIdName :: Name +lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId +oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId +noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId ------------------------------------------------ proxyHashId :: Id @@ -1228,33 +1312,12 @@ oneShotId = pcMiscPrelId oneShotName ty info (mkFunTy fun_ty fun_ty) fun_ty = mkFunTy openAlphaTy openBetaTy [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] - x' = setOneShotLambda x + x' = setOneShotLambda x -- Here is the magic bit! rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar , body, x'] $ Var body `App` Var x -runRWId :: Id -- See Note [runRW magic] in this module -runRWId = pcMiscPrelId runRWName ty info - where - info = noCafIdInfo `setInlinePragInfo` neverInlinePragma - `setStrictnessInfo` strict_sig - `setArityInfo` 1 - strict_sig = mkClosedStrictSig [strictApply1Dmd] topRes - -- Important to express its strictness, - -- since it is not inlined until CorePrep - -- Also see Note [runRW arg] in CorePrep - - -- State# RealWorld - stateRW = mkTyConApp statePrimTyCon [realWorldTy] - -- o - ret_ty = openAlphaTy - -- State# RealWorld -> o - arg_ty = stateRW `mkFunTy` ret_ty - -- (State# RealWorld -> o) -> o - ty = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $ - arg_ty `mkFunTy` ret_ty - -------------------------------------------------------------------------------- magicDictId :: Id -- See Note [magicDictId magic] magicDictId = pcMiscPrelId magicDictName ty info @@ -1285,20 +1348,6 @@ coerceId = pcMiscPrelId coerceName ty info [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] {- -Note [dollarId magic] -~~~~~~~~~~~~~~~~~~~~~ -The only reason that ($) is wired in is so that its type can be - forall (a:*, b:Open). (a->b) -> a -> b -That is, the return type can be unboxed. E.g. this is OK - foo $ True where foo :: Bool -> Int# -because ($) doesn't inspect or move the result of the call to foo. -See Trac #8739. - -There is a special typing rule for ($) in TcExpr, so the type of ($) -isn't looked at there, BUT Lint subsequently (and rightly) complains -if sees ($) applied to Int# (say), unless we give it a wired-in type -as we do here. - Note [Unsafe coerce magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We define a *primitive* @@ -1419,48 +1468,8 @@ a little bit of magic to optimize away 'noinline' after we are done running the simplifier. 'noinline' needs to be wired-in because it gets inserted automatically -when we serialize an expression to the interface format, and we DON'T -want use its fingerprints. - - -Note [runRW magic] -~~~~~~~~~~~~~~~~~~ -Some definitions, for instance @runST@, must have careful control over float out -of the bindings in their body. Consider this use of @runST@, - - f x = runST ( \ s -> let (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' ) - -If we inline @runST@, we'll get: - - f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -And now if we allow the @newArray#@ binding to float out to become a CAF, -we end up with a result that is totally and utterly wrong: - - f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in \ x -> - let (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -All calls to @f@ will share a {\em single} array! Clearly this is nonsense and -must be prevented. - -This is what @runRW#@ gives us: by being inlined extremely late in the -optimization (right before lowering to STG, in CorePrep), we can ensure that -no further floating will occur. This allows us to safely inline things like -@runST@, which are otherwise needlessly expensive (see #10678 and #5916). - -While the definition of @GHC.Magic.runRW#@, we override its type in @MkId@ -to be open-kinded, - - runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) - => (State# RealWorld -> (# State# RealWorld, o #)) - -> (# State# RealWorld, o #) - +when we serialize an expression to the interface format. See +Note [Inlining and hs-boot files] in ToIface Note [The oneShot function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1469,11 +1478,11 @@ and Note [Left folds via right fold]) it was determined that it would be useful if library authors could explicitly tell the compiler that a certain lambda is called at most once. The oneShot function allows that. -'oneShot' is open kinded, i.e. the type variables can refer to unlifted +'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted types as well (Trac #10744); e.g. oneShot (\x:Int# -> x +# 1#) -Like most magic functions it has a compulsary unfolding, so there is no need +Like most magic functions it has a compulsory unfolding, so there is no need for a real definition somewhere. We have one in GHC.Magic for the convenience of putting the documentation there. diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs index ab1f391e04..1851496af1 100644 --- a/compiler/basicTypes/Module.hs +++ b/compiler/basicTypes/Module.hs @@ -78,8 +78,6 @@ module Module baseUnitId, rtsUnitId, thUnitId, - dphSeqUnitId, - dphParUnitId, mainUnitId, thisGhcUnitId, isHoleModule, @@ -137,6 +135,8 @@ module Module unitModuleSet ) where +import GhcPrelude + import Config import Outputable import Unique @@ -149,13 +149,10 @@ import Util import Data.List import Data.Ord import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) +import Fingerprint import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Char8 as BS.Char8 -import System.IO.Unsafe -import Foreign.Ptr (castPtr) -import GHC.Fingerprint import Encoding import qualified Text.ParserCombinators.ReadP as Parse @@ -549,7 +546,6 @@ instance Outputable ComponentId where data UnitId = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId | DefiniteUnitId {-# UNPACK #-} !DefUnitId - deriving (Typeable) unitIdFS :: UnitId -> FastString unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x @@ -587,7 +583,7 @@ data IndefUnitId -- fully instantiated (free module variables are empty) -- and whether or not a substitution can have any effect. indefUnitIdFreeHoles :: UniqDSet ModuleName - } deriving (Typeable) + } instance Eq IndefUnitId where u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 @@ -642,7 +638,7 @@ indefUnitIdToUnitId dflags iuid = data IndefModule = IndefModule { indefModuleUnitId :: IndefUnitId, indefModuleName :: ModuleName - } deriving (Typeable, Eq, Ord) + } deriving (Eq, Ord) instance Outputable IndefModule where ppr (IndefModule uid m) = @@ -670,7 +666,6 @@ newtype InstalledUnitId = -- and the hash. installedUnitIdFS :: FastString } - deriving (Typeable) instance Binary InstalledUnitId where put_ bh (InstalledUnitId fs) = put_ bh fs @@ -761,7 +756,7 @@ installedUnitIdEq iuid uid = -- it only refers to a definite library; i.e., one we have generated -- code for. newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord) instance Outputable DefUnitId where ppr (DefUnitId uid) = ppr uid @@ -847,11 +842,6 @@ rawHashUnitId sorted_holes = fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', toStringRep (moduleName b), BS.Char8.singleton '\n'] -fingerprintByteString :: BS.ByteString -> Fingerprint -fingerprintByteString bs = unsafePerformIO - . BS.unsafeUseAsCStringLen bs - $ \(p,l) -> fingerprintData (castPtr p) l - fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString fingerprintUnitId prefix (Fingerprint a b) = BS.concat @@ -1075,8 +1065,7 @@ parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') integerUnitId, primUnitId, baseUnitId, rtsUnitId, - thUnitId, dphSeqUnitId, dphParUnitId, - mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId + thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId primUnitId = fsToUnitId (fsLit "ghc-prim") integerUnitId = fsToUnitId (fsLit n) where @@ -1086,8 +1075,6 @@ integerUnitId = fsToUnitId (fsLit n) baseUnitId = fsToUnitId (fsLit "base") rtsUnitId = fsToUnitId (fsLit "rts") thUnitId = fsToUnitId (fsLit "template-haskell") -dphSeqUnitId = fsToUnitId (fsLit "dph-seq") -dphParUnitId = fsToUnitId (fsLit "dph-par") thisGhcUnitId = fsToUnitId (fsLit "ghc") interactiveUnitId = fsToUnitId (fsLit "interactive") @@ -1135,9 +1122,7 @@ wiredInUnitIds = [ primUnitId, baseUnitId, rtsUnitId, thUnitId, - thisGhcUnitId, - dphSeqUnitId, - dphParUnitId ] + thisGhcUnitId ] {- ************************************************************************ diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot index 734855a880..36e8abf997 100644 --- a/compiler/basicTypes/Module.hs-boot +++ b/compiler/basicTypes/Module.hs-boot @@ -1,4 +1,6 @@ module Module where + +import GhcPrelude import FastString data Module diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 45275e3eff..d9eacd9af6 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -51,7 +51,6 @@ module Name ( setNameLoc, tidyNameOcc, localiseName, - mkLocalisedOccName, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, @@ -70,15 +69,16 @@ module Name ( NamedThing(..), getSrcLoc, getSrcSpan, getOccString, getOccFS, - pprInfixName, pprPrefixName, pprModulePrefix, + pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, nameStableString, -- Re-export the OccName stuff module OccName ) where +import GhcPrelude + import {-# SOURCE #-} TyCoRep( TyThing ) -import {-# SOURCE #-} PrelNames( starKindTyConKey, unicodeStarKindTyConKey ) import OccName import Module @@ -107,7 +107,7 @@ import Data.Data data Name = Name { n_sort :: NameSort, -- What sort of name it is n_occ :: !OccName, -- Its occurrence name - n_uniq :: {-# UNPACK #-} !Int, + n_uniq :: {-# UNPACK #-} !Unique, n_loc :: !SrcSpan -- Definition site } @@ -115,6 +115,7 @@ data Name = Name { -- (and real!) space leaks, due to the fact that we don't look at -- the SrcLoc in a Name all that often. +-- See Note [About the NameSorts] data NameSort = External Module @@ -151,7 +152,7 @@ instance NFData NameSort where data BuiltInSyntax = BuiltInSyntax | UserSyntax {- -Notes about the NameSorts: +Note [About the NameSorts] 1. Initially, top-level Ids (including locally-defined ones) get External names, and all other local Ids get Internal names @@ -192,11 +193,11 @@ instance HasOccName Name where nameUnique :: Name -> Unique nameOccName :: Name -> OccName -nameModule :: Name -> Module +nameModule :: HasDebugCallStack => Name -> Module nameSrcLoc :: Name -> SrcLoc nameSrcSpan :: Name -> SrcSpan -nameUnique name = mkUniqueGrimily (n_uniq name) +nameUnique name = n_uniq name nameOccName name = n_occ name nameSrcLoc name = srcSpanStart (n_loc name) nameSrcSpan name = n_loc name @@ -260,7 +261,7 @@ nameIsLocalOrFrom :: Module -> Name -> Bool -- you can find details (type, fixity, instances) in the -- TcGblEnv or TcLclEnv -- --- The isInteractiveModule part is because successive interactions of a GCHi session +-- The isInteractiveModule part is because successive interactions of a GHCi session -- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come -- from the magic 'interactive' package; and all the details are kept in the -- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. @@ -293,7 +294,7 @@ nameIsHomePackageImport this_mod this_pkg = moduleUnitId this_mod -- | Returns True if the Name comes from some other package: neither this --- pacakge nor the interactive package. +-- package nor the interactive package. nameIsFromExternalPackage :: UnitId -> Name -> Bool nameIsFromExternalPackage this_pkg name | Just mod <- nameModule_maybe name @@ -332,7 +333,7 @@ isSystemName _ = False -- | Create a name which is (for now at least) local to the current module and hence -- does not need a 'Module' to disambiguate it from other 'Name's mkInternalName :: Unique -> OccName -> SrcSpan -> Name -mkInternalName uniq occ loc = Name { n_uniq = getKey uniq +mkInternalName uniq occ loc = Name { n_uniq = uniq , n_sort = Internal , n_occ = occ , n_loc = loc } @@ -347,12 +348,12 @@ mkInternalName uniq occ loc = Name { n_uniq = getKey uniq mkClonedInternalName :: Unique -> Name -> Name mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = getKey uniq, n_sort = Internal + = Name { n_uniq = uniq, n_sort = Internal , n_occ = occ, n_loc = loc } mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = getKey uniq, n_sort = Internal + = Name { n_uniq = uniq, n_sort = Internal , n_occ = derive_occ occ, n_loc = loc } -- | Create a name which definitely originates in the given module @@ -361,13 +362,13 @@ mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name -- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName -- with some fresh unique without populating the Name Cache mkExternalName uniq mod occ loc - = Name { n_uniq = getKey uniq, n_sort = External mod, + = Name { n_uniq = uniq, n_sort = External mod, n_occ = occ, n_loc = loc } -- | Create a name which is actually defined by the compiler itself mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name mkWiredInName mod occ uniq thing built_in - = Name { n_uniq = getKey uniq, + = Name { n_uniq = uniq, n_sort = WiredIn mod thing built_in, n_occ = occ, n_loc = wiredInSrcSpan } @@ -376,14 +377,14 @@ mkSystemName :: Unique -> OccName -> Name mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name -mkSystemNameAt uniq occ loc = Name { n_uniq = getKey uniq, n_sort = System +mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System , n_occ = occ, n_loc = loc } mkSystemVarName :: Unique -> FastString -> Name mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) mkSysTvName :: Unique -> FastString -> Name -mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) +mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) -- | Make a name for a foreign call mkFCallName :: Unique -> String -> Name @@ -394,7 +395,7 @@ mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. setNameUnique :: Name -> Unique -> Name -setNameUnique name uniq = name {n_uniq = getKey uniq} +setNameUnique name uniq = name {n_uniq = uniq} -- This is used for hsigs: we want to use the name of the originally exported -- entity, but edit the location to refer to the reexport site @@ -412,18 +413,6 @@ tidyNameOcc name occ = name { n_occ = occ } localiseName :: Name -> Name localiseName n = n { n_sort = Internal } --- |Create a localised variant of a name. --- --- If the name is external, encode the original's module name to disambiguate. --- SPJ says: this looks like a rather odd-looking function; but it seems to --- be used only during vectorisation, so I'm not going to worry -mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName -mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name) - where - origin - | nameIsLocalOrFrom this_mod name = Nothing - | otherwise = Just (moduleNameColons . moduleName . nameModule $ name) - {- ************************************************************************ * * @@ -433,7 +422,7 @@ mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name) -} cmpName :: Name -> Name -> Ordering -cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2 +cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 -- | Compare Names lexicographically -- This only works for Names that originate in the source code or have been @@ -465,10 +454,18 @@ stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) ************************************************************************ -} +-- | The same comments as for `Name`'s `Ord` instance apply. instance Eq Name where a == b = case (a `compare` b) of { EQ -> True; _ -> False } a /= b = case (a `compare` b) of { EQ -> False; _ -> True } +-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which +-- means that the ordering is not stable across deserialization or rebuilds. +-- +-- See `nonDetCmpUnique` for further information, and trac #15240 for a bug +-- caused by improper use of this instance. + +-- For a deterministic lexicographic ordering, use `stableNameCmp`. instance Ord Name where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } @@ -525,14 +522,17 @@ instance OutputableBndr Name where pprPrefixOcc = pprPrefixName pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> case sort of WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin External mod -> pprExternal sty uniq mod occ False UserSyntax System -> pprSystem sty uniq occ Internal -> pprInternal sty uniq occ - where uniq = mkUniqueGrimily u + +-- | Print the string of Name unqualifiedly directly. +pprNameUnqualified :: Name -> SDoc +pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc pprExternal sty uniq mod occ is_wired is_builtin @@ -687,24 +687,6 @@ pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) pprPrefixName :: NamedThing a => a -> SDoc -pprPrefixName thing - | name `hasKey` starKindTyConKey || name `hasKey` unicodeStarKindTyConKey - = ppr name -- See Note [Special treatment for kind *] - | otherwise - = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) +pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) where name = getName thing - -{- -Note [Special treatment for kind *] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not put parens around the kind '*'. Even though it looks like -an operator, it is really a special case. - -This pprPrefixName stuff is really only used when printing HsSyn, -which has to be polymorphic in the name type, and hence has to go via -the overloaded function pprPrefixOcc. It's easier where we know the -type being pretty printed; eg the pretty-printing code in TyCoRep. - -See Trac #7645, which led to this. --} diff --git a/compiler/basicTypes/Name.hs-boot b/compiler/basicTypes/Name.hs-boot index c4eeca4d68..54efe686ad 100644 --- a/compiler/basicTypes/Name.hs-boot +++ b/compiler/basicTypes/Name.hs-boot @@ -1,3 +1,5 @@ module Name where +import GhcPrelude () + data Name diff --git a/compiler/basicTypes/NameCache.hs b/compiler/basicTypes/NameCache.hs index 589c7c4e3b..13fb1f57fe 100644 --- a/compiler/basicTypes/NameCache.hs +++ b/compiler/basicTypes/NameCache.hs @@ -10,6 +10,8 @@ module NameCache , NameCache(..), OrigNameCache ) where +import GhcPrelude + import Module import Name import UniqSupply @@ -115,4 +117,4 @@ initNameCache us names nsNames = initOrigNames names } initOrigNames :: [Name] -> OrigNameCache -initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names +initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs index cca771a33e..632ea7742e 100644 --- a/compiler/basicTypes/NameEnv.hs +++ b/compiler/basicTypes/NameEnv.hs @@ -33,6 +33,8 @@ module NameEnv ( #include "HsVersions.h" +import GhcPrelude + import Digraph import Name import UniqFM diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs index 57de81cb44..76b6626589 100644 --- a/compiler/basicTypes/NameSet.hs +++ b/compiler/basicTypes/NameSet.hs @@ -33,6 +33,8 @@ module NameSet ( #include "HsVersions.h" +import GhcPrelude + import Name import UniqSet import Data.List (sortBy) @@ -79,7 +81,7 @@ delFromNameSet = delOneFromUniqSet filterNameSet = filterUniqSet intersectNameSet = intersectUniqSets -delListFromNameSet set ns = foldl delFromNameSet set ns +delListFromNameSet set ns = foldl' delFromNameSet set ns intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index 0fa2749ba1..c3ee937baa 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -67,11 +67,6 @@ module OccName ( mkSuperDictSelOcc, mkSuperDictAuxOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, - mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPDataTyConOcc, mkPDataDataConOcc, - mkPDatasTyConOcc, mkPDatasDataConOcc, - mkPReprTyConOcc, - mkPADFunOcc, mkRecFldSelOcc, mkTyConRepOcc, @@ -105,6 +100,8 @@ module OccName ( FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv ) where +import GhcPrelude + import Util import Unique import DynFlags @@ -653,23 +650,6 @@ mkTyConRepOcc occ = mk_simple_deriv varName prefix occ mkGenR = mk_simple_deriv tcName "Rep_" mkGen1R = mk_simple_deriv tcName "Rep1_" --- Vectorisation -mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPADFunOcc, mkPReprTyConOcc, - mkPDataTyConOcc, mkPDataDataConOcc, - mkPDatasTyConOcc, mkPDatasDataConOcc - :: Maybe String -> OccName -> OccName -mkVectOcc = mk_simple_deriv_with varName "$v" -mkVectTyConOcc = mk_simple_deriv_with tcName "V:" -mkVectDataConOcc = mk_simple_deriv_with dataName "VD:" -mkVectIsoOcc = mk_simple_deriv_with varName "$vi" -mkPADFunOcc = mk_simple_deriv_with varName "$pa" -mkPReprTyConOcc = mk_simple_deriv_with tcName "VR:" -mkPDataTyConOcc = mk_simple_deriv_with tcName "VP:" -mkPDatasTyConOcc = mk_simple_deriv_with tcName "VPs:" -mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:" -mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:" - -- Overloaded record field selectors mkRecFldSelOcc :: String -> OccName mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] @@ -677,15 +657,6 @@ mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] -mk_simple_deriv_with :: NameSpace -- ^ the namespace - -> FastString -- ^ an identifying prefix - -> Maybe String -- ^ another optional prefix - -> OccName -- ^ the 'OccName' to derive from - -> OccName -mk_simple_deriv_with sp px Nothing occ = mk_deriv sp px [occNameFS occ] -mk_simple_deriv_with sp px (Just with) occ = - mk_deriv sp px [fsLit with, fsLit "_", occNameFS occ] - -- Data constructor workers are made by setting the name space -- of the data constructor OccName (which should be a DataName) -- to VarName @@ -871,7 +842,7 @@ emptyTidyOccEnv :: TidyOccEnv emptyTidyOccEnv = emptyUFM initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl add emptyUFM +initTidyOccEnv = foldl' add emptyUFM where add env (OccName _ fs) = addToUFM env fs 1 diff --git a/compiler/basicTypes/OccName.hs-boot b/compiler/basicTypes/OccName.hs-boot index c6fa8850cf..31d77a44a9 100644 --- a/compiler/basicTypes/OccName.hs-boot +++ b/compiler/basicTypes/OccName.hs-boot @@ -1,3 +1,5 @@ module OccName where +import GhcPrelude () + data OccName diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 0e218a39c1..bf9426ecc8 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -24,6 +24,8 @@ module PatSyn ( #include "HsVersions.h" +import GhcPrelude + import Type import Name import Outputable @@ -63,7 +65,7 @@ data PatSyn -- record pat syn or same length as -- psArgs - -- Universially-quantified type variables + -- Universally-quantified type variables psUnivTyVars :: [TyVarBinder], -- Required dictionaries (may mention psUnivTyVars) @@ -76,7 +78,8 @@ data PatSyn psProvTheta :: ThetaType, -- Result type - psOrigResTy :: Type, -- Mentions only psUnivTyVars + psResultTy :: Type, -- Mentions only psUnivTyVars + -- See Note [Pattern synonym result type] -- See Note [Matchers and builders for pattern synonyms] psMatcher :: (Id, Bool), @@ -145,6 +148,43 @@ Example 3: You can see it's existential because it doesn't appear in the result type (T3 b). +Note [Pattern synonym result type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b = MkT b a + + pattern P :: a -> T [a] Bool + pattern P x = MkT True [x] + +P's psResultTy is (T a Bool), and it really only matches values of +type (T [a] Bool). For example, this is ill-typed + + f :: T p q -> String + f (P x) = "urk" + +This is different to the situation with GADTs: + + data S a where + MkS :: Int -> S Bool + +Now MkS (and pattern synonyms coming from MkS) can match a +value of type (S a), not just (S Bool); we get type refinement. + +That in turn means that if you have a pattern + + P x :: T [ty] Bool + +it's not entirely straightforward to work out the instantiation of +P's universal tyvars. You have to /match/ + the type of the pattern, (T [ty] Bool) +against + the psResultTy for the pattern synonym, T [a] Bool +to get the instantiation a := ty. + +This is very unlike DataCons, where univ tyvars match 1-1 the +arguments of the TyCon. + + Note [Pattern synonym representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following pattern synonym declaration @@ -174,7 +214,7 @@ In this case, the fields of MkPatSyn will be set as follows: psExTyVars = [b] psProvTheta = (Show (Maybe t), Ord b) psReqTheta = (Eq t, Num t) - psOrigResTy = T (Maybe t) + psResultTy = T (Maybe t) Note [Matchers and builders for pattern synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -245,7 +285,7 @@ done by TcPatSyn.patSynBuilderOcc. Note [Pattern synonyms and the data type Type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The type of a pattern synonym is of the form (See Note -[Pattern synonym signatures]): +[Pattern synonym signatures] in TcSigs): forall univ_tvs. req => forall ex_tvs. prov => ... @@ -299,10 +339,10 @@ instance Data.Data PatSyn where -- | Build a new pattern synonym mkPatSyn :: Name -> Bool -- ^ Is the pattern synonym declared infix? - -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type variables - -- and required dicts - -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type variables - -- and provided dicts + -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type + -- variables and required dicts + -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type + -- variables and provided dicts -> [Type] -- ^ Original arguments -> Type -- ^ Original result type -> (Id, Bool) -- ^ Name of matcher @@ -325,7 +365,7 @@ mkPatSyn name declared_infix psInfix = declared_infix, psArgs = orig_args, psArity = length orig_args, - psOrigResTy = orig_res_ty, + psResultTy = orig_res_ty, psMatcher = matcher, psBuilder = builder, psFieldLabels = field_labels @@ -368,7 +408,7 @@ patSynExTyVarBinders = psExTyVars patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs , psProvTheta = prov, psReqTheta = req - , psArgs = arg_tys, psOrigResTy = res_ty }) + , psArgs = arg_tys, psResultTy = res_ty }) = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) patSynMatcher :: PatSyn -> (Id,Bool) @@ -405,9 +445,9 @@ patSynInstResTy :: PatSyn -> [Type] -> Type -- E.g. pattern P x y = Just (x,x,y) -- P :: a -> b -> Just (a,a,b) -- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) --- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars +-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs - , psOrigResTy = res_ty }) + , psResultTy = res_ty }) inst_tys = ASSERT2( univ_tvs `equalLength` inst_tys , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) @@ -417,7 +457,7 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs pprPatSynType :: PatSyn -> SDoc pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta , psExTyVars = ex_tvs, psProvTheta = prov_theta - , psArgs = orig_args, psOrigResTy = orig_res_ty }) + , psArgs = orig_args, psResultTy = orig_res_ty }) = sep [ pprForAll univ_tvs , pprThetaArrowTy req_theta , ppWhen insert_empty_ctxt $ parens empty <+> darrow diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index 9e59c971d5..45f23249bc 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -34,8 +34,7 @@ module RdrName ( -- ** Destruction rdrNameOcc, rdrNameSpace, demoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, isStar, - isUniStar, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- * Local mapping of 'RdrName' to 'Name.Name' LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, @@ -48,6 +47,7 @@ module RdrName ( lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, pprGlobalRdrEnv, globalRdrEnvElts, lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, + lookupGRE_Name_OccName, getGRE_NameQualifier_maybes, transformGREs, pickGREs, pickGREsModExp, @@ -62,11 +62,16 @@ module RdrName ( pprNameProvenance, Parent(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem, bestImport + importSpecLoc, importSpecModule, isExplicitItem, bestImport, + + -- * Utils for StarIsType + starInfo ) where #include "HsVersions.h" +import GhcPrelude + import Module import Name import Avail @@ -83,7 +88,7 @@ import Util import NameEnv import Data.Data -import Data.List( sortBy, foldl', nub ) +import Data.List( sortBy, nub ) {- ************************************************************************ @@ -109,7 +114,7 @@ import Data.List( sortBy, foldl', nub ) -- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, -- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, -- 'ApiAnnotation.AnnBackquote' @'`'@, --- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh', +-- 'ApiAnnotation.AnnVal' -- 'ApiAnnotation.AnnTilde', -- For details on above see note [Api annotations] in ApiAnnotation @@ -259,10 +264,6 @@ isExact_maybe :: RdrName -> Maybe Name isExact_maybe (Exact n) = Just n isExact_maybe _ = Nothing -isStar, isUniStar :: RdrName -> Bool -isStar = (fsLit "*" ==) . occNameFS . rdrNameOcc -isUniStar = (fsLit "★" ==) . occNameFS . rdrNameOcc - {- ************************************************************************ * * @@ -471,7 +472,7 @@ data Parent = NoParent | ParentIs { par_is :: Name } | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } -- ^ See Note [Parents for record fields] - deriving (Eq, Data, Typeable) + deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty @@ -886,13 +887,13 @@ pickGREs returns two GRE gre1: gre_lcl = True, gre_imp = [] gre2: gre_lcl = False, gre_imp = [ imported from Bar ] -Now the the "ambiguous occurrence" message can correctly report how the +Now the "ambiguous occurrence" message can correctly report how the ambiguity arises. -} pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] -- ^ Takes a list of GREs which have the right OccName 'x' --- Pick those GREs that are are in scope +-- Pick those GREs that are in scope -- * Qualified, as 'M.x' if want_qual is Qual M _ -- * Unqualified, as 'x' if want_unqual is Unqual _ -- @@ -994,22 +995,51 @@ extendGlobalRdrEnv env gre (greOccName gre) gre shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv -shadowNames = foldl shadowName +shadowNames = foldl' shadowName {- Note [GlobalRdrEnv shadowing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before adding new names to the GlobalRdrEnv we nuke some existing entries; -this is "shadowing". The actual work is done by RdrEnv.shadowNames. +this is "shadowing". The actual work is done by RdrEnv.shadowName. +Suppose + env' = shadowName env M.f + +Then: + * Looking up (Unqual f) in env' should succeed, returning M.f, + even if env contains existing unqualified bindings for f. + They are shadowed + + * Looking up (Qual M.f) in env' should succeed, returning M.f + + * Looking up (Qual X.f) in env', where X /= M, should be the same as + looking up (Qual X.f) in env. + That is, shadowName does /not/ delete earlier qualified bindings + There are two reasons for shadowing: * The GHCi REPL - Ids bought into scope on the command line (eg let x = True) have External Names, like Ghci4.x. We want a new binding for 'x' (say) - to override the existing binding for 'x'. - See Note [Interactively-bound Ids in GHCi] in HscTypes - - - Data types also have Extenal Names, like Ghci4.T; but we still want + to override the existing binding for 'x'. Example: + + ghci> :load M -- Brings `x` and `M.x` into scope + ghci> x + ghci> "Hello" + ghci> M.x + ghci> "hello" + ghci> let x = True -- Shadows `x` + ghci> x -- The locally bound `x` + -- NOT an ambiguous reference + ghci> True + ghci> M.x -- M.x is still in scope! + ghci> "Hello" + So when we add `x = True` we must not delete the `M.x` from the + `GlobalRdrEnv`; rather we just want to make it "qualified only"; + hence the `mk_fake-imp_spec` in `shadowName`. See also Note + [Interactively-bound Ids in GHCi] in HscTypes + + - Data types also have External Names, like Ghci4.T; but we still want 'T' to mean the newly-declared 'T', not an old one. * Nested Template Haskell declaration brackets @@ -1017,10 +1047,10 @@ There are two reasons for shadowing: Consider a TH decl quote: module M where - f x = h [d| f = 3 |] - We must shadow the outer declaration of 'f', else we'll get a - complaint when extending the GlobalRdrEnv, saying that there are two - bindings for 'f'. There are several tricky points: + f x = h [d| f = ...f...M.f... |] + We must shadow the outer unqualified binding of 'f', else we'll get + a complaint when extending the GlobalRdrEnv, saying that there are + two bindings for 'f'. There are several tricky points: - This shadowing applies even if the binding for 'f' is in a where-clause, and hence is in the *local* RdrEnv not the *global* @@ -1208,9 +1238,8 @@ pprNameProvenance :: GlobalRdrElt -> SDoc -- ^ Print out one place where the name was define/imported -- (With -dppr-debug, print them all) pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - = sdocWithPprDebug $ \dbg -> if dbg - then vcat pp_provs - else head pp_provs + = ifPprDebug (vcat pp_provs) + (head pp_provs) where pp_provs = pp_lcl ++ map pp_is iss pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] @@ -1246,3 +1275,80 @@ instance Outputable ImportSpec where pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty + +-- | Display info about the treatment of '*' under NoStarIsType. +-- +-- With StarIsType, three properties of '*' hold: +-- +-- (a) it is not an infix operator +-- (b) it is always in scope +-- (c) it is a synonym for Data.Kind.Type +-- +-- However, the user might not know that he's working on a module with +-- NoStarIsType and write code that still assumes (a), (b), and (c), which +-- actually do not hold in that module. +-- +-- Violation of (a) shows up in the parser. For instance, in the following +-- examples, we have '*' not applied to enough arguments: +-- +-- data A :: * +-- data F :: * -> * +-- +-- Violation of (b) or (c) show up in the renamer and the typechecker +-- respectively. For instance: +-- +-- type K = Either * Bool +-- +-- This will parse differently depending on whether StarIsType is enabled, +-- but it will parse nonetheless. With NoStarIsType it is parsed as a type +-- operator, thus we have ((*) Either Bool). Now there are two cases to +-- consider: +-- +-- 1. There is no definition of (*) in scope. In this case the renamer will +-- fail to look it up. This is a violation of assumption (b). +-- +-- 2. There is a definition of the (*) type operator in scope (for example +-- coming from GHC.TypeNats). In this case the user will get a kind +-- mismatch error. This is a violation of assumption (c). +-- +-- The user might unknowingly be working on a module with NoStarIsType +-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a +-- hint whenever an assumption about '*' is violated. Unfortunately, it is +-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). +-- +-- 'starInfo' generates an appropriate hint to the user depending on the +-- extensions enabled in the module and the name that triggered the error. +-- That is, if we have NoStarIsType and the error is related to '*' or its +-- Unicode variant, the resulting SDoc will contain a helpful suggestion. +-- Otherwise it is empty. +-- +starInfo :: Bool -> RdrName -> SDoc +starInfo star_is_type rdr_name = + -- One might ask: if can use sdocWithDynFlags here, why bother to take + -- star_is_type as input? Why not refactor? + -- + -- The reason is that sdocWithDynFlags would provide DynFlags that are active + -- in the module that tries to load the problematic definition, not + -- in the module that is being loaded. + -- + -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint + -- must be displayed even if we load this definition from a module (or GHCi) + -- with StarIsType enabled! + -- + if isUnqualStar && not star_is_type + then text "With NoStarIsType, " <> + quotes (ppr rdr_name) <> + text " is treated as a regular type operator. " + $$ + text "Did you mean to use " <> quotes (text "Type") <> + text " from Data.Kind instead?" + else empty + where + -- Does rdr_name look like the user might have meant the '*' kind by it? + -- We focus on unqualified stars specifically, because qualified stars are + -- treated as type operators even under StarIsType. + isUnqualStar + | Unqual occName <- rdr_name + = let fs = occNameFS occName + in fs == fsLit "*" || fs == fsLit "★" + | otherwise = False diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index f71dac6273..3276f41f14 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -7,10 +7,6 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} - -- Workaround for Trac #5252 crashes the bootstrap compiler without -O - -- When the earliest compiler we want to boostrap with is - -- GHC 7.2, we can make RealSrcLoc properly abstract -- | This module contains types that relate to the positions of things -- in source files, and allow tagging of those things with locations @@ -81,6 +77,8 @@ module SrcLoc ( spans, isSubspanOf, sortLocated ) where +import GhcPrelude + import Util import Json import Outputable @@ -309,12 +307,14 @@ mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) = RealSrcSpan (mkRealSrcSpan loc1 loc2) -- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Assumes the "file" part is the same in both inputs +-- within both spans. Returns UnhelpfulSpan if the files differ. combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) - = RealSrcSpan (combineRealSrcSpans span1 span2) + | srcSpanFile span1 == srcSpanFile span2 + = RealSrcSpan (combineRealSrcSpans span1 span2) + | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>") -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs @@ -335,6 +335,7 @@ srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 where loc1@(SrcLoc f l c) = realSrcSpanStart span loc2 = SrcLoc f l (c+1) + {- ************************************************************************ * * @@ -513,8 +514,8 @@ pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) data GenLocated l e = L l e deriving (Eq, Ord, Data, Functor, Foldable, Traversable) -type Located e = GenLocated SrcSpan e -type RealLocated e = GenLocated RealSrcSpan e +type Located = GenLocated SrcSpan +type RealLocated = GenLocated RealSrcSpan unLoc :: GenLocated l e -> e unLoc (L _ e) = e @@ -552,7 +553,7 @@ instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where -- GenLocated: -- Print spans without the file name etc -- ifPprDebug (braces (pprUserSpan False l)) - ifPprDebug (braces (ppr l)) + whenPprDebug (braces (ppr l)) $$ ppr e {- diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs index da1a924736..664600147e 100644 --- a/compiler/basicTypes/UniqSupply.hs +++ b/compiler/basicTypes/UniqSupply.hs @@ -29,7 +29,10 @@ module UniqSupply ( initUniqSupply ) where +import GhcPrelude + import Unique +import Panic (panic) import GHC.IO @@ -37,6 +40,7 @@ import MonadUtils import Control.Monad import Data.Bits import Data.Char +import Control.Monad.Fail #include "Unique.h" @@ -145,6 +149,10 @@ instance Applicative UniqSM where (# xx, us'' #) -> (# ff xx, us'' #) (*>) = thenUs_ +-- TODO: try to get rid of this instance +instance MonadFail UniqSM where + fail = panic + -- | Run the 'UniqSM' action, returning the final 'UniqSupply' initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) } diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index a49fa80946..b5c0fcec58 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -32,10 +32,12 @@ module Unique ( mkUniqueGrimily, -- Used in UniqSupply only! getKey, -- Used in Var, UniqFM, Name only! mkUnique, unpkUnique, -- Used in BinIface only + eqUnique, ltUnique, deriveUnique, -- Ditto newTagUnique, -- Used in CgCase initTyVarUnique, + initExitJoinUnique, nonDetCmpUnique, isValidKnownKeyUnique, -- Used in PrelInfo.knownKeyNamesOkay @@ -47,7 +49,7 @@ module Unique ( mkPrimOpIdUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, - mkPArrDataConUnique, mkCoVarUnique, + mkCoVarUnique, mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, @@ -62,12 +64,14 @@ module Unique ( -- *** From TyCon name uniques tyConRepNameUnique, -- *** From DataCon name uniques - dataConWorkerUnique, dataConRepNameUnique + dataConWorkerUnique, dataConTyRepNameUnique ) where #include "HsVersions.h" #include "Unique.h" +import GhcPrelude + import BasicTypes import FastString import Outputable @@ -237,6 +241,9 @@ use `deriving' because we want {\em precise} control of ordering eqUnique :: Unique -> Unique -> Bool eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 +ltUnique :: Unique -> Unique -> Bool +ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 + -- Provided here to make it explicit at the call-site that it can -- introduce non-determinism. -- See Note [Unique Determinism] @@ -318,7 +325,7 @@ iToBase62 n_ go n cs | n < 62 = let !c = chooseChar62 n in c : cs | otherwise - = go q (c : cs) where (q, r) = quotRem n 62 + = go q (c : cs) where (!q, r) = quotRem n 62 !c = chooseChar62 r chooseChar62 :: Int -> Char @@ -362,7 +369,6 @@ mkPreludeTyConUnique :: Int -> Unique mkPreludeDataConUnique :: Arity -> Unique mkPrimOpIdUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique -mkPArrDataConUnique :: Int -> Unique mkCoVarUnique :: Int -> Unique mkAlphaTyVarUnique i = mkUnique '1' i @@ -394,17 +400,14 @@ tyConRepNameUnique u = incrUnique u mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic -------------------------------------------------- -dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique +dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique u = incrUnique u -dataConRepNameUnique u = stepUnique u 2 +dataConTyRepNameUnique u = stepUnique u 2 -------------------------------------------------- mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i --- No numbers left anymore, so I pick something different for the character tag -mkPArrDataConUnique a = mkUnique ':' (2*a) - -- The "tyvar uniques" print specially nicely: a, b, c, etc. -- See pprUnique for details @@ -434,3 +437,6 @@ mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) + +initExitJoinUnique :: Unique +initExitJoinUnique = mkUnique 's' 0 diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs index 87c4fe2240..2009b6c764 100644 --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -35,7 +35,7 @@ module Var ( -- * The main data type and synonyms Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, - TyVar, TypeVar, KindVar, TKVar, TyCoVar, + TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, -- * In and Out variants InVar, InCoVar, InId, InTyVar, @@ -61,9 +61,12 @@ module Var ( mustHaveLocalBinding, -- * TyVar's - TyVarBndr(..), ArgFlag(..), TyVarBinder, - binderVar, binderVars, binderArgFlag, binderKind, + VarBndr(..), ArgFlag(..), TyCoVarBinder, TyVarBinder, + binderVar, binderVars, binderArgFlag, binderType, isVisibleArgFlag, isInvisibleArgFlag, sameVis, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinder, mkTyVarBinders, + isTyVarBinder, -- ** Constructing TyVar's mkTyVar, mkTcTyVar, @@ -81,6 +84,8 @@ module Var ( #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} TyCoRep( Type, Kind, pprKind ) import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, @@ -125,6 +130,9 @@ type TyVar = Var -- Type *or* kind variable (historical) -- | Type or Kind Variable type TKVar = Var -- Type *or* kind variable (historical) +-- | Type variable that might be a metavariable +type TcTyVar = Var + -- | Type Variable type TypeVar = Var -- Definitely a type variable @@ -158,7 +166,7 @@ type TyCoVar = Id -- Type, *or* coercion variable {- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the subsitution has been applied -} + synonyms to remind us whether or not the substitution has been applied -} type InVar = Var type InTyVar = TyVar @@ -184,7 +192,7 @@ type OutId = Id Note [Kind and type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before kind polymorphism, TyVar were used to mean type variables. Now -they are use to mean kind *or* type variables. KindVar is used when we +they are used to mean kind *or* type variables. KindVar is used when we know for sure that it is a kind variable. In future, we might want to go over the whole compiler code to use: - TKVar to mean kind or type variables @@ -374,9 +382,10 @@ updateVarTypeM f id = do { ty' <- f (varType id) -- Is something required to appear in source Haskell ('Required'), -- permitted by request ('Specified') (visible type application), or -- prohibited entirely from appearing in source Haskell ('Inferred')? --- See Note [TyBinders and ArgFlags] in TyCoRep -data ArgFlag = Required | Specified | Inferred - deriving (Eq, Data) +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep +data ArgFlag = Inferred | Specified | Required + deriving (Eq, Ord, Data) + -- (<) on ArgFlag meant "is less visible than" -- | Does this 'ArgFlag' classify an argument that is written in Haskell? isVisibleArgFlag :: ArgFlag -> Bool @@ -398,36 +407,67 @@ sameVis _ _ = True {- ********************************************************************* * * -* TyVarBndr, TyVarBinder +* VarBndr, TyCoVarBinder * * ********************************************************************* -} --- Type Variable Binder +-- Variable Binder -- --- TyVarBndr is polymorphic in both tyvar and visibility fields: --- * tyvar can be TyVar or IfaceTv --- * argf can be ArgFlag or TyConBndrVis -data TyVarBndr tyvar argf = TvBndr tyvar argf +-- VarBndr is polymorphic in both var and visibility fields. +-- Currently there are six different uses of 'VarBndr': +-- * Var.TyVarBinder = VarBndr TyVar ArgFlag +-- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag +-- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis +-- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis +-- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +-- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +data VarBndr var argf = Bndr var argf deriving( Data ) --- | Type Variable Binder +-- | Variable Binder -- --- A 'TyVarBinder' is the binder of a ForAllTy +-- A 'TyCoVarBinder' is the binder of a ForAllTy -- It's convenient to define this synonym here rather its natural -- home in TyCoRep, because it's used in DataCon.hs-boot -type TyVarBinder = TyVarBndr TyVar ArgFlag +-- +-- A 'TyVarBinder' is a binder with only TyVar +type TyCoVarBinder = VarBndr TyCoVar ArgFlag +type TyVarBinder = VarBndr TyVar ArgFlag -binderVar :: TyVarBndr tv argf -> tv -binderVar (TvBndr v _) = v +binderVar :: VarBndr tv argf -> tv +binderVar (Bndr v _) = v -binderVars :: [TyVarBndr tv argf] -> [tv] +binderVars :: [VarBndr tv argf] -> [tv] binderVars tvbs = map binderVar tvbs -binderArgFlag :: TyVarBndr tv argf -> argf -binderArgFlag (TvBndr _ argf) = argf +binderArgFlag :: VarBndr tv argf -> argf +binderArgFlag (Bndr _ argf) = argf + +binderType :: VarBndr TyCoVar argf -> Type +binderType (Bndr tv _) = varType tv + +-- | Make a named binder +mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder +mkTyCoVarBinder vis var = Bndr var vis + +-- | Make a named binder +-- 'var' should be a type variable +mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder +mkTyVarBinder vis var + = ASSERT( isTyVar var ) + Bndr var vis + +-- | Make many named binders +mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] +mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) + +-- | Make many named binders +-- Input vars should be type variables +mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] +mkTyVarBinders vis = map (mkTyVarBinder vis) -binderKind :: TyVarBndr TyVar argf -> Kind -binderKind (TvBndr tv _) = tyVarKind tv +isTyVarBinder :: TyCoVarBinder -> Bool +isTyVarBinder (Bndr v _) = isTyVar v {- ************************************************************************ @@ -485,20 +525,20 @@ setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar setTcTyVarDetails tv details = tv { tc_tv_details = details } ------------------------------------- -instance Outputable tv => Outputable (TyVarBndr tv ArgFlag) where - ppr (TvBndr v Required) = ppr v - ppr (TvBndr v Specified) = char '@' <> ppr v - ppr (TvBndr v Inferred) = braces (ppr v) +instance Outputable tv => Outputable (VarBndr tv ArgFlag) where + ppr (Bndr v Required) = ppr v + ppr (Bndr v Specified) = char '@' <> ppr v + ppr (Bndr v Inferred) = braces (ppr v) instance Outputable ArgFlag where ppr Required = text "[req]" ppr Specified = text "[spec]" ppr Inferred = text "[infrd]" -instance (Binary tv, Binary vis) => Binary (TyVarBndr tv vis) where - put_ bh (TvBndr tv vis) = do { put_ bh tv; put_ bh vis } +instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where + put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } - get bh = do { tv <- get bh; vis <- get bh; return (TvBndr tv vis) } + get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } instance Binary ArgFlag where diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index e22c207858..3e4844772d 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -34,7 +34,7 @@ module VarEnv ( extendDVarEnvList, lookupDVarEnv, elemDVarEnv, isEmptyDVarEnv, foldDVarEnv, - mapDVarEnv, + mapDVarEnv, filterDVarEnv, modifyDVarEnv, alterDVarEnv, plusDVarEnv, plusDVarEnv_C, @@ -73,6 +73,8 @@ module VarEnv ( emptyTidyEnv ) where +import GhcPrelude + import OccName import Var import VarSet @@ -129,7 +131,7 @@ extendInScopeSet (InScope in_scope n) v extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet extendInScopeSetList (InScope in_scope n) vs - = InScope (foldl (\s v -> extendVarSet s v) in_scope vs) + = InScope (foldl' (\s v -> extendVarSet s v) in_scope vs) (n + length vs) extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet @@ -555,6 +557,9 @@ foldDVarEnv = foldUDFM mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b mapDVarEnv = mapUDFM +filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a +filterDVarEnv = filterUDFM + alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a alterDVarEnv = alterUDFM diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs index 710cb0db3a..ac3c545b2a 100644 --- a/compiler/basicTypes/VarSet.hs +++ b/compiler/basicTypes/VarSet.hs @@ -45,6 +45,8 @@ module VarSet ( #include "HsVersions.h" +import GhcPrelude + import Var ( Var, TyVar, CoVar, TyCoVar, Id ) import Unique import Name ( Name ) |