.gitlab/upload_ghc_libs.py

@@ -51,15 +51,19 @@ def prep_base():
 def build_copy_file(pkg: Package, f: Path):
     target = Path('_build') / 'stage1' / pkg.path / 'build' / f
     dest = pkg.path / f
-    print(f'Building {target} for {dest}...')
+    build_file_hadrian(target)
+    print(f'Copying {target} to {dest}...')
+    dest.parent.mkdir(exist_ok=True, parents=True)
+    shutil.copyfile(target, dest)
+
 
+def build_file_hadrian(target: Path):
     build_cabal = Path('hadrian') / 'build-cabal'
     if not build_cabal.is_file():
         build_cabal = Path('hadrian') / 'build.cabal.sh'
 
+    print(f'Building {target}...')
     run([build_cabal, target], check=True)
-    dest.parent.mkdir(exist_ok=True, parents=True)
-    shutil.copyfile(target, dest)
 
 def modify_file(pkg: Package, fname: Path, f: Callable[[str], str]):
     target = pkg.path / fname
@@ -116,6 +120,7 @@ def prepare_sdist(pkg: Package):
 
     print(f'Preparing package {pkg.name}...')
     shutil.rmtree(pkg.path / 'dist-newstyle', ignore_errors=True)
+    build_file_hadrian(pkg.path / '{}.cabal'.format(pkg.name))
     pkg.prepare_sdist()
 
     # Upload source tarball

compiler/GHC/Cmm.hs

@@ -7,11 +7,14 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE EmptyCase #-}
 
 module GHC.Cmm (
      -- * Cmm top-level datatypes
      CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
      CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
+     CmmDataDecl, cmmDataDeclCmmDecl,
      CmmGraph, GenCmmGraph(..),
      toBlockMap, revPostorder, toBlockList,
      CmmBlock, RawCmmDecl,
@@ -52,6 +55,7 @@ import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Label
 import GHC.Utils.Outputable
 
+import Data.Void (Void)
 import Data.List (intersperse)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
@@ -116,6 +120,14 @@ instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platfor
 
 type CmmDecl     = GenCmmDecl CmmStatics    CmmTopInfo CmmGraph
 type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
+type CmmDataDecl = GenCmmDataDecl CmmStatics
+type GenCmmDataDecl d = GenCmmDecl d Void Void -- When `CmmProc` case can be statically excluded
+
+cmmDataDeclCmmDecl :: GenCmmDataDecl d -> GenCmmDecl d h g
+cmmDataDeclCmmDecl = \ case
+    CmmProc void _ _ _ -> case void of
+    CmmData section d -> CmmData section d
+{-# INLINE cmmDataDeclCmmDecl #-}
 
 type RawCmmDecl
    = GenCmmDecl

compiler/GHC/Cmm/Info/Build.hs

 {-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
     GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
-    ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
+    ScopedTypeVariables, OverloadedStrings, LambdaCase, EmptyCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -884,7 +884,7 @@ doSRTs
   :: CmmConfig
   -> ModuleSRTInfo
   -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks
-  -> [(CAFSet, CmmDecl)]     -- ^ static data decls and their 'CAFSet's
+  -> [(CAFSet, CmmDataDecl)]     -- ^ static data decls and their 'CAFSet's
   -> IO (ModuleSRTInfo, [CmmDeclSRTs])
 
 doSRTs cfg moduleSRTInfo procs data_ = do
@@ -900,8 +900,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
         flip map data_ $
         \(set, decl) ->
           case decl of
-            CmmProc{} ->
-              pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
+            CmmProc void _ _ _ -> case void of
             CmmData _ static ->
               case static of
                 CmmStatics lbl _ _ _ _ -> (lbl, set)
@@ -909,7 +908,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
 
       (proc_envs, procss) = unzip procs
       cafEnv = mapUnions proc_envs
-      decls = map snd data_ ++ concat procss
+      decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss
       staticFuns = mapFromList (getStaticFuns decls)
 
       platform = cmmPlatform cfg
@@ -980,8 +979,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
                       | otherwise ->
                           -- Not an IdLabel, ignore
                           srtMap
-                    CmmProc{} ->
-                      pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))
+                    CmmProc void _ _ _ -> case void of)
                (moduleSRTMap moduleSRTInfo') data_
 
   return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')

compiler/GHC/Cmm/Pipeline.hs

@@ -67,8 +67,8 @@ cmmPipeline logger cmm_config srtInfo prog = do
 --     [SRTs].
 --
 --   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing
-cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
-cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))
+cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))
+cpsTop _logger platform _ (CmmData section statics) = return (Right (cafAnalData platform statics, CmmData section statics))
 cpsTop logger platform cfg proc =
     do
       ----------- Control-flow optimisations ----------------------------------

compiler/GHC/Core/Opt/OccurAnal.hs

@@ -1820,7 +1820,8 @@ occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails CoreExpr)
 
 occAnalLam env (Lam bndr expr)
   | isTyVar bndr
-  = let (WithUsageDetails usage expr') = occAnalLam env expr
+  = let env1 = addOneInScope env bndr
+        WithUsageDetails usage expr' = occAnalLam env1 expr
     in WithUsageDetails usage (Lam bndr expr')
        -- Important: Keep the 'env' unchanged so that with a RHS like
        --   \(@ x) -> K @x (f @x)
@@ -2466,10 +2467,11 @@ data OccEnv
            -- If  x :-> (y, co)  is in the env,
            -- then please replace x by (y |> mco)
            -- Invariant of course: idType x = exprType (y |> mco)
-           , occ_bs_env  :: !(VarEnv (OutId, MCoercion))
-           , occ_bs_rng  :: !VarSet   -- Vars free in the range of occ_bs_env
+           , occ_bs_env  :: !(IdEnv (OutId, MCoercion))
                    -- Domain is Global and Local Ids
                    -- Range is just Local Ids
+           , occ_bs_rng  :: !VarSet
+                   -- Vars (TyVars and Ids) free in the range of occ_bs_env
     }
 
 
@@ -2546,14 +2548,15 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
                                           _      -> False
 
 addOneInScope :: OccEnv -> CoreBndr -> OccEnv
+-- Needed for all Vars not just Ids
+-- See Note [The binder-swap substitution] (BS3)
 addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr
   | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
   | otherwise                  = env { occ_bs_env = swap_env `delVarEnv` bndr }
 
 addInScope :: OccEnv -> [Var] -> OccEnv
--- See Note [The binder-swap substitution]
--- It's only necessary to call this on in-scope Ids,
--- but harmless to include TyVars too
+-- Needed for all Vars not just Ids
+-- See Note [The binder-swap substitution] (BS3)
 addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs
   | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
   | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs }
@@ -2712,25 +2715,29 @@ Some tricky corners:
 
 (BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,
       and we encounter:
-         - \x. blah
-           Here we want to delete the x-binding from occ_bs_env
-
-         - \b. blah
-           This is harder: we really want to delete all bindings that
-           have 'b' free in the range.  That is a bit tiresome to implement,
-           so we compromise.  We keep occ_bs_rng, which is the set of
-           free vars of rng(occc_bs_env).  If a binder shadows any of these
-           variables, we discard all of occ_bs_env.  Safe, if a bit
-           brutal.  NB, however: the simplifer de-shadows the code, so the
-           next time around this won't happen.
+         (i) \x. blah
+             Here we want to delete the x-binding from occ_bs_env
+
+         (ii) \b. blah
+              This is harder: we really want to delete all bindings that
+              have 'b' free in the range.  That is a bit tiresome to implement,
+              so we compromise.  We keep occ_bs_rng, which is the set of
+              free vars of rng(occc_bs_env).  If a binder shadows any of these
+              variables, we discard all of occ_bs_env.  Safe, if a bit
+              brutal.  NB, however: the simplifer de-shadows the code, so the
+              next time around this won't happen.
 
       These checks are implemented in addInScope.
-
-      The occurrence analyser itself does /not/ do cloning. It could, in
-      principle, but it'd make it a bit more complicated and there is no
-      great benefit. The simplifer uses cloning to get a no-shadowing
-      situation, the care-when-shadowing behaviour above isn't needed for
-      long.
+      (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)
+      because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we
+      must not replace `x` by `...a...` under /\a. ...x..., or similarly
+      under a case pattern match that binds `a`.
+
+      An alternative would be for the occurrence analyser to do cloning as
+      it goes.  In principle it could do so, but it'd make it a bit more
+      complicated and there is no great benefit. The simplifer uses
+      cloning to get a no-shadowing situation, the care-when-shadowing
+      behaviour above isn't needed for long.
 
 (BS4) The domain of occ_bs_env can include GlobaIds.  Eg
          case M.foo of b { alts }

compiler/GHC/Core/Opt/Simplify.hs

@@ -132,7 +132,11 @@ data SimplifyOpts = SimplifyOpts
   { so_dump_core_sizes :: !Bool
   , so_iterations      :: !Int
   , so_mode            :: !SimplMode
+
   , so_pass_result_cfg :: !(Maybe LintPassResultConfig)
+                          -- Nothing => Do not Lint
+                          -- Just cfg => Lint like this
+
   , so_hpt_rules       :: !RuleBase
   , so_top_env_cfg     :: !TopEnvConfig
   }

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

@@ -2063,34 +2063,51 @@ it is guarded by the doFloatFromRhs call in simplLazyBind.
 Note [Which type variables to abstract over]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Abstract only over the type variables free in the rhs wrt which the
-new binding is abstracted.  Note that
-
-  * The naive approach of abstracting wrt the
-    tyvars free in the Id's /type/ fails. Consider:
-        /\ a b -> let t :: (a,b) = (e1, e2)
-                      x :: a     = fst t
-                  in ...
-    Here, b isn't free in x's type, but we must nevertheless
-    abstract wrt b as well, because t's type mentions b.
-    Since t is floated too, we'd end up with the bogus:
-         poly_t = /\ a b -> (e1, e2)
-         poly_x = /\ a   -> fst (poly_t a *b*)
-
-  * We must do closeOverKinds.  Example (#10934):
+new binding is abstracted.  Several points worth noting
+
+(AB1) The naive approach of abstracting wrt the
+      tyvars free in the Id's /type/ fails. Consider:
+          /\ a b -> let t :: (a,b) = (e1, e2)
+                        x :: a     = fst t
+                    in ...
+      Here, b isn't free in x's type, but we must nevertheless
+      abstract wrt b as well, because t's type mentions b.
+      Since t is floated too, we'd end up with the bogus:
+           poly_t = /\ a b -> (e1, e2)
+           poly_x = /\ a   -> fst (poly_t a *b*)
+
+(AB2) We must do closeOverKinds.  Example (#10934):
        f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...
-    Here we want to float 't', but we must remember to abstract over
-    'k' as well, even though it is not explicitly mentioned in the RHS,
-    otherwise we get
-       t = /\ (f:k->*) (a:k). AccFailure @ (f a)
-    which is obviously bogus.
-
-  * We get the variables to abstract over by filtering down the
-    the main_tvs for the original function, picking only ones
-    mentioned in the abstracted body. This means:
-    - they are automatically in dependency order, because main_tvs is
-    - there is no issue about non-determinism
-    - we don't gratuitously change order, which may help (in a tiny
-      way) with CSE and/or the compiler-debugging experience
+      Here we want to float 't', but we must remember to abstract over
+      'k' as well, even though it is not explicitly mentioned in the RHS,
+      otherwise we get
+         t = /\ (f:k->*) (a:k). AccFailure @ (f a)
+      which is obviously bogus.
+
+(AB3) We get the variables to abstract over by filtering down the
+      the main_tvs for the original function, picking only ones
+      mentioned in the abstracted body. This means:
+      - they are automatically in dependency order, because main_tvs is
+      - there is no issue about non-determinism
+      - we don't gratuitously change order, which may help (in a tiny
+        way) with CSE and/or the compiler-debugging experience
+
+(AB4) For a recursive group, it's a bit of a pain to work out the minimal
+      set of tyvars over which to abstract:
+           /\ a b c.  let x = ...a... in
+                      letrec { p = ...x...q...
+                               q = .....p...b... } in
+                      ...
+      Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
+      over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
+      Remember this bizarre case too:
+           x::a = x
+      Here, we must abstract 'x' over 'a'.
+
+      Why is it worth doing this?  Partly tidiness; and partly #22459
+      which showed that it's harder to do polymorphic specialisation well
+      if there are dictionaries abstracted over unnecessary type variables.
+      See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise
 -}
 
 abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
@@ -2115,33 +2132,40 @@ abstractFloats uf_opts top_lvl main_tvs floats body
         rhs' = GHC.Core.Subst.substExpr subst rhs
 
         -- tvs_here: see Note [Which type variables to abstract over]
-        tvs_here = filter (`elemVarSet` free_tvs) main_tvs
-        free_tvs = closeOverKinds $
-                   exprSomeFreeVars isTyVar rhs'
+        tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs')
 
     abstract subst (Rec prs)
-       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
-            ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
-                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
-                               | (poly_id, rhs) <- poly_ids `zip` rhss
-                               , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
-            ; return (subst', Rec poly_pairs) }
+      = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
+           ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
+                 poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
+                              | (poly_id, rhs) <- poly_ids `zip` rhss
+                              , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
+           ; return (subst', Rec poly_pairs) }
+      where
+        (ids,rhss) = unzip prs
+
+
+        -- tvs_here: see Note [Which type variables to abstract over]
+        tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs)
+
+        -- See wrinkle (AB4) in Note [Which type variables to abstract over]
+        get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs
+        get_rec_rhs_tvs rhs   = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs)
+
+        get_tvs :: Var -> VarSet -> VarSet
+        get_tvs var free_tvs
+           | isTyVar var      -- CoVars have been substituted away
+           = extendVarSet free_tvs var
+           | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var
+           = -- 'var' is like 'x' in (AB4)
+             exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs
+           | otherwise
+           = free_tvs
+
+    choose_tvs free_tvs
+       = filter (`elemVarSet` all_free_tvs) main_tvs  -- (AB3)
        where
-         (ids,rhss) = unzip prs
-                -- For a recursive group, it's a bit of a pain to work out the minimal
-                -- set of tyvars over which to abstract:
-                --      /\ a b c.  let x = ...a... in
-                --                 letrec { p = ...x...q...
-                --                          q = .....p...b... } in
-                --                 ...
-                -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
-                -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
-                -- Since it's a pain, we just use the whole set, which is always safe
-                --
-                -- If you ever want to be more selective, remember this bizarre case too:
-                --      x::a = x
-                -- Here, we must abstract 'x' over 'a'.
-         tvs_here = scopedSort main_tvs
+         all_free_tvs = closeOverKinds free_tvs       -- (AB2)
 
     mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
     mk_poly1 tvs_here var

compiler/GHC/Core/Opt/Specialise.hs

@@ -2516,6 +2516,8 @@ specHeader env (bndr : bndrs) (UnspecType : args)
 -- the nitty-gritty), as a LHS rule and unfolding details.
 specHeader env (bndr : bndrs) (SpecDict d : args)
   | not (isDeadBinder bndr)
+  , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)
+    -- See Note [Weird special case for SpecDict]
   = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
        ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
        ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
@@ -2531,6 +2533,8 @@ specHeader env (bndr : bndrs) (SpecDict d : args)
               , spec_dict : spec_args
               )
        }
+   where
+     in_scope = Core.getSubstInScope (se_subst env)
 
 -- Finally, we don't want to specialise on this argument 'i':
 --   - It's an UnSpecArg, or
@@ -2752,6 +2756,8 @@ monomorpic, and specialised in one go.
 
 Wrinkles.
 
+* See Note [Weird special case for SpecDict]
+
 * With -XOverlappingInstances you might worry about this:
     class C a where ...
     instance C (Maybe Int) where ...   -- $df1 :: C (Maybe Int)
@@ -2777,6 +2783,33 @@ Wrinkles.
   it's a hard test to make.)
 
   But see Note [Specialisation and overlapping instances].
+
+Note [Weird special case for SpecDict]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are trying to specialise for this this call:
+   $wsplit @T (mkD @k @(a::k) :: C T)
+where
+   mkD :: forall k (a::k). C T
+is a top-level dictionary-former.  This actually happened in #22459,
+because of (MP1) of Note [Specialising polymorphic dictionaries].
+
+How can we speicalise $wsplit?  We might try
+
+   RULE "SPEC" forall (d :: C T). $wsplit @T d = $s$wsplit
+
+but then in the body of $s$wsplit what will we use for the dictionary
+evidence?  We can't use (mkD @k @(a::k)) because k and a aren't in scope.
+We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that
+is a lot of hard work for a very strange case.
+
+So we simply refrain from specialising in this case; hence the guard
+   allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)
+in the SpecDict cased of specHeader.
+
+How did this strange polymorphic mkD arise in the first place?
+From GHC.Core.Opt.Utils.abstractFloats, which was abstracting
+over too many type variables. But that too is now fixed;
+see Note [Which type variables to abstract over] in that module.
 -}
 
 instance Outputable DictBind where

compiler/GHC/Core/Subst.hs

@@ -15,7 +15,7 @@ module GHC.Core.Subst (
         deShadowBinds, substRuleInfo, substRulesForImportedIds,
         substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,
         substUnfolding, substUnfoldingSC,
-        lookupIdSubst, substIdType, substIdOcc,
+        lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,
         substTickish, substDVarSet, substIdInfo,
 
         -- ** Operations on substitutions
@@ -184,9 +184,11 @@ extendSubstList subst []              = subst
 extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
 
 -- | Find the substitution for an 'Id' in the 'Subst'
+-- The Id should not be a CoVar
 lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr
 lookupIdSubst (Subst in_scope ids _ _) v
-  | not (isLocalId v) = Var v
+  | assertPpr (isId v && not (isCoVar v)) (ppr v)
+    not (isLocalId v)                   = Var v
   | Just e  <- lookupVarEnv ids       v = e
   | Just v' <- lookupInScope in_scope v = Var v'
         -- Vital! See Note [Extending the IdSubstEnv]
@@ -194,6 +196,12 @@ lookupIdSubst (Subst in_scope ids _ _) v
         -- it's a bad bug and we really want to know
   | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope)
 
+lookupIdSubst_maybe :: HasDebugCallStack => Subst -> Id -> Maybe CoreExpr
+-- Just look up in the substitution; do not check the in-scope set
+lookupIdSubst_maybe (Subst _ ids _ _) v
+  = assertPpr (isId v && not (isCoVar v)) (ppr v) $
+    lookupVarEnv ids v
+
 delBndr :: Subst -> Var -> Subst
 delBndr (Subst in_scope ids tvs cvs) v
   | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)

compiler/GHC/Driver/Main.hs

@@ -266,6 +266,7 @@ import GHC.SysTools.BaseDir (findTopDir)
 
 import Data.Data hiding (Fixity, TyCon)
 import Data.List        ( nub, isPrefixOf, partition )
+import qualified Data.List.NonEmpty as NE
 import Control.Monad
 import Data.IORef
 import System.FilePath as FilePath
@@ -445,11 +446,15 @@ ioMsgMaybe' ioA = do
 -- -----------------------------------------------------------------------------
 -- | Lookup things in the compiler's environment
 
-hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
+hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)
 hscTcRnLookupRdrName hsc_env0 rdr_name
   = runInteractiveHsc hsc_env0 $
     do { hsc_env <- getHscEnv
-       ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }
+       -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage.
+       -- Once errors has been dealt with in hoistTcRnMessage, we can enforce
+       -- this invariant in types by converting to NonEmpty.
+       ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $
+          tcRnLookupRdrName hsc_env rdr_name }
 
 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do

compiler/GHC/Runtime/Debugger.hs

@@ -49,6 +49,7 @@ import GHC.Types.TyThing
 import Control.Monad
 import Control.Monad.Catch as MC
 import Data.List ( (\\), partition )
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe
 import Data.IORef
 
@@ -57,7 +58,7 @@ import Data.IORef
 -------------------------------------
 pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
 pprintClosureCommand bindThings force str = do
-  tythings <- (catMaybes . concat) `liftM`
+  tythings <- (catMaybes . concatMap NE.toList) `liftM`
                  mapM (\w -> GHC.parseName w >>=
                                 mapM GHC.lookupName)
                       (words str)

compiler/GHC/Runtime/Eval.hs

@@ -121,6 +121,7 @@ import Data.Either
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.List (find,intercalate)
+import Data.List.NonEmpty (NonEmpty)
 import Control.Monad
 import Control.Monad.Catch as MC
 import Data.Array
@@ -903,7 +904,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do
 
 -- | Parses a string as an identifier, and returns the list of 'Name's that
 -- the identifier can refer to in the current interactive context.
-parseName :: GhcMonad m => String -> m [Name]
+parseName :: GhcMonad m => String -> m (NonEmpty Name)
 parseName str = withSession $ \hsc_env -> liftIO $
    do { lrdr_name <- hscParseIdentifier hsc_env str
       ; hscTcRnLookupRdrName hsc_env lrdr_name }

compiler/GHC/Tc/Solver/Types.hs

@@ -273,21 +273,29 @@ addToEqualCtList ct old_eqs
   | debugIsOn
   = case ct of
       CEqCan { cc_lhs = TyVarLHS tv } ->
-        let shares_lhs (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv
-            shares_lhs _other                                = False
-        in
-        assert (all shares_lhs old_eqs) $
-        assert (null ([ (ct1, ct2) | ct1 <- ct : old_eqs
-                                   , ct2 <- ct : old_eqs
-                                   , let { fr1 = ctFlavourRole ct1
-                                         ; fr2 = ctFlavourRole ct2 }
-                                   , fr1 `eqCanRewriteFR` fr2 ])) $
+        assert (all (shares_lhs tv) old_eqs) $
+        assertPpr (null bad_prs)
+                  (vcat [ text "bad_prs" <+> ppr bad_prs
+                        , text "ct:old_eqs" <+> ppr (ct : old_eqs) ]) $
         (ct : old_eqs)
 
       _ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct)
 
   | otherwise
   = ct : old_eqs
+  where
+    shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv
+    shares_lhs _ _ = False
+    bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs))
+    is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2
+
+distinctPairs :: [a] -> [(a,a)]
+-- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...]
+--                             where i /= j
+-- NB: does not return pairs (xi,xi), which would be stupid in the
+--     context of addToEqualCtList (#22645)
+distinctPairs []     = []
+distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs
 
 -- returns Nothing when the new list is empty, to keep the environments smaller
 filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList

compiler/GHC/Utils/Outputable.hs

+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -151,6 +152,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NEL
 import Data.Time
 import Data.Time.Format.ISO8601
+import Data.Void
 
 import GHC.Fingerprint
 import GHC.Show         ( showMultiLineString )
@@ -1173,6 +1175,8 @@ instance OutputableP env SDoc where
 instance (OutputableP env a) => OutputableP env (Set a) where
     pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s))))
 
+instance OutputableP env Void where
+    pdoc _ = \ case
 
 {-
 ************************************************************************

compiler/ghc.cabal.in

@@ -88,7 +88,7 @@ Library
                    filepath   >= 1   && < 1.5,
                    template-haskell == 2.19.*,
                    hpc        == 0.6.*,
-                   transformers == 0.5.*,
+                   transformers >= 0.5 && < 0.7,
                    exceptions == 0.10.*,
                    stm,
                    ghc-boot   == @ProjectVersionMunged@,

configure.ac

@@ -143,7 +143,7 @@ if test "$EnableDistroToolchain" = "YES"; then
 fi
 
 AC_ARG_ENABLE(asserts-all-ways,
-[AC_HELP_STRING([--enable-asserts-all-ways],
+[AS_HELP_STRING([--enable-asserts-all-ways],
                 [Usually ASSERTs are only compiled in the DEBUG way,
                  this will enable them in all ways.])],
   [FP_CAPITALIZE_YES_NO(["$enableval"], [EnableAssertsAllWays])],
@@ -485,11 +485,6 @@ FP_CPP_CMD_WITH_ARGS(HaskellCPPCmd, HaskellCPPArgs)
 AC_SUBST([HaskellCPPCmd])
 AC_SUBST([HaskellCPPArgs])
 
-FP_SET_CFLAGS_C99([CC],[CFLAGS],[CPPFLAGS])
-FP_SET_CFLAGS_C99([CC_STAGE0],[CONF_CC_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
-
 dnl ** Which ld to use
 dnl --------------------------------------------------------------
 AC_ARG_VAR(LD,[Use as the path to ld. See also --disable-ld-override.])

distrib/configure.ac.in

@@ -111,11 +111,6 @@ FP_CPP_CMD_WITH_ARGS(HaskellCPPCmd, HaskellCPPArgs)
 AC_SUBST([HaskellCPPCmd])
 AC_SUBST([HaskellCPPArgs])
 
-FP_SET_CFLAGS_C99([CC],[CFLAGS],[CPPFLAGS])
-dnl FP_SET_CFLAGS_C99([CC_STAGE0],[CONF_CC_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
-
 dnl ** Which ld to use?
 dnl --------------------------------------------------------------
 FIND_LD([$target],[GccUseLdOpt])

ghc/GHCi/UI.hs

@@ -122,7 +122,7 @@ import qualified Data.ByteString.Char8 as BS
 import Data.Char
 import Data.Function
 import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( elemIndices, find, intercalate, intersperse,
+import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy,
                    isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Set as S
@@ -941,23 +941,26 @@ getInfoForPrompt = do
 
   return (dots <> context_bit, modules_names, line)
 
-parseCallEscape :: String -> (String, String)
-parseCallEscape s
-  | not (all isSpace beforeOpen) = ("", "")
-  | null sinceOpen               = ("", "")
-  | null sinceClosed             = ("", "")
-  | null cmd                     = ("", "")
-  | otherwise                    = (cmd, tail sinceClosed)
-  where
-    (beforeOpen, sinceOpen) = span (/='(') s
-    (cmd, sinceClosed) = span (/=')') (tail sinceOpen)
+-- | Takes a string, presumably following "%call", and tries to parse
+-- a command and arguments in parentheses:
+--
+-- > parseCallEscape "  (cmd arg1 arg2)rest" = Just ("cmd" :| ["arg1", "arg2"], "rest")
+-- > parseCallEscape "( )rest" = Nothing
+--
+parseCallEscape :: String -> Maybe (NE.NonEmpty String, String)
+parseCallEscape s = case dropWhile isSpace s of
+  '(' : sinceOpen -> case span (/= ')') sinceOpen of
+    (call, ')' : sinceClosed)
+      | cmd : args <- words call -> Just (cmd NE.:| args, sinceClosed)
+    _ -> Nothing
+  _ -> Nothing
 
 checkPromptStringForErrors :: String -> Maybe String
 checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =
   case parseCallEscape xs of
-    ("", "") -> Just ("Incorrect %call syntax. " ++
+    Nothing  -> Just ("Incorrect %call syntax. " ++
                       "Should be %call(a command and arguments).")
-    (_, afterClosed) -> checkPromptStringForErrors afterClosed
+    Just (_, afterClosed) -> checkPromptStringForErrors afterClosed
 checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs
 checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs
 checkPromptStringForErrors "" = Nothing
@@ -1010,10 +1013,12 @@ generatePromptFunctionFromString promptS modules_names line =
         processString ('%':'V':xs) =
             liftM ((text $ showVersion compilerVersion) <>) (processString xs)
         processString ('%':'c':'a':'l':'l':xs) = do
+            -- Input has just been validated by parseCallEscape
+            let (cmd NE.:| args, afterClosed) = fromJust $ parseCallEscape xs
             respond <- liftIO $ do
                 (code, out, err) <-
                     readProcessWithExitCode
-                    (head list_words) (tail list_words) ""
+                    cmd args ""
                     `catchIO` \e -> return (ExitFailure 1, "", show e)
                 case code of
                     ExitSuccess -> return out
@@ -1021,9 +1026,6 @@ generatePromptFunctionFromString promptS modules_names line =
                         hPutStrLn stderr err
                         return ""
             liftM ((text respond) <>) (processString afterClosed)
-            where
-              (cmd, afterClosed) = parseCallEscape xs
-              list_words = words cmd
         processString ('%':'%':xs) =
             liftM ((char '%') <>) (processString xs)
         processString (x:xs) =
@@ -1055,10 +1057,7 @@ installInteractivePrint :: GhciMonad m => Maybe String -> Bool -> m ()
 installInteractivePrint Nothing _  = return ()
 installInteractivePrint (Just ipFun) exprmode = do
   ok <- trySuccess $ do
-                names <- GHC.parseName ipFun
-                let name = case names of
-                             name':_ -> name'
-                             [] -> panic "installInteractivePrint"
+                name NE.:| _ <- GHC.parseName ipFun
                 modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
                                       in he{hsc_IC = new_ic})
                 return Succeeded
@@ -1374,12 +1373,13 @@ afterRunStmt step_here run_result = do
             show_types <- isOptionSet ShowType
             when show_types $ printTypeOfNames names
      GHC.ExecBreak names mb_info
-         | isNothing  mb_info ||
-           step_here (GHC.resumeSpan $ head resumes) -> do
+         | first_resume : _ <- resumes
+         , isNothing  mb_info ||
+           step_here (GHC.resumeSpan first_resume) -> do
                mb_id_loc <- toBreakIdAndLocation mb_info
                let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
                if (null bCmd)
-                 then printStoppedAtBreakInfo (head resumes) names
+                 then printStoppedAtBreakInfo first_resume names
                  else enqueueCommands [bCmd]
                -- run the command set with ":set stop <cmd>"
                st <- getGHCiState
@@ -1596,7 +1596,7 @@ infoThing allInfo str = do
     names     <- GHC.parseName str
     mb_stuffs <- mapM (GHC.getInfo allInfo) names
     let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
-                                     (catMaybes mb_stuffs)
+                                     (catMaybes (NE.toList mb_stuffs))
     return $ vcat (intersperse (text "") $ map pprInfo filtered)
 
   -- Filter out names whose parent is also there. Good
@@ -1917,7 +1917,7 @@ docCmd s  = do
 
   docs <- traverse (buildDocComponents s) names
 
-  let sdocs = pprDocs docs
+  let sdocs = pprDocs (NE.toList docs)
       sdocs' = vcat (intersperse (text "") sdocs)
   sdoc <- showSDocForUser' sdocs'
   liftIO (putStrLn sdoc)
@@ -2607,15 +2607,14 @@ guessCurrentModule :: GHC.GhcMonad m => String -> m Module
 -- Guess which module the user wants to browse.  Pick
 -- modules that are interpreted first.  The most
 -- recently-added module occurs last, it seems.
-guessCurrentModule cmd
-  = do imports <- GHC.getContext
-       when (null imports) $ throwGhcException $
-          CmdLineError (':' : cmd ++ ": no current module")
-       case (head imports) of
-          IIModule m -> GHC.findQualifiedModule NoPkgQual m
-          IIDecl d   -> do
-            pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
-            GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
+guessCurrentModule cmd = do
+  imports <- GHC.getContext
+  case imports of
+    [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module")
+    IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m
+    IIDecl d : _ -> do
+      pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
+      GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
 
 -- without bang, show items in context of their parents and omit children
 -- with bang, show class methods and data constructors separately, and
@@ -3507,18 +3506,15 @@ completeCmd argLine0 = case parseLine argLine0 of
             liftIO $ print r
     _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
   where
-    parseLine argLine
-        | null argLine = Nothing
-        | null rest1   = Nothing
-        | otherwise    = (,,) dom <$> resRange <*> s
-      where
-        (dom, rest1) = breakSpace argLine
-        (rng, rest2) = breakSpace rest1
-        resRange | head rest1 == '"' = parseRange ""
-                 | otherwise         = parseRange rng
-        s | head rest1 == '"' = readMaybe rest1 :: Maybe String
-          | otherwise         = readMaybe rest2
-        breakSpace = fmap (dropWhile isSpace) . break isSpace
+    parseLine [] = Nothing
+    parseLine argLine = case breakSpace argLine of
+      (_, []) -> Nothing
+      (dom, rest1@('"' : _)) -> (dom,,) <$> parseRange "" <*> (readMaybe rest1 :: Maybe String)
+      (dom, rest1) -> (dom,,) <$> parseRange rng <*> readMaybe rest2
+        where
+          (rng, rest2) = breakSpace rest1
+
+    breakSpace = fmap (dropWhile isSpace) . break isSpace
 
     takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
 
@@ -3658,7 +3654,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do          -- #3000
     createInscope :: GhciMonad m => String -> m [(String, Module)]
     createInscope str_rdr = do
         names <- GHC.parseName str_rdr
-        pure $ zip (repeat str_rdr) $ GHC.nameModule <$> names
+        pure $ map (str_rdr, ) $ NE.toList $ GHC.nameModule <$> names
 
     -- For every top-level identifier in scope, add the bids of the nested
     -- declarations. See Note [Field modBreaks_decls] in GHC.ByteCode.Types
@@ -3666,7 +3662,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do          -- #3000
     addNestedDecls (ident, mod) = do
         (_, decls) <- getModBreak mod
         let (mod_str, topLvl, _) = splitIdent ident
-            ident_decls = filter ((topLvl ==) . head) $ elems decls
+            ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ]
             bids = nub $ declPath <$> ident_decls
         pure $ map (combineModIdent mod_str) bids
 
@@ -3843,7 +3839,7 @@ enclosingTickSpan md (RealSrcSpan src _) = do
   massert (inRange (bounds ticks) line)
   let enclosing_spans = [ pan | (_,pan) <- ticks ! line
                                , realSrcSpanEnd pan >= realSrcSpanEnd src]
-  return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
+  return . minimumBy leftmostLargestRealSrcSpan $ enclosing_spans
  where
 
 leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
@@ -4110,9 +4106,7 @@ breakById inp = do
     lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)
     lookupModuleInscope mod_top_lvl = do
         names <- GHC.parseName mod_top_lvl
-        pure $ Just $ head $ GHC.nameModule <$> names
-          -- if GHC.parseName succeeds `names` is not empty!
-          -- if it fails, the last line will not be evaluated.
+        pure $ Just $ NE.head $ GHC.nameModule <$> names
 
     -- Lookup the Module of a module name in the module graph
     lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)
@@ -4645,20 +4639,17 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m
                               -> m ()
 wantNameFromInterpretedModule noCanDo str and_then =
   handleSourceError GHC.printException $ do
-   names <- GHC.parseName str
-   case names of
-      []    -> return ()
-      (n:_) -> do
-            let modl = assert (isExternalName n) $ GHC.nameModule n
-            if not (GHC.isExternalName n)
-               then noCanDo n $ ppr n <>
-                                text " is not defined in an interpreted module"
-               else do
-            is_interpreted <- GHC.moduleIsInterpreted modl
-            if not is_interpreted
-               then noCanDo n $ text "module " <> ppr modl <>
-                                text " is not interpreted"
-               else and_then n
+    n NE.:| _ <- GHC.parseName str
+    let modl = assert (isExternalName n) $ GHC.nameModule n
+    if not (GHC.isExternalName n)
+       then noCanDo n $ ppr n <>
+                        text " is not defined in an interpreted module"
+       else do
+    is_interpreted <- GHC.moduleIsInterpreted modl
+    if not is_interpreted
+       then noCanDo n $ text "module " <> ppr modl <>
+                        text " is not interpreted"
+       else and_then n
 
 clearCaches :: GhciMonad m => m ()
 clearCaches = discardActiveBreakPoints

ghc/ghc-bin.cabal.in

@@ -38,7 +38,7 @@ Executable ghc
                    process    >= 1   && < 1.7,
                    filepath   >= 1   && < 1.5,
                    containers >= 0.5 && < 0.7,
-                   transformers == 0.5.*,
+                   transformers >= 0.5 && < 0.7,
                    ghc-boot      == @ProjectVersionMunged@,
                    ghc           == @ProjectVersionMunged@
 

hadrian/hadrian.cabal

@@ -158,7 +158,7 @@ executable hadrian
                        , mtl                  >= 2.2     && < 2.4
                        , parsec               >= 3.1     && < 3.2
                        , shake                >= 0.18.3  && < 0.20
-                       , transformers         >= 0.4     && < 0.6
+                       , transformers         >= 0.4     && < 0.7
                        , unordered-containers >= 0.2.1   && < 0.3
                        , text                 >= 1.2     && < 3
     ghc-options:       -Wall