GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

269c4087

by Simon Peyton Jones at 2026-02-01T19:38:10-05:00

Include current phase in the range for rule/unfoldings

This MR fixes a bad loop in the compiler: #26826.

The fix is to add (WAR2) to
   Note [What is active in the RHS of a RULE or unfolding?]
in GHC.Core.Opt.Simplify.Utils

7 changed files:

compiler/GHC/Core/Opt/OccurAnal.hs
compiler/GHC/Core/Opt/Simplify/Env.hs
compiler/GHC/Core/Opt/Simplify/Utils.hs
compiler/GHC/Core/Opt/WorkWrap.hs
compiler/GHC/Types/InlinePragma.hs
+ testsuite/tests/simplCore/should_compile/T26826.hs
testsuite/tests/simplCore/should_compile/all.T

Changes:

compiler/GHC/Core/Opt/OccurAnal.hs

@@ -1417,16 +1417,17 @@ then we *must* choose f to be a loop breaker.  Example: see Note
  That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.
  Wrinkles:
 -* We only consider /active/ rules. See Note [Finding rule RHS free vars]
 +(RLB1) We only consider /active/ rules.
 +  This is important: see Note [Finding rule RHS free vars]
 -* We need only consider free vars that are also binders in this Rec
 +(RLB2) We need only consider free vars that are also binders in this Rec
    group.  See also Note [Finding rule RHS free vars]
 -* We only consider variables free in the *RHS* of the rule, in
 +(RLB3) We only consider variables free in the *RHS* of the rule, in
    contrast to the way we build the Rec group in the first place (Note
    [Rule dependency info])
 -* Why "transitive sequence of rules"?  Because active rules apply
 +(RLB4) Why "transitive sequence of rules"?  Because active rules apply
    unconditionally, without checking loop-breaker-ness.
   See Note [Loop breaker dependencies].
@@ -1854,10 +1855,13 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
      add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds
      -------- active_rule_fvs ------------
 +    -- See Note [Rules and loop breakers]
      active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds
      add_active_rule (rule, _, rhs_uds) fvs
 -      | is_active (ruleActivation rule)
 +      | is_active (ruleActivation rule)  -- See (RLB1)
        = udFreeVars bndr_set rhs_uds `unionVarSet` fvs
 +        -- Only consider the `rhs_uss`, not the LHS ones; see (RLB3)
 +        -- udFreeVars restricts to bndr_set; see (RLB2)
        | otherwise
        = fvs

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

@@ -12,7 +12,7 @@ module GHC.Core.Opt.Simplify.Env (
          -- * Environments
          SimplEnv(..), pprSimplEnv,   -- Temp not abstract
 -        SimplPhase(..), isActive,
 +        SimplPhase(..), isActive, simplStartPhase, simplEndPhase,
          seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,
          seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,
          seOptCoercionOpts, sePhase, sePlatform, sePreInline,
@@ -293,7 +293,9 @@ data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad
  -- | See Note [SimplPhase]
  data SimplPhase
    -- | A simplifier phase: InitialPhase, Phase 2, Phase 1, Phase 0, FinalPhase
 +  -- NB: (SimplPhase p) is equivalent to (SimplPhaseRange p p)
    = SimplPhase CompilerPhase
++
    -- | Simplifying the RHS of a rule or of a stable unfolding: the range of
    -- phases of the activation of the rule/stable unfolding.
    --
@@ -302,13 +304,18 @@ data SimplPhase
    --
    -- See Note [What is active in the RHS of a RULE or unfolding?]
    --     in GHC.Core.Opt.Simplify.Utils.
 -  | SimplPhaseRange
 -      { simplStartPhase :: CompilerPhase
 -      , simplEndPhase   :: CompilerPhase
 -      }
 +  | SimplPhaseRange CompilerPhase CompilerPhase
    deriving Eq
 +simplStartPhase :: SimplPhase -> CompilerPhase
 +simplStartPhase (SimplPhase p)        = p
 +simplStartPhase (SimplPhaseRange p _) = p
++
 +simplEndPhase :: SimplPhase -> CompilerPhase
 +simplEndPhase (SimplPhase p)        = p
 +simplEndPhase (SimplPhaseRange _ p) = p
++
  instance Outputable SimplPhase where
    ppr (SimplPhase p) = ppr p
    ppr (SimplPhaseRange s e) = brackets $ ppr s <> ellipsis <> ppr e
@@ -322,12 +329,13 @@ instance Outputable SimplPhase where
  --
  -- See Note [SimplPhase].
  isActive :: SimplPhase -> ActivationGhc -> Bool
 -isActive (SimplPhase p) act = isActiveInPhase p act
 -isActive (SimplPhaseRange start end) act =
 -  -- To check whether the activation is active throughout the whole phase range,
 -  -- it's sufficient to check the endpoints of the phase range, because an
 -  -- activation can never have gaps (all activations are phase intervals).
 -  isActiveInPhase start act && isActiveInPhase end act
 +isActive (SimplPhase p) act
 +  = isActiveInPhase p act
 +isActive (SimplPhaseRange start end) act
 +  = -- To check whether the activation is active throughout the whole phase range,
 +    -- it's sufficient to check the endpoints of the phase range, because an
 +    -- activation can never have gaps (all activations are phase intervals).
 +    isActiveInPhase start act && isActiveInPhase end act
  {- Note [SimplPhase]
  ~~~~~~~~~~~~~~~~~~~~

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

@@ -1099,7 +1099,7 @@ updModeForStableUnfoldings :: ActivationGhc -> SimplMode -> SimplMode
  -- See Note [Simplifying inside stable unfoldings]
  updModeForStableUnfoldings unf_act current_mode
    = current_mode
 -    { sm_phase = phaseFromActivation (sm_phase current_mode) unf_act
 +    { sm_phase = phaseForRuleOrUnf (sm_phase current_mode) unf_act
          -- See Note [What is active in the RHS of a RULE or unfolding?]
      , sm_eta_expand = False
          -- See Note [Eta expansion in stable unfoldings and rules]
@@ -1123,27 +1123,32 @@ updModeForRuleRHS :: ActivationGhc -> SimplMode -> SimplMode
  updModeForRuleRHS rule_act current_mode =
    current_mode
      -- See Note [What is active in the RHS of a RULE or unfolding?]
 -    { sm_phase = phaseFromActivation (sm_phase current_mode) rule_act
 +    { sm_phase = phaseForRuleOrUnf (sm_phase current_mode) rule_act
      , sm_eta_expand = False
          -- See Note [Eta expansion in stable unfoldings and rules]
+     }
 --- | Compute the phase range to set the 'SimplMode' to
 --- when simplifying the RHS of a rule or of a stable unfolding.
 +-- | `phaseForRuleOrUnf` computes the phase range to use when
 +-- simplifying the RHS of a rule or of a stable unfolding.
  --
 +-- This subtle function implements the careful plan described in
  -- See Note [What is active in the RHS of a RULE or unfolding?]
 -phaseFromActivation
 -  :: SimplPhase             -- ^ the current simplifier phase
 +phaseForRuleOrUnf
 +  :: SimplPhase    -- ^ the current simplifier phase
    -> ActivationGhc -- ^ the activation of the RULE or stable unfolding
    -> SimplPhase
 -phaseFromActivation p act
 -  | isNeverActive act
 -  = p
 +phaseForRuleOrUnf current_phase act
 +  | start == end
 +  = SimplPhase start
    | otherwise
 -  = SimplPhaseRange act_start act_end
 +  = SimplPhaseRange start end
    where
 -    act_start = beginPhase act
 -    act_end   = endPhase   act
 +    start, end :: CompilerPhase
 +    start = beginPhase act `earliestPhase` simplStartPhase current_phase
 +    end   = endPhase   act `latestPhase`   simplEndPhase   current_phase
 +    -- The beginPhase/endPhase           implements (WAR1)
 +    -- The simplStartPhase/simplEndPhase implements (WAR2)
 +    -- of Note [What is active in the RHS of a RULE or unfolding?]
  {- Note [Simplifying rules]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1275,26 +1280,47 @@ Our carefully crafted plan is as follows:
    -------------------------------------------------------------
    When simplifying the RHS of a RULE R with activation range A,
 -  fire only other rules R' that are active throughout all of A.
 +  fire only other rules R' that are active
 +      (WAR1) throughout all of A
 +      (WAR2) in the current phase
 +  See `phaseForRuleOrUnf`.
    -------------------------------------------------------------
 -Reason: R might fire in any phase in A. Then R' can fire only if R' is active
 -in that phase. If not, it's not safe to unconditionally fire R' in the RHS of R.
 +Reasons for (WAR1):
 +  * R might fire in any phase in A. Then R' can fire only if R' is active in that
 +    phase. If not, it's not safe to unconditionally fire R' in the RHS of R.
++
 +Reasons for (WAR2):
 +  * If A is empty (e.g. a NOINLINE pragma, so the unfolding is never active)
 +    we don't want to vacuously satisfy (WAR1) and thereby fire /all/ RULES in
 +    the unfolding.  Two RULES may be crafted so that they are never simultaneously
 +    active, and will loop if they are.
++
 +  * Suppose we are in Phase 2, looking at a stable unfolding for INLINE [1].
 +    If we just do (WAR1) we will fire RULES active in phase 1; but the
 +    occurrence analyser ignores any rules not active in the current phase.
 +    So occ-anal may fail to detect a loop breaker; see #26826 for details.
 +    See Note [Rules and loop breakers] in GHC.Core.Opt.OccurAnal.
++
 +  * Aesthetically, this means that when the simplifer is in phase N, it
 +    won't switch to a phase-range that doesn't include N (e.g. might be later
 +    than N).  This is what caused #26826.
++
 +  * Also note that as the current phase advances, it'll eventually be inside
 +    the range specified by (WAR1), and hence will not widen the range.
 +    Unless the latter is empty, of course.
  This plan is implemented by:
 -  1. Setting the simplifier phase to the range of phases
 -     corresponding to the start/end phases of the rule's activation.
 +  1. Setting the simplifier phase to the /range/ of phases
 +     corresponding to the start/end phases of the rule's activation, implementing
 +     (WAR1) and (WAR2). This happens in `phaseForRuleOrUnf`.
++
 . When checking whether another rule is active, we use the function
         isActive :: SimplPhase -> Activation -> Bool
       from GHC.Core.Opt.Simplify.Env, which checks whether the other rule is
       active throughout the whole range of phases.
 -However, if the rule whose RHS we are simplifying is never active, instead of
 -setting the phase range to an empty interval, we keep the current simplifier
 -phase. This special case avoids firing ALL rules in the RHS of a never-active
 -rule.
+-
  You might wonder about a situation such as the following:
    module M1 where
@@ -1307,6 +1333,7 @@ It looks tempting to use "r1" when simplifying the RHS of "r2", yet we
  **must not** do so: for any module M that imports M1, we are going to start
  simplification in M starting at InitialPhase, and we will see the
  fully simplified rules RHSs imported from M1.
++
  Conclusion: stick to the plan.
  Note [Simplifying inside stable unfoldings]

compiler/GHC/Core/Opt/WorkWrap.hs

@@ -914,9 +914,9 @@ mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl
    where
      srcTxt = SourceText $ fsLit "{-# INLINE"
      -- See Note [Wrapper activation]
 -    wrapper_phase = foldr (laterPhase . get_rule_phase) earliest_inline_phase rules
 -    earliest_inline_phase = beginPhase fn_act `laterPhase` nextPhase InitialPhase
 -          -- laterPhase (nextPhase InitialPhase) is a temporary hack
 +    wrapper_phase = foldr (latestPhase . get_rule_phase) earliest_inline_phase rules
 +    earliest_inline_phase = beginPhase fn_act `latestPhase` nextPhase InitialPhase
 +          -- latestPhase (nextPhase InitialPhase) is a temporary hack
            -- to inline no earlier than phase 2.  I got regressions in
            -- 'mate', due to changes in full laziness due to Note [Case
            -- MFEs], when I did earlier inlining.

compiler/GHC/Types/InlinePragma.hs

@@ -104,9 +104,8 @@ module GHC.Types.InlinePragma
    , endPhase
      -- *** Queries
    , isActiveInPhase
 -  , laterPhase
 -  , laterThanPhase
 -  , nextPhase
 +  , latestPhase, earliestPhase
 +  , laterThanPhase, nextPhase
    ) where
  import GHC.Prelude
@@ -422,13 +421,21 @@ nextPhase (Phase 0)    = FinalPhase
  nextPhase (Phase n)    = Phase (n-1)
  nextPhase FinalPhase   = FinalPhase
 -laterPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase
 --- ^ Returns the later of two phases
 -laterPhase (Phase n1)   (Phase n2)   = Phase (n1 `min` n2)
 -laterPhase InitialPhase p2           = p2
 -laterPhase FinalPhase   _            = FinalPhase
 -laterPhase p1           InitialPhase = p1
 -laterPhase _            FinalPhase   = FinalPhase
 +earliestPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase
 +-- ^ Returns the earliest of two phases
 +earliestPhase (Phase n1)   (Phase n2)   = Phase (n1 `max` n2)
 +earliestPhase InitialPhase _            = InitialPhase
 +earliestPhase FinalPhase   p2           = p2
 +earliestPhase _            InitialPhase = InitialPhase
 +earliestPhase p1           FinalPhase   = p1
++
 +latestPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase
 +-- ^ Returns the latest of two phases
 +latestPhase (Phase n1)   (Phase n2)   = Phase (n1 `min` n2)
 +latestPhase InitialPhase p2           = p2
 +latestPhase FinalPhase   _            = FinalPhase
 +latestPhase p1           InitialPhase = p1
 +latestPhase _            FinalPhase   = FinalPhase
  -- | @p1 `laterThanOrEqualPhase` p2@ computes whether @p1@ happens (strictly)
  -- after @p2@.

testsuite/tests/simplCore/should_compile/T26826.hs

 +{-# LANGUAGE BangPatterns #-}
 +{-# LANGUAGE CPP #-}
 +{-# LANGUAGE GADTs #-}
 +{-# LANGUAGE KindSignatures #-}
 +{-# LANGUAGE LambdaCase #-}
 +{-# LANGUAGE ScopedTypeVariables #-}
 +{-# LANGUAGE TypeAbstractions #-}
 +{-# LANGUAGE TypeApplications #-}
 +{-# LANGUAGE TypeData #-}
++
 +module T26826 where
++
 +import Data.Kind (Type)
++
 +type data AstSpan =
 +  FullSpan | PrimalStepSpan AstSpan | PlainSpan
++
 +data SAstSpan (s :: AstSpan) where
 +  SFullSpan :: SAstSpan FullSpan
 +  SPrimalStepSpan :: SAstSpan s -> SAstSpan (PrimalStepSpan s)
 +  SPlainSpan :: SAstSpan PlainSpan
++
 +class KnownSpan (s :: AstSpan) where
 +  knownSpan :: SAstSpan s
++
 +instance KnownSpan FullSpan where
 +  knownSpan = SFullSpan
++
 +instance KnownSpan s => KnownSpan (PrimalStepSpan s) where
 +  knownSpan = SPrimalStepSpan (knownSpan @s)
++
 +instance KnownSpan PlainSpan where
 +  knownSpan = SPlainSpan
++
 +class ADReady target where
 +  ttlet :: target a -> (target a -> target b) -> target b
 +  ttletPrimal :: target a -> (target a -> target b) -> target b
 +  ttletPlain :: target a -> (target a -> target b) -> target b
 +  tplainPart :: target a -> target a
 +  tfromPlain :: target a -> target a
 +  tprimalPart :: target a -> target a
 +  tfromPrimal :: target a -> target a
++
 +type SpanTargetFam target (s :: AstSpan) (y :: Type) = target y
++
 +type AstEnv target = ()
++
 +data AstTensor (s :: AstSpan) (y :: Type) where
 +  AstLet
 +    :: forall a b s1 s2.
 +       KnownSpan s1
 +    => AstTensor s1 a
 +    -> AstTensor s2 b
 +    -> AstTensor s2 b
++
 +  AstPrimalPart :: KnownSpan s' => AstTensor s' a -> AstTensor (PrimalStepSpan s') a
 +  AstFromPrimal :: AstTensor (PrimalStepSpan s') a -> AstTensor s' a
 +  AstPlainPart :: KnownSpan s' => AstTensor s' a -> AstTensor PlainSpan a
 +  AstFromPlain :: AstTensor PlainSpan a -> AstTensor s' a
++
 +interpretAst
 +  :: forall target s y. (ADReady target, KnownSpan s)
 +  => AstEnv target -> AstTensor s y
 +  -> SpanTargetFam target s y
 +{-# INLINE [1] interpretAst #-}
 +interpretAst !env
 +  = \case
 +      AstLet @_ @_ @s1 @s2 u v ->
 +        case knownSpan @s1 of
 +          SFullSpan ->
 +            ttlet (interpretAst env u)
 +              (\_w -> interpretAst env v)
 +          SPrimalStepSpan _ ->
 +            ttletPrimal (interpretAst env u)
 +              (\_w -> interpretAst env v)
 +          SPlainSpan ->
 +            ttletPlain (interpretAst env u)
 +              (\_w -> interpretAst env v)
 +      AstPrimalPart a ->
 +        tprimalPart (interpretAst env a)
 +      AstFromPrimal a ->
 +        tfromPrimal (interpretAst env a)
 +      AstPlainPart a ->
 +        tplainPart (interpretAst env a)
 +      AstFromPlain a ->
 +        tfromPlain (interpretAst env a)

testsuite/tests/simplCore/should_compile/all.T

@@ -578,4 +578,6 @@ test('T26615',  [grep_errmsg(r'fEqList')], multimod_compile, ['T26615', '-O -fsp
  # T26722: there should be no reboxing in $wg
  test('T26722', [grep_errmsg(r'SPEC')], compile, ['-O -dno-typeable-binds'])
++
  test('T26805', [grep_errmsg(r'fromInteger')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques'])
 +test('T26826', normal, compile, ['-O'])