purescript-lua · Unisay · Jul 3, 2026 · Jul 3, 2026 · Jul 3, 2026 · Jul 3, 2026
diff --git a/changelog.d/20260703_120000_unisay_pass_pipeline.md b/changelog.d/20260703_120000_unisay_pass_pipeline.md
@@ -0,0 +1,14 @@
+### Added
+
+- A `--lint-ir` debug flag: checks IR well-scopedness invariants before and
+  after every optimizer pass (including every fixpoint iteration) and fails
+  compilation naming the offending pass. The same checks always run in the
+  test suite, so every golden module now doubles as a scope-invariant test
+  of the whole pipeline (#138).
+
+### Changed
+
+- The IR optimization pipeline is restructured into first-class passes:
+  each pass is a value carrying its invariant contract, sequenced by a
+  runner instead of plain function composition. Fresh names are drawn from
+  a deterministic supply. No change to generated code (#138).
diff --git a/changelog.d/20260703_121000_unisay_dce_nested_let.md b/changelog.d/20260703_121000_unisay_dce_nested_let.md
@@ -0,0 +1,8 @@
+### Fixed
+
+- IR dead code elimination missed dead bindings of a `Let` that another,
+  fully dead `Let` collapsed into: the dead binding was kept while the
+  parameters of lambdas inside it were blanked, leaving unbound references
+  in the intermediate IR. The next optimizer iteration masked the damage,
+  so generated code was unaffected; the invariant checks introduced for
+  #138 surfaced the bug on the golden corpus.
diff --git a/exe/Cli.hs b/exe/Cli.hs
@@ -46,6 +46,7 @@ data Args = Args
   , luaOutputFile ∷ Tagged "output-lua" (SomeBase File)
   , outputIR ∷ Maybe ExtraOutput
   , outputLuaAst ∷ Maybe ExtraOutput
+  , lintIR ∷ Tagged "lint-ir" Bool
   , appOrModule ∷ AppOrModule
   , runEntry ∷ Maybe AppOrModule
   }
@@ -108,6 +109,14 @@ options = do
             <> linebreak
             <> bold "Default: false"
       ]
+  lintIR ←
+    flag (Tagged False) (Tagged True) . fold $
+      [ long "lint-ir"
+      , helpDoc . Just $
+          "Check IR invariants after every optimizer pass (debug)."
+            <> linebreak
+            <> bold "Default: false"
+      ]
   appOrModule ←
     option (eitherReader parseAppOrModule) . fold $
       [ metavar "ENTRY"

diff --git a/exe/Main.hs b/exe/Main.hs
@@ -7,6 +7,7 @@ import Data.Tagged (Tagged (..))
 import Language.PureScript.Backend (CompilationResult (..))
 import Language.PureScript.Backend qualified as Backend
 import Language.PureScript.Backend.IR qualified as IR
+import Language.PureScript.Backend.IR.Pass (PassCheckFailure (..))
 import Language.PureScript.Backend.Lua qualified as Lua
 import Language.PureScript.Backend.Lua.Printer qualified as Printer
 import Language.PureScript.Backend.Lua.Run qualified as Run
@@ -27,6 +28,7 @@ main = Utf8.withUtf8 do
     , luaOutputFile
     , outputIR
     , outputLuaAst
+    , lintIR
     , psOutputPath
     , appOrModule
     , runEntry
@@ -50,10 +52,11 @@ main = Utf8.withUtf8 do
     -- Stay silent in run mode so the program's own stdout isn't polluted (the
     -- output may be piped); Spago already logs the run/build phases itself.
     when (isNothing runEntry) $ putTextLn "PS Lua: compiling ..."
-    Backend.compileModules psOutputPath foreignDir entry
+    Backend.compileModules psOutputPath foreignDir lintIR entry
       & handleModuleNotFoundError
       & handleModuleDecodingError
       & handleCoreFnError
+      & handlePassCheckFailure
       & handleLuaError
       & Oops.runOops
 
@@ -112,6 +115,20 @@ handleCoreFnError =
   Oops.catch \(e ∷ IR.CoreFnError) →
     die $ "CoreFn contains an unexpected value " <> show e
 
+handlePassCheckFailure
+  ∷ ExceptT (Oops.Variant (PassCheckFailure ': e)) IO a
+  → ExceptT (Oops.Variant e) IO a
+handlePassCheckFailure =
+  Oops.catch \PassCheckFailure {failedPassName, failedPhase, failedViolations} →
+    die . toString . unlines $
+      [ "IR invariants violated "
+          <> show failedPhase
+          <> " optimizer pass "
+          <> failedPassName
+          <> ":"
+      ]
+        <> (show <$> toList failedViolations)
+
 handleLuaError
   ∷ ExceptT (Oops.Variant (Lua.Error ': e)) IO a
   → ExceptT (Oops.Variant e) IO a

diff --git a/lib/Language/PureScript/Backend.hs b/lib/Language/PureScript/Backend.hs
@@ -6,7 +6,11 @@ import Data.Map qualified as Map
 import Data.Tagged (Tagged (..), untag)
 import Language.PureScript.Backend.IR qualified as IR
 import Language.PureScript.Backend.IR.Linker qualified as Linker
-import Language.PureScript.Backend.IR.Optimizer (optimizedUberModule)
+import Language.PureScript.Backend.IR.Optimizer
+  ( optimizedUberModule
+  , optimizedUberModuleChecked
+  )
+import Language.PureScript.Backend.IR.Pass (PassCheckFailure)
 import Language.PureScript.Backend.Lua qualified as Lua
 import Language.PureScript.Backend.Lua.NestingCheck (exceedsNestingLimit)
 import Language.PureScript.Backend.Lua.Optimizer (optimizeChunk)
@@ -26,22 +30,26 @@ compileModules
     `CouldBeAnyOf` '[ CoreFn.ModuleNotFound
                     , CoreFn.ModuleDecodingErr
                     , IR.CoreFnError
+                    , PassCheckFailure
                     , Lua.Error
                     ]
   ⇒ Tagged "output" (SomeBase Dir)
   → Tagged "foreign" (Path Abs Dir)
+  → Tagged "lint-ir" Bool
   → AppOrModule
   → ExceptT (Variant e) IO CompilationResult
-compileModules outputDir foreignDir appOrModule = do
+compileModules outputDir foreignDir lintIR appOrModule = do
   let entryModuleName = entryPointModule appOrModule
   cfnModules ← CoreFn.readModuleRecursively outputDir entryModuleName
   let dataDecls = IR.collectDataDeclarations cfnModules
   irResults ← forM (Map.toList cfnModules) \(_psModuleName, cfnModule) →
     Oops.hoistEither $ IR.mkModule cfnModule dataDecls
   let (needsRuntimeLazys, irModules) = unzip irResults
-  let uberModule =
-        Linker.makeUberModule (linkerMode appOrModule) irModules
-          & optimizedUberModule
+  let linkedModule = Linker.makeUberModule (linkerMode appOrModule) irModules
+  uberModule ←
+    if untag lintIR
+      then Oops.hoistEither (optimizedUberModuleChecked linkedModule)
+      else pure (optimizedUberModule linkedModule)
   -- See Note [The PSLUA_runtime_lazy coupling] in Language.PureScript.Names
   let needsRuntimeLazy = Tagged (any untag needsRuntimeLazys)
   chunk ← Lua.fromUberModule foreignDir needsRuntimeLazy appOrModule uberModule

diff --git a/lib/Language/PureScript/Backend/IR/DCE.hs b/lib/Language/PureScript/Backend/IR/DCE.hs
@@ -139,10 +139,21 @@ eliminateDeadCode uber@UberModule {..} =
               ParamUnused pann → (ParamUnused pann, b)
               ParamNamed pann name → (ParamUnused pann, unshift name 0 b)
         Let ann binds body →
-          Rewritten Recurse case preserveLetBinds (toList binds) body of
-            ([], body') → body'
-            (b : bs, body') → Let ann (b :| bs) body'
+          Rewritten Recurse (rebuild ann (preserveLetBinds (toList binds) body))
          where
+          -- 'Rewritten Recurse' descends into the result's children without
+          -- re-applying the rule to the result itself, so when every binding
+          -- of the Let is dropped and the node collapses to its body, a body
+          -- that is itself a Let would escape the rule: its dead bindings
+          -- would be kept, while the parameters of lambdas inside them get
+          -- blanked (their ids are unreachable), leaving unbound references
+          -- behind. Process such a body here; the collapse can cascade.
+          rebuild ann' = \case
+            ([], Let ann'' binds' body') →
+              rebuild ann'' (preserveLetBinds (toList binds') body')
+            ([], body') → body'
+            (b : bs, body') → Let ann' (b :| bs) body'
+
           -- Dropping a dead binder removes a slot from that name's De Bruijn
           -- namespace, so references in the rest of the Let (later grouping
           -- RHSs and the body) that skipped over it must be lowered, just as

diff --git a/lib/Language/PureScript/Backend/IR/FlattenDeepBinds.hs b/lib/Language/PureScript/Backend/IR/FlattenDeepBinds.hs
@@ -133,6 +133,7 @@ single table to cut the upvalue cost to one is a future upgrade.
 -}
 module Language.PureScript.Backend.IR.FlattenDeepBinds
   ( flattenDeepBinds
+  , flattenDeepBindsM
   ) where
 
 import Data.List qualified as List
@@ -141,9 +142,9 @@ import Data.Set qualified as Set
 import Language.PureScript.Backend.IR.Linker (UberModule (..))
 import Language.PureScript.Backend.IR.Names
   ( Name (..)
-  , QName
   , Qualified (Local)
   )
+import Language.PureScript.Backend.IR.Supply (SupplyM, freshName, runSupply)
 import Language.PureScript.Backend.IR.Types
   ( Ann
   , Exp
@@ -159,26 +160,21 @@ import Language.PureScript.Backend.IR.Types
   , rewriteExpTopDownM
   )
 
+-- | 'flattenDeepBindsM' with a private supply, for standalone use.
+flattenDeepBinds ∷ UberModule → UberModule
+flattenDeepBinds = runSupply . flattenDeepBindsM
+
 {- | Flatten deeply-nested expression trees in every binding and export of the
-module. A single counter is threaded across the whole module so the minted
+module. The supply counter is threaded across the whole module so the minted
 @$kontN@\/@$tmpN@ names are globally unique.
 -}
-flattenDeepBinds ∷ UberModule → UberModule
-flattenDeepBinds uber@UberModule {uberModuleBindings, uberModuleExports} =
-  uber
-    { uberModuleBindings = bindings'
-    , uberModuleExports = exports'
-    }
+flattenDeepBindsM ∷ UberModule → SupplyM UberModule
+flattenDeepBindsM uber@UberModule {uberModuleBindings, uberModuleExports} = do
+  bindings' ← traverse (traverse (traverse rewrite)) uberModuleBindings
+  exports' ← traverse (traverse rewrite) uberModuleExports
+  pure uber {uberModuleBindings = bindings', uberModuleExports = exports'}
  where
-  (bindings', exports') = evalState action 0
-
-  action ∷ State Int ([Grouping (QName, Exp)], [(Name, Exp)])
-  action =
-    (,)
-      <$> traverse (traverse (traverse rewrite)) uberModuleBindings
-      <*> traverse (traverse rewrite) uberModuleExports
-
-  rewrite ∷ Exp → State Int Exp
+  rewrite ∷ Exp → SupplyM Exp
   rewrite = rewriteExpTopDownM flattenRule
 
 --------------------------------------------------------------------------------
@@ -190,7 +186,7 @@ application-spine depth is tiny, so Strategy B only ever sees the remaining deep
 'App' spines. Either may leave the expression unchanged ('NoChange'), in which
 case 'Language.PureScript.Backend.Lua.NestingCheck' remains the backstop.
 -}
-flattenRule ∷ RewriteRuleM (State Int) Ann
+flattenRule ∷ RewriteRuleM SupplyM Ann
 flattenRule expr
   | (steps, finalAction) ← peelChain expr
   , length steps > threshold =
@@ -233,7 +229,7 @@ asStep expr = case spine expr of
 Returns 'Nothing' (bail, leave the chain nested) when the forwarded live set at
 some cut exceeds the upvalue budget.
 -}
-lambdaLift ∷ [Step] → Exp → State Int (Maybe Exp)
+lambdaLift ∷ [Step] → Exp → SupplyM (Maybe Exp)
 lambdaLift steps finalAction =
   -- Build bottom-up: the deepest segment carries the final action; each
   -- shallower segment ends by calling the helper wrapping the one below it.
@@ -282,7 +278,7 @@ lambdaLift steps finalAction =
   cut
     ∷ (Exp, [(Int, Grouping (Ann, Name, Exp))])
     → [Step]
-    → State Int (Exp, [(Int, Grouping (Ann, Name, Exp))])
+    → SupplyM (Exp, [(Int, Grouping (Ann, Name, Exp))])
   cut (deepBody, konts) seg = do
     kname ← freshKontName
     let params = liveVars deepBody
@@ -359,7 +355,7 @@ total operands (see the module header's soundness note). The off-path operands
 are kept verbatim; deep ones are flattened in turn by the top-down rewrite's
 descent. Returns 'Nothing' when the path is too short to need sealing.
 -}
-sequentialiseSpine ∷ Exp → State Int (Maybe Exp)
+sequentialiseSpine ∷ Exp → SupplyM (Maybe Exp)
 sequentialiseSpine expr =
   case decompose expr of
     (frames, base)
@@ -373,7 +369,7 @@ sequentialiseSpine expr =
   seal
     ∷ ([Grouping (Ann, Name, Exp)], Exp)
     → (Int, Frame)
-    → State Int ([Grouping (Ann, Name, Exp)], Exp)
+    → SupplyM ([Grouping (Ann, Name, Exp)], Exp)
   seal (binds, acc) (i, frame) = do
     let acc' = rebuildFrame frame acc
     if i `mod` segmentSize == 0
@@ -400,11 +396,11 @@ spine = go []
 refLocal0 ∷ Name → Exp
 refLocal0 name = Ref noAnn (Local name) (Index 0)
 
-freshKontName ∷ State Int Name
-freshKontName = state \n → (Name ("$kont" <> show n), n + 1)
+freshKontName ∷ SupplyM Name
+freshKontName = freshName "$kont"
 
-freshTmpName ∷ State Int Name
-freshTmpName = state \n → (Name ("$tmp" <> show n), n + 1)
+freshTmpName ∷ SupplyM Name
+freshTmpName = freshName "$tmp"
 
 chunksOf ∷ Int → [a] → [[a]]
 chunksOf _ [] = []