GitLab

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

Commits:

9be7029d
by Simon Peyton Jones at 2026-01-30T13:03:27+00:00
```
Expand tyvars in Specialise

Pretty important!
```
1347e1f2
by Simon Peyton Jones at 2026-01-30T13:04:00+00:00
```
Comments only
```

Changes:

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

@@ -823,8 +823,8 @@ andFF FltOkSpec  _          = FltOkSpec
  andFF FltLifted  flt        = flt
 -doFloatFromRhs :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool
 -               -> [OutTyVar] -> SimplFloats -> OutExpr -> Bool
 +doFloatFromRhs :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool -> [OutTyVar]
 +               -> SimplFloats -> OutExpr -> Bool
  -- If you change this function look also at FloatIn.noFloatIntoRhs
  doFloatFromRhs env lvl rec strict_bind tvs (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
    = not (isNilOL fs)

compiler/GHC/Core/Opt/Specialise.hs

@@ -2626,17 +2626,23 @@ specHeader subst (bndr:bndrs) (SpecType ty : args)
           -- See (MP2) in Note [Specialising polymorphic dictionaries]
           let in_scope = Core.substInScopeSet subst
               not_in_scope tv = not (tv `elemInScopeSet` in_scope)
++
 +             expanded_ty = expandSomeTyVarUnfoldings not_in_scope ty
 +                  -- expanded_ty: consider f @(Maybe (a{=Int})
 +                  -- We don't want to abstract over `a`!  So, expand
 +                  -- unfoldings of any not-in-scope tyavars
++
               free_tvs = scopedSort $ fvVarList $
                          filterFV not_in_scope  $
 -                        tyCoFVsOfType ty
 +                        tyCoFVsOfType expanded_ty
               subst1 = subst `Core.extendSubstInScopeList` free_tvs
 -       ; let subst2 = Core.extendTvSubst subst1 bndr ty
 +       ; let subst2 = Core.extendTvSubst subst1 bndr expanded_ty
         ; (useful, subst3, rule_bs, rule_args, spec_bs, dx, spec_args)
               <- specHeader subst2 bndrs args
         ; pure ( useful, subst3
 -              , free_tvs ++ rule_bs,     Type ty : rule_args
 -              , free_tvs ++ spec_bs, dx, Type ty : spec_args ) }
 +              , free_tvs ++ rule_bs,     Type expanded_ty : rule_args
 +              , free_tvs ++ spec_bs, dx, Type expanded_ty : spec_args ) }
  -- Next we have a type that we don't want to specialise. We need to perform
  -- a substitution on it (in case the type refers to 'a'). Additionally, we need

compiler/GHC/Core/Utils.hs

@@ -1618,6 +1618,101 @@ in this (which it previously was):
                                in g
                        False -> \x. x
              in \w. v True
++
 +Note [isCheapApp: bottoming functions]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +I'm not sure why we have a special case for bottoming
 +functions in isCheapApp.  Maybe we don't need it.
++
 +Note [exprIsExpandable]
 +~~~~~~~~~~~~~~~~~~~~~~~
 +An expression is "expandable" if we are willing to duplicate it, if doing
 +so might make a RULE or case-of-constructor fire.  Consider
 +   let x = (a,b)
 +       y = build g
 +   in ....(case x of (p,q) -> rhs)....(foldr k z y)....
++
 +We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold),
 +but we do want
++
 + * the case-expression to simplify
 +   (via exprIsConApp_maybe, exprIsLiteral_maybe)
++
 + * the foldr/build RULE to fire
 +   (by expanding the unfolding during rule matching)
++
 +So we classify the unfolding of a let-binding as "expandable" (via the
 +uf_expandable field) if we want to do this kind of on-the-fly
 +expansion.  Specifically:
++
 +* True of constructor applications (K a b)
++
 +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.
 +  (NB: exprIsCheap might not be true of this)
++
 +* False of case-expressions.  If we have
 +    let x = case ... in ...(case x of ...)...
 +  we won't simplify.  We have to inline x.  See #14688.
++
 +* False of let-expressions (same reason); and in any case we
 +  float lets out of an RHS if doing so will reveal an expandable
 +  application (see SimplEnv.doFloatFromRhs).
++
 +* Take care: exprIsExpandable should /not/ be true of primops.  I
 +  found this in test T5623a:
 +    let q = /\a. Ptr a (a +# b)
 +    in case q @ Float of Ptr v -> ...q...
++
 +  q's inlining should not be expandable, else exprIsConApp_maybe will
 +  say that (q @ Float) expands to (Ptr a (a +# b)), and that will
 +  duplicate the (a +# b) primop, which we should not do lightly.
 +  (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)
++
 +NB: exprIsWorkFree implies exprIsExpandable.
++
 +Note [isExpandableApp: bottoming functions]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +It's important that isExpandableApp does not respond True to bottoming
 +functions.  Recall  undefined :: HasCallStack => a
 +Suppose isExpandableApp responded True to (undefined d), and we had:
++
 +  x = undefined <dict-expr>
++
 +Then Simplify.prepareRhs would ANF the RHS:
++
 +  d = <dict-expr>
 +  x = undefined d
++
 +This is already bad: we gain nothing from having x bound to (undefined
 +var), unlike the case for data constructors.  Worse, we get the
 +simplifier loop described in OccurAnal Note [Cascading inlines].
 +Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will
 +certainly_inline; so we end up inlining d right back into x; but in
 +the end x doesn't inline because it is bottom (preInlineUnconditionally);
 +so the process repeats.. We could elaborate the certainly_inline logic
 +some more, but it's better just to treat bottoming bindings as
 +non-expandable, because ANFing them is a bad idea in the first place.
++
 +Note [Record selection]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~
 +I'm experimenting with making record selection
 +look cheap, so we will substitute it inside a
 +lambda.  Particularly for dictionary field selection.
++
 +BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
 +there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
++
 +Note [Expandable overloadings]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +Suppose the user wrote this
 +   {-# RULE  forall x. foo (negate x) = h x #-}
 +   f x = ....(foo (negate x))....
 +They'd expect the rule to fire. But since negate is overloaded, we might
 +get this:
 +    f = \d -> let n = negate d in \x -> ...foo (n x)...
 +So we treat the application of a function (negate in this case) to a
 +*dictionary* as expandable.  In effect, every function is CONLIKE when
 +it's applied only to dictionaries.
  -}
  -------------------------------------
@@ -1690,6 +1785,10 @@ isWorkFreeApp fn n_val_args
        _                -> False
  isCheapApp :: CheapAppFun
 +-- Like isWorkFreeApp, but add:
 +--   - bottoming applications
 +--   - cheap (rather than just work-free) primops
 +--   - record selectors applied to just the record
  isCheapApp fn n_val_args
    | isWorkFreeApp fn n_val_args = True
    | isDeadEndId fn              = True  -- See Note [isCheapApp: bottoming functions]
@@ -1706,6 +1805,10 @@ isCheapApp fn n_val_args
          -- to bother to check the number of args
  isExpandableApp :: CheapAppFun
 +-- Like isWorkFreeApp, but add:
 +--   - record selectors applied to just the record
 +--   - ConLike Ids (if not bottoming)
 +--   - a function applied to dictionaries
  isExpandableApp fn n_val_args
    | isWorkFreeApp fn n_val_args = True
    | otherwise
@@ -1737,101 +1840,6 @@ isExpandableApp fn n_val_args
         | otherwise
         = False
 -{- Note [isCheapApp: bottoming functions]
 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -I'm not sure why we have a special case for bottoming
 -functions in isCheapApp.  Maybe we don't need it.
+-
 -Note [exprIsExpandable]
 -~~~~~~~~~~~~~~~~~~~~~~~
 -An expression is "expandable" if we are willing to duplicate it, if doing
 -so might make a RULE or case-of-constructor fire.  Consider
 -   let x = (a,b)
 -       y = build g
 -   in ....(case x of (p,q) -> rhs)....(foldr k z y)....
+-
 -We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold),
 -but we do want
+-
 - * the case-expression to simplify
 -   (via exprIsConApp_maybe, exprIsLiteral_maybe)
+-
 - * the foldr/build RULE to fire
 -   (by expanding the unfolding during rule matching)
+-
 -So we classify the unfolding of a let-binding as "expandable" (via the
 -uf_expandable field) if we want to do this kind of on-the-fly
 -expansion.  Specifically:
+-
 -* True of constructor applications (K a b)
+-
 -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.
 -  (NB: exprIsCheap might not be true of this)
+-
 -* False of case-expressions.  If we have
 -    let x = case ... in ...(case x of ...)...
 -  we won't simplify.  We have to inline x.  See #14688.
+-
 -* False of let-expressions (same reason); and in any case we
 -  float lets out of an RHS if doing so will reveal an expandable
 -  application (see SimplEnv.doFloatFromRhs).
+-
 -* Take care: exprIsExpandable should /not/ be true of primops.  I
 -  found this in test T5623a:
 -    let q = /\a. Ptr a (a +# b)
 -    in case q @ Float of Ptr v -> ...q...
+-
 -  q's inlining should not be expandable, else exprIsConApp_maybe will
 -  say that (q @ Float) expands to (Ptr a (a +# b)), and that will
 -  duplicate the (a +# b) primop, which we should not do lightly.
 -  (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)
+-
 -NB: exprIsWorkFree implies exprIsExpandable.
+-
 -Note [isExpandableApp: bottoming functions]
 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -It's important that isExpandableApp does not respond True to bottoming
 -functions.  Recall  undefined :: HasCallStack => a
 -Suppose isExpandableApp responded True to (undefined d), and we had:
+-
 -  x = undefined <dict-expr>
+-
 -Then Simplify.prepareRhs would ANF the RHS:
+-
 -  d = <dict-expr>
 -  x = undefined d
+-
 -This is already bad: we gain nothing from having x bound to (undefined
 -var), unlike the case for data constructors.  Worse, we get the
 -simplifier loop described in OccurAnal Note [Cascading inlines].
 -Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will
 -certainly_inline; so we end up inlining d right back into x; but in
 -the end x doesn't inline because it is bottom (preInlineUnconditionally);
 -so the process repeats.. We could elaborate the certainly_inline logic
 -some more, but it's better just to treat bottoming bindings as
 -non-expandable, because ANFing them is a bad idea in the first place.
+-
 -Note [Record selection]
 -~~~~~~~~~~~~~~~~~~~~~~~~~~
 -I'm experimenting with making record selection
 -look cheap, so we will substitute it inside a
 -lambda.  Particularly for dictionary field selection.
+-
 -BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
 -there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
+-
 -Note [Expandable overloadings]
 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -Suppose the user wrote this
 -   {-# RULE  forall x. foo (negate x) = h x #-}
 -   f x = ....(foo (negate x))....
 -They'd expect the rule to fire. But since negate is overloaded, we might
 -get this:
 -    f = \d -> let n = negate d in \x -> ...foo (n x)...
 -So we treat the application of a function (negate in this case) to a
 -*dictionary* as expandable.  In effect, every function is CONLIKE when
 -it's applied only to dictionaries.
 --}
  isUnaryClassId :: Id -> Bool
  -- True of (a) the method selector (classop)
@@ -3265,8 +3273,8 @@ So:
  * When we make an AbsVars list, we close over the free vars of the unfoldings
    of any tyvars in it.  So if `b{=Maybe a}` is in the list then so is `a`
 -* `mkCoreAbsLams` (more generally `mkPolyAbsLams`) forms a lambda abstraction pushing
 -   the tyvar bindings into the body:
 +* `mkCoreAbsLams` (more generally `mkPolyAbsLams`) forms a lambda abstraction
 +   pushing the tyvar bindings into the body:
        mkCoreAbsLams [a, b=[a], x:b] body
           = \a. \(x:[a]). let @b = [a] in
                           let x:b = x in   -- See (AFV1)
@@ -3301,8 +3309,10 @@ type TaggedAbsVars t = [TaggedBndr t]
  mkPolyAbsLams :: forall b. (b -> AbsVar, Var -> b -> b)
                          -> [b] -> Expr b -> Expr b
 --- `mkPolyAbsLams` is polymorphic in (get,set) so that we can
 --- use it for both CoreExpr and LevelledExpr
 +-- `mkPolyAbsLams` is polymorphic in (get,set) so that we
 +-- can use it for both CoreExpr and LevelledExpr.  See
 +--     - mkCoreAbsLams
 +--     - mkTaggedAbsLams
  {-# INLINE mkPolyAbsLams #-}
  mkPolyAbsLams (getter,setter) bndrs body
    = go emptyVarSet [] bndrs