Change isUnliftedTyCon to marshalablePrimTyCon (#20401)

isUnliftedTyCon was used in three places: Ticky, Template Haskell
and FFI checks.

It was straightforward to remove it from Ticky and Template Haskell.

It is now used in FFI only and renamed to marshalablePrimTyCon.

Previously, it was fetching information from a field
in PrimTyCon called is_unlifted. Instead, I've changed the code
to compute liftedness based on the kind.

isFFITy and legalFFITyCon are removed. They were only referred from
an old comment that I removed.

There were three functions to define a PrimTyCon, but the only difference
was that they were setting is_unlifted to True or False.
Everything is now done in mkPrimTyCon.

I also added missing integer types in Ticky.hs, I think it was an oversight.

Fixes #20401

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 af46ba75c0..9ddff4213b 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1916,7 +1916,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