GitLab

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

14b72145

by Fendor at 2026-04-17T17:26:31-04:00

Migrate `ghc-pkg` to use `OsPath` and `file-io`

`ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH
issues on windows.

`file-io` uses UNC Paths by default on windows, ensuring we use the
correct APIs and that we finally are no longer plagued by MAX_PATH
issues in CI and private machines.

On top of it, the higher correctness of `OsPath` is appreciated in this
small codebase. Also, we improve memory usage very slightly, due to the
more efficient memory representation of `OsPath` over `FilePath`

Adds `ghc-pkg` regression test for MAX_PATH on windows

Make sure `ghc-pkg` behaves as expected when long paths (> 255) are
involved on windows.

Let's generate a testcase where we can actually observe that `ghc-pkg`
behaves as epxected.

See the documentation for windows on Maximum Path Length Limitation:

* `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation`

Adds changelog entry for long path support in ghc-pkg.

91aee7ae

by Simon Peyton Jones at 2026-04-17T17:26:32-04:00

Kill off the substitution in Lint

Now that we have invariant (NoTypeShadowing) we no longer
need Lint to carry an ambient substitution.  This makes it
simpler and faster.  A really worthwhile refactor.

There are some knock-on effects

* Linting join points after worker/wrapper.  See
  Note [Join points and beta redexes]

* Running a type substitution after the desugarer.
  See Note [Substituting type-lets] in
  the new module GHC.Core.SubstTypeLets

Implements #27078

Most perf tests don't use Lint so we won't see a perf incresae.
But T1969, which uses -O0 and Lint, gets 1.3% worse because it has
to run the SubstTypeLets pass which is a somewhat expensive no-op

Overall though compile-time allocations are down 0.1%.

Metric Increase:
    T1969

36a66041

by mangoiv at 2026-04-17T17:26:32-04:00

testsuite: inline elemCoreTest

Some weird (probably python scoping) rule caused elemCoreTest, a regex
being out of scope on ubuntu, presumably because of a newer python version.
This patch just inlines the regex, which fixes the issue.

Fixes #27193

19 changed files:

+ changelog.d/ghc-pkg-long-path-support
compiler/GHC/Core/Lint.hs
+ compiler/GHC/Core/Lint/SubstTypeLets.hs
compiler/GHC/Core/Opt/OccurAnal.hs
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
compiler/GHC/Core/Subst.hs
compiler/GHC/Driver/Config/Core/Lint.hs
compiler/GHC/Unit/State.hs
compiler/ghc.cabal.in
libraries/base/tests/perf/all.T
libraries/ghc-boot/GHC/Unit/Database.hs
libraries/ghc-boot/ghc-boot.cabal.in
testsuite/tests/cabal/Makefile
testsuite/tests/cabal/all.T
+ testsuite/tests/cabal/ghcpkg10.stdout
testsuite/tests/corelint/LintEtaExpand.stderr
testsuite/tests/corelint/T21115b.stderr
utils/ghc-pkg/Main.hs
utils/ghc-pkg/ghc-pkg.cabal.in

Changes:

changelog.d/ghc-pkg-long-path-support

 +section: ghc-pkg
 +synopsis: Improve ``ghc-pkg``'s support for long paths on windows.
 +issues: #26960
 +mrs: !15584
++
 +description: {
 +    ``ghc-pkg`` can't handle working with file paths longer than the MAX_PATH
 +    restrictions on windows as it is not using UNC file paths by default.
++
 +    By using UNC file paths whenever possible, we improve ``ghc-pkg`` on windows.
 +    Note, this still requires the user to enable the use of long paths in order to opt-in
 +    this behaviour on older windows machines.
 +}
++
++

compiler/GHC/Core/Lint.hs

@@ -18,7 +18,7 @@ module GHC.Core.Lint (
      LintConfig (..),
      WarnsAndErrs,
 -    lintCoreBindings', lintUnfolding,
 +    lintCoreBindings, lintUnfolding,
      lintPassResult, lintExpr,
      lintAnnots, lintAxioms,
@@ -46,6 +46,7 @@ import GHC.Core.FVs
  import GHC.Core.Utils
  import GHC.Core.Stats ( coreBindsStats )
  import GHC.Core.DataCon
 +import GHC.Core.Lint.SubstTypeLets( substTypeLets )
  import GHC.Core.Ppr
  import GHC.Core.Coercion
  import GHC.Core.Type as Type
@@ -178,65 +179,7 @@ Note [Linting function types]
  All saturated applications of funTyCon are represented with the FunTy constructor.
  See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim
 - We check this invariant in lintType.
+-
 -Note [Linting type lets]
 -~~~~~~~~~~~~~~~~~~~~~~~~
 -In the desugarer, it's very very convenient to be able to say (in effect)
 -        let a = Type Bool in
 -        let x::a = True in <body>
 -That is, use a type let.  See Note [Core type and coercion invariant] in "GHC.Core".
 -One place it is used is in mkWwBodies; see Note [Join points and beta-redexes]
 -in GHC.Core.Opt.WorkWrap.Utils.  (Maybe there are other "clients" of this feature; I'm not sure).
+-
 -* Hence when linting <body> we need to remember that a=Int, else we
 -  might reject a correct program.  So we carry a type substitution (in
 -  this example [a -> Bool]) and apply this substitution before
 -  comparing types. In effect, in Lint, type equality is always
 -  equality-modulo-le-subst.  This is in the le_subst field of
 -  LintEnv.  But nota bene:
+-
 -  (SI1) The le_subst substitution is applied to types and coercions only
+-
 -  (SI2) The result of that substitution is used only to check for type
 -        equality, to check well-typed-ness, /but is then discarded/.
 -        The result of substitution does not outlive the CoreLint pass.
+-
 -  (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders.
+-
 -* The function
 -        lintInTy :: Type -> LintM (Type, Kind)
 -  returns a substituted type.
+-
 -* When we encounter a binder (like x::a) we must apply the substitution
 -  to the type of the binding variable.  lintBinders does this.
+-
 -* Clearly we need to clone tyvar binders as we go.
+-
 -* But take care (#17590)! We must also clone CoVar binders:
 -    let a = TYPE (ty |> cv)
 -    in \cv -> blah
 -  blindly substituting for `a` might capture `cv`.
+-
 -* Alas, when cloning a coercion variable we might choose a unique
 -  that happens to clash with an inner Id, thus
 -      \cv_66 -> let wild_X7 = blah in blah
 -  We decide to clone `cv_66` because it's already in scope.  Fine,
 -  choose a new unique.  Aha, X7 looks good.  So we check the lambda
 -  body with le_subst of [cv_66 :-> cv_X7]
+-
 -  This is all fine, even though we use the same unique as wild_X7.
 -  As (SI2) says, we do /not/ return a new lambda
 -     (\cv_X7 -> let wild_X7 = blah in ...)
 -  We simply use the le_subst substitution in types/coercions only, when
 -  checking for equality.
+-
 -* We still need to check that Id occurrences are bound by some
 -  enclosing binding.  We do /not/ use the InScopeSet for the le_subst
 -  for this purpose -- it contains only TyCoVars.  Instead we have a separate
 -  le_ids for the in-scope Id binders.
+-
 -Sigh.  We might want to explore getting rid of type-let!
 +We check this invariant in lintType.
  Note [Bad unsafe coercion]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -311,6 +254,7 @@ path does not result in allocation in the hot path. This can be surprisingly
  impactful. Changing `lint_app` reduced allocations for one test program I was
  looking at by ~4%.
++
  ************************************************************************
  *                                                                      *
                   Beginning and ending passes
@@ -407,26 +351,37 @@ data LintPassResultConfig = LintPassResultConfig
    , lpr_platform         :: !Platform
    , lpr_makeLintFlags    :: !LintFlags
    , lpr_passPpr          :: !SDoc
 +  , lpr_preSubst         :: !Bool  -- True <=> run substTypeLets before linting
 +                                   -- See Note [Substituting type-lets]
    , lpr_localsInScope    :: ![Var]
+   }
  lintPassResult :: Logger -> LintPassResultConfig
                 -> CoreProgram -> IO ()
  lintPassResult logger cfg binds
 -  = do { let warns_and_errs = lintCoreBindings'
 -               (LintConfig
 +  = do { let lint_config = LintConfig
                  { l_diagOpts = lpr_diagOpts cfg
                  , l_platform = lpr_platform cfg
                  , l_flags    = lpr_makeLintFlags cfg
                  , l_vars     = lpr_localsInScope cfg
 -                })
 -               binds
 +                }
++
 +       -- Do the pre-substitution if necessary
 +       -- See Note [Substituting type-lets] in GHC.Core.SubstTypeLets
 +       -- especially wrinkle (STL2)
 +       ; let binds1 | lpr_preSubst cfg = substTypeLets binds
 +                    | otherwise        = binds
++
 +       -- Do the main Lint pass itself
 +       ; let warns_and_errs = lintCoreBindings lint_config binds1
++
 +       -- Report the results
         ; Err.showPass logger $
             "Core Linted result of " ++
             renderWithContext defaultSDocContext (lpr_passPpr cfg)
         ; displayLintResults logger
                              (lpr_passPpr cfg)
 -                            (pprCoreBindings binds) warns_and_errs
 +                            (pprCoreBindings binds1) warns_and_errs
+        }
  displayLintResults :: Logger
@@ -456,11 +411,11 @@ lint_banner string pass = text "*** Core Lint"      <+> text string
                            <+> text "***"
  -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
 -lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs
 +lintCoreBindings :: LintConfig -> CoreProgram -> WarnsAndErrs
  --   Returns (warnings, errors)
  -- If you edit this function, you may need to update the GHC formalism
  -- See Note [GHC Formalism]
 -lintCoreBindings' cfg binds
 +lintCoreBindings cfg binds
    = initL cfg $
      addLoc TopLevelBindings           $
      do { -- Check that all top-level binders are distinct
@@ -472,8 +427,7 @@ lintCoreBindings' cfg binds
         ; checkL (null ext_dups) (dupExtVars ext_dups)
           -- Typecheck the bindings
 -       ; lintRecBindings TopLevel all_pairs $ \_ ->
 -         return () }
 +       ; lintRecBindings TopLevel all_pairs $ return () }
    where
      all_pairs = flattenBinds binds
       -- Put all the top-level binders in scope at the start
@@ -555,28 +509,28 @@ Check a core binding, returning the list of variables bound.
  -- Let
  lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
 -                -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv])
 +                -> LintM a -> LintM (a, [UsageEnv])
  lintRecBindings top_lvl pairs thing_inside
 -  = lintIdBndrs top_lvl bndrs $ \ bndrs' ->
 -    do { ues <- zipWithM lint_pair bndrs' rhss
 -       ; a <- thing_inside bndrs'
 +  = lintIdBndrs top_lvl bndrs $
 +    do { ues <- zipWithM lint_pair bndrs rhss
 +       ; a <- thing_inside
         ; return (a, ues) }
    where
      (bndrs, rhss) = unzip pairs
 -    lint_pair bndr' rhs
 -      = addLoc (RhsOf bndr') $
 -        do { (rhs_ty, ue) <- lintRhs bndr' rhs         -- Check the rhs
 -           ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty
 +    lint_pair bndr rhs
 +      = addLoc (RhsOf bndr) $
 +        do { (rhs_ty, ue) <- lintRhs bndr rhs         -- Check the rhs
 +           ; lintLetBind top_lvl Recursive bndr rhs rhs_ty
             ; return ue }
 -lintLetBody :: LintLocInfo -> [OutId] -> CoreExpr -> LintM (OutType, UsageEnv)
 +lintLetBody :: LintLocInfo -> [Id] -> CoreExpr -> LintM (Type, UsageEnv)
  lintLetBody loc bndrs body
    = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body)
         ; mapM_ (lintJoinBndrType body_ty) bndrs
         ; return (body_ty, body_ue) }
 -lintLetBind :: TopLevelFlag -> RecFlag -> OutId
 -              -> CoreExpr -> OutType -> LintM ()
 +lintLetBind :: TopLevelFlag -> RecFlag -> Id
 +            -> CoreExpr -> Type -> LintM ()
  -- Binder's type, and the RHS, have already been linted
  -- This function checks other invariants
  lintLetBind top_lvl rec_flag binder rhs rhs_ty
@@ -651,14 +605,17 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
             _ -> return ()
 -       ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
 +       -- Lint any RULES
 +       ; addLoc (RuleOf binder) $
 +         mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
 +       -- Lint the unfolding
 +       -- Do this here, not in lintIdBinder, so that all the
 +       -- binders of the letrec group are in scope
         ; addLoc (UnfoldingOf binder) $
           lintIdUnfolding binder binder_ty (idUnfolding binder)
 -       ; return () }
 -        -- We should check the unfolding, if any, but this is tricky because
 -        -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 +       ; return () }
  -- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
  -- in that it doesn't reject occurrences of the function 'makeStatic' when they
@@ -667,7 +624,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
  -- join point.
  --
  -- See Note [Checking StaticPtrs].
 -lintRhs :: Id -> CoreExpr -> LintM (OutType, UsageEnv)
 +lintRhs :: Id -> CoreExpr -> LintM (Type, UsageEnv)
  -- NB: the Id can be Linted or not -- it's only used for
  --     its OccInfo and join-pointer-hood
  lintRhs bndr rhs
@@ -682,7 +639,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
    where
      -- Allow occurrences of 'makeStatic' at the top-level but produce errors
      -- otherwise.
 -    go :: StaticPtrCheck -> LintM (OutType, UsageEnv)
 +    go :: StaticPtrCheck -> LintM (Type, UsageEnv)
      go AllowAtTopLevel
        | (binders0, rhs') <- collectTyBinders rhs
        , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
@@ -699,7 +656,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
  -- | Lint the RHS of a join point with expected join arity of @n@ (see Note
  -- [Join points] in "GHC.Core").
 -lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (OutType, UsageEnv)
 +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (Type, UsageEnv)
  lintJoinLams join_arity enforce rhs
    = go join_arity rhs
    where
@@ -715,17 +672,22 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
  lintIdUnfolding bndr bndr_ty uf
    | isStableUnfolding uf
    , Just rhs <- maybeUnfoldingTemplate uf
 -  = noMultiplicityChecks $ -- Skip linearity checking for unfoldings
 -                           -- See Note [Linting linearity]
 -  do { ty <- fst <$> (if isCompulsoryUnfolding uf
 -                        then noFixedRuntimeRepChecks $ lintRhs bndr rhs
 -            --               ^^^^^^^^^^^^^^^^^^^^^^^
 -            -- See Note [Checking for representation polymorphism]
 -                        else lintRhs bndr rhs)
 -       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
 -lintIdUnfolding  _ _ _
 -  = return ()       -- Do not Lint unstable unfoldings, because that leads
 -                    -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars
 +   = suppress_rr_checks   $
 +     noMultiplicityChecks $ -- Skip linearity checking for unfoldings
 +                            -- See Note [Linting linearity]
 +     do { (unf_ty, _unf_ue) <- lintRhs bndr rhs
 +        ; ensureEqTys bndr_ty unf_ty (mkRhsMsg bndr (text "unfolding") unf_ty) }
++
 +  | otherwise
 +  = -- Do not Lint the body of an unstable unfolding, because that leads
 +    -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars
 +    return ()
++
 +  where
 +    -- See Note [Checking for representation polymorphism]
 +    suppress_rr_checks thing_inside
 +      | isCompulsoryUnfolding uf = noFixedRuntimeRepChecks thing_inside
 +      | otherwise                = thing_inside
  {- Note [Checking for INLINE loop breakers]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -887,13 +849,8 @@ suspicious and worth investigating if you have a seg-fault or bizarre behaviour.
  ************************************************************************
  -}
 -lintCoreExpr :: InExpr -> LintM (OutType, UsageEnv)
 --- The returned type has the substitution from the monad
 --- already applied to it:
 ---      lintCoreExpr e subst = exprType (subst e)
 ---
 --- The returned "type" can be a kind, if the expression is (Type ty)
+-
 +lintCoreExpr :: CoreExpr -> LintM (Type, UsageEnv)
 +-- The returned type is the type of the expression
  -- If you edit this function, you may need to update the GHC formalism
  -- See Note [GHC Formalism]
@@ -920,7 +877,7 @@ lintCoreExpr (Cast expr co)
         ; lintCoercion co
         ; lintRole co Representational (coercionRole co)
 -       ; Pair from_ty to_ty <- substCoKindM co
 +       ; let Pair from_ty to_ty = coercionKind co
         ; checkValueType (typeKind to_ty) $
           text "target of cast" <+> quotes (ppr co)
         ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty)
@@ -934,27 +891,22 @@ lintCoreExpr (Tick tickish expr)
  lintCoreExpr (Let (NonRec tv (Type ty)) body)
    | isTyVar tv
 -  =     -- See Note [Linting type lets]
 -    do  { ty' <- lintTypeAndSubst ty
 -        ; lintTyCoBndr tv              $ \ tv' ->
 -    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'
 -                -- Now extend the substitution so we
 -                -- take advantage of it in the body
 -        ; extendTvSubstL tv ty' $
 -          addLoc (BodyOfLet tv) $
 -          lintCoreExpr body } }
 +  = do  { lintType ty
 +        ; lintTyCoBndr tv              $
 +    do  { addLoc (RhsOf tv)     $ lintTyKind tv ty
 +        ; addLoc (BodyOfLet tv) $ lintCoreExpr body } }
  lintCoreExpr (Let (NonRec bndr rhs) body)
    | isId bndr
    = do { -- First Lint the RHS, before bringing the binder into scope
           (rhs_ty, let_ue) <- lintRhs bndr rhs
 -          -- See Note [Multiplicity of let binders] in Var
 +         -- See Note [Multiplicity of let binders] in Var
           -- Now lint the binder
 -       ; lintBinder LetBind bndr $ \bndr' ->
 -    do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty
 -       ; addAliasUE bndr' let_ue $
 -         lintLetBody (BodyOfLet bndr') [bndr'] body } }
 +       ; lintBinder LetBind bndr $
 +    do { lintLetBind NotTopLevel NonRecursive bndr rhs rhs_ty
 +       ; addAliasUE bndr let_ue $
 +         lintLetBody (BodyOfLet bndr) [bndr] body } }
    | otherwise
    = failWithL (mkLetErr bndr rhs)       -- Not quite accurate
@@ -973,8 +925,8 @@ lintCoreExpr e@(Let (Rec pairs) body)
            -- See Note [Multiplicity of let binders] in Var
          ; ((body_type, body_ue), ues) <-
 -            lintRecBindings NotTopLevel pairs $ \ bndrs' ->
 -            lintLetBody (BodyOfLetRec bndrs') bndrs' body
 +            lintRecBindings NotTopLevel pairs $
 +            lintLetBody (BodyOfLetRec bndrs) bndrs body
          ; return (body_type, body_ue  `addUE` scaleUE ManyTy (foldr1WithDefault zeroUE addUE ues)) }
    where
      bndrs = map fst pairs
@@ -986,7 +938,7 @@ lintCoreExpr e@(App _ _)
      -- N.B. we may have an over-saturated application of the form:
      --   runRW (\s -> \x -> ...) y
    , ty_arg1 : ty_arg2 : cont_arg : rest <- args
 -  = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)
 +  = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (Type, UsageEnv)
               lint_rw_cont expr@(Lam _ _) mult fun_ue
                  = do { (arg_ty, arg_ue) <- lintJoinLams 1 (Just fun) expr
                       ; let app_ue = addUE fun_ue (scaleUE mult arg_ue)
@@ -1036,74 +988,73 @@ lintCoreExpr (Type ty)
  lintCoreExpr (Coercion co)
    -- See Note [Coercions in terms]
    = do { addLoc (InCo co) $ lintCoercion co
 -       ; ty <- substTyM (coercionType co)
 +       ; let ty = coercionType co
         ; return (ty, zeroUE) }
  ----------------------
 -lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed
 -          -> LintM (OutType, UsageEnv) -- returns type of the *variable*
 -lintIdOcc in_id nargs
 -  = addLoc (OccOf in_id) $
 -    do  { checkL (isNonCoVarId in_id)
 -                 (text "Non term variable" <+> ppr in_id)
 +lintIdOcc :: Id -> Int -- Number of arguments (type or value) being passed
 +          -> LintM (Type, UsageEnv) -- returns type of the *variable*
 +lintIdOcc id nargs
 +  = addLoc (OccOf id) $
 +    do  { checkL (isNonCoVarId id)
 +                 (text "Non term variable" <+> ppr id)
                   -- See GHC.Core Note [Variable occurrences in Core]
 -        -- Check that the type of the occurrence is the same
 -        -- as the type of the binding site.  The inScopeIds are
 -        -- /un-substituted/, so this checks that the occurrence type
 -        -- is identical to the binder type.
 -        -- This makes things much easier for things like:
 -        --    /\a. \(x::Maybe a). /\a. ...(x::Maybe a)...
 -        -- The "::Maybe a" on the occurrence is referring to the /outer/ a.
 -        -- If we compared /substituted/ types we'd risk comparing
 -        -- (Maybe a) from the binding site with bogus (Maybe a1) from
 -        -- the occurrence site.  Comparing un-substituted types finesses
 -        -- this altogether
 -        ; out_ty <- lintVarOcc in_id
 +        ; lintVarOcc id
            -- Check for a nested occurrence of the StaticPtr constructor.
            -- See Note [Checking StaticPtrs].
          ; when (nargs /= 0) $
 -          checkL (idName in_id /= makeStaticName) $
 +          checkL (idName id /= makeStaticName) $
            text "Found makeStatic nested in an expression"
 -        ; checkDeadIdOcc in_id
 +        ; checkDeadIdOcc id
 -        ; case isDataConId_maybe in_id of
 +        ; case isDataConId_maybe id of
               Nothing -> return ()
               Just dc -> checkTypeDataConOcc "expression" dc
 -        ; checkJoinOcc in_id nargs
 -        ; usage <- varCallSiteUsage in_id
+-
 -        ; return (out_ty, usage) }
 +        ; checkJoinOcc id nargs
 +        ; usage <- varCallSiteUsage id
 +        ; return (idType id, usage) }
 +------------------
  lintCoreFun :: CoreExpr
 -            -> Int                          -- Number of arguments (type or val) being passed
 -            -> LintM (OutType, UsageEnv) -- Returns type of the *function*
 +            -> Int                    -- Number of arguments (type or val) being passed
 +            -> LintM (Type, UsageEnv) -- Returns type of the *function*
  lintCoreFun (Var var) nargs
    = lintIdOcc var nargs
  lintCoreFun (Lam var body) nargs
 -  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad;
 -  -- See Note [Beta redexes]
 +  -- Act like lintCoreExpr of Lam, but *don't* necessarily call markAllJoinsBad;
 +  -- See Note [Join points and beta-redexes]
    | nargs /= 0
    = lintLambda var $ lintCoreFun body (nargs - 1)
  lintCoreFun expr nargs
 -  = markAllJoinsBadIf (nargs /= 0) $
 -      -- See Note [Join points are less general than the paper]
 -    lintCoreExpr expr
 +  = do { mark_bad_joins
 +           <- if nargs == 0
 +              then -- Saturated lambda
 +                   -- See Note [Join points and beta-redexes]
 +                   do { flags <- getLintFlags
 +                      ; return (not (lf_allow_beta_joins flags)) }
 +              else -- Something else
 +                   -- See Note [Join points are less general than the paper]
 +                   return True
++
 +       ; markAllJoinsBadIf mark_bad_joins $
 +         lintCoreExpr expr }
++
  ------------------
  lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
  lintLambda var lintBody =
      addLoc (LambdaBodyOf var) $
 -    lintBinder LambdaBind var $ \ var' ->
 +    lintBinder LambdaBind var $
      do { (body_ty, ue) <- lintBody
 -       ; ue' <- checkLinearity ue var'
 -       ; return (mkLamType var' body_ty, ue') }
 +       ; ue' <- checkLinearity ue var
 +       ; return (mkLamType var body_ty, ue') }
  ------------------
  checkDeadIdOcc :: Id -> LintM ()
  -- Occurrences of an Id should never be dead....
@@ -1117,8 +1068,8 @@ checkDeadIdOcc id
    = return ()
  ------------------
 -lintJoinBndrType :: OutType -- Type of the body
 -                 -> OutId   -- Possibly a join Id
 +lintJoinBndrType :: Type -- Type of the body
 +                 -> Id   -- Possibly a join Id
                   -> LintM ()
  -- Checks that the return type of a join Id matches the body
  -- E.g. join j x = rhs in body
@@ -1337,8 +1288,55 @@ checkLinearity body_ue lam_var =
        return body_ue'
      Nothing    -> return body_ue -- A type variable
 -{- Note [Linting join points with casts or ticks]
 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +{- Note [Join points and beta-redexes]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +In the worker/wrapper pass, the worker invokes the original function by calling
 +it with arguments, thus producing a beta-redex for the simplifier to munch away:
++
 +  \x y z -> e   =>    (\x y z -> e) wx wy wz
++
 +But we need to take care if `e` invokes a join point.  For example:
++
 +  join j1 x = ...
 +  join j2 y = if y == 0 then 0 else j1 y
 +=>
 +  join j1 x = ...
 +  join $wj2 y# = (\y -> if y == 0 then 0 else jump j1 y) (I# y#)
 +  join j2 y = case y of I# y# -> jump $wj2 y#
++
 +Now the jump to `j1` is inside a lambda and inside an application. That is ill-typed
 +from Lint's point of view.  And yet, after one round of simplification it'll all be
 +fine.
++
 +You might wonder if we could use a `let` instead of a lambda for the worker:
++
 +  join $wj2 y# = let y = I# y#
 +                 in  if y == 0 then 0 else jump j1 y
++
 +That would solve the join-point problem, but it really doesn't work because
 + 1. The lets shadow each other
 + 2. In particular the invariant (NoTypeShadowing) is easily broken.
 +    (We might have type lambdas of course.)
++
 +In short, te lambda arguments should not "see" any of the lambda-bound
 +variables.
++
 +So our solution is this:
++
 +* Use straightforward applicaion in the worker-wrapper pass, creating a beta-redex.
 +  See the call to `mkApps` in GHC.Core.Opt.WorkWrap.Utils.mkWwBodies.
++
 +* Tell Lint not to complain about a join-point invocation hidden under a
 +  saturated beta-redex.  The code is rather simple: see `lintCoreFun`.
++
 +  We guard this with a Lint flag `lf_allow_beta_joins`.
++
 +* Teach occurrence analysis that `j1` is still a join point, despite its
 +  call being nested inside the beta-redex.  See Note [occAnal for applications]
 +  in GHC.Core.Opt.OccurAnal.
++
 +Note [Linting join points with casts or ticks]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  As per Note [Join points, casts, and ticks] in GHC.Core, we have to be careful
  when a cast or tick occurs in between a join point binding and a corresponding
  join point occurrence.
@@ -1409,33 +1407,6 @@ lose track of why an expression is bottom, so we shouldn't make too
  much fuss when that happens.
 -Note [Beta redexes]
 -~~~~~~~~~~~~~~~~~~~
 -Consider:
+-
 -  join j @x y z = ... in
 -  (\@x y z -> jump j @x y z) @t e1 e2
+-
 -This is clearly ill-typed, since the jump is inside both an application and a
 -lambda, either of which is enough to disqualify it as a tail call (see Note
 -[Invariants on join points] in GHC.Core). However, strictly from a
 -lambda-calculus perspective, the term doesn't go wrong---after the two beta
 -reductions, the jump *is* a tail call and everything is fine.
+-
 -Why would we want to allow this when we have let? One reason is that a compound
 -beta redex (that is, one with more than one argument) has different scoping
 -rules: naively reducing the above example using lets will capture any free
 -occurrence of y in e2. More fundamentally, type lets are tricky; many passes,
 -such as Float Out, tacitly assume that the incoming program's type lets have
 -all been dealt with by the simplifier. Thus we don't want to let-bind any types
 -in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately
 -before Float Out.
+-
 -All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this
 -loophole, doing so to avoid re-traversing large functions (beta-reducing a type
 -lambda without introducing a type let requires a substitution). TODO: Improve
 -simpleOptPgm so that we can forget all this ever happened.
+-
  ************************************************************************
  *                                                                      *
  \subsection[lintCoreArgs]{lintCoreArgs}
@@ -1449,23 +1420,23 @@ subtype of the required type, as one would expect.
  -- Takes the functions type and arguments as argument.
  -- Returns the *result* of applying the function to arguments.
  -- e.g. f :: Int -> Bool -> Int would return `Int` as result type.
 -lintCoreArgs  :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv)
 +lintCoreArgs  :: (Type, UsageEnv) -> [CoreExpr] -> LintM (Type, UsageEnv)
  lintCoreArgs (fun_ty, fun_ue) args
 -  = lintApp (text "expression")
 -              lintTyArg lintValArg fun_ty args fun_ue
 +  = lintApp (text "expression") lintTyArg lintValArg fun_ty args fun_ue
 -lintTyArg :: InExpr -> LintM OutType
 +lintTyArg :: CoreExpr -> LintM Type
  -- Type argument
  lintTyArg (Type arg_ty)
    = do { checkL (not (isCoercionTy arg_ty))
                  (text "Unnecessary coercion-to-type injection:"
                    <+> ppr arg_ty)
 -       ; lintTypeAndSubst arg_ty }
 +       ; lintType arg_ty
 +       ; return arg_ty }
  lintTyArg arg
    = failWithL (hang (text "Expected type argument but found") 2 (ppr arg))
 -lintValArg  :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)
 +lintValArg  :: CoreExpr -> Mult -> UsageEnv -> LintM (Type, UsageEnv)
  lintValArg arg mult fun_ue
    = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg
             -- See Note [Representation polymorphism invariants] in GHC.Core
@@ -1484,9 +1455,9 @@ lintValArg arg mult fun_ue
  -----------------
  lintAltBinders :: UsageEnv
 -               -> Var         -- Case binder
 -               -> OutType     -- Scrutinee type
 -               -> OutType     -- Constructor type
 +               -> Var      -- Case binder
 +               -> Type     -- Scrutinee type
 +               -> Type     -- Constructor type
                 -> [(Mult, OutVar)]    -- Binders
                 -> LintM UsageEnv
  -- If you edit this function, you may need to update the GHC formalism
@@ -1505,6 +1476,7 @@ lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs)
         ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr
         ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs }
++
  -- | Implements the case rules for linearity
  checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv
  checkCaseLinearity ue case_bndr var_w bndr = do
@@ -1529,7 +1501,7 @@ checkCaseLinearity ue case_bndr var_w bndr = do
  -----------------
 -lintTyApp :: OutType -> OutType -> LintM OutType
 +lintTyApp :: Type -> Type -> LintM Type
  lintTyApp fun_ty arg_ty
    | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty
    = do  { lintTyKind tv arg_ty
@@ -1547,8 +1519,8 @@ lintTyApp fun_ty arg_ty
  -- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@
  -- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the
  -- application.
 -lintValApp :: CoreExpr -> OutType -> OutType -> UsageEnv -> UsageEnv
 -           -> LintM (OutType, UsageEnv)
 +lintValApp :: CoreExpr -> Type -> Type -> UsageEnv -> UsageEnv
 +           -> LintM (Type, UsageEnv)
  lintValApp arg fun_ty arg_ty fun_ue arg_ue
    | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty
    = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg)
@@ -1559,9 +1531,7 @@ lintValApp arg fun_ty arg_ty fun_ue arg_ue
    where
      err2 = mkNonFunAppMsg fun_ty arg_ty arg
 -lintTyKind :: OutTyVar -> OutType -> LintM ()
 --- Both args have had substitution applied
+-
 +lintTyKind :: OutTyVar -> Type -> LintM ()
  -- If you edit this function, you may need to update the GHC formalism
  -- See Note [GHC Formalism]
  lintTyKind tyvar arg_ty
@@ -1579,36 +1549,36 @@ lintTyKind tyvar arg_ty
  ************************************************************************
  -}
 -lintCaseExpr :: CoreExpr -> InId -> InType -> [CoreAlt] -> LintM (OutType, UsageEnv)
 +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (Type, UsageEnv)
  lintCaseExpr scrut case_bndr alt_ty alts
    = do { let e = Case scrut case_bndr alt_ty alts   -- Just for error messages
         -- Check the scrutinee
 -       ; (scrut_ty', scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut
 +       ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut
              -- See Note [Join points are less general than the paper]
              -- in GHC.Core
 -       ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty
 +       ; addLoc (CaseTy scrut) $ lintValueType alt_ty
 -       ; checkCaseAlts e scrut scrut_ty' alts
 +       ; checkCaseAlts e scrut scrut_ty alts
         -- Lint the case-binder. Must do this after linting the scrutinee
         -- because the case-binder isn't in scope in the scrutineex
 -       ; lintBinder CaseBind case_bndr $ \case_bndr' ->
 +       ; lintBinder CaseBind case_bndr $
        -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate
 -    do { let case_bndr_ty' = idType case_bndr'
 -             scrut_mult    = idMult case_bndr'
 +    do { let case_bndr_ty = idType case_bndr
 +             scrut_mult   = idMult case_bndr
 -       ; ensureEqTys case_bndr_ty' scrut_ty' (mkScrutMsg case_bndr case_bndr_ty' scrut_ty')
 +       ; ensureEqTys case_bndr_ty scrut_ty (mkScrutMsg case_bndr case_bndr_ty scrut_ty)
           -- See GHC.Core Note [Case expression invariants] item (7)
         ; -- Check the alternatives
 -       ; alt_ues <- mapM (lintCoreAlt case_bndr' scrut_ty' scrut_mult alt_ty') alts
 +       ; alt_ues <- mapM (lintCoreAlt case_bndr scrut_ty scrut_mult alt_ty) alts
         ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues
 -       ; return (alt_ty', case_ue) } }
 +       ; return (alt_ty, case_ue) } }
 -checkCaseAlts :: InExpr -> InExpr -> OutType -> [CoreAlt] -> LintM ()
 +checkCaseAlts :: CoreExpr -> CoreExpr -> Type -> [CoreAlt] -> LintM ()
  -- a) Check that the alts are non-empty
  -- b1) Check that the DEFAULT comes first, if it exists
  -- b2) Check that the others are in increasing order
@@ -1683,17 +1653,17 @@ checkCaseAlts e scrut scrut_ty alts
      is_lit_alt (Alt (LitAlt _) _  _) = True
      is_lit_alt _                     = False
 -lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv
 +lintAltExpr :: CoreExpr -> Type -> LintM UsageEnv
  lintAltExpr expr ann_ty
    = do { (actual_ty, ue) <- lintCoreExpr expr
         ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty)
         ; return ue }
           -- See GHC.Core Note [Case expression invariants] item (6)
 -lintCoreAlt :: OutId         -- Case binder
 -            -> OutType       -- Type of scrutinee
 +lintCoreAlt :: Id         -- Case binder
 +            -> Type       -- Type of scrutinee
              -> Mult          -- Multiplicity of scrutinee
 -            -> OutType       -- Type of the alternative
 +            -> Type       -- Type of the alternative
              -> CoreAlt
              -> LintM UsageEnv
  -- If you edit this function, you may need to update the GHC formalism
@@ -1738,11 +1708,11 @@ lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rh
            ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty }
          -- And now bring the new binders into scope
 -    ; lintBinders CasePatBind args $ \ args' -> do
 +    ; lintBinders CasePatBind args $ do
        { rhs_ue <- lintAltExpr rhs alt_ty
        ; rhs_ue' <- addLoc (CasePat alt) $
                     lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty
 -                                  (zipEqual multiplicities  args')
 +                                  (zipEqual multiplicities  args)
        ; return $ deleteUE rhs_ue' case_bndr
+       }
+    }
@@ -1784,54 +1754,52 @@ lintLinearBinder doc actual_usage described_usage
  -}
  -- When we lint binders, we (one at a time and in order):
 ---  1. Lint var types or kinds (possibly substituting)
 ---  2. Add the binder to the in scope set, and if its a coercion var,
 ---     we may extend the substitution to reflect its (possibly) new kind
 -lintBinders :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> LintM a) -> LintM a
 -lintBinders _    []         linterF = linterF []
 -lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->
 -                                      lintBinders site vars $ \ vars' ->
 -                                      linterF (var':vars')
 +--  1. Lint var types or kinds
 +--  2. Add the binder to the in scope set
 +lintBinders :: HasDebugCallStack => BindingSite -> [Var] -> LintM a -> LintM a
 +lintBinders _    []         linterF = linterF
 +lintBinders site (var:vars) linterF = lintBinder site var $
 +                                      lintBinders site vars $
 +                                      linterF
  -- If you edit this function, you may need to update the GHC formalism
  -- See Note [GHC Formalism]
 -lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a
 +lintBinder :: HasDebugCallStack => BindingSite -> Var -> LintM a -> LintM a
  lintBinder site var linterF
    | isTyCoVar var = lintTyCoBndr var linterF
    | otherwise     = lintIdBndr NotTopLevel site var linterF
 -lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a
 +lintTyCoBndr :: HasDebugCallStack => TyCoVar -> LintM a -> LintM a
  lintTyCoBndr tcv thing_inside
 -  = do { tcv_type' <- lintTypeAndSubst (varType tcv)
 -       ; let tcv_kind' = typeKind tcv_type'
 +  = do { let tcv_type = varType tcv
 +             tcv_kind = typeKind tcv_type
 +       ; lintType (varType tcv)
           -- See (FORALL1) and (FORALL2) in GHC.Core.Type
         ; if (isTyVar tcv)
           then -- Check that in (forall (a:ki). blah) we have ki:Type
 -              lintL (isLiftedTypeKind tcv_kind') $
 +              lintL (isLiftedTypeKind tcv_kind) $
                hang (text "TyVar whose kind does not have kind Type:")
 -                 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind')
 +                 2 (ppr tcv <+> dcolon <+> ppr tcv_type <+> dcolon <+> ppr tcv_kind)
           else -- Check that in (forall (cv::ty). blah),
                -- then ty looks like (t1 ~# t2)
 -              lintL (isCoVarType tcv_type') $
 +              lintL (isCoVarType tcv_type) $
                text "CoVar with non-coercion type:" <+> pprTyVar tcv
 -       ; addInScopeTyCoVar tcv tcv_type' thing_inside }
 +       ; addInScopeTyCoVar tcv thing_inside }
 -lintIdBndrs :: forall a. TopLevelFlag -> [InId] -> ([OutId] -> LintM a) -> LintM a
 +lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> LintM a -> LintM a
  lintIdBndrs top_lvl ids thing_inside
    = go ids thing_inside
    where
 -    go :: [Id] -> ([Id] -> LintM a) -> LintM a
 -    go []       thing_inside = thing_inside []
 -    go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id  $ \id' ->
 -                               go ids                         $ \ids' ->
 -                               thing_inside (id' : ids')
 +    go :: [Id] -> LintM a -> LintM a
 +    go []       thing_inside = thing_inside
 +    go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id  $
 +                               go ids                         $
 +                               thing_inside
  lintIdBndr :: TopLevelFlag -> BindingSite
 -           -> InVar -> (OutVar -> LintM a) -> LintM a
 --- Do substitution on the type of a binder and add the var with this
 --- new type to the in-scope set of the second argument
 +           -> Var -> LintM a -> LintM a
  -- ToDo: lint its rules
  lintIdBndr top_lvl bind_site id thing_inside
    = assertPpr (isId id) (ppr id) $
@@ -1864,14 +1832,16 @@ lintIdBndr top_lvl bind_site id thing_inside
         ; lintL (not (isCoVarType id_ty))
                 (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty)
 -       -- Check that the lambda binder has no value or OtherCon unfolding.
 +       -- Check that lambda-bound Ids have no unfolding; not even OtherCon
         -- See #21496
 -       ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id)))
 -                (text "Lambda binder with value or OtherCon unfolding.")
 +       ; let unf = idUnfolding id
 +       ; checkL (not (bind_site == LambdaBind && hasSomeUnfolding unf)) $
 +         hang (text "Lambda binder" <+> quotes (ppr id) <+> text "has an unfolding")
 +            2 (ppr unf)
 -       ; out_ty <- addLoc (IdTy id) (lintValueType id_ty)
 +       ; addLoc (IdTy id) (lintValueType id_ty)
 -       ; addInScopeId id out_ty thing_inside }
 +       ; addInScopeId id thing_inside }
    where
      id_ty = idType id
@@ -1891,62 +1861,44 @@ lintIdBndr top_lvl bind_site id thing_inside
  {- Note [Linting types and coercions]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Notice that
 -   lintType     :: InType     -> LintM ()
 -   lintCoercion :: InCoercion -> LintM ()
 +   lintType     :: Type     -> LintM ()
 +   lintCoercion :: Coercion -> LintM ()
  Neither returns anything.
 -If you need the kind of the type, then do `typeKind` and then apply
 -the ambient substitution using `substTyM`.  Note that the substitution
 -empty unless there is shadowing or type-lets; and if the substitution is
 -empty, the `substTyM` is a no-op.
+-
 -It is better to take the kind and then substitute, rather than substitute
 -and then take the kind, becaues the kind is usually smaller.
+-
 -Note: you might wonder if we should apply the same logic to expressions.
 -Why do we have
 -  lintExpr :: InExpr -> LintM OutType
 -Partly inertia; but also taking the type of an expresison involve looking
 -down a deep chain of let's, whereas that is not true of taking the kind
 -of a type.  It'd be worth an experiment though.
+-
 -Historical note: in the olden days we had
 -   lintType :: InType -> LintM OutType
 -but that burned a huge amount of allocation building an OutType that was
 -often discarded, or used only to get its kind.
+-
 -I also experimented with
 -   lintType :: InType -> LintM OutKind
 -but that too was slower.  It is also much simpler to return ()!  If we
 -return the kind we have to duplicate the logic in `typeKind`; and it is
 -much worse for coercions.
 +Note: you might wonder why we have
 +  lintExpr :: CoreExpr -> LintM Type
 +  lintType :: Type     -> LintM ()
++
 +That is, linting an expression yields its type, but linting a type does not
 +yield its kind. Partly inertia; but:
++
 +* Taking the type of an expresison involves looking down a deep chain of let's,
 +  whereas that is not true of taking the kind of a type.  It'd be worth an
 +  experiment though.
++
 +* I did experiment with
 +   lintType :: Type -> LintM Kind
 +  but that too was slower.  It is also much simpler to return ()!  If we return
 +  the kind we have to duplicate the logic in `typeKind`; and it is much worse
 +  for coercions.
  -}
 -lintValueType :: Type -> LintM OutType
 +lintValueType :: Type -> LintM ()
  -- Types only, not kinds
 --- Check the type, and apply the substitution to it
 --- See Note [Linting type lets]
  lintValueType ty
    = addLoc (InType ty) $
 -    do  { ty' <- lintTypeAndSubst ty
 -        ; let sk = typeKind ty'
 +    do  { lintType ty
 +        ; let sk = typeKind ty
          ; lintL (isTYPEorCONSTRAINT sk) $
            hang (text "Ill-kinded type:" <+> ppr ty)
 -             2 (text "has kind:" <+> ppr sk)
 -        ; return ty' }
 +             2 (text "has kind:" <+> ppr sk)}
  checkTyCon :: TyCon -> LintM ()
  checkTyCon tc
    = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)
  -------------------
 -lintTypeAndSubst :: InType -> LintM OutType
 -lintTypeAndSubst ty = do { lintType ty; substTyM ty }
 -           -- In GHCi we may lint an expression with a free
 -           -- type variable.  Then it won't be in the
 -           -- substitution, but it should be in scope
+-
 -lintType :: InType -> LintM ()
 +lintType :: Type -> LintM ()
  -- See Note [Linting types and coercions]
  --
  -- If you edit this function, you may need to update the GHC formalism
@@ -1956,8 +1908,7 @@ lintType (TyVarTy tv)
    = failWithL (mkBadTyVarMsg tv)
    | otherwise
 -  = do { _ <- lintVarOcc tv
 -       ; return () }
 +  = lintVarOcc tv
  lintType ty@(AppTy t1 t2)
    | TyConApp {} <- t1
@@ -1965,7 +1916,7 @@ lintType ty@(AppTy t1 t2)
    | otherwise
    = do { let (fun_ty, arg_tys) = collect t1 [t2]
         ; lintType fun_ty
 -       ; fun_kind <- substTyM (typeKind fun_ty)
 +       ; let fun_kind = typeKind fun_ty
         ; lint_ty_app ty fun_kind arg_tys }
    where
      collect (AppTy f a) as = collect f (a:as)
@@ -1997,21 +1948,21 @@ lintType ty@(FunTy af tw t1 t2)
  lintType ty@(ForAllTy {})
    = go [] ty
    where
 -    go :: [OutTyCoVar] -> InType -> LintM ()
 +    go :: [OutTyCoVar] -> Type -> LintM ()
      -- Loop, collecting the forall-binders
      go tcvs ty@(ForAllTy (Bndr tcv _) body_ty)
        | not (isTyCoVar tcv)
        = failWithL (text "Non-TyVar or Non-CoVar bound in type:" <+> ppr ty)
        | otherwise
 -      = lintTyCoBndr tcv $ \tcv' ->
 +      = lintTyCoBndr tcv $
          do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]
               -- Suspicious because it works on InTyCoVar; c.f. ForAllCo
               when (isCoVar tcv) $
               lintL (anyFreeVarsOfType (== tcv) body_ty) $
               text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)
 -           ; go (tcv' : tcvs) body_ty }
 +           ; go (tcv : tcvs) body_ty }
      go tcvs body_ty
        = do { lintType body_ty
@@ -2019,7 +1970,7 @@ lintType ty@(ForAllTy {})
  lintType (CastTy ty co)
    = do { lintType ty
 -       ; ty_kind <- substTyM (typeKind ty)
 +       ; let ty_kind = typeKind ty
         ; co_lk <- lintStarCoercion co
         ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) }
@@ -2027,14 +1978,14 @@ lintType (LitTy l)       = lintTyLit l
  lintType (CoercionTy co) = lintCoercion co
  -----------------
 -lintForAllBody :: [OutTyCoVar] -> InType -> LintM ()
 +lintForAllBody :: [OutTyCoVar] -> Type -> LintM ()
  -- Do the checks for the body of a forall-type
  lintForAllBody tcvs body_ty
    = do { -- For type variables, check for skolem escape
           -- See Note [Phantom type variables in kinds] in GHC.Core.Type
           -- The kind of (forall cv. th) is liftedTypeKind, so no
           -- need to check for skolem-escape in the CoVar case
 -         body_kind <- substTyM (typeKind body_ty)
 +         let body_kind = typeKind body_ty
         ; case occCheckExpand tcvs body_kind of
             Just {} -> return ()
             Nothing -> failWithL $
@@ -2045,7 +1996,7 @@ lintForAllBody tcvs body_ty
         ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) }
  -----------------
 -lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM ()
 +lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM ()
  -- The TyCon is a type synonym or a type family (not a data family)
  -- See Note [Linting type synonym applications]
  -- c.f. GHC.Tc.Validity.check_syn_tc_app
@@ -2071,21 +2022,21 @@ lintTySynFamApp report_unsat ty tc tys
  -----------------
  -- Confirms that a kind is really TYPE r or Constraint
 -checkValueType :: OutKind -> SDoc -> LintM ()
 +checkValueType :: Kind -> SDoc -> LintM ()
  checkValueType kind doc
    = lintL (isTYPEorCONSTRAINT kind)
            (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$
             text "when checking" <+> doc)
  -----------------
 -lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM ()
 +lintArrow :: SDoc -> FunTyFlag -> Type -> Type -> Type -> LintM ()
  -- If you edit this function, you may need to update the GHC formalism
  -- See Note [GHC Formalism]
  lintArrow what af t1 t2 tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw
                              -- or lintArrow "coercion `blah'" k1 k2 kw
 -  = do { k1 <- substTyM (typeKind t1)
 -       ; k2 <- substTyM (typeKind t2)
 -       ; kw <- substTyM (typeKind tw)
 +  = do { let k1 = typeKind t1
 +             k2 = typeKind t2
 +             kw = typeKind tw
         ; unless (isTYPEorCONSTRAINT k1) (report (text "argument")     t1 k1)
         ; unless (isTYPEorCONSTRAINT k2) (report (text "result")       t2 k2)
         ; unless (isMultiplicityTy kw)   (report (text "multiplicity") tw kw)
@@ -2111,34 +2062,34 @@ lintTyLit (StrTyLit _) = return ()
  lintTyLit (CharTyLit _) = return ()
  -----------------
 -lint_ty_app :: InType -> OutKind -> [InType] -> LintM ()
 +lint_ty_app :: Type -> Kind -> [Type] -> LintM ()
  lint_ty_app ty = lint_tyco_app (text "type" <+> quotes (ppr ty))
 -lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM ()
 +lint_co_app :: HasDebugCallStack => Coercion -> Kind -> [Type] -> LintM ()
  lint_co_app co = lint_tyco_app (text "coercion" <+> quotes (ppr co))
 -lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM ()
 +lint_tyco_app :: SDoc -> Kind -> [Type] -> LintM ()
  lint_tyco_app msg fun_kind arg_tys
      -- See Note [Avoiding compiler perf traps when constructing error messages.]
 -  = do { _ <- lintApp msg (\ty     -> do { lintType ty; substTyM ty })
 -                            (\ty _ _ -> do { lintType ty; ki <- substTyM (typeKind ty); return (ki,()) })
 -                            fun_kind arg_tys ()
 +  = do { _ <- lintApp msg (\ty     -> do { lintType ty; return ty })
 +                          (\ty _ _ -> do { lintType ty; return (typeKind ty,()) })
 +                          fun_kind arg_tys ()
         ; return () }
  ----------------
 -lintApp :: forall in_a acc. Outputable in_a =>
 +lintApp :: forall a acc. Outputable a =>
               SDoc
 -          -> (in_a -> LintM OutType)                        -- Lint the thing and return its value
 -          -> (in_a -> Mult -> acc -> LintM (OutKind, acc))  -- Lint the thing and return its type
 -          -> OutType
 -          -> [in_a]                               -- The arguments, always "In" things
 -          -> acc                                  -- Used (only) for UsageEnv in /term/ applications
 -          -> LintM (OutType,acc)
 +          -> (a -> LintM Type)                        -- Lint the thing and return its value
 +          -> (a -> Mult -> acc -> LintM (Kind, acc))  -- Lint the thing and return its type
 +          -> Type
 +          -> [a]                          -- The arguments
 +          -> acc                          -- Used (only) for UsageEnv in /term/ applications
 +          -> LintM (Type,acc)
  -- lintApp is a performance-critical function, which deals with multiple
  -- applications such as  (/\a./\b./\c. expr) @ta @tb @tc
  -- When returning the type of this expression we want to avoid substituting a:=ta,
  -- and /then/ substituting b:=tb, etc.  That's quadratic, and can be a huge
 --- perf hole.  So we gather all the arguments [in_a], and then gather the
 +-- perf hole.  So we gather all the arguments [a], and then gather the
  -- substitution incrementally in the `go` loop.
  --
  -- lintApp is used:
@@ -2158,7 +2109,7 @@ lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc
           ; let init_subst = mkEmptySubst in_scope
 -               go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc)
 +               go :: Subst -> Type -> acc -> [a] -> LintM (Type, acc)
                       -- The Subst applies (only) to the fun_ty
                       -- c.f. GHC.Core.Type.piResultTys, which has a similar loop
@@ -2202,7 +2153,7 @@ lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc
  -- explicitly and don't capture them as free variables. Otherwise this binder might
  -- become a thunk that get's allocated in the hot code path.
  -- See Note [Avoiding compiler perf traps when constructing error messages.]
 -lint_app_fail_msg :: (Outputable a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc
 +lint_app_fail_msg :: (Outputable a2) => SDoc -> Type -> a2 -> SDoc -> SDoc
  lint_app_fail_msg msg kfn arg_tys extra
    = vcat [ hang (text "Application error in") 2 msg
           , nest 2 (text "Function type =" <+> ppr kfn)
@@ -2215,7 +2166,7 @@ lint_app_fail_msg msg kfn arg_tys extra
  *                                                                      *
  ********************************************************************* -}
 -lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM ()
 +lintCoreRule :: OutVar -> Type -> CoreRule -> LintM ()
  lintCoreRule _ _ (BuiltinRule {})
    = return ()  -- Don't bother
@@ -2223,7 +2174,7 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
                                     , ru_args = args, ru_rhs = rhs })
    = noMultiplicityChecks $ -- Skip linearity checking for rules
                             -- See Note [Linting linearity]
 -    lintBinders LambdaBind bndrs $ \ _ ->
 +    lintBinders LambdaBind bndrs $
      do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args
         ; (rhs_ty, _) <- case idJoinPointHood fun of
                       JoinPoint join_arity
@@ -2311,10 +2262,10 @@ Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further
  {- Note [Asymptotic efficiency]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -When linting coercions (and types actually) we return a linted
 -(substituted) coercion.  Then we often have to take the coercionKind of
 -that returned coercion. If we get long chains, that can be asymptotically
 -inefficient, notably in
 +When linting coercions we traverse the coercion. Then we often have to take the
 +coercionKind of that returned coercion. If we get long chains, that can be
 +asymptotically inefficient, notably in
++
  * TransCo
  * InstCo
  * SelCo (cf #9233)
@@ -2326,30 +2277,23 @@ the bad perf bites us in practice.
  A solution would be to return the kind and role of the coercion,
  as well as the linted coercion.  Or perhaps even *only* the kind and role,
  which is what used to happen.   But that proved tricky and error prone
 -(#17923), so now we return the coercion.
 +(#17923).
  -}
  -- lintStarCoercion lints a coercion, confirming that its lh kind and
  -- its rh kind are both *; also ensures that the role is Nominal
  -- Returns the lh kind
 -lintStarCoercion :: InCoercion -> LintM OutType
 +lintStarCoercion :: Coercion -> LintM Type
  lintStarCoercion g
    = do { lintCoercion g
 -       ; Pair t1 t2 <- substCoKindM g
 +       ; let Pair t1 t2 = coercionKind g
         ; checkValueType (typeKind t1) (text "the kind of the left type in" <+> ppr g)
         ; checkValueType (typeKind t2) (text "the kind of the right type in" <+> ppr g)
         ; lintRole g Nominal (coercionRole g)
         ; return t1 }
 -substCoKindM :: InCoercion -> LintM (Pair OutType)
 -substCoKindM co
 -  = do { let !(Pair lk rk) = coercionKind co
 -       ; lk' <- substTyM lk
 -       ; rk' <- substTyM rk
 -       ; return (Pair lk' rk') }
+-
 -lintCoercion :: HasDebugCallStack => InCoercion -> LintM ()
 +lintCoercion :: HasDebugCallStack => Coercion -> LintM ()
  -- See Note [Linting types and coercions]
  --
  -- If you edit this function, you may need to update the GHC formalism
@@ -2361,7 +2305,7 @@ lintCoercion (CoVarCo cv)
 (text "With offending type:" <+> ppr (varType cv)))
    | otherwise  -- C.f. lintType (TyVarTy tv), which has better docs
 -  = do { _ <- lintVarOcc cv; return () }
 +  = lintVarOcc cv
  lintCoercion (Refl ty)          = lintType ty
  lintCoercion (GRefl _r ty MRefl) = lintType ty
@@ -2369,8 +2313,8 @@ lintCoercion (GRefl _r ty MRefl) = lintType ty
  lintCoercion (GRefl _r ty (MCo co))
    = do { lintType ty
         ; lintCoercion co
 -       ; tk <- substTyM (typeKind ty)
 -       ; tl <- substTyM (coercionLKind co)
 +       ; let tk = typeKind ty
 +             tl = coercionLKind co
         ; ensureEqTys tk tl $
           hang (text "GRefl coercion kind mis-match:" <+> ppr co)
 (vcat [ppr ty, ppr tk, ppr tl])
@@ -2403,8 +2347,8 @@ lintCoercion co@(AppCo co1 co2)
    = do { lintCoercion co1
         ; lintCoercion co2
         ; let !(Pair lt1 rt1) = coercionKind co1
 -       ; lk1 <- substTyM (typeKind lt1)
 -       ; rk1 <- substTyM (typeKind rt1)
 +             lk1 = typeKind lt1
 +             rk1 = typeKind rt1
         ; lint_co_app co lk1 [coercionLKind co2]
         ; lint_co_app co rk1 [coercionRKind co2]
@@ -2421,7 +2365,7 @@ lintCoercion co@(ForAllCo {})
    = do { _ <- go [] co; return () }
    where
      go :: [OutTyCoVar]   -- Binders in reverse order
 -       -> InCoercion -> LintM Role
 +       -> Coercion -> LintM Role
      go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
                           , fco_kind = kind_mco, fco_body = body_co })
        | not (isTyCoVar tcv)
@@ -2431,15 +2375,15 @@ lintCoercion co@(ForAllCo {})
        = do { mb_lk <- case kind_mco of
                       MRefl -> return Nothing
                       MCo kind_co -> Just <$> lintStarCoercion kind_co
 -           ; lintTyCoBndr tcv $ \tcv' ->
 +           ; lintTyCoBndr tcv $
          do { case mb_lk of
                  Nothing -> return ()
 -                Just lk -> ensureEqTys (varType tcv') lk $
 +                Just lk -> ensureEqTys (varType tcv) lk $
                             text "Kind mis-match in ForallCo" <+> ppr co
             -- I'm not very sure about this part, because it traverses body_co
             -- but at least it's on a cold path (a ForallCo for a CoVar)
 -           -- Also it works on InTyCoVar and InCoercion, which is suspect
 +           -- Also it works on InTyCoVar and Coercion, which is suspect
             ; when (isCoVar tcv) $
               do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $
                    text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co
@@ -2448,7 +2392,7 @@ lintCoercion co@(ForAllCo {})
                    text "Covar can only appear in Refl and GRefl: " <+> ppr co }
                    -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep
 -           ; role <- go (tcv':tcvs) body_co
 +           ; role <- go (tcv:tcvs) body_co
             ; when (role == Nominal) $
               lintL (visL `eqForAllVis` visR) $
@@ -2505,8 +2449,8 @@ lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov
         -- Check the to and from types
         ; lintType ty1
         ; lintType ty2
 -       ; tk1 <- substTyM (typeKind ty1)
 -       ; tk2 <- substTyM (typeKind ty2)
 +       ; let tk1 = typeKind ty1
 +             tk2 = typeKind ty2
         ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2)
                (checkTypes ty1 ty2)
@@ -2560,8 +2504,8 @@ lintCoercion (SymCo co) = lintCoercion co
  lintCoercion co@(TransCo co1 co2)
    = do { lintCoercion co1
         ; lintCoercion co2
 -       ; rk1 <- substTyM (coercionRKind co1)
 -       ; lk2 <- substTyM (coercionLKind co2)
 +       ; let rk1 = coercionRKind co1
 +             lk2 = coercionLKind co2
         ; ensureEqTys rk1 lk2
                 (hang (text "Trans coercion mis-match:" <+> ppr co)
 (vcat [ppr (coercionKind co1), ppr (coercionKind co2)]))
@@ -2569,7 +2513,7 @@ lintCoercion co@(TransCo co1 co2)
  lintCoercion the_co@(SelCo cs co)
    = do { lintCoercion co
 -       ; Pair s t <- substCoKindM co
 +       ; let Pair s t = coercionKind co
         ; if -- forall (both TyVar and CoVar)
              | Just _ <- splitForAllTyCoVar_maybe s
@@ -2604,7 +2548,7 @@ lintCoercion the_co@(SelCo cs co)
  lintCoercion the_co@(LRCo _lr co)
    = do { lintCoercion co
 -       ; Pair s t <- substCoKindM co
 +       ; let Pair s t = coercionKind co
         ; lintRole co Nominal (coercionRole co)
         ; case (splitAppTy_maybe s, splitAppTy_maybe t) of
             (Just {}, Just {}) -> return ()
@@ -2618,14 +2562,12 @@ lintCoercion orig_co@(InstCo co arg)
      go (InstCo co arg) args = do { lintCoercion arg; go co (arg:args) }
      go co              args = do { lintCoercion co
                                   ; let Pair lty rty = coercionKind co
 -                                 ; lty' <- substTyM lty
 -                                 ; rty' <- substTyM rty
                                   ; in_scope <- getInScope
                                   ; let subst = mkEmptySubst in_scope
 -                                 ; go_args (subst, lty') (subst,rty') args }
 +                                 ; go_args (subst, lty) (subst,rty) args }
      -------------
 -    go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion]
 +    go_args :: (Subst, Type) -> (Subst,Type) -> [Coercion]
             -> LintM ()
      go_args _ _ []
        = return ()
@@ -2634,11 +2576,11 @@ lintCoercion orig_co@(InstCo co arg)
             ; go_args lty1 rty1 args }
      -------------
 -    go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion
 -           -> LintM ((Subst,OutType), (Subst,OutType))
 +    go_arg :: (Subst, Type) -> (Subst,Type) -> Coercion
 +           -> LintM ((Subst,Type), (Subst,Type))
      go_arg (lsubst,lty) (rsubst,rty) arg
        = do { lintRole arg Nominal (coercionRole arg)
 -           ; Pair arg_lty arg_rty <- substCoKindM arg
 +           ; let Pair arg_lty arg_rty = coercionKind arg
             ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of
                -- forall over tvar
@@ -2662,11 +2604,11 @@ lintCoercion orig_co@(InstCo co arg)
  lintCoercion this_co@(AxiomCo ax cos)
    = do { mapM_ lintCoercion cos
         ; lint_roles 0 (coAxiomRuleArgRoles ax) cos
 -       ; prs <- mapM substCoKindM cos
 +       ; let prs = map coercionKind cos
         ; lint_ax ax prs }
    where
 -    lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM ()
 +    lint_ax :: CoAxiomRule -> [Pair Type] -> LintM ()
      lint_ax (BuiltInFamRew  bif) prs
        = checkL (isJust (bifrw_proves bif prs))  bad_bif
      lint_ax (BuiltInFamInj bif) prs
@@ -2754,8 +2696,8 @@ lintBranch this_co fam_tc branch arg_kinds
    = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $
                  (bad_ax this_co (text "lengths"))
 -       ; subst <- getSubst
 -       ; let empty_subst = zapSubst subst
 +       ; in_scope <- getInScope
 +       ; let empty_subst = mkEmptySubst in_scope
         ; _ <- foldlM check_ki (empty_subst, empty_subst)
                                (zip (ktvs ++ cvs) arg_kinds)
@@ -2880,12 +2822,12 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
  lint_branch :: TyCon -> CoAxBranch -> LintM ()
  lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
                                , cab_lhs = lhs_args, cab_rhs = rhs })
 -  = lintBinders LambdaBind (tvs ++ cvs) $ \_ ->
 +  = lintBinders LambdaBind (tvs ++ cvs) $
      do { let lhs = mkTyConApp ax_tc lhs_args
         ; lintType lhs
         ; lintType rhs
 -       ; lhs_kind <- substTyM (typeKind lhs)
 -       ; rhs_kind <- substTyM (typeKind rhs)
 +       ; let lhs_kind = typeKind lhs
 +             rhs_kind = typeKind rhs
         ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $
           hang (text "Inhomogeneous axiom")
 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$
@@ -2969,35 +2911,26 @@ type LintLevel = Int
  -- If you edit this type, you may need to update the GHC formalism
  -- See Note [GHC Formalism]
  data LintEnv
 -  = LE { le_flags :: LintFlags       -- Linting the result of this pass
 -       , le_loc   :: [LintLocInfo]   -- Locations
+-
 -       , le_subst :: Subst
 -                  -- Current substitution, for TyCoVars only.
 -                  -- Non-CoVar Ids don't appear in here, not even in the InScopeSet
 -                  -- Used for (a) cloning to avoid shadowing of TyCoVars,
 -                  --              so that eqType works ok
 -                  --          (b) substituting for let-bound tyvars, when we have
 -                  --              (let @a = Int -> Int in ...)
+-
 -       , le_level   :: LintLevel
 -       , le_in_vars :: VarEnv (InVar, OutType, LintLevel)
 -                    -- Maps an InVar (i.e. its unique) to its binding InVar
 -                    --    and to its OutType
 -                    -- /All/ in-scope variables are here (term variables,
 -                    --    type variables, and coercion variables)
 -                    -- Used at an occurrence of the InVar
 +  = LE { le_flags    :: LintFlags       -- Linting the result of this pass
 +       , le_loc      :: [LintLocInfo]   -- Locations
 +       , le_level    :: LintLevel
 +       , le_in_scope :: InScopeSet
++
 +       , le_vars     :: VarEnv (Var, LintLevel)
 +                     -- Maps a Var (i.e. its unique) to its binding Var and level
 +                     -- /All/ in-scope variables are here (term variables,
 +                     --    type variables, and coercion variables)
 +                     -- So the domain is the same as the le_in_scope in-scope set
 +                     -- Used at an occurrence of the Var
         , le_joins :: UniqMap Id JoinOcc
             -- ^ Join points in scope that are valid
 -           -- A subset of the InScopeSet in le_subst
             -- See Note [Join points]
         , le_ue_aliases :: NameEnv UsageEnv
               -- See Note [Linting linearity]
               -- Assigns usage environments to the alias-like binders,
               -- as found in non-recursive lets.
 -             -- Domain is OutIds
         , le_platform   :: Platform         -- ^ Target platform
         , le_diagOpts   :: DiagOpts         -- ^ Target platform
@@ -3011,7 +2944,8 @@ data LintFlags
         , lf_check_linearity :: Bool    -- ^ See Note [Linting linearity]
         , lf_check_fixed_rep :: Bool    -- ^ See Note [Checking for representation polymorphism]
         , lf_check_rubbish_lits :: Bool -- ^ See Note [Checking for rubbish literals]
 -       , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks]
 +       , lf_allow_weak_joins :: Bool   -- ^ See Note [Linting join points with casts or ticks]
 +       , lf_allow_beta_joins :: Bool   -- ^ See Note [Join points and beta-redexes]
+     }
  -- See Note [Checking StaticPtrs]
@@ -3078,20 +3012,6 @@ top-level bindings. See SimplCore Note [Grand plan for static forms].
  The linter checks that no occurrence or `makeStatic` occurs nested.
 -Note [Type substitution]
 -~~~~~~~~~~~~~~~~~~~~~~~~
 -Why do we need a type substitution?  Consider
 -        /\(a:*). \(x:a). /\(a:*). id a x
 -This is ill typed, because (renaming variables) it is really
 -        /\(a:*). \(x:a). /\(b:*). id b x
 -Hence, when checking an application, we can't naively compare x's type
 -(at its binding site) with its expected type (at a use site).  So we
 -rename type binders as we go, maintaining a substitution.
+-
 -The same substitution also supports let-type, current expressed as
 -        (/\(a:*). body) ty
 -Here we substitute 'ty' for 'a' in 'body', on the fly.
+-
  Note [Linting type synonym applications]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  When linting a type-synonym, or type-family, application
@@ -3353,12 +3273,12 @@ initL cfg m
    where
      vars = l_vars cfg
      init_level = 0
 -    env = LE { le_flags   = l_flags cfg
 -             , le_subst   = mkEmptySubst (mkInScopeSetList vars)
 -             , le_level   = init_level
 -             , le_in_vars = mkVarEnv [ (v,(v, varType v, init_level)) | v <- vars ]
 -             , le_joins   = emptyUniqMap
 -             , le_loc     = []
 +    env = LE { le_flags    = l_flags cfg
 +             , le_level    = init_level
 +             , le_vars     = mkVarEnv [ (v,(v, init_level)) | v <- vars ]
 +             , le_in_scope = mkInScopeSetList vars
 +             , le_joins    = emptyUniqMap
 +             , le_loc      = []
               , le_ue_aliases = emptyNameEnv
               , le_platform = l_platform cfg
               , le_diagOpts = l_diagOpts cfg
@@ -3421,8 +3341,7 @@ addMsg show_context env msgs msg
     loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first
     loc_msgs = map dumpLoc (le_loc env)
 -   cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs
 -                  , text "Substitution:" <+> ppr (le_subst env) ]
 +   cxt_doc = vcat $ reverse $ map snd loc_msgs
     context | show_context  = cxt_doc
             | otherwise     = whenPprDebug cxt_doc
@@ -3449,72 +3368,44 @@ inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs
      is_case_pat (LE { le_loc = CasePat {} : _ }) = True
      is_case_pat _other                           = False
 -addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a
 +addInScopeId :: Id -> LintM a -> LintM a
  -- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned
 -addInScopeId in_id out_ty thing_inside
 +addInScopeId id thing_inside
    = LintM $ \ env errs ->
 -    let !(out_id, env') = add env
 -    in unLintM (thing_inside out_id) env' errs
+-
 +    unLintM thing_inside (add env) errs
    where
 -    add env@(LE { le_level = level, le_in_vars = id_vars, le_joins = valid_joins
 -                , le_ue_aliases = aliases, le_subst = subst })
 -      = (out_id, env1)
 +    add env@(LE { le_level = level, le_vars = id_vars, le_joins = valid_joins
 +                , le_ue_aliases = aliases, le_in_scope = in_scope })
 +      = env { le_level = level1, le_vars = in_vars'
 +            , le_in_scope = in_scope `extendInScopeSet` id
 +            , le_joins = valid_joins', le_ue_aliases = aliases' }
        where
          level1 = level + 1
 -        env1 = env { le_level = level1, le_in_vars = in_vars'
 -                   , le_joins = valid_joins', le_ue_aliases = aliases' }
 -        in_vars' = extendVarEnv id_vars in_id (in_id, out_ty, level1)
 -        aliases' = delFromNameEnv aliases (idName in_id)
 +        in_vars' = extendVarEnv id_vars id (id, level1)
 +        aliases' = delFromNameEnv aliases (idName id)
             -- aliases': when shadowing an alias, we need to make sure the
             -- Id is no longer classified as such. E.g.
             --   let x = <e1> in case x of x { _DEFAULT -> <e2> }
             -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1.
 -        -- A very tiny optimisation, not sure if it's really worth it
 -        -- Short-cut when the substitution is a no-op
 -        out_id | isEmptyTCvSubst subst = in_id
 -               | otherwise             = setIdType in_id out_ty
+-
          valid_joins'
 -          | isJoinId out_id = addToUniqMap   valid_joins in_id NormalJoinOcc -- Overwrite with new arity
 -          | otherwise       = delFromUniqMap valid_joins in_id -- Remove any existing binding
 +          | isJoinId id = addToUniqMap   valid_joins id NormalJoinOcc -- Overwrite with new arity
 +          | otherwise   = delFromUniqMap valid_joins id -- Remove any existing binding
 -addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a
 +addInScopeTyCoVar :: TyCoVar -> LintM a -> LintM a
  -- This function clones to avoid shadowing of TyCoVars
 -addInScopeTyCoVar tcv tcv_type thing_inside
 -  = LintM $ \ env@(LE { le_level = level, le_in_vars = in_vars, le_subst = subst }) errs ->
 -    let (tcv', subst') = subst_bndr subst
 -        level' = level + 1
 +addInScopeTyCoVar tcv thing_inside
 +  = LintM $ \ env@(LE { le_level = level, le_vars = in_vars
 +                      , le_in_scope = in_scope }) errs ->
 +    let level' = level + 1
          env' = env { le_level = level'
 -                   , le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type, level')
 -                   , le_subst = subst' }
 -    in unLintM (thing_inside tcv') env' errs
 -  where
 -    subst_bndr subst
 -      | isEmptyTCvSubst subst                -- No change in kind
 -      , not (tcv `elemInScopeSet` in_scope)  -- Not already in scope
 -      = -- Do not extend the substitution, just the in-scope set
 -        (if (varType tcv `eqType` tcv_type) then (\x->x) else
 -          pprTrace "addInScopeTyCoVar" (
 -            vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv)
 -                 , text "tcv_type" <+> ppr tcv_type ])) $
 -        (tcv, subst `extendSubstInScope` tcv)
+-
 -      -- Clone, and extend the substitution
 -      | let tcv' = uniqAway in_scope (setVarType tcv tcv_type)
 -      = (tcv', extendTCvSubstWithClone subst tcv tcv')
 -      where
 -        in_scope = substInScopeSet subst
+-
 -getInVarEnv :: LintM (VarEnv (InId, OutType, LintLevel))
 -getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs))
 +                   , le_in_scope = in_scope `extendInScopeSet` tcv
 +                   , le_vars = extendVarEnv in_vars tcv (tcv, level') }
 +    in unLintM thing_inside env' errs
 -extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a
 -extendTvSubstL tv ty m
 -  = LintM $ \ env errs ->
 -    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs
 +getInVarEnv :: LintM (VarEnv (Id, LintLevel))
 +getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_vars env), errs))
  markAllJoinsBad :: LintM a -> LintM a
  markAllJoinsBad m
@@ -3549,54 +3440,42 @@ markAllJoinsBadIf False m = m
  getValidJoins :: LintM (UniqMap Id JoinOcc)
  getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))
 -getSubst :: LintM Subst
 -getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs))
+-
 -substTyM :: InType -> LintM OutType
 --- Apply the substitution to the type
 --- The substitution is often empty, in which case it is a no-op
 -substTyM ty
 -  = do { subst <- getSubst
 -       ; return (substTy subst ty) }
+-
  getUEAliases :: LintM (NameEnv UsageEnv)
  getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs))
  getInScope :: LintM InScopeSet
 -getInScope = LintM (\ env errs -> fromBoxedLResult (Just (substInScopeSet $ le_subst env), errs))
 +getInScope = LintM (\ env errs -> fromBoxedLResult (Just (le_in_scope env), errs))
 -lintVarOcc :: InVar -> LintM OutType
 +lintVarOcc :: Var -> LintM ()
  -- Used at an occurrence of a variable: term variables, type variables, and coercion variables
  -- Checks
  --   - that it is in scope
  --   - that it is not a GlobalId bound by a LocalId
 ---   - that the InType at the ocurrence matches the InType at the binding site
 +--   - that the Type at the ocurrence matches the Type at the binding site
  --   - that the variables free in its type are not shadowed at the occurrence site
  lintVarOcc v_occ
    | isGlobalId v_occ
 -  = return (idType v_occ)
 +  = return ()
    | otherwise
    = do { in_var_env <- getInVarEnv
         ; case lookupVarEnv in_var_env v_occ of
             Nothing -> failWithL (text pp_what <+> quotes (ppr v_occ)
                                   <+> text "is out of scope")
 -           Just (v_bndr, out_ty, bind_level)
 +           Just (v_bndr, bind_level)
               -> do { let bndr_ty = idType v_bndr
                     ; check_bad_global v_bndr
                     ; check_occ_type_match bndr_ty
 -                   ; check_occ_type_scope in_var_env bndr_ty bind_level
 -                   ; return out_ty }
+-
 +                   ; check_occ_type_scope in_var_env bndr_ty bind_level }
+     }
    where
 -    occ_ty :: InType
 +    occ_ty :: Type
      occ_ty = idType v_occ
      pp_what | isTyVar v_occ = "The type variable"
              | isCoVar v_occ = "The coercion variable"
              | otherwise     = "The value variable"
 -    check_bad_global :: InVar -> LintM ()
 +    check_bad_global :: Var -> LintM ()
      -- 'check_bad_global' checks for the case where an /occurrence/ is
      -- a GlobalId, but there is an enclosing binding for a LocalId.
      -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,
@@ -3616,26 +3495,26 @@ lintVarOcc v_occ
        | otherwise
        = return ()
 -    check_occ_type_match :: InType -> LintM ()
 +    check_occ_type_match :: Type -> LintM ()
      -- Check that the type in /binder/ and the type in the /occurrence/ are the same
      check_occ_type_match bndr_ty
 -      = ensureEqTys bndr_ty occ_ty $  -- Compares InTypes
 +      = ensureEqTys bndr_ty occ_ty $  -- Compares Types
          mkBndrOccTypeMismatchMsg v_occ bndr_ty occ_ty
 -    check_occ_type_scope :: VarEnv (InVar,OutType,LintLevel) -> InType -> LintLevel -> LintM ()
 +    check_occ_type_scope :: VarEnv (Var,LintLevel) -> Type -> LintLevel -> LintM ()
      -- Check that the free vars of the binder's type
      -- are not shadowed at the occurrence site
      check_occ_type_scope in_var_env bndr_ty bind_level
        = checkL (null bad_fvs) $
          mkBndrOccFreeVarMsg v_occ occ_ty bad_fvs
        where
 -        bad_fvs :: [InVar]
 +        bad_fvs :: [Var]
          bad_fvs = filter is_bad (tyCoVarsOfTypeList bndr_ty)
 -        is_bad :: InVar -> Bool
 +        is_bad :: Var -> Bool
          -- True of a variable bound inside bind_level
          is_bad v = case lookupVarEnv in_var_env v of
 -                      Just (_, _, v_level) -> v_level > bind_level
 +                      Just (_, v_level) -> v_level > bind_level
                        Nothing -> True
  lookupJoinId :: Id -> LintM (Maybe (JoinArity, JoinOcc))
@@ -3647,21 +3526,21 @@ lookupJoinId id
              Just join_occ -> return $ Just (idJoinArity id, join_occ)
              Nothing       -> return Nothing }
 -addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a
 +addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a
  addAliasUE id ue thing_inside = LintM $ \ env errs ->
    let new_ue_aliases =
          extendNameEnv (le_ue_aliases env) (getName id) ue
    in
      unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs
 -varCallSiteUsage :: OutId -> LintM UsageEnv
 +varCallSiteUsage :: Id -> LintM UsageEnv
  varCallSiteUsage id =
    do m <- getUEAliases
       return $ case lookupNameEnv m (getName id) of
           Nothing    -> singleUsageUE id
           Just id_ue -> id_ue
 -ensureEqTys :: OutType -> OutType -> SDoc -> LintM ()
 +ensureEqTys :: Type -> Type -> SDoc -> LintM ()
  -- check ty2 is subtype of ty1 (ie, has same structure but usage
  -- annotations need only be consistent, not equal)
  -- Assumes ty1,ty2 are have already had the substitution applied
@@ -3885,7 +3764,7 @@ mkLetErr bndr rhs
            hang (text "Rhs:")
 (ppr rhs)]
 -mkTyAppMsg :: OutType -> Type -> SDoc
 +mkTyAppMsg :: Type -> Type -> SDoc
  mkTyAppMsg ty arg_ty
    = vcat [text "Illegal type application:",
                hang (text "Function type:")
@@ -4006,13 +3885,13 @@ mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ
           , text "Arity at binding site:" <+> ppr join_arity_bndr
           , text "Arity at occurrence:  " <+> ppr join_arity_occ ]
 -mkBndrOccTypeMismatchMsg :: InVar -> InType -> InType -> SDoc
 +mkBndrOccTypeMismatchMsg :: Var -> Type -> Type -> SDoc
  mkBndrOccTypeMismatchMsg var bndr_ty occ_ty
    = vcat [ text "Mismatch in type between binder and occurrence"
           , text "Binder:    " <+> ppr var <+> dcolon <+> ppr bndr_ty
           , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ]
 -mkBndrOccFreeVarMsg :: InVar -> InType -> [TyCoVar] -> SDoc
 +mkBndrOccFreeVarMsg :: Var -> Type -> [TyCoVar] -> SDoc
  mkBndrOccFreeVarMsg var occ_ty bad_tvs
    = vcat [ text "Free vars of type are shadowed:" <+> ppr bad_tvs
           , text "Occurrence:"  <+> ppr var <+> dcolon <+> ppr occ_ty ]

compiler/GHC/Core/Lint/SubstTypeLets.hs

 +{-
 +(c) The University of Glasgow 2006
 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 +-}
++
 +module GHC.Core.Lint.SubstTypeLets(
 +         substTypeLets
 +     ) where
++
 +import GHC.Prelude
++
 +import GHC.Core
 +import GHC.Core.Subst
 +import GHC.Core.Utils( mkInScopeSetBndrs )
++
 +import GHC.Types.Var
++
 +import GHC.Utils.Misc( mapSnd )
 +import GHC.Utils.Outputable
 +import GHC.Utils.Panic
++
 +{- Note [Substituting type-lets]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +When desugaring pattern matching we really, really need non-Lint-acceptable type-lets.
 +Suppose we have
 +   f (MkT a (Just a (x::a)) (y::a)) = rhs1
 +   f (MkT b (Nothing b) (z::b)) = rhs2
 +where
 +   MkT :: ∀ a. Maybe a -> a -> T
++
 +We desugar this to
 +  f x = case x of
 +          MkT w (v :: Maybe w) (p:w)
 +              ->  let { a=w, b=w }
 +                  in let { y:a=p, z:b=p }
 +                  in case v of
 +                      Just a (x:a) -> rhs1 [y::a]
 +                      Nothing b    -> rhs2 [z::b]
++
 +Look at those type-lets { a=w, b=w }.  They make the type variables in the
 +/two/ separately-typechecked clauses for `f` line up with the /single/ pattern
 +match on `x`, which binds the type variable `w`.
++
 +Key point: the body of the let is only type-correct /after/ substituting
 +a:=w, b:=w.  Even the next let, { y:a=p } isn't type-correct without that
 +substitution, because (p:w).
++
 +So the `substTypeLets` pass does this:
 +  - It runs as part of Lint, as a pre-pass before the main Lint
 +  - It runs only when we are Linting the output of the desugarer
 +  - The result of substTypeLets is discarded after linting
++
 +When it finds a nested type-let
 +    let @a = ty in body
 +it substitutes a:=ty in `body`
++
 +Wrinkles
++
 +(STL1) It only substitutes /nested/ type-lets, not top level.
++
 +(STL2) You might think that we'd run it unconditionally, after desugaring.  But actually,
 +  the Simplifier (or SimpleOpt) will deal with these type-lets, so it is just Lint
 +  that we must placate.  We don't want to incur the cost of this pass except when
 +  we are Linting.
++
 +  TL;DR: we do substTypeLets as a pre-pass to the Lint pass that immediately follows
 +  desugaring. See `GHC.Core.lintPassResult`, and the `lpr_preSubst` field in
 +  `LintPassResultConfig`.
++
 +(STL3) Should `substTypeLets` process (stable) unfoldings? It does not need to
 +  because all unfoldings have `simpleOptExpr` applied to them, so the tricky
 +  type-lets will already be substituted.
++
 +  Of course we stil need to apply the current substitution, but that is done
 +  automatically by `substBndr`.
 +-}
++
 +substTypeLets :: CoreProgram -> CoreProgram
 +substTypeLets binds = map stl_top binds
 +  where
 +     stl_top (NonRec b r) = NonRec b (stlExpr empty_subst r)
 +     stl_top (Rec prs)    = Rec (mapSnd (stlExpr empty_subst) prs)
++
 +     empty_subst = mkEmptySubst $
 +                   mkInScopeSetBndrs binds
++
 +----------------------
 +stlBind :: Subst -> CoreBind -> (Subst, CoreBind)
 +stlBind subst (Rec prs)
 +  = assertPpr (not (any isTyVar bndrs)) (ppr prs) $
 +    (subst', Rec prs')
 +  where
 +    (bndrs,rhss) = unzip prs
 +    (subst', bndrs') = substRecBndrs subst bndrs
 +       -- substRecBndrs: see (STL3) in Note [Substituting type-lets]
 +    rhss' = map (stlExpr subst') rhss
 +    prs'  = bndrs' `zip` rhss'
++
 +stlBind subst (NonRec bndr rhs)
 +  = (subst', NonRec bndr' (stlExpr subst rhs))
 +  where
 +    (subst', bndr')  = substBndr subst bndr
 +      -- substBndr: see (STL3) in Note [Substituting type-lets]
++
 +----------------------
 +stlExpr :: Subst -> CoreExpr -> CoreExpr
++
 +stlExpr subst (Let (NonRec tv (Type ty)) body)
 +  = -- This equation is the main payload of the entire pass!
 +    stlExpr (extendTvSubst subst tv (substTy subst ty)) body
++
 +stlExpr subst (Let bind body)
 +  = Let bind' (stlExpr subst' body)
 +  where
 +    (subst', bind') = stlBind subst bind
++
 +stlExpr subst (Lam bndr body)
 +  = Lam bndr' (stlExpr subst' body)
 +  where
 +    (subst', bndr') = substBndr subst bndr
++
 +stlExpr subst (Case scrut bndr ty alts)
 +  = Case (stlExpr subst scrut) bndr' (substTy subst ty)
 +         (map stl_alt alts)
 +  where
 +    (subst', bndr') = substBndr subst bndr
++
 +    stl_alt (Alt con bndrs rhs)
 +       = Alt con bndrs' (stlExpr subst'' rhs)
 +       where
 +         (subst'', bndrs') = substBndrs subst' bndrs
++
 +-- Simple cases
 +stlExpr _     (Lit l)       = Lit l
 +stlExpr subst (Var v)       = lookupIdSubst subst v
 +stlExpr subst (App e1 e2)   = App (stlExpr subst e1) (stlExpr subst e2)
 +stlExpr subst (Type ty)     = Type (substTy subst ty)
 +stlExpr subst (Tick t e)    = Tick (substTickish subst t) (stlExpr subst e)
 +stlExpr subst (Cast e co)   = Cast (stlExpr subst e) (substCo subst co)
 +stlExpr subst (Coercion co) = Coercion (substCo subst co)

compiler/GHC/Core/Opt/OccurAnal.hs

@@ -2676,6 +2676,8 @@ occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr]
              -> WithUsageDetails CoreExpr
  -- The `fun` argument is just an accumulating parameter,
  -- the base for building the application we return
 +--
 +-- We have applied markAllNonTail to the returned usage-details
  occAnalArgs env fun args one_shots
    = go emptyDetails fun args one_shots
    where
@@ -2686,7 +2688,9 @@ occAnalArgs env fun args one_shots
      encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut
           | otherwise                               = OccVanilla
 -    go uds fun [] _ = WUD uds fun
 +    go uds fun [] _ = WUD (markAllNonTail uds) fun
 +       -- markAllNonTail: calls in arguments are not tail calls!
++
      go uds fun (arg:args) one_shots
        = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'
        where
@@ -2778,8 +2782,7 @@ occAnalApp env (Var fun_id, args, ticks)
      all_uds = fun_uds `andUDs` final_args_uds
 -    !final_args_uds = markAllNonTail                              $
 -                      markAllInsideLamIf (isRhsEnv env && is_exp) $
 +    !final_args_uds = markAllInsideLamIf (isRhsEnv env && is_exp) $
                          -- isRhsEnv: see Note [OccEncl]
                        args_uds
         -- We mark the free vars of the argument of a constructor or PAP
@@ -2809,20 +2812,27 @@ occAnalApp env (Var fun_id, args, ticks)
          -- See Note [Sources of one-shot information], bullet point A']
  occAnalApp env (fun, args, ticks)
 -  = let app_out = mkTicks ticks app'
 -    in WUD (markAllNonTail (fun_uds `andUDs` args_uds)) app_out
+-
 +  = WUD (fun_uds `andUDs` args_uds) (mkTicks ticks app')
    where
      !(WUD args_uds app') = occAnalArgs env fun' args []
 -    !(WUD fun_uds fun')  = occAnal (addAppCtxt env args) fun
 -        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier
 -        -- often leaves behind beta redexes like
 -        --      (\x y -> e) a1 a2
 -        -- Here we would like to mark x,y as one-shot, and treat the whole
 -        -- thing much like a let.  We do this by pushing some OneShotLam items
 -        -- onto the context stack.
 +    !(WUD fun_uds fun')  = go_fun env fun args
++
 +    -- See (A2) in Note [occAnal for applications]
 +    go_fun env (Lam bndr body) (_ : args)
 +      = addInScopeOne env bndr $ \ env' ->
 +        let !(WUD body_uds body') = go_fun env' body args
 +            !bndr' = tagLamBinder body_uds bndr
 +        in WUD body_uds (Lam bndr' body')
 +    go_fun env fun args
 +      | null args
 +      = occAnal env fun
 +      | otherwise
 +      = let !env' = addAppCtxt env args
 +            !(WUD fun_uds fun') = occAnal env' fun
 +        in WUD (markAllNonTail fun_uds) fun'
  addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
 +-- See (A3) in Note [occAnal for applications]
  addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
    | n_val_args > 0
    = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt
@@ -2834,8 +2844,40 @@ addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
    where
      n_val_args = valArgCount args
 +{- Note [occAnal for applications]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +One iteration of the simplifier sometimes leaves behind beta redexes like
 +     (\x y -> e) a1 a2
 +This happens particularly in worker/wrapper; see Note [Join points and beta-redexes]
 +in GHC.Core.Lint.  In these cases there are three things we want to take care of
 +in the occurrence analyser:
++
 +(A1) We don't want to mark variables inside `e` as `InsideLam`; that would just
 +  delay inlining them for another iteration of the Simplifier.
++
 +(A2) If there is a join-point invocation inside `e`, we don't want to complain about
 +  lost join points.  See Note [Join points and beta-redexes] in GHC.Core.Lint for
 +  more detail.
++
 +(A3) Suppose we have something like
 +     (case e of (a,b) -> (\x.blah) |> co) arg
 +  which can happen during 'gentle' simplification when we don't do case-of-case,
 +  not push arguments into cases.  Then we'd still like to mark that lambda
 +  as one-shot, so that things can get inlined inside it.  We can to this
 +  by pushing OneShotLam items onto the context stack.
++
 +  Live example: `read_tup4` in test CoOpt_Read.
++
 +How we address these:
++
 +* (A2): we focus narrowly on visible beta-redexes ((\x.e) arg), since that
 +  is what is needed for Note [Join points and beta-redexes].  We do this
 +  via the `go_fun` loop in `occAnalApp`.
++
 +* (A1) and (A3): for visible beta-redexes, the `go_fun` loop does the job.
 +  But for less-visible ones, like in (A3) we push `OneShotLam` items onto
 +  the context stack, in `addAppCtxt`.
 -{-
  Note [Sources of one-shot information]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  The occurrence analyser obtains one-shot-lambda information from two sources:

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

@@ -241,10 +241,10 @@ mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr
                  = (work_args, work_args, work_marks)
                call_work work_fn  = mkVarApps (Var work_fn) work_call_args
 -              call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args
 -                                  -- See Note [Join points and beta-redexes]
 +              call_rhs fn_rhs = mkApps fn_rhs fn_args
 +                   -- See Note [Join points and beta-redexes] in GHC.Core.Lint
                wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work
 -                                  -- See Note [Call-by-value for worker args]
 +                   -- See Note [Call-by-value for worker args]
                work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str)
                worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs
                worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v]
@@ -280,14 +280,6 @@ mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr
      arity_ok | isJoinId fun_id = ww_arity <= n_dmds
               | otherwise       = ww_arity == n_dmds
 --- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly.
 --- PRECONDITION: The arg expressions are not free in any of the lambdas binders.
 -mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr
 --- The precondition holds for our call site in mkWwBodies, because all the FVs
 --- of as are either cloned_arg_vars (and thus fresh) or fresh worker args.
 -mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as
 -mkAppsBeta f            as     = mkApps f as
+-
  -- See Note [Limit w/w arity]
  isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool
  isWorkerSmallEnough max_worker_args old_n_args vars
@@ -525,36 +517,6 @@ Solution is simple: put the void argument /last/:
  c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr
 -Note [Join points and beta-redexes]
 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -Originally, the worker would invoke the original function by calling it with
 -arguments, thus producing a beta-redex for the simplifier to munch away:
+-
 -  \x y z -> e => (\x y z -> e) wx wy wz
+-
 -Now that we have special rules about join points, however, this is Not Good if
 -the original function is itself a join point, as then it may contain invocations
 -of other join points:
+-
 -  join j1 x = ...
 -  join j2 y = if y == 0 then 0 else j1 y
+-
 -  =>
+-
 -  join j1 x = ...
 -  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy
 -  join j2 y = case y of I# y# -> jump $wj2 y#
+-
 -There can't be an intervening lambda between a join point's declaration and its
 -occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:
+-
 -  ...
 -  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y
 -  ...
+-
 -Hence we simply do the beta-reduction here. (This would be harder if we had to
 -worry about hygiene, but luckily wy is freshly generated.)
+-
  Note [Freshen WW arguments]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  When we do a worker/wrapper split, we must freshen the arg vars of the original

compiler/GHC/Core/Subst.hs

@@ -13,7 +13,8 @@ module GHC.Core.Subst (
          -- ** Substituting into expressions and related types
          deShadowBinds, substRuleInfo, substRulesForImportedIds,
 -        substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,
 +        substTy, substTyUnchecked, substCo,
 +        substExpr, substExprSC, substBind, substBindSC,
          substUnfolding, substUnfoldingSC,
          lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,
          substTickish, substDVarSet, substIdInfo,
@@ -42,8 +43,7 @@ import GHC.Core.FVs
  import GHC.Core.Seq
  import GHC.Core.Utils
 -        -- We are defining local versions
 -import GHC.Core.Type hiding ( substTy )
 +import GHC.Core.Type
  import GHC.Core.Coercion( mkCoVarCo, substCoVarBndr )
  import GHC.Core.TyCo.FVs

compiler/GHC/Driver/Config/Core/Lint.hs

  module GHC.Driver.Config.Core.Lint
    ( endPass
    , endPassHscEnvIO
 -  , lintCoreBindings
    , initEndPassConfig
    , initLintPassResultConfig
    , initLintConfig
@@ -50,16 +49,6 @@ endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules
             binds rules
+        }
 --- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
 -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
 -lintCoreBindings dflags coreToDo vars -- binds
 -  = lintCoreBindings' $ LintConfig
 -      { l_diagOpts = initDiagOpts dflags
 -      , l_platform = targetPlatform dflags
 -      , l_flags    = perPassFlags dflags coreToDo
 -      , l_vars     = vars
 -      }
+-
  initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig
  initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig
    { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags)
@@ -104,10 +93,17 @@ initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig
    { lpr_diagOpts      = initDiagOpts dflags
    , lpr_platform      = targetPlatform dflags
    , lpr_makeLintFlags = perPassFlags dflags pass
 -  , lpr_passPpr = ppr pass
 +  , lpr_passPpr       = ppr pass
 +  , lpr_preSubst      = doPreSubst pass
    , lpr_localsInScope = extra_vars
+   }
 +doPreSubst :: CoreToDo -> Bool
 +doPreSubst CoreDesugar = True   -- Output of desugarer, /before/ running any optimisation,
 +                                -- not even simpleOpt. See Note Note [Substituting type-lets]
 +                                -- in GHC.Core.SubstTypeLets
 +doPreSubst _           = False
++
  perPassFlags :: DynFlags -> CoreToDo -> LintFlags
  perPassFlags dflags pass
    = (defaultLintFlags dflags)
@@ -116,7 +112,8 @@ perPassFlags dflags pass
                 , lf_check_static_ptrs          = check_static_ptrs
                 , lf_check_linearity            = check_linearity
                 , lf_check_rubbish_lits         = check_rubbish
 -               , lf_allow_weak_joins           = allow_weak_joins }
 +               , lf_allow_weak_joins           = allow_weak_joins
 +               , lf_allow_beta_joins           = allow_beta_joins }
    where
      -- See Note [Checking for global Ids]
      check_globals = case pass of
@@ -158,6 +155,11 @@ perPassFlags dflags pass
                        CorePrep -> True
                        _        -> False
 +    -- See Note [Join points and beta-redexes] in GHC.Core.Lint
 +    allow_beta_joins = case pass of
 +                          CoreDoWorkerWrapper -> True
 +                          _                   -> False
++
  initLintConfig :: DynFlags -> [Var] -> LintConfig
  initLintConfig dflags vars =LintConfig
    { l_diagOpts = initDiagOpts dflags
@@ -175,4 +177,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False
                               , lf_check_fixed_rep = True
                               , lf_check_rubbish_lits = True
                               , lf_allow_weak_joins = False
 +                             , lf_allow_beta_joins = False
+                              }

compiler/GHC/Unit/State.hs

@@ -802,7 +802,7 @@ readUnitDatabase logger cfg conf_file = do
        if cache_exists
          then do
            debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename
 -          readPackageDbForGhc (OsPath.unsafeDecodeUtf filename)
 +          readPackageDbForGhc filename
          else do
            -- If there is no package.cache file, we check if the database is not
            -- empty by inspecting if the directory contains any .conf file. If it

compiler/ghc.cabal.in

@@ -361,6 +361,7 @@ Library
          GHC.Core.InstEnv
          GHC.Core.Lint
          GHC.Core.Lint.Interactive
 +        GHC.Core.Lint.SubstTypeLets
          GHC.Core.LateCC
          GHC.Core.LateCC.Types
          GHC.Core.LateCC.TopLevelBinds

libraries/base/tests/perf/all.T

@@ -5,15 +5,13 @@ setTestOpts(js_skip)
  # Check optimization of `elem`
  #--------------------------------------
 -elemCoreFilter = "sed -En '/^(is|fusion|noFusion)[A-Za-z]*($| )/,/^$/p'"
+-
  def elemCoreTest(test_name, module_name, opt):
      test(test_name,
           [only_ways(['normal']), extra_files([module_name + '.hs'])],
           multimod_compile_filter,
           [module_name,
            f'{opt} -ddump-simpl -dsuppress-all -dsuppress-uniques -dno-typeable-binds',
 -          elemCoreFilter])
 +          "sed -En '/^(is|fusion|noFusion)[A-Za-z]*($| )/,/^$/p'"])
  elemCoreTest('T17752_O1', 'T17752', '-O1')
  elemCoreTest('T17752_O2', 'T17752', '-O2')

libraries/ghc-boot/GHC/Unit/Database.hs

@@ -68,6 +68,8 @@ module GHC.Unit.Database
     -- * Misc
     , mkMungePathUrl
     , mungeUnitInfoPaths
 +   , writeFileAtomic
 +   , unsafeDecodeUtf
+    )
  where
@@ -86,18 +88,23 @@ import Data.Binary.Get as Bin
  import Data.List (intersperse)
  import Control.Exception as Exception
  import Control.Monad (when)
 -import System.FilePath as FilePath
 +import qualified System.FilePath as FilePath
  #if !defined(mingw32_HOST_OS)
  import Data.Bits ((.|.))
 -import System.Posix.Files
 +import System.Posix.Files.PosixString
  import System.Posix.Types (FileMode)
 +import System.OsString.Internal.Types (getOsString)
  #endif
  import System.IO
  import System.IO.Error
  import GHC.IO.Exception (IOErrorType(InappropriateType))
  import qualified GHC.Data.ShortText as ST
  import GHC.IO.Handle.Lock
 -import System.Directory
 +import GHC.Stack.Types (HasCallStack)
 +import System.OsPath
 +import qualified System.Directory.OsPath as OsPath
 +import qualified System.Directory.Internal as OsPath.Internal
 +import qualified System.File.OsPath as FileIO
  -- | @ghc-boot@'s UnitInfo, serialized to the database.
  type DbUnitInfo      = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule
@@ -314,13 +321,13 @@ data DbInstUnitId
  newtype PackageDbLock = PackageDbLock Handle
  -- | Acquire an exclusive lock related to package DB under given location.
 -lockPackageDb :: FilePath -> IO PackageDbLock
 +lockPackageDb :: OsPath -> IO PackageDbLock
  -- | Release the lock related to package DB.
  unlockPackageDb :: PackageDbLock -> IO ()
  -- | Acquire a lock of given type related to package DB under given location.
 -lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock
 +lockPackageDbWith :: LockMode -> OsPath -> IO PackageDbLock
  lockPackageDbWith mode file = do
    -- We are trying to open the lock file and then lock it. Thus the lock file
    -- needs to either exist or we need to be able to create it. Ideally we
@@ -350,10 +357,10 @@ lockPackageDbWith mode file = do
      (lockFileOpenIn ReadWriteMode)
      (const $ lockFileOpenIn ReadMode)
    where
 -    lock = file <.> "lock"
 +    lock = file <.> OsPath.Internal.os "lock"
      lockFileOpenIn io_mode = bracketOnError
 -      (openBinaryFile lock io_mode)
 +      (FileIO.openBinaryFile lock io_mode)
        hClose
        -- If file locking support is not available, ignore the error and proceed
        -- normally. Without it the only thing we lose on non-Windows platforms is
@@ -387,7 +394,7 @@ isDbOpenReadMode = \case
  -- | Read the part of the package DB that GHC is interested in.
  --
 -readPackageDbForGhc :: FilePath -> IO [DbUnitInfo]
 +readPackageDbForGhc :: OsPath -> IO [DbUnitInfo]
  readPackageDbForGhc file =
    decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
      (pkgs, DbOpenReadOnly) -> return pkgs
@@ -409,7 +416,7 @@ readPackageDbForGhc file =
  -- we additionally receive a PackageDbLock that represents a lock on the
  -- database, so that we can safely update it later.
  --
 -readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->
 +readPackageDbForGhcPkg :: Binary pkgs => OsPath -> DbOpenMode mode t ->
                            IO (pkgs, DbOpenMode mode PackageDbLock)
  readPackageDbForGhcPkg file mode =
      decodeFromFile file mode getDbForGhcPkg
@@ -425,7 +432,7 @@ readPackageDbForGhcPkg file mode =
  -- | Write the whole of the package DB, both parts.
  --
 -writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO ()
 +writePackageDb :: Binary pkgs => OsPath -> [DbUnitInfo] -> pkgs -> IO ()
  writePackageDb file ghcPkgs ghcPkgPart = do
    writeFileAtomic file (runPut putDbForGhcPkg)
  #if !defined(mingw32_HOST_OS)
@@ -446,10 +453,10 @@ writePackageDb file ghcPkgs ghcPkgPart = do
          ghcPart    = encode ghcPkgs
  #if !defined(mingw32_HOST_OS)
 -addFileMode :: FilePath -> FileMode -> IO ()
 +addFileMode :: OsPath -> FileMode -> IO ()
  addFileMode file m = do
 -  o <- fileMode <$> getFileStatus file
 -  setFileMode file (m .|. o)
 +  o <- fileMode <$> getFileStatus (getOsString file)
 +  setFileMode (getOsString file) (m .|. o)
  #endif
  getHeader :: Get (Word32, Word32)
@@ -496,7 +503,7 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0"
  -- | Feed a 'Get' decoder with data chunks from a file.
  --
 -decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->
 +decodeFromFile :: OsPath -> DbOpenMode mode t -> Get pkgs ->
                    IO (pkgs, DbOpenMode mode PackageDbLock)
  decodeFromFile file mode decoder = case mode of
    DbOpenReadOnly -> do
@@ -517,7 +524,7 @@ decodeFromFile file mode decoder = case mode of
      bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do
        (, DbOpenReadWrite lock) <$> decodeFileContents
    where
 -    decodeFileContents = withBinaryFile file ReadMode $ \hnd ->
 +    decodeFileContents = FileIO.withBinaryFile file ReadMode $ \hnd ->
        feed hnd (runGetIncremental decoder)
      feed hnd (Partial k)  = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize
@@ -527,21 +534,21 @@ decodeFromFile file mode decoder = case mode of
      feed _ (Done _ _ res) = return res
      feed _ (Fail _ _ msg) = ioError err
        where
 -        err = mkIOError InappropriateType loc Nothing (Just file)
 +        err = mkIOError InappropriateType loc Nothing (Just $ unsafeDecodeUtf file)
                `ioeSetErrorString` msg
          loc = "GHC.Unit.Database.readPackageDb"
  -- Copied from Cabal's Distribution.Simple.Utils.
 -writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
 +writeFileAtomic :: OsPath -> BS.Lazy.ByteString -> IO ()
  writeFileAtomic targetPath content = do
    let (targetDir, targetFile) = splitFileName targetPath
    Exception.bracketOnError
 -    (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
 -    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
 +    (FileIO.openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> OsPath.Internal.os "tmp")
 +    (\(tmpPath, handle) -> hClose handle >> OsPath.removeFile tmpPath)
      (\(tmpPath, handle) -> do
          BS.Lazy.hPut handle content
          hClose handle
 -        renameFile tmpPath targetPath)
 +        OsPath.renameFile tmpPath targetPath)
  instance Binary DbUnitInfo where
    put (GenericUnitInfo
@@ -711,7 +718,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
      -- rather than letting FilePath change it to use \ as the separator
      stripVarPrefix var path = case ST.stripPrefix var path of
                                Just "" -> Just ""
 -                              Just cs | isPathSeparator (ST.head cs) -> Just cs
 +                              Just cs | FilePath.isPathSeparator (ST.head cs) -> Just cs
                                _ -> Nothing
@@ -742,3 +749,8 @@ mungeUnitInfoPaths top_dir pkgroot pkg =
        munge_paths = map munge_path
        munge_urls  = map munge_url
        (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot
++
 +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
 +-- Prefer 'decodeUtf' and gracious error handling.
 +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
 +unsafeDecodeUtf = OsPath.Internal.so

libraries/ghc-boot/ghc-boot.cabal.in

@@ -82,6 +82,8 @@ Library
                     containers >= 0.5 && < 0.9,
                     directory  >= 1.2 && < 1.4,
                     filepath   >= 1.3 && < 1.6,
 +                   file-io    >= 0.1.6 && < 0.3,
 +                   os-string  >= 2.0.1 && < 2.1,
                     deepseq    >= 1.4 && < 1.6,
                     ghc-platform  >= 0.1,
                     ghc-toolchain >= 0.1

testsuite/tests/cabal/Makefile

@@ -79,6 +79,25 @@ ghcpkg04 :
  	@: # testpkg-1.2.3.4 and newtestpkg-2.0 are both exposed now
  	'$(TEST_HC)' $(TEST_HC_OPTS) -package-db $(PKGCONF04) -c ghcpkg04.hs || true
 +PKGCONF20=local20.package.conf
 +LOCAL_GHC_PKG20 = '$(GHC_PKG)' --no-user-package-db
++
 +DIR1=asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf
 +DIR2=zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv
 +DIR3=uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop
 +DIR4=qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer
 +WDIR=$(DIR1)/$(DIR2)/$(DIR3)/$(DIR4)
 +.PHONY: ghcpkg10
 +ghcpkg10 :
 +	@mkdir -p $(WDIR)
 +	@rm -rf $(WDIR)/$(PKGCONF20)
 +	$(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) init $(WDIR)/$(PKGCONF20)
 +	$(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) list
 +	$(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) register --force test.pkg 2>/dev/null
 +	$(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg         | $(STRIP_PKGROOT)
 +	$(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg-1.2.3.4 | $(STRIP_PKGROOT)
 +	$(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) field testpkg-1.2.3.4 import-dirs
++
  # Test stacking of package.confs (also #2441)
  PKGCONF05a=local05a.package.conf
  PKGCONF05b=local05b.package.conf

testsuite/tests/cabal/all.T

@@ -5,6 +5,7 @@ def ignore_warnings(str):
      return re.sub(r'Warning:.*\n', '', str)
  test('ghcpkg01', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, [])
 +test('ghcpkg10', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, [])
  # Use ignore_stderr to prevent (when HADDOCK_DOCS=NO):
  #  warning: haddock-interfaces .. doesn't exist or isn't a file

testsuite/tests/cabal/ghcpkg10.stdout

 +asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf/zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv/uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop/qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer/local20.package.conf
 +    (no packages)
 +Reading package info from "test.pkg" ... done.
 +name:            testpkg
 +version:         1.2.3.4
 +visibility:      public
 +id:              testpkg-1.2.3.4-XXX
 +key:             testpkg-1.2.3.4-XXX
 +license:         BSD3
 +copyright:       (c) The Univsersity of Glasgow 2004
 +maintainer:      glasgow-haskell-users@haskell.org
 +author:          simonmar@microsoft.com
 +stability:       stable
 +homepage:        http://www.haskell.org/ghc
 +package-url:     http://www.haskell.org/ghc
 +description:     A Test Package
 +category:        none
 +exposed:         True
 +exposed-modules: A
 +hidden-modules:  B C.D
 +import-dirs:     /usr/local/lib/testpkg "c:/Program Files/testpkg"
 +library-dirs:    /usr/local/lib/testpkg "c:/Program Files/testpkg"
 +hs-libraries:    testpkg-1.2.3.4-XXX
 +include-dirs:    /usr/local/include/testpkg "c:/Program Files/testpkg"
 +pkgroot:
++
 +name:            testpkg
 +version:         1.2.3.4
 +visibility:      public
 +id:              testpkg-1.2.3.4-XXX
 +key:             testpkg-1.2.3.4-XXX
 +license:         BSD3
 +copyright:       (c) The Univsersity of Glasgow 2004
 +maintainer:      glasgow-haskell-users@haskell.org
 +author:          simonmar@microsoft.com
 +stability:       stable
 +homepage:        http://www.haskell.org/ghc
 +package-url:     http://www.haskell.org/ghc
 +description:     A Test Package
 +category:        none
 +exposed:         True
 +exposed-modules: A
 +hidden-modules:  B C.D
 +import-dirs:     /usr/local/lib/testpkg "c:/Program Files/testpkg"
 +library-dirs:    /usr/local/lib/testpkg "c:/Program Files/testpkg"
 +hs-libraries:    testpkg-1.2.3.4-XXX
 +include-dirs:    /usr/local/include/testpkg "c:/Program Files/testpkg"
 +pkgroot:
++
 +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg"

testsuite/tests/corelint/LintEtaExpand.stderr

  <no location info>: warning:
      • The first argument of ‘coerce’ does not have a fixed runtime representation:
          a :: TYPE k
 -    Substitution: <InScope = {a q}
 -                   IdSubst   = []
 -                   TvSubst   = []
 -                   CvSubst   = []>
  in coerce BAD 1
  <no location info>: warning:
      • The first argument of ‘coerce’ does not have a fixed runtime representation:
          ‘q’ is not concrete.
 -    Substitution: <InScope = {a q}
 -                   IdSubst   = []
 -                   TvSubst   = []
 -                   CvSubst   = []>
  in coerce BAD 2
  <no location info>: warning:
      • The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation:
          a :: TYPE q
 -    Substitution: <InScope = {a q}
 -                   IdSubst   = []
 -                   TvSubst   = []
 -                   CvSubst   = []>
  in catch# BAD 1
  <no location info>: warning:
      • The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation:
          ‘q’ is not concrete.
 -    Substitution: <InScope = {a q}
 -                   IdSubst   = []
 -                   TvSubst   = []
 -                   CvSubst   = []>
  in catch# BAD 2

testsuite/tests/corelint/T21115b.stderr

@@ -6,10 +6,6 @@ T21115b.hs:9:1: warning:
      In the body of lambda with binder ds :: Double#
      In the body of a let with binder fail :: (# #) -> Int#
      In the body of a let with binder fail :: (# #) -> Int#
 -    Substitution: <InScope = {}
 -                   IdSubst   = []
 -                   TvSubst   = []
 -                   CvSubst   = []>
  *** Offending Program ***
  Rec {
  $trModule = Module (TrNameS "main"#) (TrNameS "T21115b"#)

utils/ghc-pkg/Main.hs

@@ -47,12 +47,19 @@ import Distribution.Types.UnqualComponentName
  import Distribution.Types.LibraryName
  import Distribution.Types.MungedPackageName
  import Distribution.Types.MungedPackageId
 -import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File)
 +import Distribution.Simple.Utils (ignoreBOM, toUTF8BS, toUTF8LBS, fromUTF8LBS)
  import qualified Data.Version as Version
 -import System.FilePath as FilePath
 +import System.OsPath as OsPath
 +import qualified System.FilePath as FilePath
  import qualified System.FilePath.Posix as FilePath.Posix
 -import System.Directory ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory,
 -                          getModificationTime, XdgDirectory ( XdgData ) )
 +import System.Directory.OsPath
 +  ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory,
 +    getModificationTime, XdgDirectory ( XdgData ),
 +    doesDirectoryExist, getDirectoryContents,
 +    doesFileExist, removeFile,
 +    getCurrentDirectory )
 +import System.Directory.Internal (os)
 +import qualified System.File.OsPath as FileIO
  import Text.Printf
  import Prelude hiding (Foldable(..))
@@ -65,15 +72,13 @@ import Data.Bifunctor
  import Data.Char ( toLower )
  import Control.Monad
 -import System.Directory ( doesDirectoryExist, getDirectoryContents,
 -                          doesFileExist, removeFile,
 -                          getCurrentDirectory )
  import System.Exit ( exitWith, ExitCode(..) )
  import System.Environment ( getArgs, getProgName, getEnv )
  import System.IO
  import System.IO.Error
 -import GHC.IO           ( catchException )
 +import GHC.IO           ( catchException, unsafePerformIO )
  import GHC.IO.Exception (IOErrorType(InappropriateType))
 +import GHC.Stack.Types (HasCallStack)
  import Data.List ( group, sort, sortBy, nub, partition, find
                   , intercalate, intersperse, unfoldr
                   , isInfixOf, isSuffixOf, isPrefixOf, stripPrefix )
@@ -429,8 +434,9 @@ runit verbosity cli nonopts = do
          print filename
          glob filename >>= print
  #endif
 -    ["init", filename] ->
 -        initPackageDB filename verbosity cli
 +    ["init", filename] -> do
 +        filenameOs <- encodeFS filename
 +        initPackageDB filenameOs verbosity cli
      ["register", filename] ->
          registerPackage filename verbosity cli
                          multi_instance
@@ -538,7 +544,7 @@ readPackageArg AsDefault str = Id <$> readGlobPkgId str
  data PackageDB (mode :: GhcPkg.DbMode)
    = PackageDB {
 -      location, locationAbsolute :: !FilePath,
 +      location, locationAbsolute :: !OsPath,
        -- We need both possibly-relative and definitely-absolute package
        -- db locations. This is because the relative location is used as
        -- an identifier for the db, so it is important we do not modify it.
@@ -570,14 +576,14 @@ allPackagesInStack = concatMap packages
  -- specified package DB can depend on, since dependencies can only extend
  -- down the stack, not up (e.g. global packages cannot depend on user
  -- packages).
 -stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack
 +stackUpTo :: OsPath -> PackageDBStack -> PackageDBStack
  stackUpTo to_modify = dropWhile ((/= to_modify) . location)
 -readFromSettingsFile :: FilePath
 -                      -> (FilePath -> RawSettings -> Either String b)
 +readFromSettingsFile :: OsPath
 +                      -> (OsPath -> RawSettings -> Either String b)
                        -> IO (Either String b)
  readFromSettingsFile settingsFile f = do
 -  settingsStr <- readFile settingsFile
 +  settingsStr <- readUtf8File settingsFile
    pure $ do
      mySettings <- case maybeReadFuzzy settingsStr of
        Just s -> pure $ Map.fromList s
@@ -586,11 +592,11 @@ readFromSettingsFile settingsFile f = do
        Nothing -> Left $ "Can't parse settings file " ++ show settingsFile
      f settingsFile mySettings
 -readFromTargetFile :: FilePath
 +readFromTargetFile :: OsPath
                     -> (Target -> b)
                     -> IO (Either String b)
  readFromTargetFile targetFile f = do
 -  targetStr <- readFile targetFile
 +  targetStr <- readUtf8File targetFile
    pure $ do
      target <- case maybeReadFuzzy targetStr of
        Just t -> Right t
@@ -626,33 +632,35 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
       case [ f | FlagGlobalConfig f <- my_flags ] of
          -- See Note [Base Dir] for more information on the base dir / top dir.
          [] -> do mb_dir <- getBaseDir
 -                 case mb_dir of
 +                 mb_dir_os <- traverse encodeFS mb_dir
 +                 case mb_dir_os of
                     Nothing  -> die err_msg
                     Just dir -> do
                       -- Look for where it is given in the settings file, if marked there.
                       -- See Note [Settings file] about this file, and why we need GHC to share it with us.
 -                     let settingsFile = dir </> "settings"
 +                     let settingsFile = dir </> os "settings"
                       exists_settings_file <- doesFileExist settingsFile
                       erel_db <-
                        if exists_settings_file
 -                          then readFromSettingsFile settingsFile getGlobalPackageDb
 -                          else pure (Left ("Settings file doesn't exist: " ++ settingsFile))
 +                          then do
 +                            readFromSettingsFile settingsFile (\ settings  -> getGlobalPackageDb (unsafeDecodeUtf settings))
 +                          else pure (Left ("Settings file doesn't exist: " ++ showOsPath settingsFile))
                       case erel_db of
 -                      Right rel_db -> return (dir, dir </> rel_db)
 +                      Right rel_db -> return (dir, dir </> unsafeEncodeUtf rel_db)
                        -- If the version of GHC doesn't have this field or the settings file
                        -- doesn't exist for some reason, look in the libdir.
                        Left err -> do
                          r <- lookForPackageDBIn dir
                          case r of
 -                          Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ dir)])
 +                          Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ showOsPath dir)])
                            Just path -> return (dir, path)
          fs -> do
            -- The value of the $topdir variable used in some package descriptions
            -- Note that the way we calculate this is slightly different to how it
            -- is done in ghc itself. We rely on the convention that the global
            -- package db lives in ghc's libdir.
 -          let pkg_db = last fs
 +          let pkg_db = unsafeEncodeUtf $ last fs
            top_dir <- absolutePath (takeDirectory pkg_db)
            return (top_dir, pkg_db)
@@ -662,10 +670,10 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
    -- getXdgDirectory can fail (e.g. if $HOME isn't set)
    mb_user_conf <-
 -    case [ f | FlagUserConfig f <- my_flags ] of
 +    case [ unsafeEncodeUtf f | FlagUserConfig f <- my_flags ] of
        _ | no_user_db -> return Nothing
        [] -> do
 -        let targetFile = top_dir </> "targets" </> "default.target"
 +        let targetFile = top_dir </> os "targets" </> os "default.target"
          exists_settings_file <- doesFileExist targetFile
          targetArchOS <- case exists_settings_file of
            False -> do
@@ -694,15 +702,15 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
          -- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR
          --
          -- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version
 -        m_appdir <- getFirstSuccess $ map (fmap (</> subdir))
 -          [ getAppUserDataDirectory "ghc"  -- this is ~/.ghc/
 -          , getXdgDirectory XdgData "ghc"  -- this is $XDG_DATA_HOME/
 +        m_appdir <- getFirstSuccess $ map (fmap (</> unsafeEncodeUtf subdir))
 +          [ getAppUserDataDirectory $ os "ghc"  -- this is ~/.ghc/
 +          , getXdgDirectory XdgData $ os "ghc"  -- this is $XDG_DATA_HOME/
+           ]
          case m_appdir of
            Nothing -> return Nothing
            Just dir -> do
              lookForPackageDBIn dir >>= \case
 -              Nothing -> return (Just (dir </> "package.conf.d", False))
 +              Nothing -> return (Just (dir </> os "package.conf.d", False))
                Just f  -> return (Just (f, True))
        fs -> return (Just (last fs, True))
@@ -716,11 +724,11 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
    e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
    let env_stack =
 -        case e_pkg_path of
 +        case fmap unsafeEncodeUtf e_pkg_path of
                  Left  _ -> sys_databases
                  Right path
 -                  | not (null path) && isSearchPathSeparator (last path)
 -                  -> splitSearchPath (init path) ++ sys_databases
 +                  | hasTrailingPathSeparator path
 +                  -> splitSearchPath (dropTrailingPathSeparator path) <> sys_databases
                    | otherwise
                    -> splitSearchPath path
@@ -733,7 +741,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
                        | Just (user_conf, _user_exists) <- mb_user_conf
                        = Just user_conf
                 is_db_flag FlagGlobal     = Just virt_global_conf
 -               is_db_flag (FlagConfig f) = Just f
 +               is_db_flag (FlagConfig f) = Just $ unsafeEncodeUtf f
                 is_db_flag _              = Nothing
    let flag_db_names | null db_flags = env_stack
@@ -748,7 +756,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
    -- stack, unless any of them are present in the stack
    -- already.
    let final_stack = filter (`notElem` env_stack)
 -                     [ f | FlagConfig f <- reverse my_flags ]
 +                     [ unsafeEncodeUtf f | FlagConfig f <- reverse my_flags ]
                       ++ env_stack
        top_db = if null db_flags
@@ -764,7 +772,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
    when (verbosity > Normal) $ do
      infoLn ("db stack: " ++ show (map location db_stack))
      F.forM_ db_to_operate_on $ \db ->
 -      infoLn ("modifying: " ++ (location db))
 +      infoLn ("modifying: " ++ showOsPath (location db))
      infoLn ("flag db stack: " ++ show (map location flag_db_stack))
    return (db_stack, db_to_operate_on, flag_db_stack)
@@ -843,17 +851,19 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
          return (db_stack, GhcPkg.DbOpenReadWrite to_modify)
        where
 -        couldntOpenDbForModification :: FilePath -> IOError -> IO a
 +        couldntOpenDbForModification :: OsPath -> IOError -> IO a
          couldntOpenDbForModification db_path e = die $ "Couldn't open database "
 -          ++ db_path ++ " for modification: " ++ show e
 +          ++ showOsPath db_path ++ " for modification: " ++ show e
          -- Parse package db in read-only mode.
 -        readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly)
 +        readDatabase :: OsPath -> IO (PackageDB 'GhcPkg.DbReadOnly)
          readDatabase db_path = do
            db <- readParseDatabase verbosity mb_user_conf
                                    GhcPkg.DbOpenReadOnly use_cache db_path
            if expand_vars
 -            then return $ mungePackageDBPaths top_dir db
 +            then do
 +              top_dir_filepath <- decodeFS top_dir
 +              return $ mungePackageDBPaths top_dir_filepath db
              else return db
      stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s)
@@ -863,20 +873,20 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
        (as, s'') <- stateSequence s' ms
        return (a : as, s'')
 -lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
 +lookForPackageDBIn :: OsPath -> IO (Maybe OsPath)
  lookForPackageDBIn dir = do
 -  let path_dir = dir </> "package.conf.d"
 +  let path_dir = dir </> os "package.conf.d"
    exists_dir <- doesDirectoryExist path_dir
    if exists_dir then return (Just path_dir) else do
 -    let path_file = dir </> "package.conf"
 +    let path_file = dir </> os "package.conf"
      exists_file <- doesFileExist path_file
      if exists_file then return (Just path_file) else return Nothing
  readParseDatabase :: forall mode t. Verbosity
 -                  -> Maybe (FilePath,Bool)
 +                  -> Maybe (OsPath,Bool)
                    -> GhcPkg.DbOpenMode mode t
                    -> Bool -- use cache
 -                  -> FilePath
 +                  -> OsPath
                    -> IO (PackageDB mode)
  readParseDatabase verbosity mb_user_conf mode use_cache path
    -- the user database (only) is allowed to be non-existent
@@ -898,7 +908,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                  Just db -> return db
                  Nothing ->
                    die $ "ghc no longer supports single-file style package "
 -                     ++ "databases (" ++ path ++ ") use 'ghc-pkg init'"
 +                     ++ "databases (" ++ showOsPath path ++ ") use 'ghc-pkg init'"
                       ++ "to create the database with the correct format."
             | otherwise -> ioError err
@@ -914,7 +924,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                          -- It's fine if the cache is not there as long as the
                          -- database is empty.
                          when (not $ null confs) $ do
 -                            warn ("WARNING: cache does not exist: " ++ cache)
 +                            warn ("WARNING: cache does not exist: " ++ showOsPath cache)
                              warn ("ghc will fail to read this package db. " ++
                                    recacheAdvice)
                        else do
@@ -923,7 +933,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                    ignore_cache (const $ return ())
                  Right tcache -> do
                    when (verbosity >= Verbose) $ do
 -                      warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
 +                      warn ("Timestamp " ++ show tcache ++ " for " ++ showOsPath cache)
                    -- If any of the .conf files is newer than package.cache, we
                    -- assume that cache is out of date.
                    cache_outdated <- (`anyM` confs) $ \conf ->
@@ -931,12 +941,12 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                    if not cache_outdated
                        then do
                            when (verbosity > Normal) $
 -                             infoLn ("using cache: " ++ cache)
 +                             infoLn ("using cache: " ++ showOsPath cache)
                            GhcPkg.readPackageDbForGhcPkg cache mode
                              >>= uncurry mkPackageDB
                        else do
                            whenReportCacheErrors $ do
 -                              warn ("WARNING: cache is out of date: " ++ cache)
 +                              warn ("WARNING: cache is out of date: " ++ showOsPath cache)
                                warn ("ghc will see an old view of this " ++
                                      "package db. " ++ recacheAdvice)
                            ignore_cache $ \file -> do
@@ -947,11 +957,11 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                                      GT -> " (older than cache)"
                                      EQ -> " (same as cache)"
                                warn ("Timestamp " ++ show tFile
 -                                ++ " for " ++ file ++ rel)
 +                                ++ " for " ++ showOsPath file ++ rel)
              where
 -                 confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs
 +                 confs = map (path </>) $ filter (os ".conf" `OsPath.isExtensionOf`) fs
 -                 ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode)
 +                 ignore_cache :: (OsPath -> IO ()) -> IO (PackageDB mode)
                   ignore_cache checkTime = do
                       -- If we're opening for modification, we need to acquire a
                       -- lock even if we don't open the cache now, because we are
@@ -987,17 +997,18 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
            packages = pkgs
+         }
 -parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
 +parseSingletonPackageConf :: Verbosity -> OsPath -> IO InstalledPackageInfo
  parseSingletonPackageConf verbosity file = do
 -  when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
 -  BS.readFile file >>= fmap fst . parsePackageInfo
 +  when (verbosity > Normal) $ infoLn ("reading package config: " ++ showOsPath file)
 +  FileIO.readFile file >>= fmap fst . parsePackageInfo . BS.toStrict
++
 -cachefilename :: FilePath
 -cachefilename = "package.cache"
 +cachefilename :: OsPath
 +cachefilename = os "package.cache"
  mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode
  mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
 -    db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
 +    db { packages = map (mungePackagePaths top_dir (unsafeDecodeUtf pkgroot)) pkgs }
    where
      pkgroot = takeDirectory $ dropTrailingPathSeparator (locationAbsolute db)
      -- It so happens that for both styles of package db ("package.conf"
@@ -1044,12 +1055,13 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
        | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
        | otherwise                                   = p
 +    toUrlPath :: FilePath -> FilePath -> FilePath
      toUrlPath r p = "file:///"
                   -- URLs always use posix style '/' separators:
                   ++ FilePath.Posix.joinPath
                          (r : -- We need to drop a leading "/" or "\\"
                               -- if there is one:
 -                             dropWhile (all isPathSeparator)
 +                             dropWhile (all FilePath.isPathSeparator)
                                         (FilePath.splitDirectories p))
      -- We could drop the separator here, and then use </> above. However,
@@ -1057,7 +1069,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
      -- rather than letting FilePath change it to use \ as the separator
      stripVarPrefix var path = case stripPrefix var path of
                                Just [] -> Just []
 -                              Just cs@(c : _) | isPathSeparator c -> Just cs
 +                              Just cs@(c : _) | FilePath.isPathSeparator c -> Just cs
                                _ -> Nothing
  -- -----------------------------------------------------------------------------
@@ -1074,18 +1086,18 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
  -- ghc itself also cooperates in this workaround
 -tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool)
 -                                 -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath
 +tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (OsPath, Bool)
 +                                 -> GhcPkg.DbOpenMode mode t -> Bool -> OsPath
                                   -> IO (Maybe (PackageDB mode))
  tryReadParseOldFileStyleDatabase verbosity mb_user_conf
                                   mode use_cache path = do
    -- assumes we've already established that path exists and is not a dir
 -  content <- readFile path `catchIO` \_ -> return ""
 +  content <- readUtf8File path `catchIO` \_ -> return ""
    if take 2 content == "[]"
      then do
        path_abs <- absolutePath path
        let path_dir = adjustOldDatabasePath path
 -      warn $ "Warning: ignoring old file-style db and trying " ++ path_dir
 +      warn $ "Warning: ignoring old file-style db and trying " ++ showOsPath path_dir
        direxists <- doesDirectoryExist path_dir
        if direxists
          then do
@@ -1112,7 +1124,7 @@ tryReadParseOldFileStyleDatabase verbosity mb_user_conf
  adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode)
  adjustOldFileStylePackageDB db = do
    -- assumes we have not yet established if it's an old style or not
 -  mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing
 +  mcontent <- liftM Just (readUtf8File (location db)) `catchIO` \_ -> return Nothing
    case fmap (take 2) mcontent of
      -- it is an old style and empty db, so look for a dir kind in location.d/
      Just "[]" -> return db {
@@ -1121,20 +1133,20 @@ adjustOldFileStylePackageDB db = do
+       }
      -- it is old style but not empty, we have to bail
      Just  _   -> die $ "ghc no longer supports single-file style package "
 -                    ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'"
 +                    ++ "databases (" ++ showOsPath (location db) ++ ") use 'ghc-pkg init'"
                      ++ "to create the database with the correct format."
      -- probably not old style, carry on as normal
      Nothing   -> return db
 -adjustOldDatabasePath :: FilePath -> FilePath
 -adjustOldDatabasePath = (<.> "d")
 +adjustOldDatabasePath :: OsPath -> OsPath
 +adjustOldDatabasePath = (<.> os "d")
  -- -----------------------------------------------------------------------------
  -- Creating a new package DB
 -initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
 +initPackageDB :: OsPath -> Verbosity -> [Flag] -> IO ()
  initPackageDB filename verbosity _flags = do
 -  let eexist = die ("cannot create: " ++ filename ++ " already exists")
 +  let eexist = die ("cannot create: " ++ showOsPath filename ++ " already exists")
    b1 <- doesFileExist filename
    when b1 eexist
    b2 <- doesDirectoryExist filename
@@ -1183,7 +1195,8 @@ registerPackage input verbosity my_flags multi_instance
        f   -> do
          when (verbosity >= Normal) $
              info ("Reading package info from " ++ show f ++ " ... ")
 -        readUTF8File f
 +        fs <- encodeFS f
 +        readUtf8File fs
    expanded <- if expand_env_vars then expandEnvVars s force
                                   else return s
@@ -1199,7 +1212,11 @@ registerPackage input verbosity my_flags multi_instance
    -- validate the expanded pkg, but register the unexpanded
    pkgroot <- absolutePath (takeDirectory to_modify)
    let top_dir = takeDirectory (location (last db_stack))
 -      pkg_expanded = mungePackagePaths top_dir pkgroot pkg
++
 +  top_dir_filepath <- decodeFS top_dir
 +  pkgroot_filepath <- decodeFS pkgroot
 +  let
 +      pkg_expanded = mungePackagePaths top_dir_filepath pkgroot_filepath pkg
    let truncated_stack = stackUpTo to_modify db_stack
    -- truncate the stack for validation, because we don't allow
@@ -1274,13 +1291,13 @@ changeDBDir verbosity cmds db db_stack = do
    updateDBCache verbosity db db_stack
   where
    do_cmd (RemovePackage p) = do
 -    let file = location db </> display (installedUnitId p) <.> "conf"
 -    when (verbosity > Normal) $ infoLn ("removing " ++ file)
 +    let file = location db </> unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf"
 +    when (verbosity > Normal) $ infoLn ("removing " ++ showOsPath file)
      removeFileSafe file
    do_cmd (AddPackage p) = do
 -    let file = location db </> display (installedUnitId p) <.> "conf"
 -    when (verbosity > Normal) $ infoLn ("writing " ++ file)
 -    writeUTF8File file (showInstalledPackageInfo p)
 +    let file = location db </> unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf"
 +    when (verbosity > Normal) $ infoLn ("writing " ++ showOsPath file)
 +    writeUtf8File file (showInstalledPackageInfo p)
    do_cmd (ModifyPackage p) =
      do_cmd (AddPackage p)
@@ -1338,13 +1355,13 @@ updateDBCache verbosity db db_stack = do
              warn $ "    " ++ pkg
    when (verbosity > Normal) $
 -      infoLn ("writing cache " ++ filename)
 +      infoLn ("writing cache " ++ showOsPath filename)
    let d = fmap (fromPackageCacheFormat . fst) pkgsGhcCacheFormat
    GhcPkg.writePackageDb filename d pkgsCabalFormat
      `catchIO` \e ->
        if isPermissionError e
 -      then die $ filename ++ ": you don't have permission to modify this file"
 +      then die $ showOsPath filename ++ ": you don't have permission to modify this file"
        else ioError e
    case packageDbLock db of
@@ -1583,7 +1600,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
        broken = map installedUnitId (brokenPackages pkg_map)
        show_normal PackageDB{ location = db_name, packages = pkg_confs } =
 -          do hPutStrLn stdout db_name
 +          do hPutStrLn stdout (showOsPath db_name)
               if null pkg_confs
                   then hPutStrLn stdout "    (no packages)"
                   else hPutStrLn stdout $ unlines (map ("    " ++) (map pp_pkg pkg_confs))
@@ -1610,7 +1627,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
  #else
      let
        show_colour PackageDB{ location = db_name, packages = pkg_confs } =
 -          do hPutStrLn stdout db_name
 +          do hPutStrLn stdout (showOsPath db_name)
               if null pkg_confs
                   then hPutStrLn stdout "    (no packages)"
                   else hPutStrLn stdout $ unlines (map ("    " ++) (map pp_pkg pkg_confs))
@@ -1698,7 +1715,7 @@ dumpUnits verbosity my_flags expand_pkgroot = do
    doDump expand_pkgroot [ (pkg, locationAbsolute db)
                          | db <- flag_db_stack, pkg <- packages db ]
 -doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
 +doDump :: Bool -> [(InstalledPackageInfo, OsPath)] -> IO ()
  doDump expand_pkgroot pkgs = do
    -- fix the encoding to UTF-8, since this is an interchange format
    hSetEncoding stdout utf8
@@ -1731,7 +1748,7 @@ findPackagesByDB db_stack pkgarg
  cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a
  cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg
 -  ++ maybe "" (\db -> " in " ++ location db) mdb
 +  ++ maybe "" (\db -> " in " ++ showOsPath (location db)) mdb
    where
      pkg_msg (Id pkgid)           = displayGlobPkgId pkgid
      pkg_msg (IUId ipid)          = display ipid
@@ -1944,7 +1961,7 @@ checkPackageConfig pkg verbosity db_stack
    checkExposedModules db_stack pkg
    checkOtherModules pkg
    let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg)))
 -  when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg)
 +  when has_code $ mapM_ (checkHSLib verbosity (fmap unsafeEncodeUtf $ libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg)
    -- ToDo: check these somehow?
    --    extra_libraries :: [String],
    --    c_includes      :: [String],
@@ -2011,20 +2028,20 @@ checkPath url_ok is_dir warn_only thisfield d
             || "https://" `isPrefixOf` d) = return ()
   | url_ok
 - , Just d' <- stripPrefix "file://" d
 - = checkPath False is_dir warn_only thisfield d'
 + , Just f <- stripPrefix "file://" d
 + = checkPath False is_dir warn_only thisfield f
     -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
     -- variables having been expanded already, see mungePackagePaths.
 - | isRelative d = verror ForceFiles $
 + | isRelative d' = verror ForceFiles $
                       thisfield ++ ": " ++ d ++ " is a relative path which "
                    ++ "makes no sense (as there is nothing for it to be "
                    ++ "relative to). You can make paths relative to the "
                    ++ "package database itself by using ${pkgroot}."
          -- relative paths don't make any sense; #4134
   | otherwise = do
 -   there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
 +   there <- liftIO $ if is_dir then doesDirectoryExist d' else doesFileExist d'
     when (not there) $
         let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
                                          ++ if is_dir then "directory" else "file"
@@ -2032,6 +2049,8 @@ checkPath url_ok is_dir warn_only thisfield d
         if warn_only
            then vwarn msg
            else verror ForceFiles msg
 +  where
 +   d' = unsafeEncodeUtf d
  checkDep :: PackageDBStack -> UnitId -> Validate ()
  checkDep db_stack pkgid
@@ -2050,24 +2069,25 @@ checkDuplicateDepends deps
    where
         dups = [ p | (p:_:_) <- group (sort deps) ]
 -checkHSLib :: Verbosity -> [String] -> String -> Validate ()
 +checkHSLib :: Verbosity -> [OsPath] -> String -> Validate ()
  checkHSLib _verbosity dirs lib = do
 -  let filenames = ["lib" ++ lib ++ ".a",
 -                   "lib" ++ lib ++ "_p.a",
 -                   "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so",
 -                   "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so",
 -                   "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib",
 -                   "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib",
 -                   lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll",
 -                   lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll",
 -                   lib ++ ".bytecodelib"
 -                  ]
 +  let filenames = fmap OsPath.unsafeEncodeUtf
 +        [ "lib" ++ lib ++ ".a"
 +        , "lib" ++ lib ++ "_p.a"
 +        , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so"
 +        , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so"
 +        , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib"
 +        , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib"
 +        , lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll"
 +        , lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll"
 +        , lib ++ ".bytecodelib"
 +        ]
    b <- liftIO $ doesFileExistOnPath filenames dirs
    when (not b) $
      verror ForceFiles ("cannot find any of " ++ show filenames ++
                         " on library path")
 -doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool
 +doesFileExistOnPath :: [OsPath] -> [OsPath] -> IO Bool
  doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames
    where fullFilenames = [ path </> filename
                          | filename <- filenames
@@ -2096,9 +2116,9 @@ checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate ()
  checkModuleFile pkg modl =
        -- there's no interface file for GHC.Prim
        unless (modl == ModuleName.fromString "GHC.Prim") $ do
 -      let files = [ ModuleName.toFilePath modl <.> extension
 -                  | extension <- ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ]
 -      b <- liftIO $ doesFileExistOnPath files (importDirs pkg)
 +      let files = [ unsafeEncodeUtf (ModuleName.toFilePath modl) <.> extension
 +                  | extension <- fmap os ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ]
 +      b <- liftIO $ doesFileExistOnPath files (fmap unsafeEncodeUtf $ importDirs pkg)
        when (not b) $
           verror ForceFiles ("cannot find any of " ++ show files)
@@ -2273,19 +2293,45 @@ installSignalHandlers = do
    return ()
  #endif
 +-- ------------------------------------------------
 +-- OsPath Utils
++
 +-- | Show an 'OsPath', throwing an exception if we fail to decode it.
 +showOsPath :: HasCallStack => OsPath -> FilePath
 +showOsPath = unsafePerformIO . decodeFS
++
 +-- | Turn a path relative to the current directory into a (normalised)
 +-- absolute path.
 +absolutePath :: OsPath -> IO OsPath
 +absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
++
 +-- ------------------------------------------------
++
  catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
  catchIO = catchException
  tryIO :: IO a -> IO (Either Exception.IOException a)
  tryIO = Exception.try
 --- removeFileSave doesn't throw an exceptions, if the file is already deleted
 -removeFileSafe :: FilePath -> IO ()
 +-----------------------------------------
 +-- Adapted from ghc/compiler/utils/Panic
++
 +-- | 'removeFileSave' doesn't throw an exceptions, if the file is already deleted
 +removeFileSafe :: OsPath -> IO ()
  removeFileSafe fn =
    removeFile fn `catchIO` \ e ->
      when (not $ isDoesNotExistError e) $ ioError e
 --- | Turn a path relative to the current directory into a (normalised)
 --- absolute path.
 -absolutePath :: FilePath -> IO FilePath
 -absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
 +-- | Read a file using UTF-8 encoding
 +--
 +-- Taken from https://github.com/haskell/cabal/blob/cea1d8ff1a80df3c3b3148d1556bd3edf656da93/Cabal-syntax/src/Distribution/Utils/Generic.hs#L326
 +-- and adapted to 'OsPath'.
 +writeUtf8File :: OsPath -> String -> IO ()
 +writeUtf8File file contents = writeFileAtomic file (toUTF8LBS contents)
++
 +-- | Read a file and interpret its content to be UTF-8 encoded.
 +--
 +-- Taken from https://github.com/haskell/cabal/blob/cea1d8ff1a80df3c3b3148d1556bd3edf656da93/Cabal-syntax/src/Distribution/Utils/Generic.hs#L309
 +-- and adapted to 'OsPath'.
 +readUtf8File :: OsPath -> IO String
 +readUtf8File file = (ignoreBOM . fromUTF8LBS) <$> FileIO.readFile file

utils/ghc-pkg/ghc-pkg.cabal.in

@@ -25,6 +25,7 @@ Executable ghc-pkg
                     process    >= 1   && < 1.7,
                     containers,
                     filepath,
 +                   file-io,
                     Cabal,
                     Cabal-syntax,
                     binary,