compiler/GHC/CmmToAsm/Wasm.hs

@@ -5,6 +5,7 @@
 module GHC.CmmToAsm.Wasm (ncgWasm) where
 
 import Data.ByteString.Builder
+import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Maybe
 import Data.Semigroup
 import GHC.Cmm
@@ -12,15 +13,18 @@ import GHC.CmmToAsm.Wasm.Asm
 import GHC.CmmToAsm.Wasm.FromCmm
 import GHC.CmmToAsm.Wasm.Types
 import GHC.Data.Stream (Stream, StreamS (..), runStream)
+import GHC.Driver.DynFlags
 import GHC.Platform
 import GHC.Prelude
 import GHC.Settings
 import GHC.Types.Unique.Supply
 import GHC.Unit
-import GHC.Utils.CliOption
+import GHC.Utils.Logger
+import GHC.Utils.Outputable (text)
 import System.IO
 
 ncgWasm ::
+  Logger ->
   Platform ->
   ToolSettings ->
   UniqSupply ->
@@ -28,15 +32,24 @@ ncgWasm ::
   Handle ->
   Stream IO RawCmmGroup a ->
   IO a
-ncgWasm platform ts us loc h cmms = do
+ncgWasm logger platform ts us loc h cmms = do
   (r, s) <- streamCmmGroups platform us cmms
-  hPutBuilder h $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"
-  hPutBuilder h $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s
+  outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"
+  outputWasm $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s
   pure r
   where
     -- See Note [WasmTailCall]
     do_tail_call = doTailCall ts
 
+    outputWasm builder = do
+      putDumpFileMaybe
+        logger
+        Opt_D_dump_asm
+        "Asm Code"
+        FormatASM
+        (text . unpack $ toLazyByteString builder)
+      hPutBuilder h builder
+
 streamCmmGroups ::
   Platform ->
   UniqSupply ->

compiler/GHC/CmmToAsm/X86/CodeGen.hs

@@ -966,16 +966,38 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
 
         return (Fixed format eax code)
 
-
     imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
+    imulMayOflo W8 a b = do
+         -- The general case (W16, W32, W64) doesn't work for W8 as its
+         -- multiplication doesn't use two registers.
+         --
+         -- The plan is:
+         -- 1. truncate and sign-extend a and b to 8bit width
+         -- 2. multiply a' = a * b in 32bit width
+         -- 3. copy and sign-extend 8bit from a' to c
+         -- 4. compare a' and c: they are equal if there was no overflow
+         (a_reg, a_code) <- getNonClobberedReg a
+         (b_reg, b_code) <- getNonClobberedReg b
+         let
+             code = a_code `appOL` b_code `appOL`
+                        toOL [
+                           MOVSxL II8 (OpReg a_reg) (OpReg a_reg),
+                           MOVSxL II8 (OpReg b_reg) (OpReg b_reg),
+                           IMUL II32 (OpReg b_reg) (OpReg a_reg),
+                           MOVSxL II8 (OpReg a_reg) (OpReg eax),
+                           CMP II16 (OpReg a_reg) (OpReg eax),
+                           SETCC NE (OpReg eax)
+                        ]
+         return (Fixed II8 eax code)
     imulMayOflo rep a b = do
          (a_reg, a_code) <- getNonClobberedReg a
          b_code <- getAnyReg b
          let
              shift_amt  = case rep of
+                           W16 -> 15
                            W32 -> 31
                            W64 -> 63
-                           _ -> panic "shift_amt"
+                           w -> panic ("shift_amt: " ++ show w)
 
              format = intFormat rep
              code = a_code `appOL` b_code eax `appOL`

compiler/GHC/CmmToLlvm/CodeGen.hs

@@ -181,6 +181,9 @@ genCall (PrimTarget MO_AcquireFence) _ _ = runStmtsDecls $
 genCall (PrimTarget MO_ReleaseFence) _ _ = runStmtsDecls $
     statement $ Fence False SyncRelease
 
+genCall (PrimTarget MO_Touch) _ _ =
+    return (nilOL, [])
+
 genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
     dstV <- getCmmRegW (CmmLocal dst)
     let ty = cmmToLlvmType $ localRegType dst

compiler/GHC/Core.hs

@@ -451,7 +451,7 @@ TL;DR: we relaxed the let/app invariant to become the let-can-float invariant.
 Note [Core top-level string literals]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 As an exception to the usual rule that top-level binders must be lifted,
-we allow binding primitive string literals (of type Addr#) of type Addr# at the
+we allow binding primitive string literals (of type Addr#) at the
 top level. This allows us to share string literals earlier in the pipeline and
 crucially allows other optimizations in the Core2Core pipeline to fire.
 Consider,
@@ -629,7 +629,7 @@ Note [Representation polymorphism invariants]
 GHC allows us to abstract over calling conventions using **representation polymorphism**.
 For example, we have:
 
-  ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). a -> b -> b
+  ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). (a -> b) -> a -> b
 
 In this example, the type `b` is representation-polymorphic: it has kind `TYPE r`,
 where the type variable `r :: RuntimeRep` abstracts over the runtime representation
@@ -662,14 +662,14 @@ Note that these two invariants require us to check other types than just the
 types of bound variables and types of function arguments, due to transformations
 that GHC performs. For example, the definition
 
-  myCoerce :: forall {r1 r2} (a :: TYPE r1) (b :: TYPE r2). Coercible a b => a -> b
+  myCoerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b
   myCoerce = coerce
 
 is invalid, because `coerce` has no binding (see GHC.Types.Id.Make.coerceId).
 So, before code-generation, GHC saturates the RHS of 'myCoerce' by performing
 an eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate):
 
-  myCoerce = \ (x :: TYPE r1) -> coerce x
+  myCoerce = \ (x :: TYPE r) -> coerce x
 
 However, this transformation would be invalid, because now the binding of x
 in the lambda abstraction would violate I1.

compiler/GHC/Core/ConLike.hs

@@ -47,6 +47,7 @@ import GHC.Utils.Outputable
 
 import Data.Maybe( isJust )
 import qualified Data.Data as Data
+import qualified Data.List as List
 
 {-
 ************************************************************************
@@ -224,8 +225,10 @@ conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
 
 
 -- | The ConLikes that have *all* the given fields
-conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
-conLikesWithFields con_likes lbls = filter has_flds con_likes
+conLikesWithFields :: [ConLike] -> [FieldLabelString]
+                   -> ( [ConLike]   -- ConLikes containing the fields
+                      , [ConLike] ) -- ConLikes not containing the fields
+conLikesWithFields con_likes lbls = List.partition has_flds con_likes
   where has_flds dc = all (has_fld dc) lbls
         has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
 

compiler/GHC/Core/DataCon.hs

@@ -572,12 +572,10 @@ data DataCon
 
 
 {- Note [TyVarBinders in DataCons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-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 PiTyBinder in terms] in GHC.Core.TyCo.Rep.)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the TyVarBinders in a DataCon and PatSyn,
+each argument flag is either Inferred or Specified, never Required.
+Lifting this restriction is tracked at #18389 (DataCon) and #23704 (PatSyn).
 
 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

compiler/GHC/Core/InstEnv.hs

@@ -11,10 +11,10 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv.
 
 module GHC.Core.InstEnv (
         DFunId, InstMatch, ClsInstLookupResult,
-        Coherence(..), PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,
+        Canonical, PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,
         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
-        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
-        instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,
+        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances,
+        instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,
         instanceDFunId, updateClsInstDFuns, updateClsInstDFun,
         fuzzyClsInstCmp, orphNamesOfClsInst,
 
@@ -42,8 +42,10 @@ import GHC.Core.RoughMap
 import GHC.Core.Class
 import GHC.Core.Unify
 import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType )
+import GHC.Hs.Extension
 
 import GHC.Unit.Module.Env
+import GHC.Unit.Module.Warnings
 import GHC.Unit.Types
 import GHC.Types.Var
 import GHC.Types.Unique.DSet
@@ -108,6 +110,10 @@ data ClsInst
              , is_flag :: OverlapFlag   -- See detailed comments with
                                         -- the decl of BasicTypes.OverlapFlag
              , is_orphan :: IsOrphan
+             , is_warn :: Maybe (WarningTxt GhcRn)
+                -- Warning emitted when the instance is used
+                -- See Note [Implementation of deprecated instances]
+                -- in GHC.Tc.Solver.Dict
     }
   deriving Data
 
@@ -122,10 +128,11 @@ fuzzyClsInstCmp x y =
     cmp (RM_KnownTc _, RM_WildCard)   = GT
     cmp (RM_KnownTc x, RM_KnownTc y) = stableNameCmp x y
 
-isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool
+isOverlappable, isOverlapping, isIncoherent, isNonCanonical :: ClsInst -> Bool
 isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))
 isOverlapping  i = hasOverlappingFlag  (overlapMode (is_flag i))
 isIncoherent   i = hasIncoherentFlag   (overlapMode (is_flag i))
+isNonCanonical i = hasNonCanonicalFlag (overlapMode (is_flag i))
 
 {-
 Note [ClsInst laziness and the rough-match fields]
@@ -217,6 +224,16 @@ instance NamedThing ClsInst where
 instance Outputable ClsInst where
    ppr = pprInstance
 
+pprDFunId :: DFunId -> SDoc
+-- Prints the analogous information to `pprInstance`
+-- but with just the DFunId
+pprDFunId dfun
+  = hang dfun_header
+       2 (vcat [ text "--" <+> pprDefinedAt (getName dfun)
+               , whenPprDebug (ppr dfun) ])
+  where
+    dfun_header = ppr_overlap_dfun_hdr empty dfun
+
 pprInstance :: ClsInst -> SDoc
 -- Prints the ClsInst as an instance declaration
 pprInstance ispec
@@ -228,11 +245,18 @@ pprInstance ispec
 pprInstanceHdr :: ClsInst -> SDoc
 -- Prints the ClsInst as an instance declaration
 pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })
-  = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun)
+  = ppr_overlap_dfun_hdr (ppr flag) dfun
+
+ppr_overlap_dfun_hdr :: SDoc -> DFunId -> SDoc
+ppr_overlap_dfun_hdr flag_sdoc dfun
+  = text "instance" <+> flag_sdoc <+> pprSigmaType (idType dfun)
 
 pprInstances :: [ClsInst] -> SDoc
 pprInstances ispecs = vcat (map pprInstance ispecs)
 
+instanceWarning :: ClsInst -> Maybe (WarningTxt GhcRn)
+instanceWarning = is_warn
+
 instanceHead :: ClsInst -> ([TyVar], Class, [Type])
 -- Returns the head, using the fresh tyvars from the ClsInst
 instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys })
@@ -260,17 +284,18 @@ instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))
 
 mkLocalClsInst :: DFunId -> OverlapFlag
                -> [TyVar] -> Class -> [Type]
+               -> Maybe (WarningTxt GhcRn)
                -> ClsInst
 -- Used for local instances, where we can safely pull on the DFunId.
 -- Consider using newClsInst instead; this will also warn if
 -- the instance is an orphan.
-mkLocalClsInst dfun oflag tvs cls tys
+mkLocalClsInst dfun oflag tvs cls tys warn
   = ClsInst { is_flag = oflag, is_dfun = dfun
             , is_tvs = tvs
             , is_dfun_name = dfun_name
             , is_cls = cls, is_cls_nm = cls_name
             , is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys
-            , is_orphan = orph
+            , is_orphan = orph, is_warn = warn
             }
   where
     cls_name = className cls
@@ -301,24 +326,26 @@ mkLocalClsInst dfun oflag tvs cls tys
 
     choose_one nss = chooseOrphanAnchor (unionNameSets nss)
 
-mkImportedClsInst :: Name           -- ^ the name of the class
-                  -> [RoughMatchTc] -- ^ the rough match signature of the instance
-                  -> Name           -- ^ the 'Name' of the dictionary binding
-                  -> DFunId         -- ^ the 'Id' of the dictionary.
-                  -> OverlapFlag    -- ^ may this instance overlap?
-                  -> IsOrphan       -- ^ is this instance an orphan?
+mkImportedClsInst :: Name                     -- ^ the name of the class
+                  -> [RoughMatchTc]           -- ^ the rough match signature of the instance
+                  -> Name                     -- ^ the 'Name' of the dictionary binding
+                  -> DFunId                   -- ^ the 'Id' of the dictionary.
+                  -> OverlapFlag              -- ^ may this instance overlap?
+                  -> IsOrphan                 -- ^ is this instance an orphan?
+                  -> Maybe (WarningTxt GhcRn) -- ^ warning emitted when solved
                   -> ClsInst
 -- Used for imported instances, where we get the rough-match stuff
 -- from the interface file
 -- The bound tyvars of the dfun are guaranteed fresh, because
 -- the dfun has been typechecked out of the same interface file
-mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan
+mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan warn
   = ClsInst { is_flag = oflag, is_dfun = dfun
             , is_tvs = tvs, is_tys = tys
             , is_dfun_name = dfun_name
             , is_cls_nm = cls_nm, is_cls = cls
             , is_tcs = RM_KnownTc cls_nm : mb_tcs
-            , is_orphan = orphan }
+            , is_orphan = orphan
+            , is_warn = warn }
   where
     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
@@ -812,8 +839,41 @@ example
 
   Here both (I7) and (I8) match, GHC picks an arbitrary one.
 
-So INCOHERENT may break the Coherence Assumption.  To avoid this
-incoherence breaking the specialiser,
+So INCOHERENT may break the Coherence Assumption. But sometimes that
+is fine, because the programmer promises that it doesn't matter which
+one is chosen.  A good example is in the `optics` library:
+
+  data IxEq i is js where { IxEq :: IxEq i is is }
+
+  class AppendIndices xs ys ks | xs ys -> ks where
+    appendIndices :: IxEq i (Curry xs (Curry ys i)) (Curry ks i)
+
+  instance {-# INCOHERENT #-} xs ~ zs => AppendIndices xs '[] zs where
+    appendIndices = IxEq
+
+  instance ys ~ zs => AppendIndices '[] ys zs where
+    appendIndices = IxEq
+
+Here `xs` and `ys` are type-level lists, and for type inference purposes we want to
+solve the `AppendIndices` constraint when /either/ of them are the empty list. The
+dictionaries are the same in both cases (indeed the dictionary type is a singleton!),
+so we really don't care which is used.  See #23287 for discussion.
+
+
+In short, sometimes we want to specialise on these incoherently-selected dictionaries,
+and sometimes we don't.  It would be best to have a per-instance pragma, but for now
+we have a global flag:
+
+* If an instance has an `{-# INCOHERENT #-}` pragma, we use its `OverlapFlag` to
+  label it as either
+  * `Incoherent`: meaning incoherent but still specialisable, or
+  * `NonCanonical`: meaning incoherent and not specialisable.
+
+The module-wide `-fspecialise-incoherents` flag determines which
+choice is made.  The rest of this note describes what happens for
+`NonCanonical` instances, i.e. with `-fno-specialise-incoherents`.
+
+To avoid this incoherence breaking the specialiser,
 
 * We label as "incoherent" the dictionary constructed by a
   (potentially) incoherent use of an instance declaration.
@@ -850,7 +910,7 @@ Here are the moving parts:
 * `GHC.HsToCore.Binds.dsHsWrapper` desugars the evidence application (f d) into
   (nospec f d) if `d` is incoherent. It has to do a dependency analysis to
   determine transitive dependencies, but we need to do that anyway.
-  See Note [Desugaring incoherent evidence] in GHC.HsToCore.Binds.
+  See Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds.
 
   See also Note [nospecId magic] in GHC.Types.Id.Make.
 -}
@@ -955,10 +1015,13 @@ data LookupInstanceErrReason =
   LookupInstErrNotFound
   deriving (Generic)
 
-data Coherence = IsCoherent | IsIncoherent
+type Canonical = Bool
 
 -- See Note [Recording coherence information in `PotentialUnifiers`]
-data PotentialUnifiers = NoUnifiers Coherence
+data PotentialUnifiers = NoUnifiers Canonical
+                       -- NoUnifiers True: We have a unique solution modulo canonicity
+                       -- NoUnifiers False: The solutions is not canonical, and thus
+                       --   we shouldn't specialise on it.
                        | OneOrMoreUnifiers (NonEmpty ClsInst)
                        -- This list is lazy as we only look at all the unifiers when
                        -- printing an error message. It can be expensive to compute all
@@ -967,33 +1030,28 @@ data PotentialUnifiers = NoUnifiers Coherence
 
 {- Note [Recording coherence information in `PotentialUnifiers`]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have any potential unifiers, then we go down the `NotSure` route
-in `matchInstEnv`.  According to Note [Rules for instance lookup]
-steps IL4 and IL6, we only care about non-`INCOHERENT` instances for
-this purpose.
-
-It is only when we don't have any potential unifiers (i.e. we know
-that we have a unique solution modulo `INCOHERENT` instances) that we
-care about that unique solution being coherent or not (see
-Note [Coherence and specialisation: overview] for why we care at all).
-So we only need the `Coherent` flag in the case where the set of
-potential unifiers is otherwise empty.
--}
 
-instance Outputable Coherence where
-  ppr IsCoherent = text "coherent"
-  ppr IsIncoherent = text "incoherent"
+When we find a matching instance, there might be other instances that
+could potentially unify with the goal. For `INCOHERENT` instances, we
+don't care (see steps IL4 and IL6 in Note [Rules for instance
+lookup]). But if we have potentially unifying coherent instance, we
+report these `OneOrMoreUnifiers` so that `matchInstEnv` can go down
+the `NotSure` route.
+
+If this hurdle is passed, i.e. we have a unique solution up to
+`INCOHERENT` instances, the specialiser needs to know if that unique
+solution is canonical or not (see Note [Coherence and specialisation:
+overview] for why we care at all). So when the set of potential
+unifiers is empty, we record in `NoUnifiers` if the one solution is
+`Canonical`.
+-}
 
 instance Outputable PotentialUnifiers where
-  ppr (NoUnifiers c) = text "NoUnifiers" <+> ppr c
+  ppr (NoUnifiers c) = text "NoUnifiers" <+> if c then text "canonical" else text "non-canonical"
   ppr xs = ppr (getPotentialUnifiers xs)
 
-instance Semigroup Coherence where
-  IsCoherent <> IsCoherent = IsCoherent
-  _ <> _ = IsIncoherent
-
 instance Semigroup PotentialUnifiers where
-  NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 <> c2)
+  NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 && c2)
   NoUnifiers _ <> u = u
   OneOrMoreUnifiers (unifier :| unifiers) <> u = OneOrMoreUnifiers (unifier :| (unifiers <> getPotentialUnifiers u))
 
@@ -1039,22 +1097,24 @@ lookupInstEnv' (InstEnv rm) vis_mods cls tys
       = acc
 
 
-    incoherently_matched :: PotentialUnifiers -> PotentialUnifiers
-    incoherently_matched (NoUnifiers _) = NoUnifiers IsIncoherent
-    incoherently_matched u = u
+    noncanonically_matched :: PotentialUnifiers -> PotentialUnifiers
+    noncanonically_matched (NoUnifiers _) = NoUnifiers False
+    noncanonically_matched u = u
 
     check_unifier :: [ClsInst] -> PotentialUnifiers
-    check_unifier [] = NoUnifiers IsCoherent
+    check_unifier [] = NoUnifiers True
     check_unifier (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items)
       | not (instIsVisible vis_mods item)
       = check_unifier items  -- See Note [Instance lookup and orphan instances]
       | Just {} <- tcMatchTys tpl_tys tys = check_unifier items
         -- Does not match, so next check whether the things unify
         -- See Note [Overlapping instances]
+        -- Record that we encountered non-canonical instances: Note [Coherence and specialisation: overview]
+      | isNonCanonical item
+      = noncanonically_matched $ check_unifier items
         -- Ignore ones that are incoherent: Note [Incoherent instances]
-        -- Record that we encountered incoherent instances: Note [Coherence and specialisation: overview]
       | isIncoherent item
-      = incoherently_matched $ check_unifier items
+      = check_unifier items
 
       | otherwise
       = assertPpr (tys_tv_set `disjointVarSet` tpl_tv_set)
@@ -1111,7 +1171,7 @@ lookupInstEnv check_overlap_safe
 
     -- If the selected match is incoherent, discard all unifiers
     final_unifs = case final_matches of
-                    (m:_) | isIncoherent (fst m) -> NoUnifiers IsCoherent
+                    (m:_) | isIncoherent (fst m) -> NoUnifiers True
                     _                            -> all_unifs
 
     -- Note [Safe Haskell isSafeOverlap]
@@ -1289,7 +1349,7 @@ noMatches = InstMatches { instMatches = [], instGuards = [] }
 pruneOverlappedMatches :: [InstMatch] -> [InstMatch]
 -- ^ Remove from the argument list any InstMatches for which another
 -- element of the list is more specific, and overlaps it, using the
--- rules of Nove [Rules for instance lookup]
+-- rules of Note [Rules for instance lookup]
 pruneOverlappedMatches all_matches =
   instMatches $ foldr insert_overlapping noMatches all_matches
 
@@ -1446,33 +1506,8 @@ If the choice of instance *does* matter, all bets are still not off:
 users can consult the detailed specification of the instance selection
 algorithm in the GHC Users' Manual. However, this means we can end up
 with different instances at the same types at different parts of the
-program, and this difference has to be preserved. For example, if we
-have
-
-    class C a where
-      op :: a -> String
-
-    instance {-# OVERLAPPABLE #-} C a where ...
-    instance {-# INCOHERENT #-} C () where ...
-
-then depending on the circumstances (see #22448 for a full setup) some
-occurrences of `op :: () -> String` may be resolved to the generic
-instance, and other to the specific one; so we end up in the desugared
-code with occurrences of both
-
-    op @() ($dC_a @())
-
-and
-
-    op @() $dC_()
-
-In particular, the specialiser needs to ignore the incoherently
-selected instance in `op @() ($dC_a @())`. So during instance lookup,
-we record in `PotentialUnifiers` if a given solution was arrived at
-incoherently; we then use this information to inhibit specialisation
-a la Note [nospecId magic] in GHC.Types.Id.Make.
-
-
+program, and this difference has to be preserved. Note [Coherence and
+specialisation: overview] details how we achieve that.
 
 ************************************************************************
 *                                                                      *

compiler/GHC/Core/Lint.hs

@@ -604,10 +604,10 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
 
          -- Check that a join-point binder has a valid type
          -- NB: lintIdBinder has checked that it is not top-level bound
-       ; case isJoinId_maybe binder of
-            Nothing    -> return ()
-            Just arity ->  checkL (isValidJoinPointType arity binder_ty)
-                                  (mkInvalidJoinPointMsg binder binder_ty)
+       ; case idJoinPointHood binder of
+            NotJoinPoint    -> return ()
+            JoinPoint arity ->  checkL (isValidJoinPointType arity binder_ty)
+                                       (mkInvalidJoinPointMsg binder binder_ty)
 
        ; when (lf_check_inline_loop_breakers flags
                && isStableUnfolding (realIdUnfolding binder)
@@ -662,7 +662,7 @@ lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv)
 -- NB: the Id can be Linted or not -- it's only used for
 --     its OccInfo and join-pointer-hood
 lintRhs bndr rhs
-    | Just arity <- isJoinId_maybe bndr
+    | JoinPoint arity <- idJoinPointHood bndr
     = lintJoinLams arity (Just bndr) rhs
     | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
     = lintJoinLams arity Nothing rhs
@@ -1085,7 +1085,7 @@ lintJoinBndrType :: LintedType -- Type of the body
 -- E.g. join j x = rhs in body
 --      The type of 'rhs' must be the same as the type of 'body'
 lintJoinBndrType body_ty bndr
-  | Just arity <- isJoinId_maybe bndr
+  | JoinPoint arity <- idJoinPointHood bndr
   , let bndr_ty = idType bndr
   , (bndrs, res) <- splitPiTys bndr_ty
   = checkL (length bndrs >= arity
@@ -1101,15 +1101,14 @@ checkJoinOcc :: Id -> JoinArity -> LintM ()
 -- Check that if the occurrence is a JoinId, then so is the
 -- binding site, and it's a valid join Id
 checkJoinOcc var n_args
-  | Just join_arity_occ <- isJoinId_maybe var
+  | JoinPoint join_arity_occ <- idJoinPointHood var
   = do { mb_join_arity_bndr <- lookupJoinId var
        ; case mb_join_arity_bndr of {
-           Nothing -> -- Binder is not a join point
-                      do { join_set <- getValidJoins
-                         ; addErrL (text "join set " <+> ppr join_set $$
-                                    invalidJoinOcc var) } ;
+           NotJoinPoint -> do { join_set <- getValidJoins
+                              ; addErrL (text "join set " <+> ppr join_set $$
+                                invalidJoinOcc var) } ;
 
-           Just join_arity_bndr ->
+           JoinPoint join_arity_bndr ->
 
     do { checkL (join_arity_bndr == join_arity_occ) $
            -- Arity differs at binding site and occurrence
@@ -2109,8 +2108,8 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
                                    , ru_args = args, ru_rhs = rhs })
   = lintBinders LambdaBind bndrs $ \ _ ->
     do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args
-       ; (rhs_ty, _) <- case isJoinId_maybe fun of
-                     Just join_arity
+       ; (rhs_ty, _) <- case idJoinPointHood fun of
+                     JoinPoint join_arity
                        -> do { checkL (args `lengthIs` join_arity) $
                                 mkBadJoinPointRuleMsg fun join_arity rule
                                -- See Note [Rules for join points]
@@ -3373,14 +3372,14 @@ lookupIdInScope id_occ
        --     wired-in Ids after worker/wrapper
        --     So we simply disable the test in this case
 
-lookupJoinId :: Id -> LintM (Maybe JoinArity)
+lookupJoinId :: Id -> LintM JoinPointHood
 -- Look up an Id which should be a join point, valid here
 -- If so, return its arity, if not return Nothing
 lookupJoinId id
   = do { join_set <- getValidJoins
        ; case lookupVarSet join_set id of
-            Just id' -> return (isJoinId_maybe id')
-            Nothing  -> return Nothing }
+            Just id' -> return (idJoinPointHood id')
+            Nothing  -> return NotJoinPoint }
 
 addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a
 addAliasUE id ue thing_inside = LintM $ \ env errs ->

compiler/GHC/Core/Opt/CSE.hs

@@ -14,7 +14,7 @@ import GHC.Types.Var.Env ( mkInScopeSet )
 import GHC.Types.Id     ( Id, idType, idHasRules, zapStableUnfolding
                         , idInlineActivation, setInlineActivation
                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
-                        , isJoinId, isJoinId_maybe, idUnfolding )
+                        , isJoinId, idJoinPointHood, idUnfolding )
 import GHC.Core.Utils   ( mkAltExpr
                         , exprIsTickedString
                         , stripTicksE, stripTicksT, mkTicks )
@@ -436,7 +436,7 @@ cse_bind toplevel env_rhs env_body (in_id, in_rhs) out_id
       -- See Note [Take care with literal strings]
   = (env_body', (out_id', in_rhs))
 
-  | Just arity <- isJoinId_maybe out_id
+  | JoinPoint arity <- idJoinPointHood out_id
       -- See Note [Look inside join-point binders]
   = let (params, in_body) = collectNBinders arity in_rhs
         (env', params') = addBinders env_rhs params

compiler/GHC/Core/Opt/DmdAnal.hs

@@ -1130,9 +1130,9 @@ splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)
 thresholdArity :: Id -> CoreExpr -> Arity
 -- See Note [Demand signatures are computed for a threshold arity based on idArity]
 thresholdArity fn rhs
-  = case isJoinId_maybe fn of
-      Just join_arity -> count isId $ fst $ collectNBinders join_arity rhs
-      Nothing         -> idArity fn
+  = case idJoinPointHood fn of
+      JoinPoint join_arity -> count isId $ fst $ collectNBinders join_arity rhs
+      NotJoinPoint         -> idArity fn
 
 -- | The result type after applying 'idArity' many arguments. Returns 'Nothing'
 -- when the type doesn't have exactly 'idArity' many arrows.
@@ -1948,6 +1948,7 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
               -- manifest arity for join points
   = -- pprTrace "finaliseArgBoxities" (
     --   vcat [text "function:" <+> ppr fn
+    --        , text "max" <+> ppr max_wkr_args
     --        , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
     --        , text "dmds after: " <+>  ppr arg_dmds' ]) $
     (arg_dmds', set_lam_dmds arg_dmds' rhs)

compiler/GHC/Core/Opt/Exitify.hs

@@ -36,20 +36,24 @@ Now `t` is no longer in a recursive function, and good things happen!
 -}
 
 import GHC.Prelude
+import GHC.Builtin.Uniques
+import GHC.Core
+import GHC.Core.Utils
+import GHC.Core.FVs
+import GHC.Core.Type
+
 import GHC.Types.Var
 import GHC.Types.Id
 import GHC.Types.Id.Info
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Utils.Monad.State.Strict
-import GHC.Builtin.Uniques
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
-import GHC.Core.FVs
-import GHC.Data.FastString
-import GHC.Core.Type
+import GHC.Types.Basic( JoinPointHood(..) )
+
+import GHC.Utils.Monad.State.Strict
 import GHC.Utils.Misc( mapSnd )
 
+import GHC.Data.FastString
+
 import Data.Bifunctor
 import Control.Monad
 
@@ -160,7 +164,7 @@ exitifyRec in_scope pairs
     go captured (_, AnnLet ann_bind body)
         -- join point, RHS and body are in tail-call position
         | AnnNonRec j rhs <- ann_bind
-        , Just join_arity <- isJoinId_maybe j
+        , JoinPoint join_arity <- idJoinPointHood j
         = do let (params, join_body) = collectNAnnBndrs join_arity rhs
              join_body' <- go (captured ++ params) join_body
              let rhs' = mkLams params join_body'

compiler/GHC/Core/Opt/FloatIn.hs

@@ -29,7 +29,7 @@ import GHC.Core.FVs
 import GHC.Core.Type
 
 import GHC.Types.Basic      ( RecFlag(..), isRec )
-import GHC.Types.Id         ( idType, isJoinId, isJoinId_maybe )
+import GHC.Types.Id         ( idType, isJoinId, idJoinPointHood )
 import GHC.Types.Tickish
 import GHC.Types.Var
 import GHC.Types.Var.Set
@@ -599,7 +599,7 @@ fiBind platform to_drop (AnnRec bindings) body_fvs
 ------------------
 fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
 fiRhs platform to_drop bndr rhs
-  | Just join_arity <- isJoinId_maybe bndr
+  | JoinPoint join_arity <- idJoinPointHood bndr
   , let (bndrs, body) = collectNAnnBndrs join_arity rhs
   = mkLams bndrs (fiExpr platform to_drop body)
   | otherwise

compiler/GHC/Core/Opt/FloatOut.hs

@@ -22,7 +22,7 @@ import GHC.Driver.Flags  ( DumpFlag (..) )
 import GHC.Utils.Logger
 import GHC.Types.Id      ( Id, idType,
 --                           idArity, isDeadEndId,
-                           isJoinId, isJoinId_maybe )
+                           isJoinId, idJoinPointHood )
 import GHC.Types.Tickish
 import GHC.Core.Opt.SetLevels
 import GHC.Types.Unique.Supply ( UniqSupply )
@@ -487,7 +487,7 @@ floatRhs :: CoreBndr
          -> LevelledExpr
          -> (FloatStats, FloatBinds, CoreExpr)
 floatRhs bndr rhs
-  | Just join_arity <- isJoinId_maybe bndr
+  | JoinPoint join_arity <- idJoinPointHood bndr
   , Just (bndrs, body) <- try_collect join_arity rhs []
   = case bndrs of
       []                -> floatExpr rhs

compiler/GHC/Core/Opt/SetLevels.hs

@@ -322,7 +322,7 @@ lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr
 --     there is no need call substAndLvlBndrs here
 lvl_top env is_rec bndr rhs
   = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr)
-                                   Nothing  -- Not a join point
+                                   NotJoinPoint
                                    (freeVars rhs)
        ; return (stayPut tOP_LEVEL bndr, rhs') }
 
@@ -666,9 +666,9 @@ lvlMFE env strict_ctxt ann_expr
          -- No wrapping needed if the type is lifted, or is a literal string
          -- or if we are wrapping it in one or more value lambdas
   = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
-                              is_bot_lam join_arity_maybe ann_expr
+                              is_bot_lam NotJoinPoint ann_expr
                   -- Treat the expr just like a right-hand side
-       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
+       ; var <- newLvlVar expr1 NotJoinPoint is_mk_static
        ; let var2 = annotateBotStr var float_n_lams mb_bot_str
        ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
                      (mkVarApps (Var var2) abs_vars)) }
@@ -689,7 +689,7 @@ lvlMFE env strict_ctxt ann_expr
                          Case expr1 (stayPut l1r ubx_bndr) box_ty
                              [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))]
 
-       ; var <- newLvlVar float_rhs Nothing is_mk_static
+       ; var <- newLvlVar float_rhs NotJoinPoint is_mk_static
        ; let l1u      = incMinorLvlFrom env
              use_expr = Case (mkVarApps (Var var) abs_vars)
                              (stayPut l1u bx_bndr) expr_ty
@@ -726,8 +726,6 @@ lvlMFE env strict_ctxt ann_expr
 
     (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
 
-    join_arity_maybe = Nothing
-
     is_mk_static = isJust (collectMakeStaticArgs expr)
         -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable
 
@@ -1177,8 +1175,8 @@ lvlBind env (AnnNonRec bndr rhs)
         -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)
 
     n_extra    = count isId abs_vars
-    mb_join_arity = isJoinId_maybe bndr
-    is_join       = isJust mb_join_arity
+    mb_join_arity = idJoinPointHood bndr
+    is_join       = isJoinPoint mb_join_arity
 
 lvlBind env (AnnRec pairs)
   |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
@@ -1193,7 +1191,7 @@ lvlBind env (AnnRec pairs)
   =    -- No float
     do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)
              (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
-             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r
+             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (idJoinPointHood b) r
        ; rhss' <- mapM lvl_rhs pairs
        ; return (Rec (bndrs' `zip` rhss'), env') }
 
@@ -1256,8 +1254,8 @@ lvlBind env (AnnRec pairs)
                                         is_bot (get_join bndr)
                                         rhs
 
-    get_join bndr | need_zap  = Nothing
-                  | otherwise = isJoinId_maybe bndr
+    get_join bndr | need_zap  = NotJoinPoint
+                  | otherwise = idJoinPointHood bndr
     need_zap = dest_lvl `ltLvl` joinCeilingLevel env
 
         -- Finding the free vars of the binding group is annoying
@@ -1284,7 +1282,7 @@ profitableFloat env dest_lvl
 lvlRhs :: LevelEnv
        -> RecFlag
        -> Bool               -- Is this a bottoming function
-       -> Maybe JoinArity
+       -> JoinPointHood
        -> CoreExprWithFVs
        -> LvlM LevelledExpr
 lvlRhs env rec_flag is_bot mb_join_arity expr
@@ -1293,7 +1291,7 @@ lvlRhs env rec_flag is_bot mb_join_arity expr
 
 lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
             -> Bool   -- Binding is for a bottoming function
-            -> Maybe JoinArity
+            -> JoinPointHood
             -> CoreExprWithFVs
             -> LvlM (Expr LevelledBndr)
 -- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline
@@ -1304,13 +1302,13 @@ lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
                   else lvlExpr body_env      body
        ; return (mkLams bndrs' body') }
   where
-    (bndrs, body)     | Just join_arity <- mb_join_arity
+    (bndrs, body)     | JoinPoint join_arity <- mb_join_arity
                       = collectNAnnBndrs join_arity rhs
                       | otherwise
                       = collectAnnBndrs rhs
     (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs
     all_bndrs         = abs_vars ++ bndrs1
-    (body_env, bndrs') | Just _ <- mb_join_arity
+    (body_env, bndrs') | JoinPoint {} <- mb_join_arity
                       = lvlJoinBndrs env1 dest_lvl rec all_bndrs
                       | otherwise
                       = case lvlLamBndrs env1 dest_lvl all_bndrs of
@@ -1741,14 +1739,14 @@ newPolyBndrs dest_lvl
     -- but we may need to adjust its arity
     dest_is_top = isTopLvl dest_lvl
     transfer_join_info bndr new_bndr
-      | Just join_arity <- isJoinId_maybe bndr
+      | JoinPoint join_arity <- idJoinPointHood bndr
       , not dest_is_top
       = new_bndr `asJoinId` join_arity + length abs_vars
       | otherwise
       = new_bndr
 
 newLvlVar :: LevelledExpr        -- The RHS of the new binding
-          -> Maybe JoinArity     -- Its join arity, if it is a join point
+          -> JoinPointHood       -- Its join arity, if it is a join point
           -> Bool                -- True <=> the RHS looks like (makeStatic ...)
           -> LvlM Id
 newLvlVar lvld_rhs join_arity_maybe is_mk_static

compiler/GHC/Core/Opt/Simplify/Env.hs

@@ -373,7 +373,7 @@ type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
 
 -- | A substitution result.
 data SimplSR
-  = DoneEx OutExpr (Maybe JoinArity)
+  = DoneEx OutExpr JoinPointHood
        -- If  x :-> DoneEx e ja   is in the SimplIdSubst
        -- then replace occurrences of x by e
        -- and  ja = Just a <=> x is a join-point of arity a
@@ -398,8 +398,8 @@ instance Outputable SimplSR where
   ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e
     where
       pp_mj = case mj of
-                Nothing -> empty
-                Just n  -> parens (int n)
+                NotJoinPoint -> empty
+                JoinPoint n  -> parens (int n)
 
   ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
                                 ppr (filter_env tv), ppr (filter_env id) -}]

compiler/GHC/Core/Opt/Simplify/Iteration.hs

@@ -425,7 +425,7 @@ simplAuxBind env bndr new_rhs
   = return ( emptyFloats env
            , case new_rhs of
                 Coercion co -> extendCvSubst env bndr co
-                _           -> extendIdSubst env bndr (DoneEx new_rhs Nothing) )
+                _           -> extendIdSubst env bndr (DoneEx new_rhs NotJoinPoint) )
 
   | otherwise
   = do  { -- ANF-ise the RHS
@@ -625,7 +625,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
           then do { tick (PostInlineUnconditionally bndr)
                   ; return ( floats
                            , extendIdSubst (setInScopeFromF env floats) old_bndr $
-                             DoneEx triv_rhs Nothing ) }
+                             DoneEx triv_rhs NotJoinPoint ) }
 
           else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs
                   ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)
@@ -961,7 +961,7 @@ completeBind env bind_cxt old_bndr new_bndr new_rhs
                  ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $
                    return ( emptyFloats env
                           , extendIdSubst env old_bndr $
-                            DoneEx unf_rhs (isJoinId_maybe new_bndr)) }
+                            DoneEx unf_rhs (idJoinPointHood new_bndr)) }
                 -- Use the substitution to make quite, quite sure that the
                 -- substitution will happen, since we are going to discard the binding
 
@@ -1303,7 +1303,7 @@ work. T5631 is a good example of this.
 simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont
              -> SimplM OutExpr
 simplJoinRhs env bndr expr cont
-  | Just arity <- isJoinId_maybe bndr
+  | JoinPoint arity <- idJoinPointHood bndr
   =  do { let (join_bndrs, join_body) = collectNBinders arity expr
               mult = contHoleScaling cont
         ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)
@@ -1985,14 +1985,14 @@ wrapJoinCont env cont thing_inside
 
 --------------------
 trimJoinCont :: Id         -- Used only in error message
-             -> Maybe JoinArity
+             -> JoinPointHood
              -> SimplCont -> SimplCont
 -- Drop outer context from join point invocation (jump)
 -- See Note [Join points and case-of-case]
 
-trimJoinCont _ Nothing cont
+trimJoinCont _ NotJoinPoint cont
   = cont -- Not a jump
-trimJoinCont var (Just arity) cont
+trimJoinCont var (JoinPoint arity) cont
   = trim arity cont
   where
     trim 0 cont@(Stop {})
@@ -2139,7 +2139,7 @@ simplIdF env var cont
 
       DoneId var1 ->
         do { rule_base <- getSimplRules
-           ; let cont' = trimJoinCont var1 (isJoinId_maybe var1) cont
+           ; let cont' = trimJoinCont var1 (idJoinPointHood var1) cont
                  info  = mkArgInfo env rule_base var1 cont'
            ; rebuildCall env info cont' }
 
@@ -3260,7 +3260,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
 improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]
   | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
   = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2
-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing
+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint
               env2 = extendIdSubst env case_bndr rhs
         ; return (env2, scrut `Cast` co, case_bndr2) }
 
@@ -3549,7 +3549,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
     bind_case_bndr env
       | isDeadBinder bndr   = return (emptyFloats env, env)
       | exprIsTrivial scrut = return (emptyFloats env
-                                     , extendIdSubst env bndr (DoneEx scrut Nothing))
+                                     , extendIdSubst env bndr (DoneEx scrut NotJoinPoint))
                               -- See Note [Do not duplicate constructor applications]
       | otherwise           = do { dc_args <- mapM (simplVar env) bs
                                          -- dc_ty_args are already OutTypes,
@@ -4463,11 +4463,11 @@ simplRules env mb_new_id rules bind_cxt
                  -- binder matches that of the rule, so that pushing the
                  -- continuation into the RHS makes sense
                  join_ok = case mb_new_id of
-                             Just id | Just join_arity <- isJoinId_maybe id
+                             Just id | JoinPoint join_arity <- idJoinPointHood id
                                      -> length args == join_arity
                              _ -> False
                  bad_join_msg = vcat [ ppr mb_new_id, ppr rule
-                                     , ppr (fmap isJoinId_maybe mb_new_id) ]
+                                     , ppr (fmap idJoinPointHood mb_new_id) ]
 
            ; args' <- mapM (simplExpr lhs_env) args
            ; rhs'  <- simplExprC rhs_env rhs rhs_cont

compiler/GHC/Core/Opt/SpecConstr.hs

@@ -1941,8 +1941,8 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
                   = calcSpecInfo fn arg_bndrs call_pat extra_bndrs
 
               spec_arity = count isId spec_lam_args
-              spec_join_arity | isJoinId fn = Just (length spec_call_args)
-                              | otherwise   = Nothing
+              spec_join_arity | isJoinId fn = JoinPoint (length spec_call_args)
+                              | otherwise   = NotJoinPoint
               spec_id    = asWorkerLikeId $
                            mkLocalId spec_name ManyTy
                                      (mkLamTypes spec_lam_args spec_body_ty)

compiler/GHC/Core/Opt/WorkWrap.hs

@@ -830,8 +830,8 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
       -- inl_act:    see Note [Worker activation]
       -- inl_rule:   it does not make sense for workers to be constructorlike.
 
-    work_join_arity | isJoinId fn_id = Just join_arity
-                    | otherwise      = Nothing
+    work_join_arity | isJoinId fn_id = JoinPoint join_arity
+                    | otherwise      = NotJoinPoint
       -- worker is join point iff wrapper is join point
       -- (see Note [Don't w/w join points for CPR])
 

compiler/GHC/Core/Ppr.hs

@@ -44,7 +44,6 @@ import GHC.Core.TyCon
 import GHC.Core.TyCo.Ppr
 import GHC.Core.Coercion
 import GHC.Types.Basic
-import GHC.Data.Maybe
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Types.SrcLoc ( pprUserRealSpan )
@@ -140,8 +139,8 @@ ppr_binding ann (val_bdr, expr)
     pp_val_bdr = pprPrefixOcc val_bdr
 
     pp_bind = case bndrIsJoin_maybe val_bdr of
-                Nothing -> pp_normal_bind
-                Just ar -> pp_join_bind ar
+                NotJoinPoint -> pp_normal_bind
+                JoinPoint ar -> pp_join_bind ar
 
     pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr)
 
@@ -306,12 +305,12 @@ ppr_expr add_par (Let bind expr)
          pprCoreExpr expr]
   where
     keyword (NonRec b _)
-     | isJust (bndrIsJoin_maybe b) = text "join"
-     | otherwise                   = text "let"
+     | isJoinPoint (bndrIsJoin_maybe b) = text "join"
+     | otherwise                        = text "let"
     keyword (Rec pairs)
      | ((b,_):_) <- pairs
-     , isJust (bndrIsJoin_maybe b) = text "joinrec"
-     | otherwise                   = text "letrec"
+     , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec"
+     | otherwise                        = text "letrec"
 
 ppr_expr add_par (Tick tickish expr)
   = sdocOption sdocSuppressTicks $ \case
@@ -382,13 +381,13 @@ instance OutputableBndr Var where
   pprBndr = pprCoreBinder
   pprInfixOcc  = pprInfixName  . varName
   pprPrefixOcc = pprPrefixName . varName
-  bndrIsJoin_maybe = isJoinId_maybe
+  bndrIsJoin_maybe = idJoinPointHood
 
 instance Outputable b => OutputableBndr (TaggedBndr b) where
   pprBndr _    b = ppr b   -- Simple
   pprInfixOcc  b = ppr b
   pprPrefixOcc b = ppr b
-  bndrIsJoin_maybe (TB b _) = isJoinId_maybe b
+  bndrIsJoin_maybe (TB b _) = idJoinPointHood b
 
 pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc
 pprOcc Infix  = pprInfixOcc