purescript-lua · Unisay · Jul 29, 2026 · Jul 29, 2026 · Jul 29, 2026
diff --git a/changelog.d/20260729_170000_unisay_cse_alpha_key_scope_order.md b/changelog.d/20260729_170000_unisay_cse_alpha_key_scope_order.md
@@ -0,0 +1,38 @@
+### Fixed
+
+- `alphaKey` — the canonical form common-subexpression elimination groups
+  repeated expressions by — no longer swallows a free reference that happens to
+  share the name of a `Let` binder it does not sit under (#349). It collected
+  every binder name of a `Let` into one rename map up front and canonicalized
+  all the right-hand sides under that map, so `let x = x in x` and
+  `let y = x in y` — alpha-equivalent, since a `Standalone` binding is
+  non-recursive and its right-hand side therefore resolves `x` to an outer
+  binder (Note [Sequential scoping of Let bindings]) — received different keys:
+
+  ```
+  alphaEq a b     = True
+  alphaKey a == b = False
+  keyA = Let () (Standalone ((),Name "$key0",Ref () (Local (Name "$key0"))) :| []) (Ref () (Local (Name "$key0")))
+  keyB = Let () (Standalone ((),Name "$key0",Ref () (Local (Name "x"))) :| []) (Ref () (Local (Name "$key0")))
+  ```
+
+  The map is now threaded through the groupings in scope order — a `Standalone`
+  right-hand side is canonicalized before its own binder enters, a
+  `RecursiveGroup`'s members all enter before any of theirs is walked — the
+  same shape `freshenBinders` and the `LetValues` case of this traversal
+  already use, so the free `x` survives in both keys:
+
+  ```
+  alphaKey a == b = True
+  keyA = Let () (Standalone ((),Name "$key0",Ref () (Local (Name "x"))) :| []) (Ref () (Local (Name "$key0")))
+  keyB = Let () (Standalone ((),Name "$key0",Ref () (Local (Name "x"))) :| []) (Ref () (Local (Name "$key0")))
+  ```
+
+  Emitted code is unchanged and the golden corpus stays byte-identical: the bug
+  could only ever cost a hoist (a shadowed right-hand side keyed to a shape
+  correct canonicalization cannot emit, so two occurrences that mean different
+  things could not merge), and it did not fire at all, because `uniquifyNames`
+  is the pipeline's entry pass and CSE runs behind the global-uniqueness
+  condition it establishes, under which no free reference can collide with a
+  binder. What the fix buys is that `alphaKey` no longer depends on that
+  condition for correct name resolution.
diff --git a/lib/Language/PureScript/Backend/IR/CSE.hs b/lib/Language/PureScript/Backend/IR/CSE.hs
@@ -99,8 +99,9 @@ converged block re-analyzes to no eligible groups at all.
 Requires and preserves the global-uniqueness condition (GUC =
 @UniqueBinders@, issue #139): the kept copy is one of the original
 occurrences (its binders stay unique — the deleted copies' binders are
-gone), the minted @$cse@ names are supply-fresh, and 'alphaKey' resolves
-references to binders by name, which GUC makes unambiguous.
+gone) and the minted @$cse@ names are supply-fresh. What GUC buys the
+analysis is the exactness of the scope guard above; 'alphaKey' itself
+threads binders in scope order and so needs no uniqueness assumption.
 
 == Pipeline placement
 
@@ -423,13 +424,15 @@ two expressions have equal keys iff they are alpha-equivalent up to
 annotations (the 'Language.PureScript.Backend.IR.Types.alphaEq' relation
 weakened by ignoring the annotations optimization sheds unevenly).
 
-Binders are resolved to their references by name, so the key is correct
-under the GUC discipline the pass runs under: binders are unique, so a
-reference belongs to a binder iff the names match (the discard binder
-@_@ is exempt from uniqueness and referenced by nothing, so it stays
-unrenamed). Free references keep their names; a positional
-@$key\<n\>@ name cannot collide with one, because @$@ never occurs in a
-source identifier and every supply-minted name uses another prefix.
+Binders are resolved to their references by name (the discard binder
+@_@ is the one exception: it stays unrenamed). Free references — bound
+outside the expression — keep their
+names, one that happens to share a binder's name included: the rename
+map is threaded in scope order, so a reference is renamed only by a
+binder that encloses it, and the innermost such one (Note [Sequential
+scoping of Let bindings]). A positional @$key\<n\>@ name cannot collide
+with a surviving free name, because @$@ never occurs in a source
+identifier and every supply-minted name uses another prefix.
 -}
 alphaKey ∷ RawExp ann → RawExp ()
 alphaKey = canonicalize . void
@@ -447,21 +450,10 @@ alphaKey = canonicalize . void
     AbsN ann params body → do
       (renames', params') ← mapAccumM renameParam renames params
       AbsN ann params' <$> go renames' body
+    -- The groupings bind sequentially, so the map grows left to right.
     Let ann binds body → do
-      -- Under unique binders no Let name can be referenced before it is
-      -- bound, so all the groupings can enter the rename map up front.
-      renames' ←
-        foldlM
-          ( \rs name → do
-              name' ← mint
-              pure (Map.insert name name' rs)
-          )
-          renames
-          (filter (/= discardName) (bindingNames =<< toList binds))
-      let renameBound (bindAnn, name, expr) =
-            (bindAnn,Map.findWithDefault name name renames',)
-              <$> go renames' expr
-      Let ann <$> traverse (traverse renameBound) binds <*> go renames' body
+      (renames', binds') ← mapAccumM keyGrouping renames binds
+      Let ann binds' <$> go renames' body
     -- The RHS is canonicalized under the incoming map — the binders
     -- scope over the body only (Note [Multi-value results]).
     LetValues ann params rhs body → do
@@ -470,6 +462,46 @@ alphaKey = canonicalize . void
       LetValues ann params' rhs' <$> go renames' body
     other → traverseOf subexpressions (go renames) other
 
+  keyGrouping
+    ∷ Map Name Name
+    → Grouping ((), Name, RawExp ())
+    → State Natural (Map Name Name, Grouping ((), Name, RawExp ()))
+  keyGrouping renames = \case
+    -- A Standalone binding is non-recursive: its RHS does not see its
+    -- own binder, so the RHS is canonicalized under the incoming map and
+    -- the binder enters only afterwards. A RHS reference sharing the
+    -- binder's name is therefore an occurrence of an outer binder and
+    -- keeps its name, as it must.
+    Standalone (bindAnn, name, expr) → do
+      expr' ← go renames expr
+      (renames', name') ← bindMinted renames name
+      pure (renames', Standalone (bindAnn, name', expr'))
+    -- Every member of a recursive group is in scope in every member's
+    -- RHS, so the whole group enters the map before any RHS is walked.
+    RecursiveGroup members → do
+      (renames', rebound) ←
+        mapAccumM
+          ( \rs (bindAnn, name, expr) → do
+              (rs', name') ← bindMinted rs name
+              pure (rs', (bindAnn, name', expr))
+          )
+          renames
+          members
+      members' ← forM rebound \(bindAnn, name, expr) →
+        (bindAnn,name,) <$> go renames' expr
+      pure (renames', RecursiveGroup members')
+
+  -- The discard binder is exempt from the uniqueness invariant — one Let
+  -- can bind it several times (magic-do's discard statements) — and
+  -- nothing may reference it, so it takes no positional name and stays
+  -- out of the map.
+  bindMinted ∷ Map Name Name → Name → State Natural (Map Name Name, Name)
+  bindMinted rs name
+    | name == discardName = pure (rs, name)
+    | otherwise = do
+        name' ← mint
+        pure (Map.insert name name' rs, name')
+
   renameParam
     ∷ Map Name Name
     → Parameter ()

diff --git a/test/Language/PureScript/Backend/IR/CSE/Spec.hs b/test/Language/PureScript/Backend/IR/CSE/Spec.hs
@@ -76,6 +76,41 @@ spec = describe "CSE" do
             (application (application f cse0) cse0)
     cseExpression expr `shouldBe` expected
 
+  it "hoists Lets whose Standalone RHS references an outer binder (#349)" do
+    -- See Note [Sequential scoping of Let bindings]: a Standalone binding
+    -- is non-recursive, so the right-hand-side x is a free occurrence of
+    -- the enclosing x in both copies below — which therefore differ only
+    -- in the name chosen for the binder. Wrapping in a lambda makes each
+    -- copy a candidate.
+    let shadowing name =
+          abstraction (paramNamed (Name "$p")) $
+            lets
+              (pure (Standalone (noAnn, Name name, refLocal (Name "x"))))
+              (refLocal (Name name))
+        expr = application (application f (shadowing "x")) (shadowing "y")
+        expected =
+          lets
+            (pure (bind0 (shadowing "x")))
+            (application (application f cse0) cse0)
+    cseExpression expr `shouldBe` expected
+
+  it "hoists recursive groups differing only in the member name" do
+    -- The contrast to the case above: a RecursiveGroup member's
+    -- right-hand side does see its own binder, so the self-reference is
+    -- bound in both copies and the two are alpha-equivalent.
+    let recursive name =
+          let self = Name name
+           in abstraction (paramNamed (Name "$p")) $
+                lets
+                  (pure (RecursiveGroup ((noAnn, self, refLocal self) :| [])))
+                  (refLocal self)
+        expr = application (application g (recursive "a")) (recursive "b")
+        expected =
+          lets
+            (pure (bind0 (recursive "a")))
+            (application (application g cse0) cse0)
+    cseExpression expr `shouldBe` expected
+
   it "hoists a repeat sitting in both branches of an if" do
     let expr =
           ifThenElse cond (application f (lam "a")) (application g (lam "b"))