.editorconfig

@@ -12,3 +12,7 @@ end_of_line = lf
 
 [Makefile]
 indent_style = tab
+
+[*.c]
+indent_style = space
+indent_size = 2

README.md

@@ -53,19 +53,22 @@ For building library documentation, you'll need [Haddock][6].  To build
 the compiler documentation, you need [Sphinx](http://www.sphinx-doc.org/)
 and Xelatex (only for PDF output).
 
-**Quick start**: the following gives you a default build:
+**Quick start**: GHC is built using the [Hadrian build system](hadrian/README.md).
+The following gives you a default build:
 
     $ ./boot
     $ ./configure
-    $ make         # can also say 'make -jX' for X number of jobs
-    $ make install
+    $ hadrian/build         # can also say '-jX' for X number of jobs
 
   On Windows, you need an extra repository containing some build tools.
   These can be downloaded for you by configure. This only needs to be done once by running:
 
     $ ./configure --enable-tarballs-autodownload
 
-(NB: **Do you have multiple cores? Be sure to tell that to `make`!** This can
+  Additionally, on Windows, to run Hadrian you should run `hadrian/build.bat`
+  instead of `hadrian/build`.
+
+(NB: **Do you have multiple cores? Be sure to tell that to `hadrian`!** This can
 save you hours of build time depending on your system configuration, and is
 almost always a win regardless of how many cores you have. As a simple rule,
 you should have about N+1 jobs, where `N` is the amount of cores you have.)

compiler/GHC/Core/Opt/Exitify.hs

@@ -433,6 +433,7 @@ inlining.
 Exit join points, recognizable using `isExitJoinId` are join points with an
 occurrence in a recursive group, and can be recognized (after the occurrence
 analyzer ran!) using `isExitJoinId`.
+
 This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,
 because the lambdas of a non-recursive join point are not considered for
 `occ_in_lam`.  For example, in the following code, `j1` is /not/ marked
@@ -446,6 +447,29 @@ To prevent inlining, we check for isExitJoinId
 * In `simplLetUnfolding` we simply give exit join points no unfolding, which
   prevents inlining in `postInlineUnconditionally` and call sites.
 
+But see Note [Be selective about not-inlining exit join points]
+
+Note [Be selective about not-inlining exit join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we follow "do not inline exit join points" mantra throughout,
+some bad things happen.
+
+* We can lose CPR information: see #21148
+
+* We get useless clutter (#22084) that
+  - makes the program bigger (including duplicated code #20739), and
+  - adds extra jumps (and maybe stack saves) at runtime
+
+So instead we follow "do not inline exit join points" for a /single run/
+of the simplifier, right after Exitification.  That should give a
+sufficient chance for used-once things to inline, but subsequent runs
+will inline them back in.  (Annoyingly, as things stand, only with -O2
+is there a subsequent run, but that might change, and it's not a huge
+deal anyway.)
+
+This is controlled by the Simplifier's sm_keep_exits flag; see
+GHC.Core.Opt.Pipeline.
+
 Note [Placement of the exitification pass]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 I (Joachim) experimented with multiple positions for the Exitification pass in

compiler/GHC/Core/Opt/Pipeline.hs

@@ -15,7 +15,7 @@ import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
 import GHC.Driver.Env
 import GHC.Driver.Config.Core.Lint ( endPass )
 import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
-import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode )
+import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode )
 import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts )
 import GHC.Driver.Config.Core.Rules ( initRuleOpts )
 import GHC.Platform.Ways  ( hasWay, Way(WayProf) )
@@ -28,6 +28,7 @@ import GHC.Core.Utils   ( dumpIdInfoOfProgram )
 import GHC.Core.Lint    ( lintAnnots )
 import GHC.Core.Lint.Interactive ( interactiveInScope )
 import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm )
+import GHC.Core.Opt.Simplify.Env( SimplMode(..) )
 import GHC.Core.Opt.Simplify.Monad
 import GHC.Core.Opt.Monad
 import GHC.Core.Opt.Pipeline.Types
@@ -154,32 +155,45 @@ getCoreToDo dflags rule_base extra_vars
     maybe_strictness_before _
       = CoreDoNothing
 
-    simpl_phase phase name iter
-      = CoreDoPasses
-      $   [ maybe_strictness_before phase
-          , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter
-                             (initSimplMode dflags phase name) rule_base
-          , maybe_rule_check phase ]
+    ----------------------------
+    base_simpl_mode :: SimplMode
+    base_simpl_mode = initSimplMode dflags
 
-    -- Run GHC's internal simplification phase, after all rules have run.
-    -- See Note [Compiler phases] in GHC.Types.Basic
-    simplify name = simpl_phase FinalPhase name max_iter
-
-    -- initial simplify: mk specialiser happy: minimum effort please
+    -- gentle_mode: make specialiser happy: minimum effort please
     -- See Note [Inline in InitialPhase]
     -- See Note [RULEs enabled in InitialPhase]
-    simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter
-                                    (initGentleSimplMode dflags) rule_base
+    gentle_mode = base_simpl_mode { sm_names     = ["Gentle"]
+                                  , sm_phase     = InitialPhase
+                                  , sm_case_case = False }
+
+    simpl_mode phase name
+      = base_simpl_mode { sm_names = [name], sm_phase = phase }
+
+    keep_exits :: SimplMode -> SimplMode
+    -- See Note [Be selective about not-inlining exit join points]
+    -- in GHC.Core.Opt.Exitify
+    keep_exits mode = mode { sm_keep_exits = True }
+
+    ----------------------------
+    run_simplifier mode iter
+      = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode rule_base
 
+    simpl_phase phase name iter = CoreDoPasses $
+                                  [ maybe_strictness_before phase
+                                  , run_simplifier (simpl_mode phase name) iter
+                                  , maybe_rule_check phase ]
+
+    -- Run GHC's internal simplification phase, after all rules have run.
+    -- See Note [Compiler phases] in GHC.Types.Basic
+    simpl_gently          = run_simplifier gentle_mode  max_iter
+    simplify_final   name = run_simplifier (             simpl_mode FinalPhase name) max_iter
+    simpl_keep_exits name = run_simplifier (keep_exits $ simpl_mode FinalPhase name) max_iter
+
+    ----------------------------
     dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper]
                           else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper]
 
 
-    demand_analyser = (CoreDoPasses (
-                           dmd_cpr_ww ++
-                           [simplify "post-worker-wrapper"]
-                           ))
-
     -- Static forms are moved to the top level with the FloatOut pass.
     -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
     static_ptrs_float_outwards =
@@ -269,14 +283,16 @@ getCoreToDo dflags rule_base extra_vars
 
         runWhen call_arity $ CoreDoPasses
             [ CoreDoCallArity
-            , simplify "post-call-arity"
+            , simplify_final "post-call-arity"
             ],
 
         -- Strictness analysis
-        runWhen strictness demand_analyser,
+        runWhen strictness $ CoreDoPasses
+            (dmd_cpr_ww ++ [simplify_final "post-worker-wrapper"]),
 
         runWhen exitification CoreDoExitify,
             -- See Note [Placement of the exitification pass]
+            -- in GHC.Core.Opt.Exitify
 
         runWhen full_laziness $
            CoreDoFloatOutwards FloatOutSwitches {
@@ -298,7 +314,17 @@ getCoreToDo dflags rule_base extra_vars
 
         runWhen do_float_in CoreDoFloatInwards,
 
-        simplify "final",  -- Final tidy-up
+        -- Final tidy-up run of the simplifier
+        simpl_keep_exits "final tidy up",
+            -- Keep exit join point because this is the first
+            -- Simplifier run after Exitify. Subsequent runs will
+            -- re-inline those exit join points; their work is done.
+            -- See Note [Be selective about not-inlining exit join points]
+            -- in GHC.Core.Opt.Exitify
+            --
+            -- Annoyingly, we only /have/ a subsequent run with -O2.  With
+            -- plain -O we'll still have those exit join points hanging around.
+            -- Oh well.
 
         maybe_rule_check FinalPhase,
 
@@ -308,31 +334,31 @@ getCoreToDo dflags rule_base extra_vars
                 -- Case-liberation for -O2.  This should be after
                 -- strictness analysis and the simplification which follows it.
         runWhen liberate_case $ CoreDoPasses
-           [ CoreLiberateCase, simplify "post-liberate-case" ],
+           [ CoreLiberateCase, simplify_final "post-liberate-case" ],
            -- Run the simplifier after LiberateCase to vastly
            -- reduce the possibility of shadowing
            -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr
 
         runWhen spec_constr $ CoreDoPasses
-           [ CoreDoSpecConstr, simplify "post-spec-constr"],
+           [ CoreDoSpecConstr, simplify_final "post-spec-constr"],
            -- See Note [Simplify after SpecConstr]
 
         maybe_rule_check FinalPhase,
 
         runWhen late_specialise $ CoreDoPasses
-           [ CoreDoSpecialising, simplify "post-late-spec"],
+           [ CoreDoSpecialising, simplify_final "post-late-spec"],
 
         -- LiberateCase can yield new CSE opportunities because it peels
         -- off one layer of a recursive function (concretely, I saw this
         -- in wheel-sieve1), and I'm guessing that SpecConstr can too
         -- And CSE is a very cheap pass. So it seems worth doing here.
         runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses
-           [ CoreCSE, simplify "post-final-cse" ],
+           [ CoreCSE, simplify_final "post-final-cse" ],
 
         ---------  End of -O2 passes --------------
 
         runWhen late_dmd_anal $ CoreDoPasses (
-            dmd_cpr_ww ++ [simplify "post-late-ww"]
+            dmd_cpr_ww ++ [simplify_final "post-late-ww"]
           ),
 
         -- Final run of the demand_analyser, ensures that one-shot thunks are

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

@@ -248,13 +248,16 @@ data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad
   , sm_uf_opts      :: !UnfoldingOpts -- ^ Unfolding options
   , sm_case_case    :: !Bool          -- ^ Whether case-of-case is enabled
   , sm_pre_inline   :: !Bool          -- ^ Whether pre-inlining is enabled
-  , sm_float_enable :: !FloatEnable   -- ^ Whether to enable floating out
+  , sm_keep_exits   :: !Bool          -- ^ True <=> keep ExitJoinIds
+                                      -- See Note [Do not inline exit join points]
+                                      --          in GHC.Core.Opt.Exitify
+  , sm_float_enable     :: !FloatEnable   -- ^ Whether to enable floating out
   , sm_do_eta_reduction :: !Bool
-  , sm_arity_opts :: !ArityOpts
-  , sm_rule_opts :: !RuleOpts
-  , sm_case_folding :: !Bool
-  , sm_case_merge :: !Bool
-  , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
+  , sm_arity_opts       :: !ArityOpts
+  , sm_rule_opts        :: !RuleOpts
+  , sm_case_folding     :: !Bool
+  , sm_case_merge       :: !Bool
+  , sm_co_opt_opts      :: !OptCoercionOpts -- ^ Coercion optimiser options
   }
 
 instance Outputable SimplMode where

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

@@ -1320,11 +1320,11 @@ preInlineUnconditionally
 -- Reason: we don't want to inline single uses, or discard dead bindings,
 --         for unlifted, side-effect-ful bindings
 preInlineUnconditionally env top_lvl bndr rhs rhs_env
-  | not pre_inline_unconditionally           = Nothing
+  | not pre_inline                           = Nothing
   | not active                               = Nothing
   | isTopLevel top_lvl && isDeadEndId bndr   = Nothing -- Note [Top-level bottoming Ids]
   | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]
-  | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]
+  | keep_exits, isExitJoinId bndr            = Nothing -- Note [Do not inline exit join points]
                                                        -- in module Exitify
   | not (one_occ (idOccInfo bndr))           = Nothing
   | not (isStableUnfolding unf)              = Just $! (extend_subst_with rhs)
@@ -1334,19 +1334,36 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
   , Just inl <- maybeUnfoldingTemplate unf   = Just $! (extend_subst_with inl)
   | otherwise                                = Nothing
   where
+    mode       = seMode env
+    phase      = sm_phase mode
+    keep_exits = sm_keep_exits mode
+    pre_inline = sm_pre_inline mode
+
     unf = idUnfolding bndr
     extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
 
     one_occ IAmDead = True -- Happens in ((\x.1) v)
+
     one_occ OneOcc{ occ_n_br   = 1
                   , occ_in_lam = NotInsideLam }   = isNotTopLevel top_lvl || early_phase
+
     one_occ OneOcc{ occ_n_br   = 1
                   , occ_in_lam = IsInsideLam
                   , occ_int_cxt = IsInteresting } = canInlineInLam rhs
-    one_occ _                                     = False
 
-    pre_inline_unconditionally = sePreInline env
-    active = isActive (sePhase env) (inlinePragmaActivation inline_prag)
+    one_occ OneOcc{ occ_n_br = 1 } -- Inline join point that are used once, even inside
+      | isJoinId bndr = True       -- lambdas (which are presumably other join points)
+      -- E.g.   join j x = rhs in
+      --        joinrec k y = ....j x....
+      -- Here j must be an exit for k, and we can safely inline it under the lambda
+      -- This includes the case where j is nullary: a nullary join point is just the
+      -- same as an arity-1 one. So we don't look at occ_int_cxt.
+      -- All of this only applies if keep_exits is False, otherwise the
+      -- earlier guard on preInlineUnconditionally would have fired
+
+    one_occ _ = False
+
+    active = isActive phase (inlinePragmaActivation inline_prag)
              -- See Note [pre/postInlineUnconditionally in gentle mode]
     inline_prag = idInlinePragma bndr
 
@@ -1378,7 +1395,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
       -- not ticks.  Counting ticks cannot be duplicated, and non-counting
       -- ticks around a Lam will disappear anyway.
 
-    early_phase = sePhase env /= FinalPhase
+    early_phase = phase /= FinalPhase
     -- If we don't have this early_phase test, consider
     --      x = length [1,2,3]
     -- The full laziness pass carefully floats all the cons cells to

compiler/GHC/Core/Opt/SpecConstr.hs

@@ -881,7 +881,7 @@ data SpecConstrOpts = SpecConstrOpts
 
   , sc_count     :: !(Maybe Int)
   -- ^ Max # of specialisations for any one function. Nothing => no limit.
-  -- See Note [Avoiding exponential blowup].
+  -- See Note [Avoiding exponential blowup] and decreaseSpecCount
 
   , sc_recursive :: !Int
   -- ^ Max # of specialisations over recursive type. Stops
@@ -1098,16 +1098,20 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs
 
 decreaseSpecCount :: ScEnv -> Int -> ScEnv
 -- See Note [Avoiding exponential blowup]
-decreaseSpecCount env n_specs
+decreaseSpecCount env _n_specs
   = env { sc_force = False   -- See Note [Forcing specialisation]
-        , sc_opts = (sc_opts env)
-            { sc_count = case sc_count $ sc_opts env of
-                       Nothing -> Nothing
-                       Just n  -> Just $! (n `div` (n_specs + 1))
+        , sc_opts = opts { sc_count = case sc_count opts of
+                             Nothing -> Nothing
+                             Just n  -> Just $! dec n
             }
         }
-        -- The "+1" takes account of the original function;
-        -- See Note [Avoiding exponential blowup]
+  where
+    opts  = sc_opts env
+    dec n = n `div` 2  -- See Note [Avoiding exponential blowup]
+
+    -- Or:   n `div` (n_specs + 1)
+    -- See the historical note part of Note [Avoiding exponential blowup]
+    -- The "+1" takes account of the original function;
 
 ---------------------------------------------------
 -- See Note [Forcing specialisation]
@@ -1183,9 +1187,20 @@ we can specialise $j2, and similarly $j3.  Even if we make just *one*
 specialisation of each, because we also have the original we'll get 2^n
 copies of $j3, which is not good.
 
-So when recursively specialising we divide the sc_count by the number of
-copies we are making at this level, including the original.
-
+So when recursively specialising we divide the sc_count (the maximum
+number of specialisations, in the ScEnv) by two.  You might think that
+gives us n*(n/2)*(n/4)... copies of the innnermost thing, which is
+still exponential the depth.  But we use integer division, rounding
+down, so if the starting sc_count is 3, we'll get 3 -> 1 -> 0, and
+stop.  In fact, simply subtracting 1 would be good enough, for the same
+reason.
+
+Historical note: in the past we divided by (n_specs+1), where n_specs
+is the number of specialisations at this level; but that gets us down
+to zero jolly quickly, which I found led to some regressions.  (An
+example is nofib/spectral/fibheaps, the getMin' function inside the
+outer function $sfibToList, which has several interesting call
+patterns.)
 
 ************************************************************************
 *                                                                      *
@@ -1512,8 +1527,10 @@ scExpr' env (Case scrut b ty alts)
                 scrut_occ = case con of
                                DataAlt dc -- See Note [Do not specialise evals]
                                   | not (single_alt && all deadArgOcc arg_occs)
-                                  -> ScrutOcc (unitUFM dc arg_occs)
-                               _  -> UnkOcc
+                                  -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
+                                     ScrutOcc (unitUFM dc arg_occs)
+                               _  -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
+                                     UnkOcc
           ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }
 
 
@@ -1792,16 +1809,19 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
   , not (null arg_bndrs)                         -- Only specialise functions
   , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it
   = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $
-    do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls
+    do  { (boring_call, pats_discarded, new_pats)
+             <- callsToNewPats env fn spec_info arg_occs all_calls
 
         ; let n_pats = length new_pats
---        ; if (not (null new_pats) || isJust mb_unspec) then
---            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"
---                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)
---                                        , text "arg_occs" <+> ppr arg_occs
---                                        , text "good pats" <+> ppr new_pats])  $
---               return ()
---          else return ()
+--        ; when (not (null new_pats) || isJust mb_unspec) $
+--          pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"
+--                                       , text "boring_call:" <+> ppr boring_call
+--                                       , text "pats_discarded:" <+> ppr pats_discarded
+--                                       , text "old spec_count" <+> ppr spec_count
+--                                       , text "spec count limit" <+> ppr (sc_count (sc_opts env))
+--                                       , text "mb_unspec" <+> ppr (isJust mb_unspec)
+--                                       , text "arg_occs" <+> ppr arg_occs
+--                                       , text "new_pats" <+> ppr new_pats])
 
         ; let spec_env = decreaseSpecCount env n_pats
         ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
@@ -1810,7 +1830,7 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
 
         ; let spec_usg = combineUsages spec_usgs
 
-              unspec_rhs_needed = boring_call || isExportedId fn
+              unspec_rhs_needed = pats_discarded || boring_call || isExportedId fn
 
               -- If there were any boring calls among the seeds (= all_calls), then those
               -- calls will call the un-specialised function.  So we should use the seeds
@@ -1821,15 +1841,14 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
                                -> (spec_usg `combineUsage` rhs_usg, Nothing)
                   _            -> (spec_usg,                      mb_unspec)
 
---        ; pprTrace "specialise return }"
---             (vcat [ ppr fn
---                   , text "boring_call:" <+> ppr boring_call
---                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $
---          return ()
+--        ; pprTraceM "specialise return }" $
+--          vcat [ ppr fn
+--               , text "unspec_rhs_needed:" <+> ppr unspec_rhs_needed
+--               , text "new calls:" <+> ppr (scu_calls new_usg)]
 
-          ; return (new_usg, SI { si_specs     = new_specs ++ specs
-                                , si_n_specs   = spec_count + n_pats
-                                , si_mb_unspec = mb_unspec' }) }
+        ; return (new_usg, SI { si_specs     = new_specs ++ specs
+                              , si_n_specs   = spec_count + n_pats
+                              , si_mb_unspec = mb_unspec' }) }
 
   | otherwise  -- No calls, inactive, or not a function
                -- Behave as if there was a single, boring call
@@ -1872,7 +1891,9 @@ spec_one :: ScEnv
 
 spec_one env fn arg_bndrs body (call_pat, rule_number)
   | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat
-  = do  { spec_uniq <- getUniqueM
+  = do  { -- pprTraceM "spec_one {" (ppr fn <+> ppr pats)
+
+        ; spec_uniq <- getUniqueM
         ; let env1 = extendScSubstList (extendScInScope env qvars)
                                        (arg_bndrs `zip` pats)
               (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs)
@@ -1898,9 +1919,6 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
         -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)
         ; (spec_usg, spec_body) <- scExpr body_env body
 
---      ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $
---        return ()
-
                 -- And build the results
         ; (qvars', pats') <- generaliseDictPats qvars pats
         ; let spec_body_ty   = exprType spec_body
@@ -1944,21 +1962,22 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
                                   fn_name qvars' pats' rule_rhs
                            -- See Note [Transfer activation]
 
-        -- ; pprTraceM "spec_one {" (vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))
-        --                               , text "sc_count:" <+> ppr (sc_count env)
-        --                               , text "pats:" <+> ppr pats
-        --                               , text "call_pat:" <+> ppr call_pat
-        --                               , text "-->" <+> ppr spec_name
-        --                               , text "bndrs" <+> ppr arg_bndrs
-        --                               , text "extra_bndrs" <+> ppr extra_bndrs
-        --                               , text "cbv_args" <+> ppr cbv_args
-        --                               , text "spec_lam_args" <+> ppr spec_lam_args
-        --                               , text "spec_call_args" <+> ppr spec_call_args
-        --                               , text "rule_rhs" <+> ppr rule_rhs
-        --                               , text "adds_void_worker_arg" <+> ppr add_void_arg
-        --                               , text "body" <+> ppr body
-        --                               , text "spec_rhs" <+> ppr spec_rhs
-        --                               , text "how_bound" <+> ppr (sc_how_bound env) ])
+--        ; pprTraceM "spec_one end }" $
+--          vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))
+--               , text "pats:" <+> ppr pats
+--               , text "call_pat:" <+> ppr call_pat
+--               , text "-->" <+> ppr spec_name
+--               , text "bndrs" <+> ppr arg_bndrs
+--               , text "extra_bndrs" <+> ppr extra_bndrs
+--               , text "cbv_args" <+> ppr cbv_args
+--               , text "spec_lam_args" <+> ppr spec_lam_args
+--               , text "spec_call_args" <+> ppr spec_call_args
+--               , text "rule_rhs" <+> ppr rule_rhs
+--               , text "adds_void_worker_arg" <+> ppr add_void_arg
+----               , text "body" <+> ppr body
+----               , text "spec_rhs" <+> ppr spec_rhs
+----               , text "how_bound" <+> ppr (sc_how_bound env) ]
+--               ]
         ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule
                                , os_id = spec_id
                                , os_rhs = spec_rhs }) }
@@ -2328,7 +2347,9 @@ instance Outputable CallPat where
 callsToNewPats :: ScEnv -> Id
                -> SpecInfo
                -> [ArgOcc] -> [Call]
-               -> UniqSM (Bool, [CallPat])
+               -> UniqSM ( Bool        -- At least one boring call
+                         , Bool        -- Patterns were discarded
+                         , [CallPat] ) -- Patterns to specialise
 -- Result has no duplicate patterns,
 -- nor ones mentioned in si_specs (hence "new" patterns)
 -- Bool indicates that there was at least one boring pattern
@@ -2360,12 +2381,11 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
                 -- Discard specialisations if there are too many of them
               (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats
 
---        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
---                                       , text "done_specs:" <+> ppr (map os_pat done_specs)
---                                       , text "good_pats:" <+> ppr good_pats ]) $
---          return ()
+--        ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
+--                                        , text "done_specs:" <+> ppr (map os_pat done_specs)
+--                                        , text "trimmed_pats:" <+> ppr trimmed_pats ])
 
-        ; return (have_boring_call || pats_were_discarded, trimmed_pats) }
+        ; return (have_boring_call, pats_were_discarded, trimmed_pats) }
           -- If any of the calls does not give rise to a specialisation, either
           -- because it is boring, or because there are too many specialisations,
           -- return a flag to say so, so that we know to keep the original function.
@@ -2474,29 +2494,29 @@ callToPats env bndr_occs call@(Call fn args con_env)
               sanitise id   = updateIdTypeAndMult expandTypeSynonyms id
                 -- See Note [Free type variables of the qvar types]
 
-              -- Bad coercion variables: see Note [SpecConstr and casts]
-              bad_covars :: CoVarSet
+
+        -- Check for bad coercion variables: see Note [SpecConstr and casts]
+        ; let bad_covars :: CoVarSet
               bad_covars = mapUnionVarSet get_bad_covars pats
               get_bad_covars :: CoreArg -> CoVarSet
               get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty)
               get_bad_covars _         = emptyVarSet
               bad_covar v = isId v && not (is_in_scope v)
 
-        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $
-          warnPprTrace (not (isEmptyVarSet bad_covars))
+        ; warnPprTrace (not (isEmptyVarSet bad_covars))
               "SpecConstr: bad covars"
               (ppr bad_covars $$ ppr call) $
+
           if interesting && isEmptyVarSet bad_covars
-          then do
-              -- pprTraceM "callToPatsOut" (
-              --         text "fn:" <+> ppr fn $$
-              --         text "args:" <+> ppr args $$
-              --         text "in_scope:" <+> ppr in_scope $$
-              --         -- text "in_scope:" <+> ppr in_scope $$
-              --         text "pat_fvs:" <+> ppr pat_fvs
-              --       )
-              --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>
-              return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids }))
+          then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats
+                                    , cp_strict_args = concat cbv_ids }
+--                  ; pprTraceM "callToPatsOut" $
+--                    vcat [ text "fn:" <+> ppr fn
+--                         , text "args:" <+> ppr args
+--                         , text "bndr_occs:" <+> ppr bndr_occs
+--                         , text "pat_fvs:" <+> ppr pat_fvs
+--                         , text "cp_res:" <+> ppr cp_res ]
+                  ; return (Just cp_res) }
           else return Nothing }
 
     -- argToPat takes an actual argument, and returns an abstracted

compiler/GHC/Driver/Config/Core/Opt/Simplify.hs

@@ -2,7 +2,6 @@ module GHC.Driver.Config.Core.Opt.Simplify
   ( initSimplifyExprOpts
   , initSimplifyOpts
   , initSimplMode
-  , initGentleSimplMode
   ) where
 
 import GHC.Prelude
@@ -27,12 +26,13 @@ import GHC.Types.Var ( Var )
 initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts
 initSimplifyExprOpts dflags ic = SimplifyExprOpts
   { se_fam_inst = snd $ ic_instances ic
-  , se_mode = (initSimplMode dflags InitialPhase "GHCi")
-    { sm_inline = False
-      -- Do not do any inlining, in case we expose some
-      -- unboxed tuple stuff that confuses the bytecode
+
+  , se_mode = (initSimplMode dflags) { sm_names = ["GHCi"]
+                                     , sm_inline = False }
+      -- sm_inline: do not do any inlining, in case we expose
+      -- some unboxed tuple stuff that confuses the bytecode
       -- interpreter
-    }
+
   , se_top_env_cfg = TopEnvConfig
     { te_history_size = historySize dflags
     , te_tick_factor = simplTickFactor dflags
@@ -57,31 +57,25 @@ initSimplifyOpts dflags extra_vars iterations mode rule_base = let
     }
   in opts
 
-initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode
-initSimplMode dflags phase name = SimplMode
-  { sm_names = [name]
-  , sm_phase = phase
-  , sm_rules = gopt Opt_EnableRewriteRules dflags
-  , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
-  , sm_cast_swizzle = True
-  , sm_inline = True
-  , sm_uf_opts = unfoldingOpts dflags
-  , sm_case_case = True
-  , sm_pre_inline = gopt Opt_SimplPreInlining dflags
-  , sm_float_enable = floatEnable dflags
+initSimplMode :: DynFlags -> SimplMode
+initSimplMode dflags = SimplMode
+  { sm_names = ["Unknown simplifier run"]  -- Always overriden
+  , sm_phase = InitialPhase
+  , sm_rules            = gopt Opt_EnableRewriteRules dflags
+  , sm_eta_expand       = gopt Opt_DoLambdaEtaExpansion dflags
+  , sm_pre_inline       = gopt Opt_SimplPreInlining dflags
   , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags
-  , sm_arity_opts = initArityOpts dflags
-  , sm_rule_opts = initRuleOpts dflags
-  , sm_case_folding = gopt Opt_CaseFolding dflags
-  , sm_case_merge = gopt Opt_CaseMerge dflags
-  , sm_co_opt_opts = initOptCoercionOpts dflags
-  }
-
-initGentleSimplMode :: DynFlags -> SimplMode
-initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")
-  { -- Don't do case-of-case transformations.
-    -- This makes full laziness work better
-    sm_case_case = False
+  , sm_uf_opts          = unfoldingOpts dflags
+  , sm_float_enable     = floatEnable dflags
+  , sm_arity_opts       = initArityOpts dflags
+  , sm_rule_opts        = initRuleOpts dflags
+  , sm_case_folding     = gopt Opt_CaseFolding dflags
+  , sm_case_merge       = gopt Opt_CaseMerge dflags
+  , sm_co_opt_opts      = initOptCoercionOpts dflags
+  , sm_cast_swizzle = True
+  , sm_inline       = True
+  , sm_case_case    = True
+  , sm_keep_exits   = False
   }
 
 floatEnable :: DynFlags -> FloatEnable

compiler/GHC/Tc/Instance/Class.hs

@@ -571,15 +571,15 @@ Some further observations about `withDict`:
 (WD3) As an alternative to `withDict`, one could define functions like `withT`
       above in terms of `unsafeCoerce`. This is more error-prone, however.
 
-(WD4) In order to define things like `reifySymbol` below:
+(WD4) In order to define things like `withKnownNat` below:
 
-        reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r
+        withKnownNat :: SNat n -> (KnownNat n => r) -> r
 
       `withDict` needs to be instantiated with `Any`, like so:
 
-        reifySymbol n k = withDict @(KnownSymbol Any) @String @r n (k @Any)
+        withKnownNat = withDict @(KnownNat Any) @(SNat Any) @r
 
-      The use of `Any` is explained in Note [NOINLINE someNatVal] in
+      The use of `Any` is explained in Note [NOINLINE withSomeSNat] in
       base:GHC.TypeNats.
 
 (WD5) In earlier implementations, `withDict` was implemented as an identifier

docs/users_guide/9.6.1-notes.rst

@@ -129,6 +129,8 @@ Runtime system
   ``(<=)`` instead of ``compare`` per CLC proposal:
   https://github.com/haskell/core-libraries-committee/issues/24
 
+- Updated to `Unicode 15.0.0 <https://www.unicode.org/versions/Unicode15.0.0/>`_.
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 

docs/users_guide/exts/pattern_synonyms.rst

@@ -524,9 +524,9 @@ Pragmas for pattern synonyms
 ----------------------------
 
 The :ref:`inlinable-pragma`, :ref:`inline-pragma` and :ref:`noinline-pragma` are supported for pattern
-synonyms. For example: ::
+synonyms as of GHC 9.2. For example: ::
 
-    patternInlinablePattern x = [x]
+    pattern InlinablePattern x = [x]
     {-# INLINABLE InlinablePattern #-}
     pattern InlinedPattern x = [x]
     {-# INLINE InlinedPattern #-}

libraries/base/Data/Array/Byte.hs

@@ -185,8 +185,7 @@ compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#)
 -- | Do two byte arrays share the same pointer?
 sameByteArray :: ByteArray# -> ByteArray# -> Bool
 sameByteArray ba1 ba2 =
-    case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of
-      r -> isTrue# r
+    case sameByteArray# ba1 ba2 of r -> isTrue# r
 
 -- | @since 4.17.0.0
 instance Eq ByteArray where

libraries/base/GHC/TypeLits.hs

@@ -11,6 +11,10 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-|
 GHC's @DataKinds@ language extension lifts data constructors, natural
@@ -34,15 +38,20 @@ module GHC.TypeLits
     N.Natural, N.Nat, Symbol  -- Symbol is declared in GHC.Types in package ghc-prim
 
     -- * Linking type and value level
-  , N.KnownNat, natVal, natVal'
-  , KnownSymbol, symbolVal, symbolVal'
-  , KnownChar, charVal, charVal'
+  , N.KnownNat(natSing), natVal, natVal'
+  , KnownSymbol(symbolSing), symbolVal, symbolVal'
+  , KnownChar(charSing), charVal, charVal'
   , N.SomeNat(..), SomeSymbol(..), SomeChar(..)
   , someNatVal, someSymbolVal, someCharVal
   , N.sameNat, sameSymbol, sameChar
   , OrderingI(..)
   , N.cmpNat, cmpSymbol, cmpChar
-
+    -- ** Singleton values
+  , N.SNat, SSymbol, SChar
+  , pattern N.SNat, pattern SSymbol, pattern SChar
+  , fromSNat, fromSSymbol, fromSChar
+  , withSomeSNat, withSomeSSymbol, withSomeSChar
+  , N.withKnownNat, withKnownSymbol, withKnownChar
 
     -- * Functions on type literals
   , type (N.<=), type (N.<=?), type (N.+), type (N.*), type (N.^), type (N.-)
@@ -58,17 +67,19 @@ module GHC.TypeLits
 
   ) where
 
-import GHC.Base(Eq(..), Ord(..), Ordering(..), String, otherwise, withDict)
-import GHC.Types(Symbol, Char)
+import GHC.Base ( Eq(..), Functor(..), Ord(..), Ordering(..), String
+                , (.), otherwise, withDict )
+import GHC.Types(Symbol, Char, TYPE)
 import GHC.TypeError(ErrorMessage(..), TypeError)
 import GHC.Num(Integer, fromInteger)
-import GHC.Show(Show(..))
+import GHC.Show(Show(..), appPrec, appPrec1, showParen, showString)
 import GHC.Read(Read(..))
 import GHC.Real(toInteger)
 import GHC.Prim(Proxy#)
 import Data.Maybe(Maybe(..))
 import Data.Proxy (Proxy(..))
-import Data.Type.Equality((:~:)(Refl))
+import Data.Type.Coercion (Coercion(..), TestCoercion(..))
+import Data.Type.Equality((:~:)(Refl), TestEquality(..))
 import Data.Type.Ord(OrderingI(..))
 import Unsafe.Coerce(unsafeCoerce)
 
@@ -91,7 +102,7 @@ natVal p = toInteger (N.natVal p)
 -- | @since 4.7.0.0
 symbolVal :: forall n proxy. KnownSymbol n => proxy n -> String
 symbolVal _ = case symbolSing :: SSymbol n of
-                SSymbol x -> x
+                UnsafeSSymbol x -> x
 
 -- | @since 4.8.0.0
 natVal' :: forall n. N.KnownNat n => Proxy# n -> Integer
@@ -100,7 +111,7 @@ natVal' p = toInteger (N.natVal' p)
 -- | @since 4.8.0.0
 symbolVal' :: forall n. KnownSymbol n => Proxy# n -> String
 symbolVal' _ = case symbolSing :: SSymbol n of
-                SSymbol x -> x
+                UnsafeSSymbol x -> x
 
 
 -- | This type represents unknown type-level symbols.
@@ -113,11 +124,11 @@ class KnownChar (n :: Char) where
 
 charVal :: forall n proxy. KnownChar n => proxy n -> Char
 charVal _ = case charSing :: SChar n of
-                 SChar x -> x
+                 UnsafeSChar x -> x
 
 charVal' :: forall n. KnownChar n => Proxy# n -> Char
 charVal' _ = case charSing :: SChar n of
-                SChar x -> x
+                UnsafeSChar x -> x
 
 data SomeChar = forall n. KnownChar n => SomeChar (Proxy n)
 
@@ -133,10 +144,8 @@ someNatVal n
 --
 -- @since 4.7.0.0
 someSymbolVal :: String -> SomeSymbol
-someSymbolVal n   = withSSymbol SomeSymbol (SSymbol n) Proxy
-{-# NOINLINE someSymbolVal #-}
--- For details see Note [NOINLINE someNatVal] in "GHC.TypeNats"
--- The issue described there applies to `someSymbolVal` as well.
+someSymbolVal s = withSomeSSymbol s (\(ss :: SSymbol s) ->
+                  withKnownSymbol ss (SomeSymbol @s Proxy))
 
 -- | @since 4.7.0.0
 instance Eq SomeSymbol where
@@ -159,8 +168,8 @@ instance Read SomeSymbol where
 --
 -- @since 4.16.0.0
 someCharVal :: Char -> SomeChar
-someCharVal n   = withSChar SomeChar (SChar n) Proxy
-{-# NOINLINE someCharVal #-}
+someCharVal c = withSomeSChar c (\(sc :: SChar c) ->
+                withKnownChar sc (SomeChar @c Proxy))
 
 instance Eq SomeChar where
   SomeChar x == SomeChar y = charVal x == charVal y
@@ -210,22 +219,20 @@ type family NatToChar (n :: N.Nat) :: Char
 -- same type-level symbols, or 'Nothing'.
 --
 -- @since 4.7.0.0
-sameSymbol :: (KnownSymbol a, KnownSymbol b) =>
+sameSymbol :: forall a b proxy1 proxy2.
+              (KnownSymbol a, KnownSymbol b) =>
               proxy1 a -> proxy2 b -> Maybe (a :~: b)
-sameSymbol x y
-  | symbolVal x == symbolVal y  = Just (unsafeCoerce Refl)
-  | otherwise                   = Nothing
+sameSymbol _ _ = testEquality (symbolSing @a) (symbolSing @b)
 
 
 -- | We either get evidence that this function was instantiated with the
 -- same type-level characters, or 'Nothing'.
 --
 -- @since 4.16.0.0
-sameChar :: (KnownChar a, KnownChar b) =>
-              proxy1 a -> proxy2 b -> Maybe (a :~: b)
-sameChar x y
-  | charVal x == charVal y  = Just (unsafeCoerce Refl)
-  | otherwise                = Nothing
+sameChar :: forall a b proxy1 proxy2.
+            (KnownChar a, KnownChar b) =>
+            proxy1 a -> proxy2 b -> Maybe (a :~: b)
+sameChar _ _ = testEquality (charSing @a) (charSing @b)
 
 -- | Like 'sameSymbol', but if the symbols aren't equal, this additionally
 -- provides proof of LT or GT.
@@ -257,20 +264,217 @@ cmpChar x y = case compare (charVal x) (charVal y) of
 
 
 --------------------------------------------------------------------------------
--- PRIVATE:
+-- Singleton values
+
+-- | Return the 'Integer' corresponding to @n@ in an @'SNat' n@ value.
+-- The returned 'Integer' is always non-negative.
+--
+-- For a version of this function that returns a 'Natural' instead of an
+-- 'Integer', see 'N.fromSNat' in "GHC.TypeNats".
+--
+-- @since 4.18.0.0
+fromSNat :: N.SNat n -> Integer
+fromSNat sn = toInteger (N.fromSNat sn)
+
+-- | Attempt to convert an 'Integer' into an @'SNat' n@ value, where @n@ is a
+-- fresh type-level natural number. If the 'Integer' argument is non-negative,
+-- invoke the continuation with @Just sn@, where @sn@ is the @'SNat' n@ value.
+-- If the 'Integer' argument is negative, invoke the continuation with
+-- 'Nothing'.
+--
+-- For a version of this function where the continuation uses @'SNat@ n@
+-- instead of @'Maybe' ('SNat' n)@, see 'N.withSomeSNat' in "GHC.TypeNats".
+--
+-- @since 4.18.0.0
+withSomeSNat :: forall rep (r :: TYPE rep).
+                Integer -> (forall n. Maybe (N.SNat n) -> r) -> r
+withSomeSNat n k
+  | n >= 0    = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn))
+  | otherwise = k Nothing
+
+-- | A value-level witness for a type-level symbol. This is commonly referred
+-- to as a /singleton/ type, as for each @s@, there is a single value that
+-- inhabits the type @'SSymbol' s@ (aside from bottom).
+--
+-- The definition of 'SSymbol' is intentionally left abstract. To obtain an
+-- 'SSymbol' value, use one of the following:
+--
+-- 1. The 'symbolSing' method of 'KnownSymbol'.
+--
+-- 2. The @SSymbol@ pattern synonym.
+--
+-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a
+--    'String'.
+--
+-- @since 4.18.0.0
+newtype SSymbol (s :: Symbol) = UnsafeSSymbol String
 
-newtype SSymbol (s :: Symbol) = SSymbol String
+-- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a
+-- 'KnownSymbol' constraint.
+--
+-- As an __expression__: Constructs an explicit @'SSymbol' s@ value from an
+-- implicit @'KnownSymbol' s@ constraint:
+--
+-- @
+-- SSymbol @s :: 'KnownSymbol' s => 'SSymbol' s
+-- @
+--
+-- As a __pattern__: Matches on an explicit @'SSymbol' s@ value bringing
+-- an implicit @'KnownSymbol' s@ constraint into scope:
+--
+-- @
+-- f :: 'SSymbol' s -> ..
+-- f SSymbol = {- SSymbol s in scope -}
+-- @
+--
+-- @since 4.18.0.0
+pattern SSymbol :: forall s. () => KnownSymbol s => SSymbol s
+pattern SSymbol <- (knownSymbolInstance -> KnownSymbolInstance)
+  where SSymbol = symbolSing
+
+-- An internal data type that is only used for defining the SSymbol pattern
+-- synonym.
+data KnownSymbolInstance (s :: Symbol) where
+  KnownSymbolInstance :: KnownSymbol s => KnownSymbolInstance s
+
+-- An internal function that is only used for defining the SSymbol pattern
+-- synonym.
+knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s
+knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance
+
+-- | @since 4.18.0.0
+instance Show (SSymbol s) where
+  showsPrec p (UnsafeSSymbol s)
+    = showParen (p > appPrec)
+      ( showString "SSymbol @"
+        . showsPrec appPrec1 s
+      )
+
+-- | @since 4.18.0.0
+instance TestEquality SSymbol where
+  testEquality (UnsafeSSymbol x) (UnsafeSSymbol y)
+    | x == y    = Just (unsafeCoerce Refl)
+    | otherwise = Nothing
+
+-- | @since 4.18.0.0
+instance TestCoercion SSymbol where
+  testCoercion x y = fmap (\Refl -> Coercion) (testEquality x y)
+
+-- | Return the String corresponding to @s@ in an @'SSymbol' s@ value.
+--
+-- @since 4.18.0.0
+fromSSymbol :: SSymbol s -> String
+fromSSymbol (UnsafeSSymbol s) = s
 
+-- | Convert an explicit @'SSymbol' s@ value into an implicit @'KnownSymbol' s@
+-- constraint.
+--
+-- @since 4.18.0.0
+withKnownSymbol :: forall s rep (r :: TYPE rep).
+                   SSymbol s -> (KnownSymbol s => r) -> r
+withKnownSymbol = withDict @(KnownSymbol s)
 -- See Note [withDict] in "GHC.Tc.Instance.Class" in GHC
-withSSymbol :: forall a b.
-               (KnownSymbol a => Proxy a -> b)
-            -> SSymbol a      -> Proxy a -> b
-withSSymbol f x y = withDict @(KnownSymbol a) x f y
 
-newtype SChar (s :: Char) = SChar Char
+-- | Convert a 'String' into an @'SSymbol' s@ value, where @s@ is a fresh
+-- type-level symbol.
+--
+-- @since 4.18.0.0
+withSomeSSymbol :: forall rep (r :: TYPE rep).
+                   String -> (forall s. SSymbol s -> r) -> r
+withSomeSSymbol s k = k (UnsafeSSymbol s)
+{-# NOINLINE withSomeSSymbol #-}
+-- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats"
+-- The issue described there applies to `withSomeSSymbol` as well.
+
+-- | A value-level witness for a type-level character. This is commonly referred
+-- to as a /singleton/ type, as for each @c@, there is a single value that
+-- inhabits the type @'SChar' c@ (aside from bottom).
+--
+-- The definition of 'SChar' is intentionally left abstract. To obtain an
+-- 'SChar' value, use one of the following:
+--
+-- 1. The 'charSing' method of 'KnownChar'.
+--
+-- 2. The @SChar@ pattern synonym.
+--
+-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'.
+--
+-- @since 4.18.0.0
+newtype SChar (s :: Char) = UnsafeSChar Char
 
+-- | A explicitly bidirectional pattern synonym relating an 'SChar' to a
+-- 'KnownChar' constraint.
+--
+-- As an __expression__: Constructs an explicit @'SChar' c@ value from an
+-- implicit @'KnownChar' c@ constraint:
+--
+-- @
+-- SChar @c :: 'KnownChar' c => 'SChar' c
+-- @
+--
+-- As a __pattern__: Matches on an explicit @'SChar' c@ value bringing
+-- an implicit @'KnownChar' c@ constraint into scope:
+--
+-- @
+-- f :: 'SChar' c -> ..
+-- f SChar = {- SChar c in scope -}
+-- @
+--
+-- @since 4.18.0.0
+pattern SChar :: forall c. () => KnownChar c => SChar c
+pattern SChar <- (knownCharInstance -> KnownCharInstance)
+  where SChar = charSing
+
+-- An internal data type that is only used for defining the SChar pattern
+-- synonym.
+data KnownCharInstance (n :: Char) where
+  KnownCharInstance :: KnownChar c => KnownCharInstance c
+
+-- An internal function that is only used for defining the SChar pattern
+-- synonym.
+knownCharInstance :: SChar c -> KnownCharInstance c
+knownCharInstance sc = withKnownChar sc KnownCharInstance
+
+-- | @since 4.18.0.0
+instance Show (SChar c) where
+  showsPrec p (UnsafeSChar c)
+    = showParen (p > appPrec)
+      ( showString "SChar @"
+        . showsPrec appPrec1 c
+      )
+
+-- | @since 4.18.0.0
+instance TestEquality SChar where
+  testEquality (UnsafeSChar x) (UnsafeSChar y)
+    | x == y    = Just (unsafeCoerce Refl)
+    | otherwise = Nothing
+
+-- | @since 4.18.0.0
+instance TestCoercion SChar where
+  testCoercion x y = fmap (\Refl -> Coercion) (testEquality x y)
+
+-- | Return the 'Char' corresponding to @c@ in an @'SChar' c@ value.
+--
+-- @since 4.18.0.0
+fromSChar :: SChar c -> Char
+fromSChar (UnsafeSChar c) = c
+
+-- | Convert an explicit @'SChar' c@ value into an implicit @'KnownChar' c@
+-- constraint.
+--
+-- @since 4.18.0.0
+withKnownChar :: forall c rep (r :: TYPE rep).
+                 SChar c -> (KnownChar c => r) -> r
+withKnownChar = withDict @(KnownChar c)
 -- See Note [withDict] in "GHC.Tc.Instance.Class" in GHC
-withSChar :: forall a b.
-             (KnownChar a => Proxy a -> b)
-            -> SChar a      -> Proxy a -> b
-withSChar f x y = withDict @(KnownChar a) x f y
+
+-- | Convert a 'Char' into an @'SChar' c@ value, where @c@ is a fresh type-level
+-- character.
+--
+-- @since 4.18.0.0
+withSomeSChar :: forall rep (r :: TYPE rep).
+                 Char -> (forall c. SChar c -> r) -> r
+withSomeSChar c k = k (UnsafeSChar c)
+{-# NOINLINE withSomeSChar #-}
+-- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats"
+-- The issue described there applies to `withSomeSChar` as well.

libraries/base/GHC/TypeNats.hs

@@ -13,6 +13,9 @@
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-| This module is an internal GHC module.  It declares the constants used
 in the implementation of type-level natural numbers.  The programmer interface
@@ -26,10 +29,16 @@ module GHC.TypeNats
     Natural -- declared in GHC.Num.Natural in package ghc-bignum
   , Nat
     -- * Linking type and value level
-  , KnownNat, natVal, natVal'
+  , KnownNat(natSing), natVal, natVal'
   , SomeNat(..)
   , someNatVal
   , sameNat
+    -- ** Singleton values
+  , SNat
+  , pattern SNat
+  , fromSNat
+  , withSomeSNat
+  , withKnownNat
 
     -- * Functions on type literals
   , type (<=), type (<=?), type (+), type (*), type (^), type (-)
@@ -39,15 +48,16 @@ module GHC.TypeNats
 
   ) where
 
-import GHC.Base(Eq(..), Ord(..), otherwise, WithDict(..))
+import GHC.Base(Eq(..), Functor(..), Ord(..), WithDict(..), (.), otherwise)
 import GHC.Types
 import GHC.Num.Natural(Natural)
-import GHC.Show(Show(..))
+import GHC.Show(Show(..), appPrec, appPrec1, showParen, showString)
 import GHC.Read(Read(..))
 import GHC.Prim(Proxy#)
 import Data.Maybe(Maybe(..))
 import Data.Proxy (Proxy(..))
-import Data.Type.Equality((:~:)(Refl))
+import Data.Type.Coercion (Coercion(..), TestCoercion(..))
+import Data.Type.Equality((:~:)(Refl), TestEquality(..))
 import Data.Type.Ord(OrderingI(..), type (<=), type (<=?))
 import Unsafe.Coerce(unsafeCoerce)
 
@@ -73,12 +83,12 @@ class KnownNat (n :: Nat) where
 -- | @since 4.10.0.0
 natVal :: forall n proxy. KnownNat n => proxy n -> Natural
 natVal _ = case natSing :: SNat n of
-             SNat x -> x
+             UnsafeSNat x -> x
 
 -- | @since 4.10.0.0
 natVal' :: forall n. KnownNat n => Proxy# n -> Natural
 natVal' _ = case natSing :: SNat n of
-             SNat x -> x
+             UnsafeSNat x -> x
 
 -- | This type represents unknown type-level natural numbers.
 --
@@ -89,66 +99,72 @@ data SomeNat    = forall n. KnownNat n    => SomeNat    (Proxy n)
 --
 -- @since 4.10.0.0
 someNatVal :: Natural -> SomeNat
-someNatVal n = withSNat SomeNat (SNat n) Proxy
-{-# NOINLINE someNatVal #-} -- See Note [NOINLINE someNatVal]
+someNatVal n = withSomeSNat n (\(sn :: SNat n) ->
+               withKnownNat sn (SomeNat @n Proxy))
 
 {-
-Note [NOINLINE someNatVal]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-`someNatVal` converts a natural number to an existentially quantified
-dictionary for `KnownNat` (aka `SomeNat`).  The existential quantification
-is very important, as it captures the fact that we don't know the type
-statically, although we do know that it exists.   Because this type is
-fully opaque, we should never be able to prove that it matches anything else.
-This is why coherence should still hold:  we can manufacture a `KnownNat k`
-dictionary, but it can never be confused with a `KnownNat 33` dictionary,
-because we should never be able to prove that `k ~ 33`.
-
-But how to implement `someNatVal`?  We can't quite implement it "honestly"
-because `SomeNat` needs to "hide" the type of the newly created dictionary,
-but we don't know what the actual type is!  If `someNatVal` was built into
-the language, then we could manufacture a new skolem constant,
-which should behave correctly.
-
-Since extra language constructors have additional maintenance costs,
-we use a trick to implement `someNatVal` in the library.  The idea is that
-instead of generating a "fresh" type for each use of `someNatVal`, we simply
-use GHC's placeholder type `Any` (of kind `Nat`). So, the elaborated
-version of the code is:
-
-  someNatVal n = withSNat @T (SomeNat @T) (SNat @T n) (Proxy @T)
-    where type T = Any Nat
+Note [NOINLINE withSomeSNat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The function
 
-After inlining and simplification, this ends up looking something like this:
+    withSomeSNat :: forall rep (r :: TYPE rep).
+                    Natural -> (forall k. SNat k -> r) -> r
 
-  someNatVal n = SomeNat @T (KnownNat @T (SNat @T n)) (Proxy @T)
-    where type T = Any Nat
+converts a `Natural` number to a singleton natural `SNat k`, where the `k` is
+locally quantified in a continuation (hence the `forall k`). The local
+quantification is important: we can manufacture an `SNat k` value, but it can
+never be confused with (say) an `SNat 33` value, because we should never be
+able to prove that `k ~ 33`. Moreover, if we call `withSomeSNat` twice, we'll
+get an `SNat k1` value and an `SNat k2` value, but again we can't confuse them.
+`SNat` is a singleton type!
 
-`KnownNat` is the constructor for dictionaries for the class `KnownNat`.
-See Note [withDict] in "GHC.Tc.Instance.Class" for details on how
-we actually construct the dictionary.
+But how to implement `withSomeSNat`? We have no way to make up a fresh type
+variable. To do that we need `runExists`: see #19675.
 
-Note that using `Any Nat` is not really correct, as multiple calls to
-`someNatVal` would violate coherence:
+Lacking `runExists`, we use a trick to implement `withSomeSNat`: instead of
+generating a "fresh" type for each use of `withSomeSNat`, we simply use GHC's
+placeholder type `Any` (of kind `Nat`), thus (in Core):
 
-  type T = Any Nat
+  withSomeSNat n f = f @T (UnsafeSNat @T n)
+    where type T = Any @Nat
 
-  x = SomeNat @T (KnownNat @T (SNat @T 1)) (Proxy @T)
-  y = SomeNat @T (KnownNat @T (SNat @T 2)) (Proxy @T)
+***  BUT we must mark `withSomeSNat` as NOINLINE! ***
+(And the same for withSomeSSymbol and withSomeSChar in GHC.TypeLits.)
 
-Note that now the code has two dictionaries with the same type, `KnownNat Any`,
-but they have different implementations, namely `SNat 1` and `SNat 2`.  This
-is not good, as GHC assumes coherence, and it is free to interchange
-dictionaries of the same type, but in this case this would produce an incorrect
-result.   See #16586 for examples of this happening.
+If we inline it we'll lose the type distinction between separate calls (those
+"fresh" type variables just turn into `T`). And that can interact badly with
+GHC's type-class specialiser. Consider this definition, where
+`foo :: KnownNat n => blah`:
 
-We can avoid this problem by making the definition of `someNatVal` opaque
-and we do this by using a `NOINLINE` pragma.  This restores coherence, because
-GHC can only inspect the result of `someNatVal` by pattern matching on the
-existential, which would generate a new type.  This restores correctness,
-at the cost of having a little more allocation for the `SomeNat` constructors.
--}
+  ex :: Natural
+  ex = withSomeSNat 1 (\(s1 :: SNat one) -> withKnownNat @one s1 $
+       withSomeSNat 2 (\(s2 :: SNat two) -> withKnownNat @two s2 $
+       foo @one ... + foo @two ...))
+
+In the last line we have in scope two distinct dictionaries of types
+`KnownNat one` and `KnownNat two`. The calls `foo @one` and `foo @two` each pick
+out one of those dictionaries to pass to `foo`.
 
+But if we inline `withSomeSNat` we'll get (switching to Core):
+
+  ex = withKnownNat @T (UnsafeSNat @T 1) (\(kn1 :: KnownNat T) ->
+       withKnownNat @T (UnsafeSNat @T 2) (\(kn2 :: KnownNat T) ->
+       foo @T kn1 ... + foo @T kn2 ...))
+    where type T = Any Nat
+
+We are now treading on thin ice. We have two dictionaries `kn1` and `kn2`, both
+of type `KnownNat T`, but with different implementations. GHC may specialise
+`foo` at type `T` using one of these dictionaries and use that same
+specialisation for the other. See #16586 for more examples of where something
+like this has actually happened.
+
+`KnownNat` should be a singleton type, but if we allow `withSomeSNat` to inline
+it won't be a singleton type any more. We have lost the "fresh type variable".
+
+TL;DR. We avoid this problem by making the definition of `withSomeSNat` opaque,
+using an `NOINLINE` pragma. When we get `runExists` (#19675) we will be able to
+stop using this hack.
+-}
 
 
 -- | @since 4.7.0.0
@@ -218,11 +234,10 @@ type family Log2 (m :: Nat) :: Nat
 -- same type-level numbers, or 'Nothing'.
 --
 -- @since 4.7.0.0
-sameNat :: (KnownNat a, KnownNat b) =>
+sameNat :: forall a b proxy1 proxy2.
+           (KnownNat a, KnownNat b) =>
            proxy1 a -> proxy2 b -> Maybe (a :~: b)
-sameNat x y
-  | natVal x == natVal y = Just (unsafeCoerce Refl)
-  | otherwise            = Nothing
+sameNat _ _ = testEquality (natSing @a) (natSing @b)
 
 -- | Like 'sameNat', but if the numbers aren't equal, this additionally
 -- provides proof of LT or GT.
@@ -241,12 +256,96 @@ cmpNat x y = case compare (natVal x) (natVal y) of
 
 
 --------------------------------------------------------------------------------
--- PRIVATE:
+-- Singleton values
 
-newtype SNat    (n :: Nat)    = SNat    Natural
+-- | A value-level witness for a type-level natural number. This is commonly
+-- referred to as a /singleton/ type, as for each @n@, there is a single value
+-- that inhabits the type @'SNat' n@ (aside from bottom).
+--
+-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat'
+-- value, use one of the following:
+--
+-- 1. The 'natSing' method of 'KnownNat'.
+--
+-- 2. The @SNat@ pattern synonym.
+--
+-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural'
+--    number.
+--
+-- @since 4.18.0.0
+newtype SNat (n :: Nat) = UnsafeSNat Natural
 
+-- | A explicitly bidirectional pattern synonym relating an 'SNat' to a
+-- 'KnownNat' constraint.
+--
+-- As an __expression__: Constructs an explicit @'SNat' n@ value from an
+-- implicit @'KnownNat' n@ constraint:
+--
+-- @
+-- SNat @n :: 'KnownNat' n => 'SNat' n
+-- @
+--
+-- As a __pattern__: Matches on an explicit @'SNat' n@ value bringing
+-- an implicit @'KnownNat' n@ constraint into scope:
+--
+-- @
+-- f :: 'SNat' n -> ..
+-- f SNat = {- SNat n in scope -}
+-- @
+--
+-- @since 4.18.0.0
+pattern SNat :: forall n. () => KnownNat n => SNat n
+pattern SNat <- (knownNatInstance -> KnownNatInstance)
+  where SNat = natSing
+
+-- An internal data type that is only used for defining the SNat pattern
+-- synonym.
+data KnownNatInstance (n :: Nat) where
+  KnownNatInstance :: KnownNat n => KnownNatInstance n
+
+-- An internal function that is only used for defining the SNat pattern
+-- synonym.
+knownNatInstance :: SNat n -> KnownNatInstance n
+knownNatInstance sn = withKnownNat sn KnownNatInstance
+
+-- | @since 4.18.0.0
+instance Show (SNat n) where
+  showsPrec p (UnsafeSNat n)
+    = showParen (p > appPrec)
+      ( showString "SNat @"
+        . showsPrec appPrec1 n
+      )
+
+-- | @since 4.18.0.0
+instance TestEquality SNat where
+  testEquality (UnsafeSNat x) (UnsafeSNat y)
+    | x == y    = Just (unsafeCoerce Refl)
+    | otherwise = Nothing
+
+-- | @since 4.18.0.0
+instance TestCoercion SNat where
+  testCoercion x y = fmap (\Refl -> Coercion) (testEquality x y)
+
+-- | Return the 'Natural' number corresponding to @n@ in an @'SNat' n@ value.
+--
+-- @since 4.18.0.0
+fromSNat :: SNat n -> Natural
+fromSNat (UnsafeSNat n) = n
+
+-- | Convert an explicit @'SNat' n@ value into an implicit @'KnownNat' n@
+-- constraint.
+--
+-- @since 4.18.0.0
+withKnownNat :: forall n rep (r :: TYPE rep).
+                SNat n -> (KnownNat n => r) -> r
+withKnownNat = withDict @(KnownNat n)
 -- See Note [withDict] in "GHC.Tc.Instance.Class" in GHC
-withSNat :: forall a b.
-            (KnownNat a => Proxy a -> b)
-         -> SNat a      -> Proxy a -> b
-withSNat f x y = withDict @(KnownNat a) x f y
+
+-- | Convert a 'Natural' number into an @'SNat' n@ value, where @n@ is a fresh
+-- type-level natural number.
+--
+-- @since 4.18.0.0
+withSomeSNat :: forall rep (r :: TYPE rep).
+                Natural -> (forall n. SNat n -> r) -> r
+withSomeSNat n k = k (UnsafeSNat n)
+{-# NOINLINE withSomeSNat #-} -- See Note [NOINLINE withSomeSNat]

libraries/base/changelog.md

@@ -29,7 +29,7 @@
     is now exported from `Prelude`. See [CLC #50](https://github.com/haskell/core-libraries-committee/issues/50)
     for the related discussion,
     as well as [the migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/export-lifta2-prelude.md)
-  * Update to Unicode 15.0.0.
+  * Update to [Unicode 15.0.0](https://www.unicode.org/versions/Unicode15.0.0/).
   * Add `Eq` and `Ord` instances for `Generically1`.
   * Relax instances for Functor combinators; put superclass on Class1 and Class2
     to make non-breaking. See [CLC
@@ -37,6 +37,12 @@
     related discussion, as well as [the migration
     guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/functor-combinator-instances-and-class1s.md).
   * Add `gcdetails_block_fragmentation_bytes` to `GHC.Stats.GCDetails` to track heap fragmentation.
+  * `GHC.TypeLits` and `GHC.TypeNats` now export the `natSing`, `symbolSing`,
+    and `charSing` methods of `KnownNat`, `KnownSymbol`, and `KnownChar`,
+    respectively. They also export the `SNat`, `SSymbol`, and `SChar` types
+    that are used in these methods and provide an API to interact with these
+    types, per
+    [CLC proposal #85](https://github.com/haskell/core-libraries-committee/issues/85).
 
 ## 4.17.0.0 *August 2022*
 

libraries/base/tests/T15183.hs

+{-# LANGUAGE DataKinds #-}
+module Main (main) where
+
+import Control.Exception (ArithException(..), throw)
+import Data.Proxy (Proxy(..))
+import GHC.TypeLits ( KnownChar, KnownNat, KnownSymbol
+                    , SChar, Nat, SNat, Symbol, SSymbol
+                    , charVal, natVal, symbolVal
+                    , withKnownChar, withKnownNat, withKnownSymbol
+                    , withSomeSChar, withSomeSNat, withSomeSSymbol )
+
+-- As found in the `reflection` library
+reifyNat :: Integer -> (forall (n :: Nat). KnownNat n => Proxy n -> r) -> r
+reifyNat n k = withSomeSNat n $ \(mbSn :: Maybe (SNat n)) ->
+               case mbSn of
+                 Just sn -> withKnownNat sn $ k @n Proxy
+                 Nothing -> throw Underflow
+
+reifySymbol :: String -> (forall (s :: Symbol). KnownSymbol s => Proxy s -> r) -> r
+reifySymbol s k = withSomeSSymbol s $ \(ss :: SSymbol s) ->
+                  withKnownSymbol ss $ k @s Proxy
+
+reifyChar :: Char -> (forall (c :: Char). KnownChar c => Proxy c -> r) -> r
+reifyChar c k = withSomeSChar c $ \(sc :: SChar c) ->
+                withKnownChar sc (k @c Proxy)
+
+main :: IO ()
+main = do
+  reifyNat    42   $ \(_ :: Proxy n) -> print $ natVal $ Proxy @n
+  reifySymbol "hi" $ \(_ :: Proxy s) -> print $ symbolVal $ Proxy @s
+  reifyChar   'a'  $ \(_ :: Proxy c) -> print $ charVal $ Proxy @c

libraries/base/tests/T15183.stdout

+42
+"hi"
+'a'

libraries/base/tests/all.T

@@ -257,6 +257,7 @@ test('T13167',
      [when(opsys('mingw32'), only_ways(['winio', 'winio_threaded'])),
       fragile_for(16536, concurrent_ways)],
      compile_and_run, [''])
+test('T15183', normal, compile_and_run, [''])
 test('T15349', [exit_code(1), expect_broken_for(15349, ['ghci'])], compile_and_run, [''])
 test('T16111', exit_code(1), compile_and_run, [''])
 test('T16943a', normal, compile_and_run, [''])

libraries/base/tools/ucd2haskell/ucd.sh

@@ -12,11 +12,7 @@ VERIFY_CHECKSUM=y
 
 # Filename:checksum
 FILES="\
-  ucd/DerivedCoreProperties.txt:e3eddd7d469cd1b0feed7528defad1a1cc7c6a9ceb0ae4446a6d10921ed2e7bc \
-  ucd/DerivedNormalizationProps.txt:b2c444c20730b097787fdf50bd7d6dd3fc5256ab8084f5b35b11c8776eca674c \
-  ucd/UnicodeData.txt:36018e68657fdcb3485f636630ffe8c8532e01c977703d2803f5b89d6c5feafb \
-  ucd/PropList.txt:6bddfdb850417a5bee6deff19290fd1b138589909afb50f5a049f343bf2c6722 \
-  ucd/extracted/DerivedCombiningClass.txt:12b0c3af9b600b49488d66545a3e7844ea980809627201bf9afeebe1c9f16f4e"
+  ucd/UnicodeData.txt:806e9aed65037197f1ec85e12be6e8cd870fc5608b4de0fffd990f689f376a73"
 
 # Download the files
 
@@ -39,10 +35,10 @@ download_file() {
         if test "$__checksum" != "$new_checksum"
         then
             echo "sha256sum of the downloaded __file $__file "
-            echo "   [$new_checksum] does not match the expected __checksum [$__checksum]"
+            echo "   [$new_checksum] does not match the expected checksum [$__checksum]"
             exit 1
         else
-            echo "$__file __checksum ok"
+            echo "$__file checksum ok"
         fi
     fi
 }

rts/include/Stg.h

@@ -263,8 +263,8 @@ typedef StgFunPtr       F_;
 #define EB_(X)    extern const char X[]
 #define IB_(X)    static const char X[]
 /* static (non-heap) closures (requires alignment for pointer tagging): */
-#define EC_(X)    extern       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
-#define IC_(X)    static       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
+#define EC_(X)    extern       StgWordArray (X) GNU_ATTRIBUTE(aligned (SIZEOF_VOID_P))
+#define IC_(X)    static       StgWordArray (X) GNU_ATTRIBUTE(aligned (SIZEOF_VOID_P))
 /* writable data (does not require alignment): */
 #define ERW_(X)   extern       StgWordArray (X)
 #define IRW_(X)   static       StgWordArray (X)