GitLab

Simon Jakobi pushed to branch wip/sjakobi/T25181 at Glasgow Haskell Compiler / GHC

Commits:

22a6adcc

by Simon Jakobi at 2026-07-05T12:47:01+02:00

Simplifier: unbox through seq# on manifest values (#25181)

For 'case seq# <manifest-value> s of (# s', r #) -> rhs' the Simplifier
previously could neither let case-of-known-constructor see through r nor
discard the seq#, so programs like T25181 retained a redundant box (and
480MB of allocation in the reproducer, vs 40KB on GHC 9.8).

This patch adds three cooperating transformations in
GHC.Core.Opt.Simplify.Iteration, restricted to manifest values (never
merely-known-evaluated variables, which would reintroduce the #24334
unsoundness):

* rebuildCase (0): ANF-ise a constructor argument of seq# when the
  result is scrutinised immediately, so that the unfolding below is
  expandable.
* simplAlt: give the seq# result binder an unfolding pointing at the
  manifest-value argument, enabling case-of-known-constructor.
* rebuildCase (2c): discard 'case seq# <manifest-value> s of
  (# s', _dead #) -> rhs' to rhs[s/s'].

See the new (SEQ5) in Note [seq# magic] in GHC.Types.Id.Make.

Adds the reproducer as perf test T25181.

Assisted-by: Claude Fable 5

4 changed files:

compiler/GHC/Core/Opt/Simplify/Iteration.hs
compiler/GHC/Types/Id/Make.hs
+ testsuite/tests/perf/should_run/T25181.hs
testsuite/tests/perf/should_run/all.T

Changes:

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

@@ -3218,6 +3218,35 @@ rebuildCase, reallyRebuildCase
     -> SimplCont
     -> SimplM (SimplFloats, OutExpr)
 +--------------------------------------------------
 +--      0. ANF-ise a manifest-value seq# argument
 +--------------------------------------------------
++
 +rebuildCase (saf,env) scrut case_bndr alts@[Alt _ [_token, res] rhs] cont
 +  -- ANF-ise `case seq# (Con e1 .. en) s of (# s', r #) -> case r of ...`
 +  -- to `let a1 = e1 .. in case seq# (Con a1 .. an) s of ...`, so that
 +  -- simplAlt can give `r` an *expandable* unfolding `Con a1 .. an` and
 +  -- case-of-known-constructor can see through the seq#.
 +  -- Guarded on `r` being scrutinised immediately, which guarantees that the
 +  -- unfolding pays off; otherwise the let-floats would just be inlined back
 +  -- on the next iteration. See (SEQ5) in Note [seq# magic] in GHC.Types.Id.Make
 +  | (Var f, [ty_a, ty_s, arg, tok]) <- collectArgs scrut
 +  , f `hasKey` seqHashKey
 +  , scrutinises_res rhs
 +  , exprIsManifestValue arg
 +  , (_, con_args) <- collectArgs arg
 +  , any (\a -> isValArg a && not (exprIsTrivial a)) con_args
 +  = do { (anf_floats, arg') <- prepareRhs env NotTopLevel (fsLit "sat") arg
 +       ; let floats = emptyFloats env `addLetFloats` anf_floats
 +             env'   = env `setInScopeFromF` floats
 +             scrut' = Var f `mkApps` [ty_a, ty_s, arg', tok]
 +       ; (floats2, expr') <- rebuildCase (saf,env') scrut' case_bndr alts cont
 +       ; return (floats `addFloats` floats2, expr') }
 +  where
 +    scrutinises_res (Case (Var v) _ _ _) = v == res
 +    scrutinises_res (Tick _ e)           = scrutinises_res e
 +    scrutinises_res _                    = False
++
  --------------------------------------------------
  --      1. Eliminate the case if there's a known constructor
  --------------------------------------------------
@@ -3292,7 +3321,21 @@ rebuildCase (saf,env) scrut case_bndr alts@[Alt _ bndrs rhs] cont
         ; (floats2, expr') <- simplExprF env' rhs cont
         ; return (floats1 `addFloats` floats2, expr') }
 -  -- 2c. Try the seq rules if
 +  -- 2c. Discard a seq# on a manifest value if its result is dead:
 +  --       case seq# <manifest-value> s of (# s', _ #) -> rhs ==> rhs[s/s']
 +  --     See (SEQ5) in Note [seq# magic] in GHC.Types.Id.Make
 +  | [token_out, res] <- bndrs
 +  , isDeadBinder res, isDeadBinder case_bndr
 +  , (Var f, [_ty1, _ty2, arg, Var token_in]) <- collectArgs scrut
 +  , f `hasKey` seqHashKey
 +  , exprIsManifestValue arg
 +  , exprOkToDiscard arg
 +  = do { tick (CaseElim case_bndr)
 +       ; (floats1, env')  <- simplAuxBind (saf,env) token_out (Var token_in)
 +       ; (floats2, expr') <- simplExprF env' rhs cont
 +       ; return (floats1 `addFloats` floats2, expr') }
++
 +  -- 2d. Try the seq rules if
    --     a) it binds only the case binder
    --     b) a rule for seq applies
    -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make
@@ -3317,6 +3360,24 @@ rebuildCase (saf,env) scrut case_bndr alts cont
    | otherwise
    = reallyRebuildCase (saf,env) scrut case_bndr alts cont
 +exprIsManifestValue :: OutExpr -> Bool
 +-- True of expressions that are values no matter what the context:
 +-- literals, lambdas, and (saturated or partial) constructor applications.
 +-- Unlike exprIsHNF, never true for a variable that is merely *known* to be
 +-- evaluated: for the seq#-discarding transformations that use this
 +-- predicate, such a variable carries a dependency on its binding site that
 +-- must not be lost. See (SEQ5) in Note [seq# magic] in GHC.Types.Id.Make.
 +exprIsManifestValue e = go e
 +  where
 +    go (Cast e _) = go e
 +    go (Tick t e) = not (tickishCounts t) && go e
 +    go (Lit _)    = True
 +    go (Lam b e)  = isRuntimeVar b || go e
 +    go (Var f)    = isDataConWorkId f
 +    go e@(App {}) | (Var f, _) <- collectArgs e
 +                  = isDataConWorkId f && exprIsHNF e
 +    go _          = False
++
  doCaseToLet :: OutExpr          -- Scrutinee
              -> InId             -- Case binder
              -> Bool
@@ -3590,7 +3651,21 @@ simplAlt (saf,env) scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rh
                con_app = mkConApp2 con inst_tys' vs'
                env''   = addAltUnfoldings env' case_bndr' bndr_swap' con_app
 -        ; rhs' <- simplAltExprC (saf,env'') rhs cont'
 +              -- If the scrutinee is (seq# <manifest-value> s), record that
 +              -- value as the unfolding of the result binder, so that
 +              -- case-of-known-constructor can see through the seq#.
 +              -- See (SEQ5) in Note [seq# magic] in GHC.Types.Id.Make
 +              env_seq | Just scr <- scrut'
 +                      , isUnboxedTupleDataCon con
 +                      , [_token, res] <- vs'
 +                      , (Var f, [_ty1, _ty2, arg, _]) <- collectArgs scr
 +                      , f `hasKey` seqHashKey
 +                      , exprIsManifestValue arg
 +                      = addBinderUnfolding env'' res $
 +                        mkSimpleUnfolding (seUnfoldingOpts env) arg
 +                      | otherwise = env''
++
 +        ; rhs' <- simplAltExprC (saf,env_seq) rhs cont'
          ; return (Alt (DataAlt con) vs' rhs') }
  {- Note [Adding evaluatedness info to pattern-bound variables]

compiler/GHC/Types/Id/Make.hs

@@ -2516,6 +2516,43 @@ Things to note
    example in #24334 (immortalised as test T24334) for why it should be done in
    CorePrep.
 +(SEQ5)
 +  T25181 shows that we additionally want to unbox through seq# when its
 +  argument is a manifest value:
++
 +      case seq# (f x, y) s of (# s', p #) ->
 +      case p of (a, b) -> rhs
++
 +  Evaluating a manifest value (a literal, lambda, or constructor application;
 +  see exprIsManifestValue in GHC.Core.Opt.Simplify.Iteration) is a no-op, so
 +  here seq# guarantees nothing beyond ordinary data dependencies; the only
 +  remaining cost is the allocation of the value itself, which we want the
 +  Simplifier to eliminate where possible. Hence three cooperating
 +  transformations in GHC.Core.Opt.Simplify.Iteration:
++
 +  * rebuildCase (0) ANF-ises the seq# argument when the result is scrutinised
 +    immediately: `let sat = f x in case seq# (sat, y) s of ...`. Without this
 +    the unfolding below would be a con-app with non-trivial fields, which is
 +    not *expandable*, so exprIsConApp_maybe would refuse to expand it and
 +    case-of-known-constructor would never fire.
++
 +  * simplAlt gives `p` an unfolding `(sat, y)`, so that
 +    case-of-known-constructor rewrites `case p of (a, b) -> rhs` to
 +    `let a = sat; b = y in rhs`, typically making `p` dead.
++
 +  * rebuildCase (2c) then discards the seq# when its result is dead:
 +      case seq# <manifest-value> s of (# s', _ #) -> rhs[s']  ==>  rhs[s]
++
 +  Soundness: unlike the late, unsound seqRule of #24334, all transformations
 +  demand a *manifest* value, not a variable that is merely known to be
 +  evaluated (hence exprIsManifestValue, not exprIsHNF). Discarding
 +  `seq# x s` for an evaluated variable `x` would lose the syntactic
 +  dependency of the continuation on `x`, allowing lazy computations to float
 +  past x's binding site and thereby evaluate too early; see the `pseq`
 +  example in #24334. A manifest value, by contrast, converges unconditionally
 +  and depends on nothing except its own (pure, discardable) field
 +  expressions, so no ordering constraint is lost.
++
  Implementing seq#.  The compiler has magic for `seq#` in
  - GHC.CoreToStg.Prep.cpeRhsE: Implement (SEQ4).

testsuite/tests/perf/should_run/T25181.hs

 +-- T25181
 +import Control.Exception (evaluate)
++
 +import Prelude hiding (repeat)
++
 +repeat :: a -> [a]
 +repeat a = res
 +  where res = a : res
 +{-# NOINLINE repeat #-}
++
 +silly :: [(Int, Int)] -> IO ()
 +silly = foldr go (pure ())
 +  where
 +    go p r = do
 +      (x, y) <- evaluate p
 +      (x', y') <- evaluate (x + 3, y)
 +      evaluate y'
 +      r
++
 +main :: IO ()
 +-- 10,000,000 repetitions take only a twentieth of a second,
 +-- but allocations go up dramatically if the result is not
 +-- known evaluated.
 +main = silly $ take 10000000 $ repeat (1,1)

testsuite/tests/perf/should_run/all.T

@@ -367,6 +367,12 @@ test('T15226a',
      compile_and_run,
      ['-O'])
 +test('T25181',
 +    [collect_stats('bytes allocated',5),
 +     only_ways(['normal'])],
 +    compile_and_run,
 +    ['-O'])
++
  test('T15263',
      [collect_stats('bytes allocated', 4),
       only_ways(['normal'])],