purescript-lua · Unisay · Jul 4, 2026 · Jul 4, 2026 · Jul 4, 2026
diff --git a/changelog.d/20260704_140000_unisay_fixpoint_change_flag.md b/changelog.d/20260704_140000_unisay_fixpoint_change_flag.md
@@ -0,0 +1,12 @@
+### Changed
+
+- The optimizer's fixpoint oracle no longer compares whole `UberModule`s for
+  structural equality (#144). Every pass now returns a change flag (precise for
+  the fixpoint members — optimize and DCE — whose rewrite rules report honestly
+  since the bottom-up driver change); a fixpoint stops on the first round that
+  reports no change, bounded by a generous iteration cap. The production runner
+  accepts the module reached at the cap (an early stop only costs optimization,
+  never correctness), while the checked runner — used by the test suite and
+  `--lint-ir` — fails loudly in both dishonesty directions: a pass that changes
+  the module while reporting no change (`PassUnreportedChange`), and a fixpoint
+  that fails to converge within the cap (`FixpointDivergence`).
diff --git a/lib/Language/PureScript/Backend/IR/DCE.hs b/lib/Language/PureScript/Backend/IR/DCE.hs
@@ -24,9 +24,11 @@ import Language.PureScript.Backend.IR.Types
   , Grouping (..)
   , Parameter (..)
   , RawExp (..)
+  , WasRewritten (..)
   , getAnn
   , listGrouping
   , rewriteExpBottomUp
+  , rewrittenIf
   , subexpressions
   )
 
@@ -40,20 +42,38 @@ type Scope = Map (Qualified Name) Id
 
 type Node = ((), Id, [Id])
 
-eliminateDeadCode ∷ UberModule → UberModule
+{- | Drop the unreachable bindings of the module. The 'WasRewritten'
+result (see 'Language.PureScript.Backend.IR.Pass.passRun') reports
+precisely whether anything was dropped, blanked, or pruned — an
+expression rewrite fired ('dceAnnotatedExp'), a top-level binding or
+foreign was dropped, or a 'ForeignImport' name list was pruned.
+-}
+eliminateDeadCode ∷ UberModule → (UberModule, WasRewritten)
 eliminateDeadCode uber@UberModule {..} =
   -- traceIt "annotatedForeigns" annotatedForeigns $
   --   traceIt "annotatedBindings" annotatedBindings $
   --     traceIt "annotatedExports" annotatedExports $
   --       traceIt "topLevelScope" topLevelScope $
   --         traceIt "adjacencyList" adjacencyList $
   --           traceIt "reachableIds" reachableIds $
-  uber
-    { uberModuleForeigns = preservedForeigns
-    , uberModuleBindings = preservedBindings
-    , uberModuleExports = preservedExports
-    }
+  ( uber
+      { uberModuleForeigns = preservedForeigns
+      , uberModuleBindings = preservedBindings
+      , uberModuleExports = preservedExports
+      }
+  , mconcat
+      [ exprRewrites
+      , rewrittenIf (length preservedForeigns /= length annotatedForeigns)
+      , rewrittenIf
+          (groupingMembers preservedBindings /= groupingMembers annotatedBindings)
+      ]
+  )
  where
+  exprRewrites ∷ WasRewritten
+  exprRewrites = foreignExprRewrites <> bindingExprRewrites <> exportExprRewrites
+
+  groupingMembers ∷ [Grouping a] → Int
+  groupingMembers = length . (listGrouping =<<)
   -- traceIt ∷ ∀ a b. Show a ⇒ String → a → b → b
   -- traceIt label it =
   --   trace ("\n\n" <> label <> ":\n" <> pp it <> "\n")
@@ -66,39 +86,43 @@ eliminateDeadCode uber@UberModule {..} =
   --           }
 
   -- See Note [Foreign bindings structure emitted by the Linker]
-  preservedForeigns ∷ [(QName, Exp)]
-  preservedForeigns = do
-    (name, expr) ← annotatedForeigns
-    guard $ nodeId expr `member` reachableIds
-    pure . (name,) $ case expr of
-      ForeignImport (_id, ann) modname path names →
-        ForeignImport
-          ann
-          modname
-          path
-          [(a, n) | ((i, a), n) ← names, i `member` reachableIds]
-      other → dceAnnotatedExp other
-
-  preservedBindings ∷ [Grouping (QName, Exp)] =
-    annotatedBindings >>= \case
-      Standalone (qname, expr) → do
-        guard $ nodeId expr `member` reachableIds
-        [Standalone (qname, dceAnnotatedExp expr)]
-      RecursiveGroup recBinds →
-        case NE.nonEmpty (preservedRecBinds (toList recBinds)) of
-          Nothing → []
-          Just pb → [RecursiveGroup pb]
-   where
-    preservedRecBinds ∷ [(QName, AExp)] → [(QName, Exp)]
-    preservedRecBinds recBinds = do
-      (qname, expr) ← recBinds
+  ( preservedForeigns ∷ [(QName, Exp)]
+    , foreignExprRewrites ∷ WasRewritten
+    ) = second fold $ unzip do
+      (name, expr) ← annotatedForeigns
       guard $ nodeId expr `member` reachableIds
-      pure (qname, dceAnnotatedExp expr)
+      pure case expr of
+        ForeignImport (_id, ann) modname path names →
+          let keptNames = [(a, n) | ((i, a), n) ← names, i `member` reachableIds]
+           in ( (name, ForeignImport ann modname path keptNames)
+              , rewrittenIf (length keptNames /= length names)
+              )
+        other → first (name,) (dceAnnotatedExp other)
+
+  ( preservedBindings ∷ [Grouping (QName, Exp)]
+    , bindingExprRewrites ∷ WasRewritten
+    ) = second fold $ unzip do
+      annotatedBindings >>= \case
+        Standalone (qname, expr) → do
+          guard $ nodeId expr `member` reachableIds
+          let (e, rewritten) = dceAnnotatedExp expr
+          [(Standalone (qname, e), rewritten)]
+        RecursiveGroup recBinds →
+          case NE.nonEmpty (preservedRecBinds (toList recBinds)) of
+            Nothing → []
+            Just pb → [(RecursiveGroup (fst <$> pb), foldMap snd pb)]
+     where
+      preservedRecBinds ∷ [(QName, AExp)] → [((QName, Exp), WasRewritten)]
+      preservedRecBinds recBinds = do
+        (qname, expr) ← recBinds
+        guard $ nodeId expr `member` reachableIds
+        pure (first (qname,) (dceAnnotatedExp expr))
 
-  preservedExports ∷ [(Name, Exp)]
-  preservedExports = do
-    (name, annotatedExp) ← annotatedExports
-    pure (name, dceAnnotatedExp annotatedExp)
+  ( preservedExports ∷ [(Name, Exp)]
+    , exportExprRewrites ∷ WasRewritten
+    ) = second fold $ unzip do
+      (name, annotatedExp) ← annotatedExports
+      pure (first (name,) (dceAnnotatedExp annotatedExp))
 
   -- run these computations in the same monad
   -- so that we can share the state of the ID counter
@@ -124,16 +148,16 @@ eliminateDeadCode uber@UberModule {..} =
   -- the node collapses to its body, a body that is itself a Let has
   -- already had its own dead bindings dropped — the Recurse-escape bug
   -- class (issue #149) cannot arise, and no rebuild cascade is needed.
-  -- Both rules observe the honesty contract of 'RewriteRule': they fire
-  -- only when a binder is actually blanked or dropped (issue #145), so
-  -- the driver's change flag is a sound fixpoint signal (issue #144).
-  dceAnnotatedExp ∷ AExp → Exp
+  -- Both rules fire only when a binder is actually blanked or dropped
+  -- (the 'RewriteRule' contract, issue #145), so the driver's
+  -- 'WasRewritten' signal is precise.
+  dceAnnotatedExp ∷ AExp → (Exp, WasRewritten)
   dceAnnotatedExp =
-    deannotateExp . fst . rewriteExpBottomUp \case
+    first deannotateExp . rewriteExpBottomUp \case
       -- Under GUC a dead binder is unreferenced by definition, so
       -- blanking its name touches no reference elsewhere (the hazard
       -- behind issue #56). Requiring 'ParamNamed' keeps the rule
-      -- honest: an already-blank parameter is left alone (issue #145).
+      -- precise: an already-blank parameter is left alone.
       Abs ann (ParamNamed pann@(paramId, _) _name) b
         | not (paramId `member` reachableIds) →
             Just (Abs ann (ParamUnused pann) b)

diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs
@@ -1,5 +1,6 @@
 module Language.PureScript.Backend.IR.Optimizer where
 
+import Control.Monad.Writer.CPS (WriterT, runWriterT, tell)
 import Data.Foldable (foldrM)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -31,6 +32,7 @@ import Language.PureScript.Backend.IR.Types
   , Parameter (..)
   , RawExp (..)
   , RewriteRuleM
+  , WasRewritten (..)
   , alphaEq
   , bindingExprs
   , countFreeRef
@@ -104,7 +106,7 @@ optimizerPipeline neverNames =
   uniquifyPass =
     Pass
       { passName = "uniquify"
-      , passRun = pure . uniquifyNames
+      , passRun = conservatively . pure . uniquifyNames
       , passRequires = wellScoped
       , passEnsures = guc
       }
@@ -115,20 +117,26 @@ optimizerPipeline neverNames =
       , passRequires = guc
       , passEnsures = guc
       }
-  dcePass = gucPass "dce" eliminateDeadCode
+  dcePass =
+    Pass
+      { passName = "dce"
+      , passRun = pure . eliminateDeadCode
+      , passRequires = guc
+      , passEnsures = guc
+      }
   mergeForeignsPass = gucPass "mergeForeigns" mergeForeignsIntoBindings
   floatInPass = gucPass "float-in" floatIn
   magicDoPass =
     Pass
       { passName = "magicDo"
-      , passRun = magicDo
+      , passRun = conservatively . magicDo
       , passRequires = guc
       , passEnsures = guc
       }
   flattenDeepBindsPass =
     Pass
       { passName = "flattenDeepBinds"
-      , passRun = flattenDeepBindsM
+      , passRun = conservatively . flattenDeepBindsM
       , passRequires = guc
       , passEnsures = guc
       }
@@ -137,11 +145,16 @@ optimizerPipeline neverNames =
   gucPass name run =
     Pass
       { passName = name
-      , passRun = pure . run
+      , passRun = conservatively . pure . run
       , passRequires = guc
       , passEnsures = guc
       }
 
+  -- Run-once passes report a conservative 'Rewritten' — only fixpoint
+  -- members (optimize, dce) need a precise signal (see 'passRun').
+  conservatively ∷ SupplyM UberModule → SupplyM (UberModule, WasRewritten)
+  conservatively = fmap (,Rewritten)
+
   wellScoped ∷ Set Invariant
   wellScoped = Set.singleton WellScoped
 
@@ -170,28 +183,36 @@ neverInlineNames UberModule {uberModuleBindings} =
     , getAnn expr == Just Never
     ]
 
-optimizeModule ∷ Set QName → UberModule → SupplyM UberModule
-optimizeModule neverNames UberModule {..} = do
+optimizeModule ∷ Set QName → UberModule → SupplyM (UberModule, WasRewritten)
+optimizeModule neverNames UberModule {..} = runWriterT do
   (bindings, exports) ←
     foldrM withBinding ([], uberModuleExports) uberModuleBindings
   uberModuleBindings' ←
-    traverse (traverse (traverse optimizedExpressionM)) bindings
-  uberModuleExports' ← traverse (traverse optimizedExpressionM) exports
+    traverse (traverse (traverse optimizeExp)) bindings
+  uberModuleExports' ← traverse (traverse optimizeExp) exports
   pure
     UberModule
       { uberModuleForeigns
       , uberModuleBindings = uberModuleBindings'
       , uberModuleExports = uberModuleExports'
       }
  where
+  -- Every expression rewrite and every top-level inlining reports into
+  -- the pass's 'WasRewritten' result; nothing else in this pass changes
+  -- the module, so a converged module reports 'Unmodified'.
+  optimizeExp ∷ Exp → WriterT WasRewritten SupplyM Exp
+  optimizeExp e = do
+    (e', rewritten) ← lift (optimizedExpressionM e)
+    e' <$ tell rewritten
+
   withBinding
     ∷ Grouping (QName, Exp)
     → ([Grouping (QName, Exp)], [(Name, Exp)])
-    → SupplyM ([Grouping (QName, Exp)], [(Name, Exp)])
+    → WriterT WasRewritten SupplyM ([Grouping (QName, Exp)], [(Name, Exp)])
   withBinding binding (bindings, exports) =
     case binding of
       Standalone (qname, expr0) → do
-        expr ← optimizedExpressionM expr0
+        expr ← optimizeExp expr0
         -- See Note [Inline annotations and inlining heuristics]
         let isUsedOnce name =
               1 == Map.findWithDefault 0 (qualifiedQName name) uberModuleFreeRefs
@@ -204,13 +225,18 @@ optimizeModule neverNames UberModule {..} = do
               (bindingExprs =<< uberModuleBindings) <> map snd exports
         if qname `Set.notMember` neverNames
           && (isInlinableExpr expr || isUsedOnce qname)
-          then
-            (,)
-              <$> substituteInBindings qname expr bindings
-              <*> substituteInExports qname expr exports
+          then do
+            -- The binding is dropped from the module in favor of the
+            -- substituted copies: a rewrite even when it had no
+            -- occurrences left to substitute.
+            tell Rewritten
+            lift $
+              (,)
+                <$> substituteInBindings qname expr bindings
+                <*> substituteInExports qname expr exports
           else pure (Standalone (qname, expr) : bindings, exports)
       RecursiveGroup recGroup → do
-        recGroup' ← traverse (traverse optimizedExpressionM) recGroup
+        recGroup' ← traverse (traverse optimizeExp) recGroup
         pure (RecursiveGroup recGroup' : bindings, exports)
 
 -- Cross-entry substitution: the host entry's binders give no uniqueness
@@ -244,21 +270,20 @@ its own supply. Production code uses 'optimizedExpressionM' so all
 passes share one supply.
 -}
 optimizedExpression ∷ Exp → Exp
-optimizedExpression = runSupply . optimizedExpressionM
+optimizedExpression = runSupply . fmap fst . optimizedExpressionM
 
-optimizedExpressionM ∷ Exp → SupplyM Exp
+optimizedExpressionM ∷ Exp → SupplyM (Exp, WasRewritten)
 optimizedExpressionM =
   -- See Note [Eta reduction is unsound]
-  fmap fst
-    . rewriteExpBottomUpM
-      ( constantFolding
-          `thenRewrite` betaReduce
-          `thenRewrite` betaReduceUnusedParams
-          `thenRewrite` removeUnreachableThenBranch
-          `thenRewrite` removeUnreachableElseBranch
-          `thenRewrite` removeIfWithEqualBranches
-          `thenRewrite` inlineLocalBindings
-      )
+  rewriteExpBottomUpM
+    ( constantFolding
+        `thenRewrite` betaReduce
+        `thenRewrite` betaReduceUnusedParams
+        `thenRewrite` removeUnreachableThenBranch
+        `thenRewrite` removeUnreachableElseBranch
+        `thenRewrite` removeIfWithEqualBranches
+        `thenRewrite` inlineLocalBindings
+    )
 
 {- Note [IR is assumed well-typed]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -377,14 +402,16 @@ removeUnreachableElseBranch e = pure case e of
 inlineLocalBindings ∷ RewriteRuleM SupplyM Ann
 inlineLocalBindings = \case
   Let ann groupings body → do
-    (body', Any inlined) ← foldrM inlineLocalBinding (body, Any False) groupings
-    pure $ if inlined then Just (Let ann groupings body') else Nothing
+    (body', inlined) ← foldrM inlineLocalBinding (body, Unmodified) groupings
+    pure case inlined of
+      Rewritten → Just (Let ann groupings body')
+      Unmodified → Nothing
   _ → pure Nothing
 
 {- | Inline one binding into the Let's body when the heuristic wants it
 /and/ the body actually references it — a zero-occurrence substitution
-is a no-op and must not report a change (the honesty contract of
-'RewriteRuleM'), or the optimize fixpoint would never converge.
+is a no-op and must not report a rewrite (the 'RewriteRule' contract),
+or the optimize fixpoint would never converge.
 
 The inlinee must not reference the binding's own name: substitution
 never descends into its insertions, so a self-reference would keep the
@@ -398,7 +425,10 @@ a same-named reference in the RHS would be a duplicate binder upstream
 — but 'optimizedExpression' is also exercised directly on non-GUC
 input, where the rule must decline rather than loop or capture.
 -}
-inlineLocalBinding ∷ Grouping (Ann, Name, Exp) → (Exp, Any) → SupplyM (Exp, Any)
+inlineLocalBinding
+  ∷ Grouping (Ann, Name, Exp)
+  → (Exp, WasRewritten)
+  → SupplyM (Exp, WasRewritten)
 inlineLocalBinding grouping (body, inlined) =
   case grouping of
     RecursiveGroup _grp → pure (body, inlined) -- Not inlining recursive bindings
@@ -408,7 +438,7 @@ inlineLocalBinding grouping (body, inlined) =
       , isInlinableExpr inlinee || occurrences == 1 →
           -- The binding survives until DCE drops it, so the inserted copy
           -- must not reuse its binder names ('substituteCopyM').
-          (,Any True) <$> substituteCopyM name inlinee body
+          (,Rewritten) <$> substituteCopyM name inlinee body
       | otherwise → pure (body, inlined)
      where
       occurrences ∷ Natural