[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Make ru_fn field strict to avoid retaining Ids

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Fri Aug 19 15:47:39 UTC 2022



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


Commits:
519c712e by Matthew Pickering at 2022-08-19T00:09:11-04:00
Make ru_fn field strict to avoid retaining Ids

It's better to perform this projection from Id to Name strictly so we
don't retain an old Id (hence IdInfo, hence Unfolding, hence everything
etc)

- - - - -
7dda04b0 by Matthew Pickering at 2022-08-19T00:09:11-04:00
Force `getOccFS bndr` to avoid retaining reference to Bndr.

This is another symptom of #19619

- - - - -
4303acba by Matthew Pickering at 2022-08-19T00:09:11-04:00
Force unfoldings when they are cleaned-up in Tidy and CorePrep

If these thunks are not forced then the entire unfolding for the binding
is live throughout the whole of CodeGen despite the fact it should have
been discarded.

Fixes #22071

- - - - -
2361b3bc by Matthew Pickering at 2022-08-19T00:09:47-04:00
haddock docs: Fix links from identifiers to dependent packages

When implementing the base_url changes I made the pretty bad mistake of
zipping together two lists which were in different orders. The simpler
thing to do is just modify `haddockDependencies` to also return the
package identifier so that everything stays in sync.

Fixes #22001

- - - - -
9a7e2ea1 by Matthew Pickering at 2022-08-19T00:10:23-04:00
Revert "Refactor SpecConstr to use treat bindings uniformly"

This reverts commit 415468fef8a3e9181b7eca86de0e05c0cce31729.

This refactoring introduced quite a severe residency regression (900MB
live from 650MB live when compiling mmark), see #21993 for a reproducer
and more discussion.

Ticket #21993

- - - - -
29ca2b0c by Zachary Wood at 2022-08-19T11:47:17-04:00
tc: warn about lazy annotations on unlifted arguments (fixes #21951)

- - - - -
6d53fa9e by Andreas Klebinger at 2022-08-19T11:47:17-04:00
Fix #22048 where we failed to drop rules for -fomit-interface-pragmas.

Now we also filter the local rules (again) which fixes the issue.

- - - - -


17 changed files:

- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/TyCl.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Settings/Builders/Haddock.hs
- + testsuite/tests/driver/T22048.hs
- testsuite/tests/driver/all.T
- + testsuite/tests/typecheck/should_compile/T21951a.hs
- + testsuite/tests/typecheck/should_compile/T21951a.stderr
- + testsuite/tests/typecheck/should_compile/T21951b.hs
- + testsuite/tests/typecheck/should_compile/T21951b.stderr
- testsuite/tests/typecheck/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core.hs
=====================================
@@ -1151,7 +1151,7 @@ data CoreRule
 
         -- Rough-matching stuff
         -- see comments with InstEnv.ClsInst( is_cls, is_rough )
-        ru_fn    :: Name,               -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule
+        ru_fn    :: !Name,               -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule
         ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side
 
         -- Proper-matching stuff


=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -634,7 +634,8 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
                         floats' = floats `extendFloats` NonRec bndr' triv_rhs
                   ; return ( floats', setInScopeFromF env floats' ) } }
   where
-    occ_fs = getOccFS bndr
+    -- Force the occ_fs so that the old Id is not retained in the new Id.
+    !occ_fs = getOccFS bndr
     uf_opts = seUnfoldingOpts env
     work_ty = coercionLKind co
     info   = idInfo bndr
@@ -711,9 +712,11 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs
          -- rhs_env: add to in-scope set the binders from rhs_floats
          -- so that prepareRhs knows what is in scope in rhs
        ; let rhs_env = env `setInScopeFromF` rhs_floats1
+             -- Force the occ_fs so that the old Id is not retained in the new Id.
+             !occ_fs = getOccFS bndr
 
        -- Now ANF-ise the remaining rhs
-       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1
+       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1
 
        -- Finally, decide whether or not to float
        ; let all_floats = rhs_floats1 `addLetFloats` anf_floats
@@ -4294,7 +4297,8 @@ simplRules env mb_new_id rules bind_cxt
                  lhs_env = updMode updModeForRules env'
                  rhs_env = updMode (updModeForStableUnfoldings act) env'
                            -- See Note [Simplifying the RHS of a RULE]
-                 fn_name' = case mb_new_id of
+                 -- Force this to avoid retaining reference to old Id
+                 !fn_name' = case mb_new_id of
                               Just id -> idName id
                               Nothing -> fn_name
 


=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -77,7 +77,6 @@ import GHC.Serialized   ( deserializeWithData )
 
 import Control.Monad    ( zipWithM )
 import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
-import Data.Maybe( mapMaybe )
 import Data.Ord( comparing )
 
 {-
@@ -375,14 +374,11 @@ The recursive call ends up looking like
 So we want to spot the constructor application inside the cast.
 That's why we have the Cast case in argToPat
 
-Note [Seeding recursive groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a recursive group that is either
-  * nested, or
-  * top-level, but with no exported Ids
-we can see all the calls to the function, so we seed the specialisation
-loop from the calls in the body, and /not/ from the calls in the RHS.
-Consider:
+Note [Local recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a *local* recursive group, we can see all the calls to the
+function, so we seed the specialisation loop from the calls in the
+body, not from the calls in the RHS.  Consider:
 
   bar m n = foo n (n,n) (n,n) (n,n) (n,n)
    where
@@ -405,42 +401,52 @@ a local function.
 In a case like the above we end up never calling the original un-specialised
 function.  (Although we still leave its code around just in case.)
 
-Wrinkles
-
-* Boring calls. If we find any boring calls in the body, including
-  *unsaturated* ones, such as
+However, if we find any boring calls in the body, including *unsaturated*
+ones, such as
       letrec foo x y = ....foo...
       in map foo xs
-  then we will end up calling the un-specialised function, so then we
-  *should* use the calls in the un-specialised RHS as seeds.  We call
-  these "boring call patterns", and callsToNewPats reports if it finds
-  any of these.  Then 'specialise' unleashes the usage info from the
-  un-specialised RHS.
-
-* Exported Ids. `specialise` /also/ unleashes `si_mb_unspec`
-  for exported Ids.  That way we are sure to generate usage info from
-  the /un-specialised/ RHS of an exported function.
-
-More precisely:
-
-* Always start from the calls in the body of the let or (for top level)
-  calls in the rest of the module.  See the body_calls in the call to
-  `specialise` in `specNonRec`, and to `go` in `specRec`.
-
-* si_mb_unspec holds the usage from the unspecialised RHS.
-  See `initSpecInfo`.
-
-* `specialise` will unleash si_mb_unspec, if
-  - `callsToNewPats` reports "boring calls found", or
-  - this is a top-level exported Id.
-
-Historical note.  At an earlier point, if a top-level Id was exported,
-we used only seeds from the RHS, and /not/from the body. But Dimitrios
-had an example where using call patterns from the body (the other defns
-in the module) was crucial.  And doing so improved nofib allocation results:
-    multiplier: 4%   better
-    minimax:    2.8% better
-In any case, it is easier to do!
+then we will end up calling the un-specialised function, so then we *should*
+use the calls in the un-specialised RHS as seeds.  We call these
+"boring call patterns", and callsToPats reports if it finds any of these.
+
+Note [Seeding top-level recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This seeding is done in the binding for seed_calls in specRec.
+
+1. If all the bindings in a top-level recursive group are local (not
+   exported), then all the calls are in the rest of the top-level
+   bindings.  This means we can specialise with those call patterns
+   ONLY, and NOT with the RHSs of the recursive group (exactly like
+   Note [Local recursive groups])
+
+2. But if any of the bindings are exported, the function may be called
+   with any old arguments, so (for lack of anything better) we specialise
+   based on
+     (a) the call patterns in the RHS
+     (b) the call patterns in the rest of the top-level bindings
+   NB: before Apr 15 we used (a) only, but Dimitrios had an example
+       where (b) was crucial, so I added that.
+       Adding (b) also improved nofib allocation results:
+                  multiplier: 4%   better
+                  minimax:    2.8% better
+
+Actually in case (2), instead of using the calls from the RHS, it
+would be better to specialise in the importing module.  We'd need to
+add an INLINABLE pragma to the function, and then it can be
+specialised in the importing scope, just as is done for type classes
+in GHC.Core.Opt.Specialise.specImports. This remains to be done (#10346).
+
+Note [Top-level recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To get the call usage information from "the rest of the top level
+bindings" (c.f. Note [Seeding top-level recursive groups]), we work
+backwards through the top-level bindings so we see the usage before we
+get to the binding of the function.  Before we can collect the usage
+though, we go through all the bindings and add them to the
+environment. This is necessary because usage is only tracked for
+functions in the environment.  These two passes are called
+   'go' and 'goEnv'
+in specConstrProgram.  (Looks a bit revolting to me.)
 
 Note [Do not specialise diverging functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -758,18 +764,35 @@ unbox the strict fields, because T is polymorphic!)
 
 specConstrProgram :: ModGuts -> CoreM ModGuts
 specConstrProgram guts
-  = do { env0 <- initScEnv guts
-       ; us   <- getUniqueSupplyM
-       ; let (_usg, binds') = initUs_ us $
-                              scTopBinds env0 (mg_binds guts)
-
-       ; return (guts { mg_binds = binds' }) }
-
-scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind])
-scTopBinds _env []     = return (nullUsage, [])
-scTopBinds env  (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $
-                                                (\env -> scTopBinds env bs)
-                            ; return (usg, b' ++ bs') }
+  = do
+      dflags <- getDynFlags
+      us     <- getUniqueSupplyM
+      (_, annos) <- getFirstAnnotations deserializeWithData guts
+      this_mod <- getModule
+      -- pprTraceM "specConstrInput" (ppr $ mg_binds guts)
+      let binds' = reverse $ fst $ initUs us $ do
+                    -- Note [Top-level recursive groups]
+                    (env, binds) <- goEnv (initScEnv (initScOpts dflags this_mod) annos)
+                                          (mg_binds guts)
+                        -- binds is identical to (mg_binds guts), except that the
+                        -- binders on the LHS have been replaced by extendBndr
+                        --   (SPJ this seems like overkill; I don't think the binders
+                        --    will change at all; and we don't substitute in the RHSs anyway!!)
+                    go env nullUsage (reverse binds)
+
+      return (guts { mg_binds = binds' })
+  where
+    -- See Note [Top-level recursive groups]
+    goEnv env []            = return (env, [])
+    goEnv env (bind:binds)  = do (env', bind')   <- scTopBindEnv env bind
+                                 (env'', binds') <- goEnv env' binds
+                                 return (env'', bind' : binds')
+
+    -- Arg list of bindings is in reverse order
+    go _   _   []           = return []
+    go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind
+                                 binds' <- go env usg' binds
+                                 return (bind' : binds')
 
 {-
 ************************************************************************
@@ -933,24 +956,14 @@ initScOpts dflags this_mod = SpecConstrOpts
           sc_keen        = gopt Opt_SpecConstrKeen dflags
         }
 
-initScEnv :: ModGuts -> CoreM ScEnv
-initScEnv guts
-  = do { dflags    <- getDynFlags
-       ; (_, anns) <- getFirstAnnotations deserializeWithData guts
-       ; this_mod  <- getModule
-       ; return (SCE { sc_opts        = initScOpts dflags this_mod,
-                       sc_force       = False,
-                       sc_subst       = init_subst,
-                       sc_how_bound   = emptyVarEnv,
-                       sc_vals        = emptyVarEnv,
-                       sc_annotations = anns }) }
-  where
-    init_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet $
-                 bindersOfBinds (mg_binds guts)
-        -- Acccount for top-level bindings that are not in dependency order;
-        -- see Note [Glomming] in GHC.Core.Opt.OccurAnal
-        -- Easiest thing is to bring all the top level binders into scope at once,
-        -- as if  at once, as if all the top-level decls were mutually recursive.
+initScEnv :: SpecConstrOpts -> UniqFM Name SpecConstrAnnotation -> ScEnv
+initScEnv opts anns
+  = SCE { sc_opts        = opts,
+          sc_force       = False,
+          sc_subst       = emptySubst,
+          sc_how_bound   = emptyVarEnv,
+          sc_vals        = emptyVarEnv,
+          sc_annotations = anns }
 
 data HowBound = RecFun  -- These are the recursive functions for which
                         -- we seek interesting call patterns
@@ -1174,8 +1187,8 @@ data ScUsage
         scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences
      }                                  -- The domain is OutIds
 
-type CallEnv = IdEnv [Call]  -- Domain is OutIds
-data Call    = Call OutId [CoreArg] ValueEnv
+type CallEnv = IdEnv [Call]
+data Call = Call Id [CoreArg] ValueEnv
         -- The arguments of the call, together with the
         -- env giving the constructor bindings at the call site
         -- We keep the function mainly for debug output
@@ -1197,9 +1210,6 @@ nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
 combineCalls :: CallEnv -> CallEnv -> CallEnv
 combineCalls = plusVarEnv_C (++)
 
-delCallsFor :: ScUsage -> [Var] -> ScUsage
-delCallsFor env bndrs = env { scu_calls = scu_calls env `delVarEnvList` bndrs }
-
 combineUsage :: ScUsage -> ScUsage -> ScUsage
 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
                            scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
@@ -1282,121 +1292,6 @@ The main recursive function gathers up usage information, and
 creates specialised versions of functions.
 -}
 
-scBind :: TopLevelFlag -> ScEnv -> InBind
-       -> (ScEnv -> UniqSM (ScUsage, a))   -- Specialise the scope of the binding
-       -> UniqSM (ScUsage, [OutBind], a)
-scBind top_lvl env (NonRec bndr rhs) do_body
-  | isTyVar bndr         -- Type-lets may be created by doBeta
-  = do { (final_usage, body') <- do_body (extendScSubst env bndr rhs)
-       ; return (final_usage, [], body') }
-
-  | not (isTopLevel top_lvl)  -- Nested non-recursive value binding
-    -- See Note [Specialising local let bindings]
-  = do  { let (body_env, bndr') = extendBndr env bndr
-              -- Not necessary at top level; but here we are nested
-
-        ; rhs_info  <- scRecRhs env (bndr',rhs)
-
-        ; let body_env2 = extendHowBound body_env [bndr'] RecFun
-              rhs'      = ri_new_rhs rhs_info
-              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
-
-        ; (body_usg, body') <- do_body body_env3
-
-          -- Now make specialised copies of the binding,
-          -- based on calls in body_usg
-        ; (spec_usg, specs) <- specNonRec env (scu_calls body_usg) rhs_info
-          -- NB: For non-recursive bindings we inherit sc_force flag from
-          -- the parent function (see Note [Forcing specialisation])
-
-        -- Specialized + original binding
-        ; let spec_bnds  = [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs]
-              bind_usage = (body_usg `delCallsFor` [bndr'])
-                           `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg]
-
-        ; return (bind_usage, spec_bnds, body')
-        }
-
-  | otherwise  -- Top-level, non-recursive value binding
-    -- At top level we do not specialise non-recursive bindings; that
-    -- is, we do not call specNonRec, passing the calls from the body.
-    -- The original paper only specialised /recursive/ bindings, but
-    -- we later started specialising nested non-recursive bindings:
-    -- see Note [Specialising local let bindings]
-    --
-    -- I tried always specialising non-recursive top-level bindings too,
-    -- but found some regressions (see !8135).  So I backed off.
-  = do { (rhs_usage, rhs')   <- scExpr env rhs
-
-       -- At top level, we've already put all binders into scope; see initScEnv
-       -- Hence no need to call `extendBndr`. But we still want to
-       -- extend the `ValueEnv` to record the value of this binder.
-       ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs')
-       ; (body_usage, body') <- do_body body_env
-
-       ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body') }
-
-scBind top_lvl env (Rec prs) do_body
-  | isTopLevel top_lvl
-  , Just threshold <- sc_size (sc_opts env)
-  , not force_spec
-  , not (all (couldBeSmallEnoughToInline (sc_uf_opts (sc_opts env)) threshold) rhss)
-  = -- Do no specialisation if the RHSs are too big
-    -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor
-    --       why it only applies at top level. But that's the way it has been
-    --       for a while. See #21456.
-    do  { (body_usg, body') <- do_body rhs_env2
-        ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss
-        ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg)
-                        `delCallsFor` bndrs'
-              bind'   = Rec (bndrs' `zip` rhss')
-        ; return (all_usg, [bind'], body') }
-
-  | otherwise
-  = do  { rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
-        ; (body_usg, body') <- do_body rhs_env2
-
-        ; (spec_usg, specs) <- specRec (scForce rhs_env2 force_spec)
-                                       (scu_calls body_usg) rhs_infos
-                -- Do not unconditionally generate specialisations from rhs_usgs
-                -- Instead use them only if we find an unspecialised call
-                -- See Note [Seeding recursive groups]
-
-        ; let all_usg = (spec_usg `combineUsage` body_usg)  -- Note [spec_usg includes rhs_usg]
-                        `delCallsFor` bndrs'
-              bind'   = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))
-                        -- zipWithEqual: length of returned [SpecInfo]
-                        -- should be the same as incoming [RhsInfo]
-
-        ; return (all_usg, [bind'], body') }
-  where
-    (bndrs,rhss) = unzip prs
-    force_spec   = any (forceSpecBndr env) bndrs    -- Note [Forcing specialisation]
-
-    (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs)
-                      | otherwise          = extendRecBndrs env bndrs
-       -- At top level, we've already put all binders into scope; see initScEnv
-
-    rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
-
-{- Note [Specialising local let bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is not uncommon to find this
-
-   let $j = \x. <blah> in ...$j True...$j True...
-
-Here $j is an arbitrary let-bound function, but it often comes up for
-join points.  We might like to specialise $j for its call patterns.
-Notice the difference from a letrec, where we look for call patterns
-in the *RHS* of the function.  Here we look for call patterns in the
-*body* of the let.
-
-At one point I predicated this on the RHS mentioning the outer
-recursive function, but that's not essential and might even be
-harmful.  I'm not sure.
--}
-
-------------------------
 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
         -- The unique supply is needed when we invent
         -- a new name for the specialised function and its args
@@ -1421,11 +1316,6 @@ scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b
                               (usg, e') <- scExpr env' e
                               return (usg, Lam b' e')
 
-scExpr' env (Let bind body)
-  = do { (final_usage, binds', body') <- scBind NotTopLevel env bind $
-                                         (\env -> scExpr env body)
-       ; return (final_usage, mkLets binds' body') }
-
 scExpr' env (Case scrut b ty alts)
   = do  { (scrut_usg, scrut') <- scExpr env scrut
         ; case isValue (sc_vals env) scrut' of
@@ -1465,7 +1355,79 @@ scExpr' env (Case scrut b ty alts)
                                _          -> evalScrutOcc
           ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }
 
+scExpr' env (Let (NonRec bndr rhs) body)
+  | isTyVar bndr        -- Type-lets may be created by doBeta
+  = scExpr' (extendScSubst env bndr rhs) body
+
+  | otherwise
+  = do  { let (body_env, bndr') = extendBndr env bndr
+        ; rhs_info  <- scRecRhs env (bndr',rhs)
+
+        ; let body_env2 = extendHowBound body_env [bndr'] RecFun
+                           -- See Note [Local let bindings]
+              rhs'      = ri_new_rhs rhs_info
+              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
+
+        ; (body_usg, body') <- scExpr body_env3 body
+
+          -- NB: For non-recursive bindings we inherit sc_force flag from
+          -- the parent function (see Note [Forcing specialisation])
+        ; (spec_usg, specs) <- specNonRec env body_usg rhs_info
+
+        -- Specialized + original binding
+        ; let spec_bnds = mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body'
+        -- ; pprTraceM "spec_bnds" $ (ppr spec_bnds)
+
+        ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
+                    `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]
+                  spec_bnds
+                  )
+        }
+
+
+-- A *local* recursive group: see Note [Local recursive groups]
+scExpr' env (Let (Rec prs) body)
+  = do  { let (bndrs,rhss)      = unzip prs
+              (rhs_env1,bndrs') = extendRecBndrs env bndrs
+              rhs_env2          = extendHowBound rhs_env1 bndrs' RecFun
+              force_spec        = any (forceSpecBndr env) bndrs'
+                -- Note [Forcing specialisation]
+
+        ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
+        ; (body_usg, body')     <- scExpr rhs_env2 body
+
+        -- NB: start specLoop from body_usg
+        ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)
+                                       body_usg rhs_infos
+                -- Do not unconditionally generate specialisations from rhs_usgs
+                -- Instead use them only if we find an unspecialised call
+                -- See Note [Local recursive groups]
+
+        ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]
+              bind'   = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))
+                        -- zipWithEqual: length of returned [SpecInfo]
+                        -- should be the same as incoming [RhsInfo]
+
+        ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
+                  Let bind' body') }
+
+{-
+Note [Local let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is not uncommon to find this
+
+   let $j = \x. <blah> in ...$j True...$j True...
 
+Here $j is an arbitrary let-bound function, but it often comes up for
+join points.  We might like to specialise $j for its call patterns.
+Notice the difference from a letrec, where we look for call patterns
+in the *RHS* of the function.  Here we look for call patterns in the
+*body* of the let.
+
+At one point I predicated this on the RHS mentioning the outer
+recursive function, but that's not essential and might even be
+harmful.  I'm not sure.
+-}
 
 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
 
@@ -1520,6 +1482,51 @@ mkVarUsage env fn args
     arg_occ | null args = UnkOcc
             | otherwise = evalScrutOcc
 
+----------------------
+scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
+scTopBindEnv env (Rec prs)
+  = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
+              rhs_env2          = extendHowBound rhs_env1 bndrs RecFun
+
+              prs'              = zip bndrs' rhss
+        ; return (rhs_env2, Rec prs') }
+  where
+    (bndrs,rhss) = unzip prs
+
+scTopBindEnv env (NonRec bndr rhs)
+  = do  { let (env1, bndr') = extendBndr env bndr
+              env2          = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)
+        ; return (env2, NonRec bndr' rhs) }
+
+----------------------
+scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
+
+scTopBind env body_usage (Rec prs)
+  | Just threshold <- sc_size $ sc_opts env
+  , not force_spec
+  , not (all (couldBeSmallEnoughToInline (sc_uf_opts $ sc_opts env) threshold) rhss)
+                -- No specialisation
+  = -- pprTrace "scTopBind: nospec" (ppr bndrs) $
+    do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss
+        ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }
+
+  | otherwise   -- Do specialisation
+  = do  { rhs_infos <- mapM (scRecRhs env) prs
+
+        ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)
+                                         body_usage rhs_infos
+
+        ; return (body_usage `combineUsage` spec_usage,
+                  Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }
+  where
+    (bndrs,rhss) = unzip prs
+    force_spec   = any (forceSpecBndr env) bndrs
+      -- Note [Forcing specialisation]
+
+scTopBind env usage (NonRec bndr rhs)   -- Oddly, we don't seem to specialise top-level non-rec functions
+  = do  { (rhs_usg', rhs') <- scExpr env rhs
+        ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }
+
 ----------------------
 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo
 scRecRhs env (bndr,rhs)
@@ -1567,8 +1574,7 @@ data RhsInfo
     }
 
 data SpecInfo       -- Info about specialisations for a particular Id
-  = SI { si_specs :: [OneSpec]          -- The specialisations we have
-                                        -- generated for this function
+  = SI { si_specs :: [OneSpec]          -- The specialisations we have generated
 
        , si_n_specs :: Int              -- Length of si_specs; used for numbering them
 
@@ -1579,7 +1585,7 @@ data SpecInfo       -- Info about specialisations for a particular Id
                                         --             RHS usage (which has not yet been
                                         --             unleashed)
                                         -- Nothing => we have
-                                        -- See Note [Seeding recursive groups]
+                                        -- See Note [Local recursive groups]
                                         -- See Note [spec_usg includes rhs_usg]
 
         -- One specialisation: Rule plus definition
@@ -1589,62 +1595,57 @@ data OneSpec =
      , os_id   :: OutId      -- Spec id
      , os_rhs  :: OutExpr }  -- Spec rhs
 
-initSpecInfo :: RhsInfo -> SpecInfo
-initSpecInfo (RI { ri_rhs_usg = rhs_usg })
-  = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Just rhs_usg }
-    -- si_mb_unspec: add in rhs_usg if there are any boring calls,
-    --               or if the bndr is exported
+noSpecInfo :: SpecInfo
+noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }
 
 ----------------------
 specNonRec :: ScEnv
-           -> CallEnv         -- Calls in body
+           -> ScUsage         -- Body usage
            -> RhsInfo         -- Structure info usage info for un-specialised RHS
            -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)
                                                --     plus details of specialisations
 
-specNonRec env body_calls rhs_info
-  = specialise env body_calls rhs_info (initSpecInfo rhs_info)
+specNonRec env body_usg rhs_info
+  = specialise env (scu_calls body_usg) rhs_info
+               (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })
 
 ----------------------
-specRec :: ScEnv
-        -> CallEnv                         -- Calls in body
+specRec :: TopLevelFlag -> ScEnv
+        -> ScUsage                         -- Body usage
         -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs
         -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)
                                            --     plus details of specialisations
 
-specRec env body_calls rhs_infos
-  = go 1 body_calls nullUsage (map initSpecInfo rhs_infos)
-    -- body_calls: see Note [Seeding recursive groups]
-    -- NB: 'go' always calls 'specialise' once, which in turn unleashes
-    --     si_mb_unspec if there are any boring calls in body_calls,
-    --     or if any of the Id(s) are exported
+specRec top_lvl env body_usg rhs_infos
+  = go 1 seed_calls nullUsage init_spec_infos
   where
     opts = sc_opts env
+    (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]
+       | isTopLevel top_lvl
+       , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs
+       = (all_calls,     [noSpecInfo | _ <- rhs_infos])
+       | otherwise                              -- Seed from body only
+       = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }
+                         | ri <- rhs_infos])
+
+    calls_in_body = scu_calls body_usg
+    calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos
+    all_calls = calls_in_rhss `combineCalls` calls_in_body
 
     -- Loop, specialising, until you get no new specialisations
-    go, go_again :: Int   -- Which iteration of the "until no new specialisations"
-                          -- loop we are on; first iteration is 1
-                 -> CallEnv   -- Seed calls
-                              -- Two accumulating parameters:
-                 -> ScUsage      -- Usage from earlier specialisations
-                 -> [SpecInfo]   -- Details of specialisations so far
-                 -> UniqSM (ScUsage, [SpecInfo])
+    go :: Int   -- Which iteration of the "until no new specialisations"
+                -- loop we are on; first iteration is 1
+       -> CallEnv   -- Seed calls
+                    -- Two accumulating parameters:
+       -> ScUsage      -- Usage from earlier specialisations
+       -> [SpecInfo]   -- Details of specialisations so far
+       -> UniqSM (ScUsage, [SpecInfo])
     go n_iter seed_calls usg_so_far spec_infos
-      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
-        --                           , text "iteration" <+> int n_iter
-        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
-        --                    ]) $
-        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
-            ; let (extra_usg_s, all_spec_infos) = unzip specs_w_usg
-                  extra_usg = combineUsages extra_usg_s
-                  all_usg   = usg_so_far `combineUsage` extra_usg
-                  new_calls = scu_calls extra_usg
-            ; go_again n_iter new_calls all_usg all_spec_infos }
-
-    -- go_again deals with termination
-    go_again n_iter seed_calls usg_so_far spec_infos
       | isEmptyVarEnv seed_calls
-      = return (usg_so_far, spec_infos)
+      = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)
+        --                           , ppr seed_calls
+        --                           , ppr body_usg ]) $
+        return (usg_so_far, spec_infos)
 
       -- Limit recursive specialisation
       -- See Note [Limit recursive specialisation]
@@ -1653,20 +1654,26 @@ specRec env body_calls rhs_infos
            -- If both of these are false, the sc_count
            -- threshold will prevent non-termination
       , any ((> the_limit) . si_n_specs) spec_infos
-      = -- Give up on specialisation, but don't forget to include the rhs_usg
-        -- for the unspecialised function, since it may now be called
-        -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $
-        let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos)
-        in return (usg_so_far `combineUsage` rhs_usgs, spec_infos)
+      = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $
+        return (usg_so_far, spec_infos)
 
       | otherwise
-      = go (n_iter + 1) seed_calls usg_so_far spec_infos
+      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
+        --                           , text "iteration" <+> int n_iter
+        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
+        --                    ]) $
+        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
+            ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg
+                  extra_usg = combineUsages extra_usg_s
+                  all_usg   = usg_so_far `combineUsage` extra_usg
+            ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }
 
     -- See Note [Limit recursive specialisation]
     the_limit = case sc_count opts of
                   Nothing  -> 10    -- Ugh!
                   Just max -> max
 
+
 ----------------------
 specialise
    :: ScEnv
@@ -1689,12 +1696,14 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
                spec_info@(SI { si_specs = specs, si_n_specs = spec_count
                              , si_mb_unspec = mb_unspec })
   | isDeadEndId fn  -- Note [Do not specialise diverging functions]
-                    -- /and/ do not generate specialisation seeds from its RHS
+                    -- and do not generate specialisation seeds from its RHS
   = -- pprTrace "specialise bot" (ppr fn) $
     return (nullUsage, spec_info)
 
   | not (isNeverActive (idInlineActivation fn))
       -- See Note [Transfer activation]
+      --
+      --
       -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].
       -- Since OPAQUE things are always never-active (see
       -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for
@@ -1720,16 +1729,14 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
 
         ; let spec_usg = combineUsages spec_usgs
 
-              unspec_rhs_needed = boring_call || isExportedId fn
-
               -- If there were any boring calls among the seeds (= all_calls), then those
               -- calls will call the un-specialised function.  So we should use the seeds
               -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning
               -- then in new_usg.
-              (new_usg, mb_unspec') = case mb_unspec of
-                  Just rhs_usg | unspec_rhs_needed
-                               -> (spec_usg `combineUsage` rhs_usg, Nothing)
-                  _            -> (spec_usg,                      mb_unspec)
+              (new_usg, mb_unspec')
+                  = case mb_unspec of
+                      Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
+                      _                          -> (spec_usg,                      mb_unspec)
 
 --        ; pprTrace "specialise return }"
 --             (vcat [ ppr fn
@@ -1737,8 +1744,8 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
 --                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $
 --          return ()
 
-          ; return (new_usg, SI { si_specs     = new_specs ++ specs
-                                , si_n_specs   = spec_count + n_pats
+          ; return (new_usg, SI { si_specs = new_specs ++ specs
+                                , si_n_specs = spec_count + n_pats
                                 , si_mb_unspec = mb_unspec' }) }
 
   | otherwise  -- No calls, inactive, or not a function
@@ -2020,8 +2027,7 @@ calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
 Note [spec_usg includes rhs_usg]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In calls to 'specialise', the returned ScUsage must include the rhs_usg in
-the passed-in SpecInfo in si_mb_unspec, unless there are no calls at all to
-the function.
+the passed-in SpecInfo, unless there are no calls at all to the function.
 
 The caller can, indeed must, assume this.  They should not combine in rhs_usg
 themselves, or they'll get rhs_usg twice -- and that can lead to an exponential
@@ -2239,11 +2245,9 @@ callsToNewPats :: ScEnv -> Id
                -> SpecInfo
                -> [ArgOcc] -> [Call]
                -> UniqSM (Bool, [CallPat])
--- Result has no duplicate patterns,
--- nor ones mentioned in si_specs (hence "new" patterns)
--- Bool indicates that there was at least one boring pattern
--- The "New" in the name means "patterns that are not already covered
--- by an existing specialisation"
+        -- Result has no duplicate patterns,
+        -- nor ones mentioned in done_pats
+        -- Bool indicates that there was at least one boring pattern
 callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
   = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
 


=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -2153,7 +2153,9 @@ cpCloneBndr env bndr
        -- Drop (now-useless) rules/unfoldings
        -- See Note [Drop unfoldings and rules]
        -- and Note [Preserve evaluatedness] in GHC.Core.Tidy
-       ; let unfolding' = trimUnfolding (realIdUnfolding bndr)
+       -- And force it.. otherwise the old unfolding is just retained.
+       -- See #22071
+       ; let !unfolding' = trimUnfolding (realIdUnfolding bndr)
                           -- Simplifier will set the Id's unfolding
 
              bndr'' = bndr' `setIdUnfolding`      unfolding'


=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -1048,7 +1048,8 @@ findExternalRules opts binds imp_id_rules unfold_env
             -- In needed_fvs', we don't bother to delete binders from the fv set
 
          local_rules  = [ rule
-                        | id <- bndrs
+                        | (opt_expose_rules opts)
+                        , id <- bndrs
                         , is_external_id id   -- Only collect rules for external Ids
                         , rule <- idCoreRules id
                         , expose_rule rule ]  -- and ones that can fire in a client
@@ -1292,12 +1293,14 @@ tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unf
 
     --------- Unfolding ------------
     unf_info = realUnfoldingInfo idinfo
-    unfold_info
+    -- Force this, otherwise the old unfolding is retained over code generation
+    -- See #22071
+    !unfold_info
       | isCompulsoryUnfolding unf_info || show_unfold
       = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
       | otherwise
       = minimal_unfold_info
-    minimal_unfold_info = trimUnfolding unf_info
+    !minimal_unfold_info = trimUnfolding unf_info
     unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs
     -- NB: do *not* expose the worker if show_unfold is off,
     --     because that means this thing is a loop breaker or


=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -445,6 +445,9 @@ instance Diagnostic TcRnMessage where
     TcRnBangOnUnliftedType ty
       -> mkSimpleDecorated $
            text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty)
+    TcRnLazyBangOnUnliftedType ty
+      -> mkSimpleDecorated $
+           text "Lazy flag has no effect on unlifted type" <+> quotes (ppr ty)
     TcRnMultipleDefaultDeclarations dup_things
       -> mkSimpleDecorated $
            hang (text "Multiple default declarations")
@@ -1094,6 +1097,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnBangOnUnliftedType{}
       -> WarningWithFlag Opt_WarnRedundantStrictnessFlags
+    TcRnLazyBangOnUnliftedType{}
+      -> WarningWithFlag Opt_WarnRedundantStrictnessFlags
     TcRnMultipleDefaultDeclarations{}
       -> ErrorWithoutFlag
     TcRnBadDefaultType{}
@@ -1424,6 +1429,8 @@ instance Diagnostic TcRnMessage where
              -> noHints
     TcRnBangOnUnliftedType{}
       -> noHints
+    TcRnLazyBangOnUnliftedType{}
+      -> noHints
     TcRnMultipleDefaultDeclarations{}
       -> noHints
     TcRnBadDefaultType{}


=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -1133,6 +1133,17 @@ data TcRnMessage where
   -}
   TcRnBangOnUnliftedType :: !Type -> TcRnMessage
 
+  {-| TcRnLazyBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that
+      occurs when a lazy annotation is applied to an unlifted type.
+
+      Example(s):
+      data T = MkT ~Int# -- Lazy flag has no effect on unlifted types
+
+     Test cases: typecheck/should_compile/T21951a
+                 typecheck/should_compile/T21951b
+  -}
+  TcRnLazyBangOnUnliftedType :: !Type -> TcRnMessage
+
   {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has
       more than one default declaration.
 


=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -4441,6 +4441,12 @@ checkValidDataCon dflags existential_ok tc con
                , isUnliftedType orig_arg_ty
                = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty
 
+               -- Warn about a ~ on an unlifted type (#21951)
+               -- e.g.   data T = MkT ~Int#
+               | HsSrcBang _ _ SrcLazy <- bang
+               , isUnliftedType orig_arg_ty
+               = addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty
+
                | HsSrcBang _ want_unpack _ <- bang
                , isSrcUnpacked want_unpack
                , case rep_bang of { HsUnpack {} -> False; _ -> True }


=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -249,7 +249,7 @@ buildPackageDocumentation = do
         vanillaSrcs <- hsSources context
         let srcs = vanillaSrcs `union` generatedSrcs
 
-        need $ srcs ++ haddocks
+        need $ srcs ++ (map snd haddocks)
 
         -- Build Haddock documentation
         -- TODO: Pass the correct way from Rules via Context.
@@ -364,8 +364,8 @@ buildManPage = do
             copyFileUntracked (dir -/- "ghc.1") file
 
 -- | Find the Haddock files for the dependencies of the current library.
-haddockDependencies :: Context -> Action [FilePath]
+haddockDependencies :: Context -> Action [(Package, FilePath)]
 haddockDependencies context = do
     depNames <- interpretInContext context (getContextData depNames)
-    sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
+    sequence [ (,) <$> pure depPkg <*> (pkgHaddockFile $ vanillaContext Stage1 depPkg)
              | Just depPkg <- map findPackageByName depNames, depPkg /= rts ]


=====================================
hadrian/src/Settings/Builders/Haddock.hs
=====================================
@@ -43,9 +43,8 @@ haddockBuilderArgs = mconcat
         context  <- getContext
         version  <- expr $ pkgVersion  pkg
         synopsis <- expr $ pkgSynopsis pkg
-        trans_deps <- expr $ contextDependencies context
-        pkgs <- expr $ mapM (pkgIdentifier . C.package) $ trans_deps
         haddocks <- expr $ haddockDependencies context
+        haddocks_with_versions <- expr $ sequence $ [(,h) <$> pkgIdentifier p | (p, h) <- haddocks]
         hVersion <- expr $ pkgVersion haddock
         statsDir <- expr $ haddockStatsFilesDir
         baseUrlTemplate <- expr (docsBaseUrl <$> userSetting defaultDocArgs)
@@ -69,7 +68,7 @@ haddockBuilderArgs = mconcat
             , map ("--hide=" ++) <$> getContextData otherModules
             , pure [ "--read-interface=../" ++ p
                      ++ "," ++ baseUrl p ++ "/src/%{MODULE}.html#%{NAME},"
-                     ++ haddock | (p, haddock) <- zip pkgs haddocks ]
+                     ++ haddock | (p, haddock) <- haddocks_with_versions ]
             , pure [ "--optghc=" ++ opt | opt <- ghcOpts, not ("--package-db" `isInfixOf` opt) ]
             , getInputs
             , arg "+RTS"


=====================================
testsuite/tests/driver/T22048.hs
=====================================
@@ -0,0 +1,11 @@
+module T22048 where
+
+{-# NOINLINE g #-}
+g :: Bool -> Bool
+g = not
+
+-- With -fomit-interface-pragmas these rules should not make it into interface files.
+{-# RULES
+"imported_rule"    [~1] forall xs. map g xs              = []
+"local_rule"       [~1] forall .   g True                = False
+#-}


=====================================
testsuite/tests/driver/all.T
=====================================
@@ -312,3 +312,4 @@ test('T21866', normal, multimod_compile, ['T21866','-no-link'])
 test('T21349', extra_files(['T21349']), makefile_test, [])
 test('T21869', [normal, when(unregisterised(), skip)], makefile_test, [])
 test('T22044', normal, makefile_test, [])
+test('T22048', [only_ways(['normal']), grep_errmsg("_rule")], compile, ["-O -fomit-interface-pragmas -ddump-simpl"])


=====================================
testsuite/tests/typecheck/should_compile/T21951a.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE UnliftedDatatypes #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE MagicHash #-}
+
+module Wibble where
+
+import Data.Kind
+import GHC.Exts
+
+data UA = UA ~(Array# Int)


=====================================
testsuite/tests/typecheck/should_compile/T21951a.stderr
=====================================
@@ -0,0 +1,4 @@
+T21951a.hs:10:11: warning: [-Wredundant-strictness-flags]
+     Lazy flag has no effect on unlifted type ‘Array# Int’
+     In the definition of data constructor ‘UA’
+      In the data type declaration for ‘UA’


=====================================
testsuite/tests/typecheck/should_compile/T21951b.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE UnliftedDatatypes #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE MagicHash #-}
+
+module Wibble where
+
+import Data.Kind
+import GHC.Exts
+
+type U :: UnliftedType
+data U = MkU Int
+
+data T = T ~U


=====================================
testsuite/tests/typecheck/should_compile/T21951b.stderr
=====================================
@@ -0,0 +1,4 @@
+T21951b.hs:13:10: warning: [-Wredundant-strictness-flags]
+     Lazy flag has no effect on unlifted type ‘U’
+     In the definition of data constructor ‘T’
+      In the data type declaration for ‘T’


=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -853,3 +853,5 @@ test('DeepSubsumption06', normal, compile, ['-XHaskell98'])
 test('DeepSubsumption07', normal, compile, ['-XHaskell2010'])
 test('DeepSubsumption08', normal, compile, [''])
 test('DeepSubsumption09', normal, compile, [''])
+test('T21951a', normal, compile, ['-Wredundant-strictness-flags'])
+test('T21951b', normal, compile, ['-Wredundant-strictness-flags'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/805462db2c104d3932190f7115e8ecfcacd8514b...6d53fa9e4b363d835550f2eab8a919f50bb9c0f7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/805462db2c104d3932190f7115e8ecfcacd8514b...6d53fa9e4b363d835550f2eab8a919f50bb9c0f7
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220819/72baab68/attachment-0001.html>


More information about the ghc-commits mailing list