GitLab

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

Commits:

b0fdf8cd

by Simon Peyton Jones at 2026-10-28T11:10:35+00:00

Restore master's expected output for T26903

The branch had accepted an output with the newtype cast pushed into
each case alternative (before the cast rule in splitContArgs existed).
With that rule the output is identical to master's again.

41989ea5
by Simon Peyton Jones at 2026-10-28T17:44:05+00:00
```
Tidy mkFloatBind

...just refactoring
```
e2d74292
by Simon Peyton Jones at 2026-10-28T17:44:31+00:00
```
Experimental change to simplOutExpr

...for testint
```

4 changed files:

compiler/GHC/Core/Opt/Simplify/Env.hs
compiler/GHC/Core/Opt/Simplify/Iteration.hs
compiler/GHC/Core/Opt/Simplify/Utils.hs
testsuite/tests/simplCore/should_compile/T26903.stderr

Changes:

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

@@ -40,7 +40,7 @@ module GHC.Core.Opt.Simplify.Env (
          SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,
          mkFloatBind, addLetFloat, addLetFloats, addCaseFloat,
          addJoinFloats, addFloats, addFloatBindsF,
 -        extendFloats, isEmptyJoinFloats,
 +        isEmptyJoinFloats,
          doFloatFromRhs, getTopFloatBinds,
          FloatEnable(..), mapLetFloats,
@@ -443,7 +443,7 @@ instance Outputable SimplFloats where
  emptyFloats :: SimplEnvIS -> SimplFloats
  emptyFloats env
 -  = SimplFloats { sfBinds   = nilOL
 +  = SimplFloats { sfBinds   = emptyFloatBinds
                  , sfJoins   = emptyJoinFloats
                  , sfInScope = seInScope env }
@@ -962,14 +962,17 @@ addLetFloat :: SimplFloats -> OutBind -> SimplFloats
  -- makes a FloatCase.
  -- See Note [Using FloatBinds in SimplFloats]
  addLetFloat floats bind
 +  = assert (all (not . isJoinId) (bindersOf bind)) $
 +    add_float floats (mkLetFloat bind)
++
 +mkLetFloat :: OutBind -> FloatBind
 +mkLetFloat bind
    | NonRec bndr rhs <- bind
    , needsCaseBinding (idType bndr) rhs
    = -- This should never happen, but currently does because of #27910
 -    add_float floats (FloatCase rhs bndr DEFAULT [])
+-
 +    FloatCase rhs bndr DEFAULT []
    | otherwise
 -  = assert (all (not . isJoinId) (bindersOf bind)) $
 -    add_float floats (FloatLet bind)
 +  = FloatLet bind
  addCaseFloat :: SimplFloats -> OutExpr -> OutId -> AltCon -> [OutVar] -> SimplFloats
  -- Add a single-alternative case float
@@ -1002,21 +1005,21 @@ mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
  -- extend the incoming SimplEnv's in-scope set with its binders
  -- These binders may already be in the in-scope set,
  -- but may have by now been augmented with more IdInfo
 +-- Works for join-points as well as ordinary let-bindings
  mkFloatBind env bind
 -  = (floats, env { seInScope = sfInScope floats })
 +  = (floats, env { seInScope = in_scope' })
    where
 +    in_scope  = seInScope env
 +    in_scope' = in_scope `extendInScopeSetBind` bind
      -- See Note [Bangs in the Simplifier]
 -    !floats = emptyFloats env `extendFloats` bind
+-
 -extendFloats :: SimplFloats -> OutBind -> SimplFloats
 --- Add this binding (join point or not) to the floats,
 --- and extend the in-scope env too
 -extendFloats floats@(SimplFloats { sfJoins = jfloats, sfInScope = in_scope }) bind
 -  | isJoinBind bind
 -  = floats { sfJoins = jfloats `addJoinFlts` unitJoinFloat bind
 -           , sfInScope    = in_scope `extendInScopeSetBind` bind }
 -  | otherwise
 -  = floats `addLetFloat` bind
 +    !floats | isJoinBind bind
 +            = SimplFloats { sfBinds   = emptyFloatBinds
 +                          , sfJoins   = unitJoinFloat bind
 +                          , sfInScope = in_scope' }
 +            | otherwise
 +            = SimplFloats { sfBinds   = unitOL (mkLetFloat bind)
 +                          , sfJoins   = emptyJoinFloats
 +                          , sfInScope = in_scope' }
  addLetFloats :: SimplFloats -> OrdList OutBind -> SimplFloats
  -- Add the let-bindings /inside/ the existing floats,

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

@@ -36,6 +36,7 @@ import GHC.Core.Ppr     ( pprCoreExpr )
  import GHC.Core.Unfold
  import GHC.Core.Unfold.Make
  import GHC.Core.Utils
 +import GHC.Core.Stats ( exprSize )
  import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe
                            , pushCoTyArg, pushCoValArg, exprIsDeadEnd
                            , typeArity, arityTypeArity, etaExpandAT )
@@ -600,6 +601,7 @@ tryCastWorkerWrapper :: SimplEnv -> BindContext
                       -> InId -> OutId -> OutExpr
                       -> SimplM (SimplFloats, SimplEnv)
  -- See Note [Cast worker/wrapper]
 +-- Binder /can/ be a JoinId
  tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
    | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points
    , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform
@@ -636,7 +638,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
            else do { wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs
                    ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)
                                  `setIdUnfolding`  wrap_unf
 -                        floats' = floats `extendFloats` NonRec bndr' triv_rhs
 +                        floats' = floats `addLetFloat` NonRec bndr' triv_rhs
                    ; return ( floats', setInScopeFromF env floats' ) } }
    where
      -- Force the occ_fs so that the old Id is not retained in the new Id.
@@ -1655,6 +1657,10 @@ rebuildWithFloats :: SimplEnv -> SimplFloats -> OutExpr -> SimplCont
                    -> SimplM (SimplFloats, OutExpr)
  -- (rebuildWithFloats env floats expr cont) rebuilds (let floats in expr)
  -- with continuation `cont`.  Used only when seCaseCase is off.
 +-- The only reason it differs from wrapFloats-then-rebuild is when
 +-- we can do case-of-known-constructor:
 +--     case (let <binds> in Just e) of Just x -> rhs
 +--     --> let <binds> in let x=e in rhs
  -- See (COC3) in Note [sm_case_case: switching off case continuations]
  rebuildWithFloats env floats expr cont
    | Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont' } <- cont
@@ -2409,11 +2415,53 @@ simplOutExpr :: HasDebugCallStack
  --
  -- What if expr = (K x y) and cont is `Select`?  That is handled by rebuild.
  --   (Why?  That's a bit inconsistent with beta.)
 -simplOutExpr env expr cont
 +simplOutExpr env _expr _cont
    | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) $
      False  -- Just checks the assertion!
    = panic "simplOutExpr"
 +simplOutExpr env expr cont
 +  | contIsStop cont
 +  = rebuild_go env expr cont
++
 +simplOutExpr env expr@(Var v) cont
 +  | isDataConWorkId v = rebuild_go env expr cont
 +  | otherwise         = simplOutId env v cont
 +simplOutExpr env (App fun (Type ty)) cont
 +  = simplOutExpr env fun (ApplyToTy { sc_arg_ty = ty, sc_hole_ty = exprType fun, sc_cont = cont })
 +simplOutExpr env (App fun arg) cont
 +  = simplOutExpr env fun (ApplyToVal { sc_arg = arg, sc_env = Simplified NoDup, sc_cast = MRefl
 +                                 , sc_hole_ty = exprType fun, sc_cont = cont })
 +simplOutExpr env (Cast e co) cont
 +  = do { cont' <- pushCast env co cont; simplOutExpr env e cont' }
 +simplOutExpr env expr@(Lam {}) cont
 +  | hasArgs cont = reSimplifyOutExpr env expr cont  -- Beta-reduce
 +  | otherwise    = rebuild_go env expr cont
++
 +simplOutExpr env expr@(Case {}) cont
 +  -- `cont` is not a Stop (first equation), so pushing it into the
 +  -- alternatives now saves leaving a case-of-case, or a (case ...) arg
 +  -- redex, for the next iteration.  But only for small expressions:
 +  -- see (RSO2) in Note [Re-simplifying an OutExpr]
 +  | exprSize expr <= reSimplifyThreshold = reSimplifyOutExpr env expr cont
 +  | otherwise                            = rebuild_go env expr cont
++
 +simplOutExpr env expr@(Let {}) cont
 +  = -- For now just give up, but we could probably do better
 +    rebuild_go env expr cont
++
 +simplOutExpr env expr@(Tick {}) cont
 +  = rebuild_go env expr cont
 +simplOutExpr env expr@(Coercion {}) cont
 +  = rebuild_go env expr cont
 +simplOutExpr env expr@(Lit {}) cont
 +  = rebuild_go env expr cont
++
 +simplOutExpr _env expr@(Type {}) cont
 +  = pprPanic "simplOutExpr:Type" (ppr expr $$ ppr cont)
++
++
 +{-
    | Lam {} <- expr
    , cont_has_args
    = simplLam env (occurAnalyseExpr expr) cont
@@ -2440,6 +2488,80 @@ simplOutExpr env expr cont
    = rebuild_go env expr cont
    where
      cont_has_args = hasArgs cont
 +-}
++
 +reSimplifyOutExpr :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
 +-- See Note [Re-simplifying an OutExpr]
 +reSimplifyOutExpr env expr cont
 +  = simplExprF env (occurAnalyseExpr expr) cont
++
 +reSimplifyThreshold :: Int
 +-- See (RSO2) in Note [Re-simplifying an OutExpr]
 +reSimplifyThreshold = 100
++
 +{- Note [Re-simplifying an OutExpr]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +simplOutExpr is given an already-simplified expression `expr` (an OutExpr,
 +typically from a `DoneEx` in the substitution) and a continuation `cont`.
 +If `expr` is a lambda and `cont` has arguments, or if `expr` is a `case` and
 +`cont` is not a Stop, we want to push `cont` into `expr`: beta-reduce, do
 +case-of-case, apply the arguments in each alternative, and so on.  Otherwise
 +the next Simplifier iteration would have to do it, and extra iterations are
 +expensive (T13056).
++
 +We do this by simply running the Simplifier over `expr` again, with the
 +substitution-free environment `env` (a SimplEnvIS).  That re-simplification
 +is mostly a renaming pass, but it is essential: we must NOT treat the binders
 +inside `expr` as if they were already simplified (e.g. by building a `Select`
 +with `sc_env = Simplified`, so that the alternatives go through the SAF_Out
 +route and `simplAltBinders` neither clones nor records the alternative binders).
 +Here is why:
++
 +* The binders inside an OutExpr are not in the in-scope set at the point where
 +  `expr` is used.  (The in-scope set records only binders that scope over the
 +  current point, not binders nested inside expressions in the substitution.)
++
 +* Fresh uniques come from `uniqAway`, which deterministically picks the next
 +  unique above the largest in the in-scope set.  So a binder created while
 +  simplifying `expr` (at its original binding site) and a binder created later
 +  elsewhere, from an in-scope set that does not contain the former, can share
 +  a unique.
++
 +* So if we pushed `cont` into the alternatives without cloning the alternative
 +  binders against the current in-scope set, free variables of `cont` could be
 +  captured; and any Core operation that relies on the in-scope set, such as
 +  `exprIsConApp_maybe`, may crash (T9630: lookupIdSubst panic).
++
 +Re-simplifying with an empty substitution cures all this: `simplBinders`
 +clones every binder whose unique is in scope and extends the in-scope set
 +with every binder.  (This is also what happens when an unfolding is inlined.)
++
 +Two further points:
++
 +(RSO1) We occurrence-analyse `expr` first because its occurrence info may be
 +  stale: the Simplifier may have duplicated occurrences of binders inside
 +  `expr` (by case-of-case, say) without updating the binders' OccInfo.
 +  Compare Note [Occurrence-analyse after rule firing].
++
 +(RSO2) The cost of re-simplifying is proportional to the size of `expr`, and
 +  that can go quadratic.  In T15630 we get a chain
 +      f1 = case f0 of {...};  f2 = case f1 of {...};  f3 = case f2 of {...}; ...
 +  where each `fi` is bound by knownCon (so its RHS is already an OutExpr and
 +  preInlineUnconditionally never sees it), occurs once, and so becomes a
 +  `DoneEx` via postInlineUnconditionally.  Its one occurrence is scrutinised
 +  by a case, so we arrive here with a `Select` continuation, and the
 +  re-simplified result of level i is contained in `expr` at level i+1.
 +  Re-simplifying at every level costs O(n^2) in the length of the chain,
 +  whereas simply rebuilding leaves case-of-case redexes that the next
 +  iteration deals with in one linear pass.
++
 +  So we re-simplify only if `expr` is smaller than `reSimplifyThreshold`.
 +  That keeps the win on T13056 (whose re-simplified expressions all have
 +  size < 60, and where it saves a Simplifier iteration) and avoids the
 +  quadratic cost on T15630 and T15630a (chain members of size 100-320).
 +  A lambda applied to arguments is always re-simplified: beta-reduction is
 +  too good to miss.
 +-}
  ---------------------------------------------------------
  simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
@@ -4369,11 +4491,36 @@ mkDupableContWithDmds env dmds
          ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont
          ; let env' = env `setInScopeFromF` floats1
          ; arg' <- simplArg env' Nothing hole_ty se arg arg_mco
 -        ; (let_floats2, triv_arg) <- makeTrivial env' NotTopLevel dmd (fsLit "karg") arg'
 +        ; (let_floats2, dup_arg)
 +             <- if small_enough_to_dup dmd arg'
 +                then return (nilOL, arg')  -- See Note [Duplicating small arguments]
 +                else makeTrivial env' NotTopLevel dmd (fsLit "karg") arg'
          ; let all_floats = floats1 `addLetFloats` let_floats2
          ; return ( all_floats
 -                 , ApplyToVal { sc_arg = triv_arg, sc_env = Simplified OkDup
 +                 , ApplyToVal { sc_arg = dup_arg, sc_env = Simplified OkDup
                                , sc_cast = MRefl, sc_cont = cont', sc_hole_ty = hole_ty }) }
 +  where
 +    -- See Note [Duplicating small arguments]
 +    small_enough_to_dup dmd arg
 +      = not (isStrUsedDmd dmd) && exprIsDupable (sePlatform env) arg
++
 +{- Note [Duplicating small arguments]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +When mkDupableCont makes an (ApplyToVal arg) continuation duplicable, it
 +let-binds the argument,  karg = arg, and duplicates (ApplyToVal karg).  So
 +     (case x of { A -> f; B -> g }) arg
 +     ==>  let karg = arg in case x of { A -> f karg; B -> g karg }
 +But if `arg` is small, the very next Simplifier iteration will inline karg into
 +both branches (postInlineUnconditionally: lazy, one occurrence per branch, and
 +smallEnoughToInline), costing an entire extra iteration for nothing (T13056).
 +So we duplicate such an argument straight away if it is not strictly demanded
 +(a strict one costs no allocation, so there is nothing to gain by duplicating
 +it) and it is `exprIsDupable`.  That is not quite postInlineUnconditionally's
 +criterion (`smallEnoughToInline`), but it is much cheaper than building an
 +unfolding just to measure it, and getting it slightly wrong is harmless:
 +if we fail to duplicate, karg is inlined in the next iteration as before.
 +Duplication is work-safe because only one alternative is executed.
 +-}
  mkDupableContWithDmds env _
      (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })

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

@@ -2999,6 +2999,7 @@ simplWrapFloats :: SimplMode -> SimplFloats
                  -> SimplM OutExpr
  -- Wrap the floats around the body, using mkCase for case-floats
  -- See Note [Wrapping case-floats with mkCase]
 +-- Monadic only because of the `mkCase`
  simplWrapFloats mode (SimplFloats { sfBinds = lfs, sfJoins = jbs }) body body_ty
    = go (fromOL lfs)
    where

testsuite/tests/simplCore/should_compile/T26903.stderr

  ==================== Tidy Core ====================
  Result size of Tidy Core
 -  = {terms: 127, types: 130, coercions: 24, joins: 0/0}
 +  = {terms: 127, types: 130, coercions: 48, joins: 0/0}
  $dmop
 -  = \ @a $dC $dOrd xs ys ->
 -      case $fOrdList_$ccompare $dOrd xs ys of {
 -        __DEFAULT ->
 -          (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [])
 -          `cast` <Co:3>;
 -        GT ->
 -          (reverse1 (reverse1 (reverse1 (reverse xs) []) []) [])
 -          `cast` <Co:3>
 -      }
 +  = (\ @a _ $dOrd xs ys ->
 +       case $fOrdList_$ccompare $dOrd xs ys of {
 +         __DEFAULT ->
 +           reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
 +         GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
 +       })
 +    `cast` <Co:20> :: ...
  $fCInt_$cop
 -  = \ xs ys ->
 -      case $fOrdList_$s$ccompare xs ys of {
 -        __DEFAULT ->
 -          (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [])
 -          `cast` <Co:3>;
 -        GT ->
 -          (reverse1 (reverse1 (reverse1 (reverse xs) []) []) [])
 -          `cast` <Co:3>
 -      }
 +  = (\ xs ys ->
 +       case $fOrdList_$s$ccompare xs ys of {
 +         __DEFAULT ->
 +           reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
 +         GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
 +       })
 +    `cast` <Co:11> :: ...
  $fCInt1
    = \ xs ys ->
        case $fOrdList_$s$ccompare xs ys of {
          __DEFAULT ->
 -          (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [])
 -          `cast` <Co:3>;
 -        GT ->
 -          (reverse1 (reverse1 (reverse1 (reverse xs) []) []) [])
 -          `cast` <Co:3>
 +          reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
 +        GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
+       }
 -$fCInt = C:C $fCInt1
 +$fCInt = C:C ($fCInt1 `cast` <Co:11> :: ...)
  test4 = reverse1 [] []
@@ -51,8 +44,8 @@ test
        case $fOrdList_$s$ccompare [] xs of {
          __DEFAULT ->
            (reverse1 (reverse1 (reverse1 (reverse1 (++ [] xs) []) []) []) [])
 -          `cast` <Co:3>;
 -        GT -> test1 `cast` <Co:3>
 +          `cast` <Co:3> :: ...;
 +        GT -> test1 `cast` <Co:3> :: ...
+       }