[Git][ghc/ghc][wip/T23026] 7 commits: Take more care with unlifted bindings in the specialiser

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Thu Mar 2 17:47:32 UTC 2023



Simon Peyton Jones pushed to branch wip/T23026 at Glasgow Haskell Compiler / GHC


Commits:
7192ef91 by Simon Peyton Jones at 2023-02-28T18:54:59-05:00
Take more care with unlifted bindings in the specialiser

As #22998 showed, we were floating an unlifted binding to top
level, which breaks a Core invariant.

The fix is easy, albeit a little bit conservative.  See
Note [Care with unlifted bindings] in GHC.Core.Opt.Specialise

- - - - -
bb500e2a by Simon Peyton Jones at 2023-02-28T18:55:35-05:00
Account for TYPE vs CONSTRAINT in mkSelCo

As #23018 showed, in mkRuntimeRepCo we need to account for coercions
between TYPE and COERCION.

See Note [mkRuntimeRepCo] in GHC.Core.Coercion.

- - - - -
79ffa170 by Ben Gamari at 2023-03-01T04:17:20-05:00
hadrian: Add dependency from lib/settings to mk/config.mk

In 81975ef375de07a0ea5a69596b2077d7f5959182 we attempted to fix #20253
by adding logic to the bindist Makefile to regenerate the `settings`
file from information gleaned by the bindist `configure` script.
However, this fix had no effect as `lib/settings` is shipped in the
binary distribution (to allow in-place use of the binary distribution).
As `lib/settings` already existed and its rule declared no dependencies,
`make` would fail to use the added rule to regenerate it.

Fix this by explicitly declaring a dependency from `lib/settings` on
`mk/config.mk`.

Fixes #22982.

- - - - -
a2a1a1c0 by Sebastian Graf at 2023-03-01T04:17:56-05:00
Revert the main payload of "Make `drop` and `dropWhile` fuse (#18964)"

This reverts the bits affecting fusion of `drop` and `dropWhile` of commit
0f7588b5df1fc7a58d8202761bf1501447e48914 and keeps just the small refactoring
unifying `flipSeqTake` and `flipSeqScanl'` into `flipSeq`.

It also adds a new test for #23021 (which was the reason for reverting) as
well as adds a clarifying comment to T18964.

Fixes #23021, unfixes #18964.

Metric Increase:
    T18964
Metric Decrease:
    T18964

- - - - -
cf118e2f by Simon Peyton Jones at 2023-03-01T04:18:33-05:00
Refine the test for naughty record selectors

The test for naughtiness in record selectors is surprisingly subtle.
See the revised Note [Naughty record selectors] in GHC.Tc.TyCl.Utils.

Fixes #23038.

- - - - -
86f240ca by romes at 2023-03-01T04:19:10-05:00
fix: Consider strictness annotation in rep_bind

Fixes #23036

- - - - -
70a34368 by Simon Peyton Jones at 2023-03-02T17:48:41+00:00
Get the right in-scope set in etaBodyForJoinPoint

Fixes #23026

- - - - -


27 changed files:

- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- hadrian/bindist/Makefile
- libraries/base/GHC/List.hs
- + testsuite/tests/patsyn/should_compile/T23038.hs
- + testsuite/tests/patsyn/should_compile/T23038.stderr
- testsuite/tests/patsyn/should_compile/all.T
- testsuite/tests/perf/should_run/T18964.hs
- + testsuite/tests/perf/should_run/T23021.hs
- + testsuite/tests/perf/should_run/T23021.stdout
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T23026.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/simplCore/should_run/T22998.hs
- + testsuite/tests/simplCore/should_run/T22998.stdout
- testsuite/tests/simplCore/should_run/all.T
- + testsuite/tests/th/T23036.hs
- + testsuite/tests/th/T23036.stderr
- testsuite/tests/th/all.T
- + testsuite/tests/typecheck/should_compile/T23018.hs
- testsuite/tests/typecheck/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core.hs
=====================================
@@ -366,68 +366,32 @@ a Coercion, (sym c).
 
 Note [Core letrec invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The right hand sides of all top-level and recursive @let at s
-/must/ be of lifted type (see "Type#type_classification" for
-the meaning of /lifted/ vs. /unlifted/).
+The Core letrec invariant:
 
-There is one exception to this rule, top-level @let at s are
-allowed to bind primitive string literals: see
-Note [Core top-level string literals].
+    The right hand sides of all
+      /top-level/ or /recursive/
+    bindings must be of lifted type
 
-Note [Core top-level string literals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As an exception to the usual rule that top-level binders must be lifted,
-we allow binding primitive string literals (of type Addr#) of type Addr# at the
-top level. This allows us to share string literals earlier in the pipeline and
-crucially allows other optimizations in the Core2Core pipeline to fire.
-Consider,
+    There is one exception to this rule, top-level @let at s are
+    allowed to bind primitive string literals: see
+    Note [Core top-level string literals].
 
-  f n = let a::Addr# = "foo"#
-        in \x -> blah
+See "Type#type_classification" in GHC.Core.Type
+for the meaning of "lifted" vs. "unlifted").
 
-In order to be able to inline `f`, we would like to float `a` to the top.
-Another option would be to inline `a`, but that would lead to duplicating string
-literals, which we want to avoid. See #8472.
-
-The solution is simply to allow top-level unlifted binders. We can't allow
-arbitrary unlifted expression at the top-level though, unlifted binders cannot
-be thunks, so we just allow string literals.
-
-We allow the top-level primitive string literals to be wrapped in Ticks
-in the same way they can be wrapped when nested in an expression.
-CoreToSTG currently discards Ticks around top-level primitive string literals.
-See #14779.
-
-Also see Note [Compilation plan for top-level string literals].
-
-Note [Compilation plan for top-level string literals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is a summary on how top-level string literals are handled by various
-parts of the compilation pipeline.
-
-* In the source language, there is no way to bind a primitive string literal
-  at the top level.
-
-* In Core, we have a special rule that permits top-level Addr# bindings. See
-  Note [Core top-level string literals]. Core-to-core passes may introduce
-  new top-level string literals.
-
-* In STG, top-level string literals are explicitly represented in the syntax
-  tree.
-
-* A top-level string literal may end up exported from a module. In this case,
-  in the object file, the content of the exported literal is given a label with
-  the _bytes suffix.
+For the non-top-level, non-recursive case see Note [Core let-can-float invariant].
 
 Note [Core let-can-float invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The let-can-float invariant:
 
-    The right hand side of a non-recursive 'Let'
-    /may/ be of unlifted type, but only if
+    The right hand side of a /non-top-level/, /non-recursive/ binding
+    may be of unlifted type, but only if
     the expression is ok-for-speculation
     or the 'Let' is for a join point.
 
+    (For top-level or recursive lets see Note [Core letrec invariant].)
+
 This means that the let can be floated around
 without difficulty. For example, this is OK:
 
@@ -466,6 +430,53 @@ we need to allow lots of things in the arguments of a call.
 
 TL;DR: we relaxed the let/app invariant to become the let-can-float invariant.
 
+Note [Core top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As an exception to the usual rule that top-level binders must be lifted,
+we allow binding primitive string literals (of type Addr#) of type Addr# at the
+top level. This allows us to share string literals earlier in the pipeline and
+crucially allows other optimizations in the Core2Core pipeline to fire.
+Consider,
+
+  f n = let a::Addr# = "foo"#
+        in \x -> blah
+
+In order to be able to inline `f`, we would like to float `a` to the top.
+Another option would be to inline `a`, but that would lead to duplicating string
+literals, which we want to avoid. See #8472.
+
+The solution is simply to allow top-level unlifted binders. We can't allow
+arbitrary unlifted expression at the top-level though, unlifted binders cannot
+be thunks, so we just allow string literals.
+
+We allow the top-level primitive string literals to be wrapped in Ticks
+in the same way they can be wrapped when nested in an expression.
+CoreToSTG currently discards Ticks around top-level primitive string literals.
+See #14779.
+
+Also see Note [Compilation plan for top-level string literals].
+
+Note [Compilation plan for top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is a summary on how top-level string literals are handled by various
+parts of the compilation pipeline.
+
+* In the source language, there is no way to bind a primitive string literal
+  at the top level.
+
+* In Core, we have a special rule that permits top-level Addr# bindings. See
+  Note [Core top-level string literals]. Core-to-core passes may introduce
+  new top-level string literals.
+
+  See GHC.Core.Utils.exprIsTopLevelBindable, and exprIsTickedString
+
+* In STG, top-level string literals are explicitly represented in the syntax
+  tree.
+
+* A top-level string literal may end up exported from a module. In this case,
+  in the object file, the content of the exported literal is given a label with
+  the _bytes suffix.
+
 Note [NON-BOTTOM-DICTS invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It is a global invariant (not checkable by Lint) that


=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -612,14 +612,40 @@ eqTyConRole tc
   | otherwise
   = pprPanic "eqTyConRole: unknown tycon" (ppr tc)
 
--- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@,
---   (or CONSTRAINT instead of TYPE)
--- produce a coercion @rep_co :: r1 ~ r2 at .
+-- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)`
+-- produce a coercion `rep_co :: r1 ~ r2`
+-- But actually it is possible that
+--     co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2)
+-- or  co :: (t1 :: TYPE r1)       ~ (t2 :: CONSTRAINT r2)
+-- or  co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2)
+-- See Note [mkRuntimeRepCo]
 mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion
 mkRuntimeRepCo co
-  = mkSelCo (SelTyCon 0 Nominal) kind_co
+  = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $
+    mkSelCo (SelTyCon 0 Nominal) kind_co
   where
     kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2
+    Pair k1 k2 = coercionKind kind_co
+
+{- Note [mkRuntimeRepCo]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Given
+   class C a where { op :: Maybe a }
+we will get an axiom
+   axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2)
+(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.)
+
+Then we may call mkRuntimeRepCo on (axC ty), and that will return
+   mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2
+
+So mkSelCo needs to be happy with decomposing a coercion of kind
+   CONSTRAINT r1 ~ TYPE r2
+
+Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call`
+in `mkSelCo`. See #23018 for a concrete example.  (In this context it's
+important that TYPE and CONSTRAINT have the same arity and kind, not
+merely that they are not-apart; otherwise SelCo would not make sense.)
+-}
 
 isReflCoVar_maybe :: Var -> Maybe Coercion
 -- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)
@@ -1173,7 +1199,8 @@ mkSelCo_maybe cs co
        , Just (tc2, tys2) <- splitTyConApp_maybe ty2
        , let { len1 = length tys1
              ; len2 = length tys2 }
-       =  tc1 == tc2
+       =  (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2))
+                      -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo]
        && len1 == len2
        && n < len1
        && r == tyConRole (coercionRole co) tc1 n


=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -44,6 +44,13 @@ import Control.Monad   ( zipWithM )
 %*                                                                      *
 %************************************************************************
 
+This module does coercion optimisation.  See the paper
+
+   Evidence normalization in Systtem FV (RTA'13)
+   https://simon.peytonjones.org/evidence-normalization/
+
+The paper is also in the GHC repo, in docs/opt-coercion.
+
 Note [Optimising coercion optimisation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Looking up a coercion's role or kind is linear in the size of the


=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -3105,7 +3105,7 @@ etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs
 -- Adds as many binders as asked for; assumes expr is not a lambda
 etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr)
 etaBodyForJoinPoint need_args body
-  = go need_args (exprType body) (init_subst body) [] body
+  = go need_args body_ty (mkEmptySubst in_scope) [] body
   where
     go 0 _  _     rev_bs e
       = (reverse rev_bs, e)
@@ -3124,9 +3124,16 @@ etaBodyForJoinPoint need_args body
       = pprPanic "etaBodyForJoinPoint" $ int need_args $$
                                          ppr body $$ ppr (exprType body)
 
-    init_subst e = mkEmptySubst (mkInScopeSet (exprFreeVars e))
-
-
+    body_ty = exprType body
+    in_scope = mkInScopeSet (exprFreeVars body `unionVarSet` tyCoVarsOfType body_ty)
+    -- in_scope is a bit tricky.
+    -- - We are wrapping `body` in some value lambdas, so must not shadow
+    --   any free vars of `body`
+    -- - We are wrapping `body` in some type lambdas, so must not shadow any
+    --   tyvars in body_ty.  Example: body is just a variable
+    --            (g :: forall (a::k). T k a -> Int)
+    --   We must not shadown that `k` when adding the /\a. So treat the free vars
+    --   of body_ty as in-scope.  Showed up in #23026.
 
 --------------
 freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id)


=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -27,7 +27,7 @@ import GHC.Core
 import GHC.Core.Make      ( mkLitRubbish )
 import GHC.Core.Unify     ( tcMatchTy )
 import GHC.Core.Rules
-import GHC.Core.Utils     ( exprIsTrivial
+import GHC.Core.Utils     ( exprIsTrivial, exprIsTopLevelBindable
                           , mkCast, exprType
                           , stripTicksTop, mkInScopeSetBndrs )
 import GHC.Core.FVs
@@ -1515,7 +1515,10 @@ specBind top_lvl env (NonRec fn rhs) do_body
                          = [mkDB $ NonRec b r | (b,r) <- pairs]
                            ++ fromOL dump_dbs
 
-       ; if float_all then
+             can_float_this_one = exprIsTopLevelBindable rhs (idType fn)
+             -- exprIsTopLevelBindable: see Note [Care with unlifted bindings]
+
+       ; if float_all && can_float_this_one then
              -- Rather than discard the calls mentioning the bound variables
              -- we float this (dictionary) binding along with the others
               return ([], body', all_free_uds `snocDictBinds` final_binds)
@@ -1876,6 +1879,28 @@ even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to
 the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to
 preserve laziness.
 
+Note [Care with unlifted bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#22998)
+    f x = let x::ByteArray# = <some literal>
+              n::Natural    = NB x
+          in wombat @192827 (n |> co)
+where
+  co :: Natural ~ KnownNat 192827
+  wombat :: forall (n:Nat). KnownNat n => blah
+
+Left to itself, the specialiser would float the bindings for `x` and `n` to top
+level, so we can specialise `wombat`.  But we can't have a top-level ByteArray#
+(see Note [Core letrec invariant] in GHC.Core).  Boo.
+
+This is pretty exotic, so we take a simple way out: in specBind (the NonRec
+case) do not float the binding itself unless it satisfies exprIsTopLevelBindable.
+This is conservative: maybe the RHS of `x` has a free var that would stop it
+floating to top level anyway; but that is hard to spot (since we don't know what
+the non-top-level in-scope binders are) and rare (since the binding must satisfy
+Note [Core let-can-float invariant] in GHC.Core).
+
+
 Note [Specialising Calls]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we have a function with a complicated type:


=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -124,7 +124,7 @@ module GHC.Core.Type (
 
         -- *** Levity and boxity
         sORTKind_maybe, typeTypeOrConstraint,
-        typeLevity_maybe,
+        typeLevity_maybe, tyConIsTYPEorCONSTRAINT,
         isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind,
         isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,
         isBoxedRuntimeRep,
@@ -2652,13 +2652,18 @@ isPredTy ty = case typeTypeOrConstraint ty of
                   TypeLike       -> False
                   ConstraintLike -> True
 
------------------------------------------
 -- | Does this classify a type allowed to have values? Responds True to things
 -- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint.
 isTYPEorCONSTRAINT :: Kind -> Bool
 -- ^ True of a kind `TYPE _` or `CONSTRAINT _`
 isTYPEorCONSTRAINT k = isJust (sORTKind_maybe k)
 
+tyConIsTYPEorCONSTRAINT :: TyCon -> Bool
+tyConIsTYPEorCONSTRAINT tc
+  = tc_uniq == tYPETyConKey || tc_uniq == cONSTRAINTTyConKey
+  where
+    !tc_uniq = tyConUnique tc
+
 isConstraintLikeKind :: Kind -> Bool
 -- True of (CONSTRAINT _)
 isConstraintLikeKind kind


=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1899,12 +1899,18 @@ rep_bind (L loc (FunBind
                    fun_matches = MG { mg_alts
                            = (L _ [L _ (Match
                                    { m_pats = []
-                                   , m_grhss = GRHSs _ guards wheres }
-                                      )]) } }))
+                                   , m_grhss = GRHSs _ guards wheres
+                                   -- For a variable declaration I'm pretty
+                                   -- sure we always have a FunRhs
+                                   , m_ctxt = FunRhs { mc_strictness = strictessAnn }
+                                   } )]) } }))
  = do { (ss,wherecore) <- repBinds wheres
         ; guardcore <- addBinds ss (repGuards guards)
         ; fn'  <- lookupNBinder fn
-        ; p    <- repPvar fn'
+        ; p    <- repPvar fn' >>= case strictessAnn of
+                                    SrcLazy -> repPtilde
+                                    SrcStrict -> repPbang
+                                    NoSrcStrict -> pure
         ; ans  <- repVal p guardcore wherecore
         ; ans' <- wrapGenSyms ss ans
         ; return (locA loc, ans') }


=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -903,19 +903,30 @@ mkOneRecordSelector all_cons idDetails fl has_sel
     con1 = assert (not (null cons_w_field)) $ head cons_w_field
 
     -- Selector type; Note [Polymorphic selectors]
-    field_ty    = conLikeFieldType con1 lbl
-    data_tv_set = tyCoVarsOfTypes (data_ty : req_theta)
-    data_tvbs   = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $
-                  conLikeUserTyVarBinders con1
+    (univ_tvs, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
+
+    field_ty     = conLikeFieldType con1 lbl
+    field_ty_tvs = tyCoVarsOfType field_ty
+    data_ty_tvs  = tyCoVarsOfType data_ty
+    sel_tvs      = field_ty_tvs `unionVarSet` data_ty_tvs
+    sel_tvbs     = filter (\tvb -> binderVar tvb `elemVarSet` sel_tvs) $
+                   conLikeUserTyVarBinders con1
 
     -- is_naughty: see Note [Naughty record selectors]
-    is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)
-              || has_sel == NoFieldSelectors  -- No field selectors => all are naughty
-                                              -- thus suppressing making a binding
-                                              -- A slight hack!
+    is_naughty = not ok_scoping || no_selectors
+    ok_scoping = case con1 of
+                   RealDataCon {} -> field_ty_tvs `subVarSet` data_ty_tvs
+                   PatSynCon {}   -> field_ty_tvs `subVarSet` mkVarSet univ_tvs
+       -- In the PatSynCon case, the selector type is (data_ty -> field_ty), but
+       -- fvs(data_ty) are all universals (see Note [Pattern synonym result type] in
+       -- GHC.Core.PatSyn, so no need to check them.
+
+    no_selectors   = has_sel == NoFieldSelectors  -- No field selectors => all are naughty
+                                                  -- thus suppressing making a binding
+                                                  -- A slight hack!
 
     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
-           | otherwise  = mkForAllTys (tyVarSpecToBinders data_tvbs) $
+           | otherwise  = mkForAllTys (tyVarSpecToBinders sel_tvbs) $
                           -- Urgh! See Note [The stupid context] in GHC.Core.DataCon
                           mkPhiTy (conLikeStupidTheta con1) $
                           -- req_theta is empty for normal DataCon
@@ -926,7 +937,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
                             -- fields in all the constructor have multiplicity Many.
                           field_ty
 
-    -- Make the binding: sel (C2 { fld = x }) = x
+    -- make the binding: sel (C2 { fld = x }) = x
     --                   sel (C7 { fld = x }) = x
     --    where cons_w_field = [C2,C7]
     sel_bind = mkTopFunBind Generated sel_lname alts
@@ -976,8 +987,6 @@ mkOneRecordSelector all_cons idDetails fl has_sel
       where
         inst_tys = dataConResRepTyArgs dc
 
-    (_, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
-
     unit_rhs = mkLHsTupleExpr [] noExtField
     msg_lit = HsStringPrim NoSourceText (bytesFS (field_label lbl))
 
@@ -1036,36 +1045,42 @@ so that if the user tries to use 'x' as a selector we can bleat
 helpfully, rather than saying unhelpfully that 'x' is not in scope.
 Hence the sel_naughty flag, to identify record selectors that don't really exist.
 
-In general, a field is "naughty" if its type mentions a type variable that
-isn't in
-  * the (original, user-written) result type of the constructor, or
-  * the "required theta" for the constructor
-
-Note that this *allows* GADT record selectors (Note [GADT record
-selectors]) whose types may look like sel :: T [a] -> a
-
-The "required theta" part is illustrated by test patsyn/should_run/records_run
-where we have
-
-  pattern ReadP :: Read a => a -> String
-  pattern ReadP {readp} <- (read -> readp)
-
-The selector is defined like this:
-
-  $selreadp :: ReadP a => String -> a
-  $selReadP s = readp s
-
-Perfectly fine!  The (ReadP a) constraint lets us contructor a value
-of type 'a' from a bare String.  NB: "required theta" is empty for
-data cons (see conLikeFullSig), so this reasoning only bites for
-patttern synonyms.
-
 For naughty selectors we make a dummy binding
    sel = ()
 so that the later type-check will add them to the environment, and they'll be
 exported.  The function is never called, because the typechecker spots the
 sel_naughty field.
 
+To determine naughtiness we distingish two cases:
+
+* For RealDataCons, a field is "naughty" if its type mentions a
+  type variable that isn't in the (original, user-written) result type
+  of the constructor. Note that this *allows* GADT record selectors
+  (Note [GADT record selectors]) whose types may look like sel :: T [a] -> a
+
+* For a PatSynCon, a field is "naughty" if its type mentions a type variable
+  that isn't in the universal type variables.
+
+  This is a bit subtle. Consider test patsyn/should_run/records_run:
+    pattern ReadP :: forall a. ReadP a => a -> String
+    pattern ReadP {fld} <- (read -> readp)
+  The selector is defined like this:
+    $selReadPfld :: forall a. ReadP a => String -> a
+    $selReadPfld @a (d::ReadP a) s = readp @a d s
+  Perfectly fine!  The (ReadP a) constraint lets us contruct a value of type
+  'a' from a bare String.
+
+  Another curious case (#23038):
+     pattern N :: forall a. () => forall. () => a -> Any
+     pattern N { fld } <- ( unsafeCoerce -> fld1 ) where N = unsafeCoerce
+  The selector looks like this
+     $selNfld :: forall a. Any -> a
+     $selNfld @a x = unsafeCoerce @Any @a x
+  Pretty strange (but used in the `cleff` package).
+
+  TL;DR for pattern synonyms, the selector is OK if the field type mentions only
+  the universal type variables of the pattern synonym.
+
 Note [NoFieldSelectors and naughty record selectors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Under NoFieldSelectors (see Note [NoFieldSelectors] in GHC.Rename.Env), record


=====================================
hadrian/bindist/Makefile
=====================================
@@ -77,7 +77,7 @@ endif
 WrapperBinsDir=${bindir}
 
 # N.B. this is duplicated from includes/ghc.mk.
-lib/settings :
+lib/settings : config.mk
 	$(call removeFiles,$@)
 	@echo '[("GCC extra via C opts", "$(GccExtraViaCOpts)")' >> $@
 	@echo ',("C compiler command", "$(SettingsCCompilerCommand)")' >> $@


=====================================
libraries/base/GHC/List.hs
=====================================
@@ -886,23 +886,12 @@ takeWhileFB p c n = \x r -> if p x then x `c` r else n
 -- []
 -- >>> dropWhile (< 0) [1,2,3]
 -- [1,2,3]
-{-# NOINLINE [1] dropWhile #-}
 dropWhile               :: (a -> Bool) -> [a] -> [a]
 dropWhile _ []          =  []
 dropWhile p xs@(x:xs')
             | p x       =  dropWhile p xs'
             | otherwise =  xs
 
-{-# INLINE [0] dropWhileFB #-} -- See Note [Inline FB functions]
-dropWhileFB :: (a -> Bool) -> (a -> b -> b) -> b -> a -> (Bool -> b) -> Bool -> b
-dropWhileFB p c _n x xs = \drp -> if drp && p x then xs True else x `c` xs False
-
-{-# RULES
-"dropWhile"     [~1] forall p xs. dropWhile p xs =
-                                build (\c n -> foldr (dropWhileFB p c n) (flipSeq n) xs True)
-"dropWhileList" [1]  forall p xs. foldr (dropWhileFB p (:) []) (flipSeq []) xs True = dropWhile p xs
- #-}
-
 -- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@
 -- of length @n@, or @xs@ itself if @n >= 'length' xs at .
 --
@@ -998,31 +987,17 @@ drop n xs     | n <= 0 =  xs
 drop _ []              =  []
 drop n (_:xs)          =  drop (n-1) xs
 #else /* hack away */
-{-# INLINE[1] drop #-} -- Why [1]? See justification on take! => RULES
+{-# INLINE drop #-}
 drop n ls
   | n <= 0     = ls
   | otherwise  = unsafeDrop n ls
-
--- A version of drop that drops the whole list if given an argument
--- less than 1
-{-# NOINLINE [0] unsafeDrop #-} -- See Note [Inline FB functions]
-unsafeDrop :: Int -> [a] -> [a]
-unsafeDrop !_ []     = []
-unsafeDrop 1  (_:xs) = xs
-unsafeDrop m  (_:xs) = unsafeDrop (m - 1) xs
-
-{-# RULES
-"drop"     [~1] forall n xs . drop n xs =
-  build (\c nil -> if n <= 0
-                   then foldr c nil xs
-                   else foldr (dropFB c nil) (flipSeq nil) xs n)
-"unsafeDropList"  [1] forall n xs . foldr (dropFB (:) []) (flipSeq []) xs n
-                                        = unsafeDrop n xs
- #-}
-
-{-# INLINE [0] dropFB #-} -- See Note [Inline FB functions]
-dropFB :: (a -> b -> b) -> b -> a -> (Int -> b) -> Int -> b
-dropFB c _n x xs = \ m -> if m <= 0 then x `c` xs m else xs (m-1)
+  where
+    -- A version of drop that drops the whole list if given an argument
+    -- less than 1
+    unsafeDrop :: Int -> [a] -> [a]
+    unsafeDrop !_ []     = []
+    unsafeDrop 1  (_:xs) = xs
+    unsafeDrop m  (_:xs) = unsafeDrop (m - 1) xs
 #endif
 
 -- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of


=====================================
testsuite/tests/patsyn/should_compile/T23038.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns, ScopedTypeVariables #-}
+
+module T23038 where
+
+import GHC.Types( Any )
+import Unsafe.Coerce( unsafeCoerce )
+
+pattern N1 :: forall a. () => forall. () => a -> Any
+pattern N1 { fld1 } <- ( unsafeCoerce -> fld1 )
+  where N1 = unsafeCoerce
+
+pattern N2 :: forall. () => forall a. () => a -> Any
+pattern N2 { fld2 } <- ( unsafeCoerce -> fld2 )
+  where N2 = unsafeCoerce
+
+test1, test2 :: forall a. Any -> a
+
+test1 = fld1  -- Should be OK
+test2 = fld2  -- Should be rejected


=====================================
testsuite/tests/patsyn/should_compile/T23038.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T23038.hs:19:9: error: [GHC-55876]
+    • Cannot use record selector ‘fld2’ as a function due to escaped type variables
+    • In the expression: fld2
+      In an equation for ‘test2’: test2 = fld2
+    Suggested fix: Use pattern-matching syntax instead


=====================================
testsuite/tests/patsyn/should_compile/all.T
=====================================
@@ -83,3 +83,4 @@ test('T17775-singleton', normal, compile, [''])
 test('T14630', normal, compile, ['-Wname-shadowing'])
 test('T21531', [ grep_errmsg(r'INLINE') ], compile, ['-ddump-ds'])
 test('T22521', normal, compile, [''])
+test('T23038', normal, compile_fail, [''])


=====================================
testsuite/tests/perf/should_run/T18964.hs
=====================================
@@ -3,6 +3,9 @@ import Data.Int
 
 main :: IO ()
 main = do
+  -- This test aims to track #18964, the fix of which had to be reverted in the
+  -- wake of #23021. The comments below apply to a world where #18964 is fixed.
+  --------------------
   -- drop should fuse away and the program should consume O(1) space
   -- If fusion fails, this allocates about 640MB.
   print $ sum $ drop 10 [0..10000000::Int64]


=====================================
testsuite/tests/perf/should_run/T23021.hs
=====================================
@@ -0,0 +1,30 @@
+-- The direct implementation of drop and dropWhile operates in O(1) space.
+-- This regression test asserts that potential fusion rules for dropWhile/drop
+-- maintain that property for the fused pipelines in dropWhile2 and drop2 (which
+-- are marked NOINLINE for that purpose).
+-- #23021 was opened because we had fusion rules in place that did not maintain
+-- this property.
+
+dropWhile2 :: Int -> [Int] -> [Int]
+dropWhile2 n = dropWhile (< n) . dropWhile (< n)
+{-# NOINLINE dropWhile2 #-}
+
+drop2 :: Int -> [Int] -> [Int]
+drop2 n = drop n . drop n
+{-# NOINLINE drop2 #-}
+
+main :: IO ()
+main = do
+  let xs = [0..9999999]
+  print $ last $ dropWhile2 0 xs
+  print $ last $ dropWhile2 1 xs
+  print $ last $ dropWhile2 2 xs
+  print $ last $ dropWhile2 3 xs
+  print $ last $ dropWhile2 4 xs
+  print $ last $ dropWhile2 5 xs
+  print $ last $ drop2 0 xs
+  print $ last $ drop2 1 xs
+  print $ last $ drop2 2 xs
+  print $ last $ drop2 3 xs
+  print $ last $ drop2 4 xs
+  print $ last $ drop2 5 xs


=====================================
testsuite/tests/perf/should_run/T23021.stdout
=====================================
@@ -0,0 +1,12 @@
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999
+9999999


=====================================
testsuite/tests/perf/should_run/all.T
=====================================
@@ -411,4 +411,7 @@ test('T21839r',
     compile_and_run,
     ['-O'])
 
+# #18964 should be marked expect_broken, but it's still useful to track that
+# perf doesn't regress further, so it is not marked as such.
 test('T18964', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O'])
+test('T23021', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O2'])


=====================================
testsuite/tests/simplCore/should_compile/T23026.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+
+module T23026 where
+
+import Data.Kind (Type)
+
+data Sing (a :: k)
+data SingInstance (a :: k) = SingInstance (Sing a)
+
+app :: (Sing a -> SingInstance a) -> Sing a -> SingInstance a
+app f x = f x
+{-# NOINLINE app #-}
+
+withSomeSing
+  :: forall k2 k1 (f :: k2 -> k1 -> Type) a2 a1.
+     (Sing a2, Sing a1)
+  -> f a2 a1
+  -> (forall b2 b1. f b2 b1 -> Int)
+  -> Int
+withSomeSing (sa2, sa1) x g =
+  case app SingInstance sa2 of
+    SingInstance _ ->
+      case app SingInstance sa1 of
+        SingInstance _ -> g x
+{-# INLINABLE withSomeSing #-}


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -476,3 +476,4 @@ test('T23012', normal, compile, ['-O'])
 
 test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])
 test('T23024', normal, multimod_compile, ['T23024', '-O -v0'])
+test('T23026', normal, compile, ['-O'])


=====================================
testsuite/tests/simplCore/should_run/T22998.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE DataKinds #-}
+module Main where
+
+import Data.Proxy (Proxy(Proxy))
+import GHC.TypeLits (natVal)
+
+main :: IO ()
+main = print x
+  where
+    x = natVal @18446744073709551616 Proxy + natVal @18446744073709551616 Proxy


=====================================
testsuite/tests/simplCore/should_run/T22998.stdout
=====================================
@@ -0,0 +1 @@
+36893488147419103232


=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -108,3 +108,5 @@ test('T21575', normal, compile_and_run, ['-O'])
 test('T21575b', [], multimod_compile_and_run, ['T21575b', '-O'])
 test('T20836', normal, compile_and_run, ['-O0']) # Should not time out; See #20836
 test('T22448', normal, compile_and_run, ['-O1'])
+test('T22998', normal, compile_and_run, ['-O0 -fspecialise -dcore-lint'])
+


=====================================
testsuite/tests/th/T23036.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T23036 where
+
+import Language.Haskell.TH
+
+a, b, c :: ()
+a = $([|let x = undefined in ()|])
+b = $([|let !x = undefined in ()|])
+c = $([|let ~x = undefined in ()|])
+
+-- Test strictness annotations are also correctly handled in function and pattern binders
+d, e, f:: ()
+d = $([|let !(x,y) = undefined in ()|])
+e = $([|let (!x,y,~z) = undefined in ()|])
+f = $([|let f !x ~y z = undefined in ()|])
+


=====================================
testsuite/tests/th/T23036.stderr
=====================================
@@ -0,0 +1,18 @@
+T23036.hs:7:6-34: Splicing expression
+    [| let x = undefined in () |] ======> let x = undefined in ()
+T23036.hs:8:6-35: Splicing expression
+    [| let !x = undefined in () |] ======> let !x = undefined in ()
+T23036.hs:9:6-35: Splicing expression
+    [| let ~x = undefined in () |] ======> let ~x = undefined in ()
+T23036.hs:13:6-39: Splicing expression
+    [| let !(x, y) = undefined in () |]
+  ======>
+    let !(x, y) = undefined in ()
+T23036.hs:14:6-42: Splicing expression
+    [| let (!x, y, ~z) = undefined in () |]
+  ======>
+    let (!x, y, ~z) = undefined in ()
+T23036.hs:15:6-42: Splicing expression
+    [| let f !x ~y z = undefined in () |]
+  ======>
+    let f !x ~y z = undefined in ()


=====================================
testsuite/tests/th/all.T
=====================================
@@ -559,3 +559,4 @@ test('T22784', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T22818', normal, compile, ['-v0'])
 test('T22819', normal, compile, ['-v0'])
 test('TH_fun_par', normal, compile, [''])
+test('T23036', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])


=====================================
testsuite/tests/typecheck/should_compile/T23018.hs
=====================================
@@ -0,0 +1,9 @@
+module T23018 where
+
+import qualified Control.DeepSeq as DeepSeq
+
+class XX f where
+   rnf :: DeepSeq.NFData a => f a -> ()
+
+instance XX Maybe where
+   rnf = DeepSeq.rnf


=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -863,3 +863,4 @@ test('T22912', normal, compile, [''])
 test('T22924', normal, compile, [''])
 test('T22985a', normal, compile, ['-O'])
 test('T22985b', normal, compile, [''])
+test('T23018', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ab16d39cc9bcd5b34071e18c82d0473891fa0ed3...70a3436804ad6a385c3199ac63b4bf5168ba1c15

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ab16d39cc9bcd5b34071e18c82d0473891fa0ed3...70a3436804ad6a385c3199ac63b4bf5168ba1c15
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/20230302/897bac6e/attachment-0001.html>


More information about the ghc-commits mailing list