diff options
| -rw-r--r-- | compiler/GHC/Builtin/Types.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Builtin/Types/Prim.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Core/TyCon.hs | 64 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Tidy.hs | 103 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Ticky.hs | 21 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/TcType.hs | 38 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Error.hs | 6 |
8 files changed, 42 insertions, 203 deletions
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 79d0fcdb47..bcd74e59f4 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -461,12 +461,6 @@ It has these properties: * It is wired-in so we can easily refer to it where we don't have a name environment (e.g. see Rules.matchRule for one example) - * If (Any k) is the type of a value, it must be a /lifted/ value. So - if we have (Any @(TYPE rr)) then rr must be 'LiftedRep. See - Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. This is a convenient - invariant, and makes isUnliftedTyCon well-defined; otherwise what - would (isUnliftedTyCon Any) be? - It's used to instantiate un-constrained type variables after type checking. For example, 'length' has type diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 7ba9023f25..5eb260ce59 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -609,11 +609,10 @@ PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo. tYPETyCon :: TyCon tYPETyConName :: Name -tYPETyCon = mkKindTyCon tYPETyConName +tYPETyCon = mkPrimTyCon tYPETyConName (mkTemplateAnonTyConBinders [runtimeRepTy]) liftedTypeKind [Nominal] - (mkPrelTyConRepName tYPETyConName) -------------------------- -- ... and now their names @@ -977,7 +976,7 @@ RealWorld; it's only used in the type system, to parameterise State#. -} realWorldTyCon :: TyCon -realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind [] +realWorldTyCon = mkPrimTyCon realWorldTyConName [] liftedTypeKind [] realWorldTy :: Type realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index e267932e14..a83e391257 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -35,8 +35,6 @@ module GHC.Core.TyCon( mkClassTyCon, mkFunTyCon, mkPrimTyCon, - mkKindTyCon, - mkLiftedPrimTyCon, mkTupleTyCon, mkSumTyCon, mkDataTyConRhs, @@ -68,7 +66,6 @@ module GHC.Core.TyCon( isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, tyConInjectivityInfo, isBuiltInSynFamTyCon_maybe, - isUnliftedTyCon, isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, isImplicitTyCon, @@ -907,11 +904,6 @@ data TyCon -- This list has length = tyConArity -- See also Note [TyCon Role signatures] - isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may - -- not contain bottom) but other are lifted, - -- e.g. @RealWorld@ - -- Only relevant if tyConKind = * - primRepName :: TyConRepName -- ^ The 'Typeable' representation. -- A cached version of -- @'mkPrelTyConRepName' ('tyConName' tc)@. @@ -1970,39 +1962,17 @@ mkTcTyCon name binders res_kind scoped_tvs poly flav noTcTyConScopedTyVars :: [(Name, TcTyVar)] noTcTyConScopedTyVars = [] --- | Create an unlifted primitive 'TyCon', such as @Int#@. +-- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld#@ +-- Primitive TyCons are marshalable iff not lifted. +-- If you'd like to change this, modify marshalablePrimTyCon. mkPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -- Must answer 'True' to 'isFixedRuntimeRepKind' (no representation polymorphism). - -> [Role] -> TyCon + -> Kind -- ^ /result/ kind + -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism). + -- (If you need a representation-polymorphic PrimTyCon, + -- change tcHasFixedRuntimeRep, marshalablePrimTyCon, reifyTyCon for PrimTyCons.) + -> [Role] + -> TyCon mkPrimTyCon name binders res_kind roles - = mkPrimTyCon' name binders res_kind roles True (mkPrelTyConRepName name) - --- | Kind constructors -mkKindTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -> [Role] -> Name -> TyCon -mkKindTyCon name binders res_kind roles rep_nm - = tc - where - tc = mkPrimTyCon' name binders res_kind roles False rep_nm - --- | Create a lifted primitive 'TyCon' such as @RealWorld@ -mkLiftedPrimTyCon :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -> [Role] -> TyCon -mkLiftedPrimTyCon name binders res_kind roles - = mkPrimTyCon' name binders res_kind roles False rep_nm - where rep_nm = mkPrelTyConRepName name - -mkPrimTyCon' :: Name -> [TyConBinder] - -> Kind -- ^ /result/ kind - -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism). - -- (If you need a representation-polymorphic PrimTyCon, - -- change tcHasFixedRuntimeRep.) - -> [Role] - -> Bool -> TyConRepName -> TyCon -mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm = let tc = PrimTyCon { tyConName = name, @@ -2013,8 +1983,7 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm tyConArity = length roles, tyConNullaryTy = mkNakedTyConTy tc, tcRoles = roles, - isUnlifted = is_unlifted, - primRepName = rep_nm + primRepName = mkPrelTyConRepName name } in tc @@ -2101,19 +2070,6 @@ isPrimTyCon :: TyCon -> Bool isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False --- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can --- only be true for primitive and unboxed-tuple 'TyCon's -isUnliftedTyCon :: TyCon -> Bool -isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) - = is_unlifted -isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) - | SumTyCon {} <- rhs - = True -isUnliftedTyCon _ = False - -- | Returns @True@ if the supplied 'TyCon' resulted from either a -- @data@ or @newtype@ declaration isAlgTyCon :: TyCon -> Bool diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 41b1ad6b9e..ed5e99805f 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -1338,106 +1338,3 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold -- it to the top level. So it seems more robust just to -- fix it here. arity = exprArity orig_rhs - -{- -************************************************************************ -* * - Old, dead, type-trimming code -* * -************************************************************************ - -We used to try to "trim off" the constructors of data types that are -not exported, to reduce the size of interface files, at least without --O. But that is not always possible: see the old Note [When we can't -trim types] below for exceptions. - -Then (#7445) I realised that the TH problem arises for any data type -that we have deriving( Data ), because we can invoke - Language.Haskell.TH.Quote.dataToExpQ -to get a TH Exp representation of a value built from that data type. -You don't even need {-# LANGUAGE TemplateHaskell #-}. - -At this point I give up. The pain of trimming constructors just -doesn't seem worth the gain. So I've dumped all the code, and am just -leaving it here at the end of the module in case something like this -is ever resurrected. - - -Note [When we can't trim types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea of type trimming is to export algebraic data types -abstractly (without their data constructors) when compiling without --O, unless of course they are explicitly exported by the user. - -We always export synonyms, because they can be mentioned in the type -of an exported Id. We could do a full dependency analysis starting -from the explicit exports, but that's quite painful, and not done for -now. - -But there are some times we can't do that, indicated by the 'no_trim_types' flag. - -First, Template Haskell. Consider (#2386) this - module M(T, makeOne) where - data T = Yay String - makeOne = [| Yay "Yep" |] -Notice that T is exported abstractly, but makeOne effectively exports it too! -A module that splices in $(makeOne) will then look for a declaration of Yay, -so it'd better be there. Hence, brutally but simply, we switch off type -constructor trimming if TH is enabled in this module. - -Second, data kinds. Consider (#5912) - {-# LANGUAGE DataKinds #-} - module M() where - data UnaryTypeC a = UnaryDataC a - type Bug = 'UnaryDataC -We always export synonyms, so Bug is exposed, and that means that -UnaryTypeC must be too, even though it's not explicitly exported. In -effect, DataKinds means that we'd need to do a full dependency analysis -to see what data constructors are mentioned. But we don't do that yet. - -In these two cases we just switch off type trimming altogether. - -mustExposeTyCon :: Bool -- Type-trimming flag - -> NameSet -- Exports - -> TyCon -- The tycon - -> Bool -- Can its rep be hidden? --- We are compiling without -O, and thus trying to write as little as --- possible into the interface file. But we must expose the details of --- any data types whose constructors or fields are exported -mustExposeTyCon no_trim_types exports tc - | no_trim_types -- See Note [When we can't trim types] - = True - - | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to - -- figure out whether it was mentioned in the type - -- of any other exported thing) - = True - - | isEnumerationTyCon tc -- For an enumeration, exposing the constructors - = True -- won't lead to the need for further exposure - - | isFamilyTyCon tc -- Open type family - = True - - -- Below here we just have data/newtype decls or family instances - - | null data_cons -- Ditto if there are no data constructors - = True -- (NB: empty data types do not count as enumerations - -- see Note [Enumeration types] in GHC.Core.TyCon - - | any exported_con data_cons -- Expose rep if any datacon or field is exported - = True - - | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) - = True -- Expose the rep for newtypes if the rep is an FFI type. - -- For a very annoying reason. 'Foreign import' is meant to - -- be able to look through newtypes transparently, but it - -- can only do that if it can "see" the newtype representation - - | otherwise - = False - where - data_cons = tyConDataCons tc - exported_con con = any (`elemNameSet` exports) - (dataConName con : dataConFieldLabels con) --} diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 6a30bfff75..3aff61ac80 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -675,20 +675,21 @@ showTypeCategory ty | otherwise = case tcSplitTyConApp_maybe ty of Nothing -> '.' Just (tycon, _) -> - (if isUnliftedTyCon tycon then Data.Char.toLower else id) $ let anyOf us = getUnique tycon `elem` us in case () of _ | anyOf [funTyConKey] -> '>' - | anyOf [charPrimTyConKey, charTyConKey] -> 'C' - | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D' - | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F' - | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey, - intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey - ] -> 'I' - | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey, - word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey - ] -> 'W' + | anyOf [charTyConKey] -> 'C' + | anyOf [charPrimTyConKey] -> 'c' + | anyOf [doubleTyConKey] -> 'D' + | anyOf [doublePrimTyConKey] -> 'd' + | anyOf [floatTyConKey] -> 'F' + | anyOf [floatPrimTyConKey] -> 'f' + | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I' + | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i' + | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W' + | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w' | anyOf [listTyConKey] -> 'L' + | isUnboxedTupleTyCon tycon -> 't' | isTupleTyCon tycon -> 'T' | isPrimTyCon tycon -> 'P' | isEnumerationTyCon tycon -> 'E' diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 13cd3e71c9..8de124fb58 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1914,7 +1914,7 @@ reifyTyCon tc | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) - (isUnliftedTyCon tc)) + (isUnliftedTypeKind (tyConResKind tc))) | isTypeFamilyTyCon tc = do { let tvs = tyConTyVars tc diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index b79a4152e1..a4dfead21b 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -118,7 +118,6 @@ module GHC.Tc.Utils.TcType ( isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool - isFFITy, -- :: Type -> Bool isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type @@ -228,7 +227,7 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Error( Validity'(..), Validity, isValid ) +import GHC.Utils.Error( Validity'(..), Validity ) import qualified GHC.LanguageExtensions as LangExt import Data.List ( mapAccumL ) @@ -2200,10 +2199,6 @@ tcSplitIOType_maybe ty _ -> Nothing -isFFITy :: Type -> Bool --- True for any TyCon that can possibly be an arg or result of an FFI call -isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty) - isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity -- Checks for valid argument type for a 'foreign import' isFFIArgumentTy dflags safety ty @@ -2332,17 +2327,19 @@ legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity legalOutgoingTyCon dflags _ tc = marshalableTyCon dflags tc -legalFFITyCon :: TyCon -> Validity --- True for any TyCon that can possibly be an arg or result of an FFI call -legalFFITyCon tc - | isUnliftedTyCon tc = IsValid - | tc == unitTyCon = IsValid - | otherwise = boxedMarshalableTyCon tc +-- Check for marshalability of a primitive type. +-- We exclude lifted types such as RealWorld and TYPE. +-- They can technically appear in types, e.g. +-- f :: RealWorld -> TYPE LiftedRep -> RealWorld +-- f x _ = x +-- but there are no values of type RealWorld or TYPE LiftedRep, +-- so it doesn't make sense to use them in FFI. +marshalablePrimTyCon :: TyCon -> Bool +marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind tc)) marshalableTyCon :: DynFlags -> TyCon -> Validity marshalableTyCon dflags tc - | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) + | marshalablePrimTyCon tc , not (null (tyConPrimRep tc)) -- Note [Marshalling void] = validIfUnliftedFFITypes dflags | otherwise @@ -2366,11 +2363,8 @@ boxedMarshalableTyCon tc legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity -- Check args of 'foreign import prim', only allow simple unlifted types. --- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since --- currently they're of the wrong kind to use in function args anyway. legalFIPrimArgTyCon dflags tc - | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) + | marshalablePrimTyCon tc = validIfUnliftedFFITypes dflags | otherwise = NotValid unlifted_only @@ -2379,9 +2373,11 @@ legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity -- Check result type of 'foreign import prim'. Allow simple unlifted -- types and also unboxed tuple and sum result types. legalFIPrimResultTyCon dflags tc - | isUnliftedTyCon tc - , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc - || not (null (tyConPrimRep tc)) -- Note [Marshalling void] + | marshalablePrimTyCon tc + , not (null (tyConPrimRep tc)) -- Note [Marshalling void] + = validIfUnliftedFFITypes dflags + + | isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc = validIfUnliftedFFITypes dflags | otherwise diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index c2b708b56a..fb981452b6 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -10,7 +10,7 @@ module GHC.Utils.Error ( -- * Basic types - Validity'(..), Validity, andValid, allValid, isValid, getInvalids, orValid, + Validity'(..), Validity, andValid, allValid, getInvalids, orValid, Severity(..), -- * Messages @@ -198,10 +198,6 @@ data Validity' a -- | Monomorphic version of @Validity'@ specialised for 'SDoc's. type Validity = Validity' SDoc -isValid :: Validity' a -> Bool -isValid IsValid = True -isValid (NotValid {}) = False - andValid :: Validity' a -> Validity' a -> Validity' a andValid IsValid v = v andValid v _ = v |