purescript-lua · Unisay · Jul 24, 2026 · Jul 24, 2026
diff --git a/changelog.d/20260724_160000_unisay_canonicalize_through_toplevel_aliases.md b/changelog.d/20260724_160000_unisay_canonicalize_through_toplevel_aliases.md
@@ -0,0 +1,36 @@
+### Fixed
+
+- Mixed-monad `discard` chains no longer miscompile to a runtime nil
+  call (#297). When one module instantiates `discard` with two different
+  Bind dictionaries — Effect or ST plus any second monad — the
+  PureScript compiler's own CSE floats the shared partial application in
+  two stages —
+
+  ```
+  discard  = Control.Bind.discard discardUnit
+  discard1 = discard bindST
+  discard2 = discard bindEffect
+  ```
+
+  — a shape neither canonicalization tier matched: the Effect/ST chains
+  stayed nested past magic-do, and once post-magic-do call-site inlining
+  exposed the canonical pair, the tier-2 rewrite manufactured a reference
+  to a foreign accessor binding dead-code elimination had already
+  removed. The generated Lua read a never-assigned module-table field and
+  crashed on first use:
+
+  ```lua
+  local M = {}
+  ...
+  return M.Effect_bindE(Effect_Console_log("st:"))(...)()  -- nil call
+  ```
+
+  Tier 2 now resolves head positions through top-level aliases before
+  matching the canonical table — closed under any CSE split of the
+  structurally bounded spines — so the chains flatten again, and it
+  declines a rewrite whose produced reference the module can no longer
+  resolve. Independently, the compiler now refuses to emit code for an
+  optimized module with dangling imported references
+  (`lintDanglingImports`), so any future resurrect-after-DCE fails the
+  build instead of shipping broken Lua; the golden harness applies the
+  same closedness check to every golden module.
diff --git a/lib/Language/PureScript/Backend.hs b/lib/Language/PureScript/Backend.hs
@@ -7,11 +7,14 @@ import Data.Tagged (Tagged (..), untag)
 import Language.PureScript.Backend.IR qualified as IR
 import Language.PureScript.Backend.IR.Inliner qualified as Inliner
 import Language.PureScript.Backend.IR.Linker qualified as Linker
+import Language.PureScript.Backend.IR.Linter qualified as Linter
 import Language.PureScript.Backend.IR.Optimizer
   ( optimizedUberModule
   , optimizedUberModuleChecked
   )
-import Language.PureScript.Backend.IR.Pass (PassCheckFailure)
+import Language.PureScript.Backend.IR.Pass
+  ( PassCheckFailure (ResultDanglingImports)
+  )
 import Language.PureScript.Backend.Lua qualified as Lua
 import Language.PureScript.Backend.Lua.ForeignLift qualified as ForeignLift
 import Language.PureScript.Backend.Lua.Limits (LuaLimits)
@@ -60,6 +63,13 @@ compileModules outputDir foreignDir lintIR limits directives appOrModule = do
     if untag lintIR
       then Oops.hoistEither (optimizedUberModuleChecked dataDecls liftedModule)
       else pure (optimizedUberModule dataDecls liftedModule)
+  -- A dangling imported reference compiles to a read of a never-assigned
+  -- module-table field — a nil call at runtime — so refuse to emit code for
+  -- it (issue #297). Unconditional, unlike the per-pass linting behind
+  -- --lint-ir: one O(module) scan of the final result.
+  whenJust
+    (nonEmpty (Linter.lintDanglingImports uberModule))
+    (Oops.throw . ResultDanglingImports)
   -- 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/EffectNames.hs b/lib/Language/PureScript/Backend/IR/EffectNames.hs
@@ -5,6 +5,7 @@ module Language.PureScript.Backend.IR.EffectNames
   ( canonicalBindNames
   , canonicalPureNames
   , canonicalizeEffectApp
+  , canonicalizeEffectAppInModule
   ) where
 
 import Data.Map.Strict qualified as Map
@@ -73,13 +74,49 @@ The rewrite runs in two tiers, both required:
      @bind = bind bindST@) and only becomes 'Imported' after the linker
      requalifies it, so tier 1 cannot see it. The rule also catches
      pairs exposed later by alias dissolution. It rewrites two nodes to
-     one, so it is fixpoint-safe, and the canonical heads are real
-     foreigns, so firing after magic-do is harmless.
+     one, so it is fixpoint-safe.
 
 Both tiers match 'Imported' references only. A 'Local' reference has no
 stable identity to match — the qualified name is the identity that
 survives linking.
 
+Tier 2 resolves head positions through top-level aliases (issue #297).
+When a module instantiates @discard@ with two /different/ Bind
+dictionaries — Effect or ST plus any second monad — purs's own CSE (the
+CoreFn common-subexpression pass over compiler-synthesized dictionary
+applications) floats the shared partial application as a binding of its
+own:
+
+  > discard  = Control.Bind.discard discardUnit
+  > discard1 = discard bindST
+  > discard2 = discard bindEffect
+
+(A single-use instantiation may also stay applied inline in its chain —
+@discard bindEffect m k@ — rather than becoming a float; the node shape
+is the same.) Either way the row's head is hidden behind a module-local
+alias that tier 1 cannot see (the reference is 'Local' at translation
+time) and a plain structural match cannot either. Tier 2 therefore
+matches each head position /through/ top-level aliases
+('canonicalizeEffectAppInModule'):
+a reference denotes a row's name if it is that name, or if the
+top-level binding it names has a right-hand side that denotes it
+(visited-bounded, so alias cycles cannot loop it). The dictionary
+positions stay strict references — dictionaries are already top-level
+constants, so CSE never hides them. The matched spines are structurally
+bounded (@bind@/@pure@: two nodes, @discard@: three), so resolution
+terminates after at most a hop per node.
+
+Tier 2 also /declines/ a rewrite whose produced reference would dangle
+(issue #297 again, the severe half): the canonical accessor bindings are
+subject to dissolution and dead-code elimination like any other, so a
+row exposed late — e.g. by alias dissolution after magic-do — may name
+an accessor that no longer exists, and the manufactured reference would
+compile to a read of a never-assigned module-table field (a nil call at
+runtime). Declining is sound: the dictionary application left behind is
+executable — @bindE m k@ is already the program the application
+denotes. Tier 1 needs no such gate: it runs before linking, and the
+linker includes the accessor bindings its references demand.
+
 There is deliberately /no/ standalone @discard discardUnit ==> bind@
 row: it would rewrite the discards of every monad, churning all the
 non-Effect chains for zero benefit — only the Effect/ST rows feed a
@@ -94,31 +131,95 @@ Consumers of the canonical names: magic-do matches chain heads against
 --------------------------------------------------------------------------------
 -- Canonicalization ------------------------------------------------------------
 
-{- | Rewrite an Effect/ST dictionary application into an application of
-the real foreign method, per the table in
-Note [Canonical Effect/ST heads]. The produced reference keeps the
-outer application's annotation. 'Nothing' when the node is not a row of
-the table.
+{- | Tier 1 of Note [Canonical Effect/ST heads]: rewrite an Effect/ST
+dictionary application into a reference to the real foreign method, per
+the table in the note. Runs at CoreFn translation, where no top-level
+aliases are visible (module-local references are still 'Local') and
+every produced reference is safe — the linker includes the accessor
+bindings the references demand. The produced reference keeps the outer
+application's annotation. 'Nothing' when the node is not a row of the
+table.
 -}
 canonicalizeEffectApp ∷ RawExp ann → Maybe (RawExp ann)
-canonicalizeEffectApp = \case
-  App ann (Ref _ (Imported hm hn)) (Ref _ (Imported dm dn))
-    | QName hm hn == bindQName →
-        canonicalRef ann <$> Map.lookup (QName dm dn) bindMethods
-    | QName hm hn == pureQName →
-        canonicalRef ann <$> Map.lookup (QName dm dn) pureMethods
-  App
-    ann
-    (App _ (Ref _ (Imported hm hn)) (Ref _ (Imported um un)))
-    (Ref _ (Imported dm dn))
-      | QName hm hn == discardQName
-      , QName um un == discardUnitQName →
-          canonicalRef ann <$> Map.lookup (QName dm dn) bindMethods
+canonicalizeEffectApp = canonicalizeWith (const Nothing) (const True)
+
+{- | Tier 2 of Note [Canonical Effect/ST heads]: like
+'canonicalizeEffectApp', with the module's top-level bindings in scope.
+Head positions match through top-level aliases (the purs CSE floats of
+issue #297), and a rewrite is declined unless the module still binds
+the canonical method the produced reference would name.
+-}
+canonicalizeEffectAppInModule
+  ∷ Map QName (RawExp ann) → RawExp ann → Maybe (RawExp ann)
+canonicalizeEffectAppInModule topLevel =
+  canonicalizeWith (`Map.lookup` topLevel) (`Map.member` topLevel)
+
+{- | The shared matcher: the first argument resolves a top-level alias
+to its right-hand side, the second says whether a reference to the
+given name may be manufactured. See Note [Canonical Effect/ST heads]
+for both.
+-}
+canonicalizeWith
+  ∷ ∀ ann
+   . (QName → Maybe (RawExp ann))
+  → (QName → Bool)
+  → RawExp ann
+  → Maybe (RawExp ann)
+canonicalizeWith resolve live = \case
+  App ann hd (Ref _ (Imported dm dn)) → do
+    methods ← methodTable hd
+    target ← Map.lookup (QName dm dn) methods
+    guard (live target)
+    pure (canonicalRef ann target)
   _ → Nothing
  where
   canonicalRef ∷ ann → QName → RawExp ann
   canonicalRef ann (QName m n) = Ref ann (Imported m n)
 
+  -- The method table the head selects: bind/pure denoted directly or
+  -- through aliases, or the discard·discardUnit pair — the pair itself
+  -- possibly one alias, each of its positions possibly one more.
+  methodTable ∷ RawExp ann → Maybe (Map QName QName)
+  methodTable hd
+    | denotes bindQName hd = Just bindMethods
+    | denotes pureQName hd = Just pureMethods
+    | Just (inner, unitArg) ← viewAppThroughAliases hd
+    , denotes discardQName inner
+    , denotes discardUnitQName unitArg =
+        Just bindMethods
+    | otherwise = Nothing
+
+  -- Whether the expression denotes the given qualified name: it is a
+  -- reference to it, or a reference to a top-level alias whose
+  -- right-hand side denotes it. The visited set bounds alias chains.
+  denotes ∷ QName → RawExp ann → Bool
+  denotes target = go mempty
+   where
+    go ∷ Set QName → RawExp ann → Bool
+    go visited = \case
+      Ref _ (Imported m n)
+        | QName m n == target → True
+        | qname ← QName m n
+        , Set.notMember qname visited
+        , Just rhs ← resolve qname →
+            go (Set.insert qname visited) rhs
+      _ → False
+
+  -- View an application node through top-level aliases: the node
+  -- itself, or the application a chain of aliases resolves to.
+  viewAppThroughAliases ∷ RawExp ann → Maybe (RawExp ann, RawExp ann)
+  viewAppThroughAliases = go mempty
+   where
+    go ∷ Set QName → RawExp ann → Maybe (RawExp ann, RawExp ann)
+    go visited = \case
+      App _ f a → Just (f, a)
+      Ref _ (Imported m n)
+        | qname ← QName m n
+        , Set.notMember qname visited
+        , Just rhs ← resolve qname →
+            go (Set.insert qname visited) rhs
+      _ → Nothing
+
 {- | The canonical Effect/ST bind methods: @Effect.bindE@ and
 @Control.Monad.ST.Internal.bind_@.
 -}

diff --git a/lib/Language/PureScript/Backend/IR/Linter.hs b/lib/Language/PureScript/Backend/IR/Linter.hs
@@ -4,18 +4,21 @@ suite always, in the CLI behind a debug flag. A violation names the exact
 top-level site, turning a silent miscompile into a loud failure that
 points at the offending pass.
 
-The linter only checks 'Local' references: after
+The per-pass checks cover 'Local' references only: after
 'Language.PureScript.Backend.IR.Linker.qualifyTopRefs' every top-level
-cross-reference is 'Language.PureScript.Backend.IR.Names.Imported', which
-this scope check deliberately ignores (mechanically checking those is
-part of the globally-unique-names redesign, issue #139).
+cross-reference is 'Language.PureScript.Backend.IR.Names.Imported', and
+unit fixtures legitimately use such references as free external names,
+so 'Imported' resolution ('lintDanglingImports') is checked on closed
+modules only — the optimizer's final result — rather than at every pass
+boundary.
 -}
 module Language.PureScript.Backend.IR.Linter
   ( Violation (..)
   , Site (..)
   , lintWellScoped
   , lintUniqueBinders
   , lintWellApplied
+  , lintDanglingImports
   , unboundLocals
   ) where
 
@@ -24,9 +27,10 @@ import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Language.PureScript.Backend.IR.Linker (UberModule (..))
 import Language.PureScript.Backend.IR.Names
-  ( Name (..)
-  , QName
-  , Qualified (Local)
+  ( ModuleName (..)
+  , Name (..)
+  , QName (..)
+  , Qualified (Imported, Local)
   , discardName
   )
 import Language.PureScript.Backend.IR.Types
@@ -82,6 +86,12 @@ data Violation
     site, like 'RefToDiscard'.
     -}
     ValuesOutsideTail Site
+  | {- | An 'Imported' reference to a top-level name the module does not
+    bind ('lintDanglingImports'). Codegen renders it as a read of a
+    never-assigned module-table field — a nil call at runtime (issue
+    #297).
+    -}
+    DanglingImport Site QName
   deriving stock (Eq, Show)
 
 -- | The top-level entry of the module a violation was found in.
@@ -138,6 +148,35 @@ lintWellApplied = overSites \site e →
     <> [CtorApplied site | hasAppliedCtor e]
     <> [ValuesOutsideTail site | hasMisplacedValues e]
 
+{- | Check that the module is closed: every 'Imported' reference outside
+the marker namespace @Prim@ (@Prim.undefined@, the effect-run marker)
+names a top-level binding or foreign of the module. Only meaningful for
+a linked module — unit fixtures reference external names freely — so it
+is checked on the optimizer's final result, not at pass boundaries: see
+'Language.PureScript.Backend.compileModules'. A dangling reference
+compiles to a read of a never-assigned module-table field, a nil call
+at runtime (issue #297).
+-}
+lintDanglingImports ∷ UberModule → [Violation]
+lintDanglingImports uber@UberModule {..} =
+  overSites (\site e → DanglingImport site <$> danglingImports e) uber
+ where
+  resolvable ∷ Set QName
+  resolvable =
+    Set.fromList $
+      fmap fst (listGrouping =<< uberModuleBindings)
+        <> fmap fst uberModuleForeigns
+
+  danglingImports ∷ Exp → [QName]
+  danglingImports e =
+    ordNub
+      [ qname
+      | Ref _ (Imported m n) ← toListOf (cosmosOf subexpressions) e
+      , m /= ModuleName "Prim"
+      , let qname = QName m n
+      , Set.notMember qname resolvable
+      ]
+
 {- | Run a per-site check over every top-level binding, foreign binding,
 and export of the module.
 -}