purescript-lua · Unisay · Jul 12, 2026 · Jul 12, 2026 · Jul 12, 2026
diff --git a/changelog.d/20260712_190000_unisay_alias_to_always_binding.md b/changelog.d/20260712_190000_unisay_alias_to_always_binding.md
@@ -5,6 +5,10 @@
   substituting the alias multiplied the target's use sites right before
   `Always` pasted its body into every one of them, duplicating the body
   (a lifted foreign's lambda, for example) across all alias use sites.
-  The `Always` directive is now also consulted by name at the top level,
-  so a binding that merely received an always-annotated body during an
-  earlier paste no longer turns unconditionally inlinable itself (#171).
+  The `Always` directive is now consulted by name at the top level, and
+  a whole-binding paste spends the root annotation instead of letting it
+  ride into the host binding, so an annotation no longer carries any
+  directive weight once optimization starts rewriting the tree.
+  `shareForeignAccessors` reads its `@inline always` opt-out from the
+  same name-keyed policy rather than from surviving node annotations
+  (#171).
diff --git a/lib/Language/PureScript/Backend/IR/Inliner.hs b/lib/Language/PureScript/Backend/IR/Inliner.hs
@@ -68,8 +68,10 @@ stages:
          consults it by name (@policyAlways@) and keeps a bare-Ref alias
          to such a name as the single materialization point — dissolving
          the alias would multiply the target's use sites right before
-         Always pastes its body into each (issue #171); the local rules
-         read the root annotation directly ('isInlinableExpr');
+         Always pastes its body into each (issue #171). The pasted
+         copies shed the annotation at the paste, so only pristine roots
+         ever carry directive weight; the local rules still read the
+         root annotation directly ('isInlinableExpr');
        * @Never@ names are never pasted ('withBinding', the call-site
          rules, and the uncurry split all veto them);
        * @Arity n@ names are pasted exactly at call sites applying at

diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs
@@ -204,7 +204,8 @@ optimizerPipeline policy =
       , passEnsures = guc
       }
   floatInPass = gucPass "float-in" floatIn
-  shareAccessorsPass = gucPass "share-accessors" shareForeignAccessors
+  shareAccessorsPass =
+    gucPass "share-accessors" (shareForeignAccessors policy)
   magicDoPass =
     Pass
       { passName = "magicDo"
@@ -265,18 +266,23 @@ and re-binds every accessor whose read occurs at two or more sites to
 its linker name, rewriting the reads to references.
 
 Runs once, after the specialize fixpoint has finished pasting (see
-'optimizerPipeline'). Only unannotated reads participate: a read
-carrying @inline always@ is pasted per site on explicit request, and a
-@never@ accessor never dissolved in the first place (see
-Note [Inline annotations and inlining heuristics]). The re-bound
+'optimizerPipeline'). The @inline@ directive is consulted by name, from
+the same 'InlinePolicy' every other inlining decision reads: a name
+under @inline always@ is skipped — its read is pasted per site on
+explicit request — and a @never@ accessor never dissolved in the first
+place, so its reads are already references to the kept binding (see
+Note [Inline annotations and inlining heuristics]). The read nodes
+themselves carry no directive weight here: a paste sheds the root
+annotation ('withBinding'), and a fold can transplant or drop one
+mid-pipeline. The re-bound
 accessor is inserted right after its module's 'ForeignImport' binding,
 where the module-init order guarantees the foreign table is already
 initialized; the reads it replaces sit in bindings placed after every
 foreign table ('mergeForeignsIntoBindings' front-loads them all) or in
 exports.
 -}
-shareForeignAccessors ∷ UberModule → UberModule
-shareForeignAccessors uber@UberModule {uberModuleBindings, uberModuleExports}
+shareForeignAccessors ∷ InlinePolicy → UberModule → UberModule
+shareForeignAccessors policy uber
   | Map.null shared = uber
   | otherwise =
       uber
@@ -286,9 +292,12 @@ shareForeignAccessors uber@UberModule {uberModuleBindings, uberModuleExports}
         , uberModuleExports = fmap (fmap rewriteExp) uberModuleExports
         }
  where
-  -- Unannotated accessor reads, keyed by the QName the linker
-  -- originally bound the accessor to, with one representative
-  -- expression per key (every copy of a read is identical). Only reads
+  UberModule {uberModuleBindings, uberModuleExports} = uber
+
+  -- Accessor reads of names with no @inline always@ directive, keyed
+  -- by the QName the linker originally bound the accessor to, with one
+  -- representative expression per key (copies are identical up to
+  -- their annotation slot, normalized to 'Nothing' here). Only reads
   -- whose module still has its 'ForeignImport' binding participate —
   -- always the case for a well-scoped module, since the read itself
   -- references the foreign table.
@@ -300,17 +309,19 @@ shareForeignAccessors uber@UberModule {uberModuleBindings, uberModuleExports}
     sharedNames =
       Map.keysSet $
         Map.filter (> 1) $
-          Map.fromListWith (+) [(qname, 1 ∷ Natural) | (qname, _) ← accessorReads]
+          Map.fromListWith
+            (+)
+            [(qname, 1 ∷ Natural) | (qname, _) ← accessorReads]
 
   accessorReads ∷ [(QName, Exp)]
   accessorReads =
-    [ (qname, node)
+    [ (qname, setAnn Nothing node)
     | expr ←
         (snd <$> (listGrouping =<< uberModuleBindings))
           <> (snd <$> uberModuleExports)
     , node ← universeOf subexpressions expr
-    , isNothing (getAnn node)
     , Just qname ← [foreignAccessorQName node]
+    , qname `Set.notMember` policyAlways policy
     , qname `Set.notMember` boundNames
     , qnameModuleName qname `Set.member` modulesWithForeign
     ]
@@ -333,8 +344,7 @@ shareForeignAccessors uber@UberModule {uberModuleBindings, uberModuleExports}
   rewriteExp = transformOf subexpressions \node →
     case foreignAccessorQName node of
       Just qname@(QName modname name)
-        | isNothing (getAnn node)
-        , qname `Map.member` shared →
+        | qname `Map.member` shared →
             refImported modname name
       _ → node
 
@@ -508,15 +518,15 @@ optimizeModule inlining policy UberModule {..} = runWriterT do
 
   -- The top-level counterpart of 'isInlinableExpr', diverging from it
   -- twice (issue #171). The Always directive is consulted by name —
-  -- 'policyAlways', not the RHS root annotation, which an earlier paste
-  -- may have planted there: a binding that merely received an
-  -- always-annotated body must not itself turn unconditionally
-  -- inlinable. And a bare-Ref alias to an @inline always@ binding is
-  -- never dissolved: substituting it would multiply the target's use
-  -- sites right before Always pastes its body into every one of them,
-  -- destroying the alias that is the better materialization point on
-  -- both size and speed. The target's body pastes into the surviving
-  -- alias instead.
+  -- 'policyAlways', never the RHS root annotation — for the reason all
+  -- directives are ('collectInlinePolicy'): a rewrite can drop or
+  -- transplant a live node's annotation, and the whole-binding paste
+  -- sheds it outright (see 'withBinding'). And a bare-Ref alias to an
+  -- @inline always@ binding is never dissolved: substituting it would
+  -- multiply the target's use sites right before Always pastes its
+  -- body into every one of them, destroying the alias that is the
+  -- better materialization point on both size and speed. The target's
+  -- body pastes into the surviving alias instead.
   topLevelInlinable ∷ QName → Exp → Bool
   topLevelInlinable qname expr =
     qname `Set.member` policyAlways policy
@@ -577,11 +587,19 @@ optimizeModule inlining policy UberModule {..} = runWriterT do
             -- substituted copies: a rewrite even when it had no
             -- occurrences left to substitute.
             tell Rewritten
+            -- The pasted copies are no longer the directed binding, so
+            -- the root annotation is spent at the paste rather than
+            -- riding into the hosts (mirrors the call-site paste in
+            -- 'inlineSaturatedCall'): an @inline always@ body pasted
+            -- into a bare-Ref alias would otherwise plant Just Always
+            -- on the alias's root, turning the alias itself
+            -- unconditionally inlinable one round later (issue #171).
+            let pasted = setAnn Nothing expr
             (bindings', exports') ←
               lift $
                 (,)
-                  <$> substituteInBindings qname expr bindings
-                  <*> substituteInExports qname expr exports
+                  <$> substituteInBindings qname pasted bindings
+                  <*> substituteInExports qname pasted exports
             -- Substituting drops the binding's own occurrences and pastes
             -- one copy of its free refs per occurrence replaced.
             let pastedRefs = fmap (* occurrences) (countFreeRefs expr)

diff --git a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs
@@ -32,6 +32,7 @@ import Language.PureScript.Backend.IR.Optimizer
   , optimizedExpression
   , optimizedUberModule
   , optimizedUberModuleChecked
+  , shareForeignAccessors
   , sinkProjectionIntoLet
   )
 import Language.PureScript.Backend.IR.Supply (runSupply)
@@ -966,6 +967,78 @@ spec = describe "IR Optimizer" do
         === [ (Name "main1", refImported mainModule (Name "add"))
             , (Name "main2", refImported mainModule (Name "add"))
             ]
+      -- The Always directive is spent on the paste: the body
+      -- materialized into the alias carries no annotation, so nothing
+      -- downstream can mistake the alias for a directed binding.
+      let aliasAnns =
+            [ getAnn rhs
+            | Standalone (qn, rhs) ← Linker.uberModuleBindings optimized
+            , qn == addName
+            ]
+      aliasAnns === [Nothing]
+
+    test "a use-once alias to an @inline always binding still dissolves" do
+      -- The veto guards multi-use aliases only: at a single use site the
+      -- dissolution is a relocation (the target's site count stays one),
+      -- so the alias collapses and the body lands at the one site, its
+      -- annotation spent.
+      let semiringModule = moduleNameFromString "Data.Semiring"
+          mainModule = moduleNameFromString "Main"
+          liftedIntAdd =
+            setAnn (Just Always) . abstraction (paramNamed (Name "x")) $
+              primBinOp PrimAdd (refLocal (Name "x")) (refLocal (Name "x"))
+          original =
+            Linker.UberModule
+              { uberModuleForeigns = []
+              , uberModuleBindings =
+                  [ Standalone
+                      (QName semiringModule (Name "intAdd"), liftedIntAdd)
+                  , Standalone
+                      ( QName mainModule (Name "add")
+                      , refImported semiringModule (Name "intAdd")
+                      )
+                  ]
+              , uberModuleExports =
+                  [(Name "main1", refImported mainModule (Name "add"))]
+              }
+      optimized ←
+        either (fail . show) pure (optimizedUberModuleChecked original)
+      annotateShow optimized
+      Linker.uberModuleBindings optimized === []
+      let exportNames = fst <$> Linker.uberModuleExports optimized
+      exportNames === [Name "main1"]
+      for_ (Linker.uberModuleExports optimized) \(_name, body) →
+        diff body alphaEq (setAnn Nothing liftedIntAdd)
+
+  describe "respects @inline always after a rewrite drops it (#171)" do
+    test "dissolves a fold-stripped always binding into every use site" do
+      -- foo = @inline always (if true then f 1 else g 2). The
+      -- unreachable-else fold rewrites the root to `f 1`, dropping the
+      -- annotation; the policy keys off the pristine name, so foo still
+      -- dissolves into both use sites — the @inline always mirror of the
+      -- "respects @inline never (issue #131)" test above.
+      let mainModule = moduleNameFromString "Main"
+          ext = moduleNameFromString "Ext"
+          thenB = application (refImported ext (Name "f")) (literalInt 1)
+          elseB = application (refImported ext (Name "g")) (literalInt 2)
+          fooExp =
+            setAnn (Just Always) (ifThenElse (literalBool True) thenB elseB)
+          original =
+            Linker.UberModule
+              { uberModuleForeigns = []
+              , uberModuleBindings =
+                  [Standalone (QName mainModule (Name "foo"), fooExp)]
+              , uberModuleExports =
+                  [ (Name "main1", refImported mainModule (Name "foo"))
+                  , (Name "main2", refImported mainModule (Name "foo"))
+                  ]
+              }
+      optimized ←
+        either (fail . show) pure (optimizedUberModuleChecked original)
+      annotateShow optimized
+      Linker.uberModuleBindings optimized === []
+      Linker.uberModuleExports optimized
+        === [(Name "main1", thenB), (Name "main2", thenB)]
 
   describe "gates inlining by Complexity and Capture (issue #231)" do
     let main' = moduleNameFromString "Main"
@@ -1721,11 +1794,49 @@ spec = describe "IR Optimizer" do
             [Name "a", Name "b"]
             (Just Always)
       accessorBindings optimized `shouldBe` []
+      -- The pasted reads shed the annotation at the paste; the per-site
+      -- contract holds anyway, because 'shareForeignAccessors' consults
+      -- the directive by name, not by reading the (unreliable) node
+      -- annotations.
       Linker.uberModuleExports optimized
-        `shouldBe` [ (Name "a", xAccessor (Just Always))
-                   , (Name "b", xAccessor (Just Always))
+        `shouldBe` [ (Name "a", xAccessor noAnn)
+                   , (Name "b", xAccessor noAnn)
                    ]
 
+    it "re-binds annotated reads of an undirected name" do
+      -- A fold can transplant a stray annotation onto a read
+      -- ('reduceObjectProp' hands the projection's own annotation to the
+      -- folded value), so the pass consults no node annotations: the
+      -- directive lives in the name-keyed policy alone. The inserted
+      -- binding is normalized to no annotation, whichever copy became
+      -- the representative.
+      let foreignBinding =
+            Standalone
+              ( QName mainModule (Name "foreign")
+              , ForeignImport noAnn mainModule "Main.purs" [(noAnn, Name "x")]
+              )
+          shared =
+            shareForeignAccessors
+              mempty
+              Linker.UberModule
+                { uberModuleForeigns = []
+                , uberModuleBindings = [foreignBinding]
+                , uberModuleExports =
+                    [ (Name "a", xAccessor (Just Never))
+                    , (Name "b", xAccessor (Just Never))
+                    ]
+                }
+      Linker.uberModuleExports shared
+        `shouldBe` [ (Name "a", refImported mainModule (Name "x"))
+                   , (Name "b", refImported mainModule (Name "x"))
+                   ]
+      let insertedAnns =
+            [ getAnn rhs
+            | Standalone (qn, rhs) ← Linker.uberModuleBindings shared
+            , qn == QName mainModule (Name "x")
+            ]
+      insertedAnns `shouldBe` [Nothing]
+
   describe "counts free references against the live module (#143)" do
     -- Within a single 'optimizeModule' run the use-once check must consult
     -- the current (post-substitution) view of the module, not a stale

diff --git a/test/ps/output/Golden.Annotations.M1/golden.ir b/test/ps/output/Golden.Annotations.M1/golden.ir
@@ -9,7 +9,7 @@ UberModule
       )
     ], uberModuleForeigns = [], uberModuleExports =
     [
-      ( Name "inlineMe", AbsN ( Just Always )
+      ( Name "inlineMe", AbsN Nothing
         ( ParamNamed Nothing ( Name "v$0" ) :| [] )
         ( IfThenElse Nothing
           ( Eq Nothing ( LiteralInt Nothing 1 ) ( Ref Nothing ( Local ( Name "v$0" ) ) ) )
@@ -21,7 +21,7 @@ UberModule
         ( Ref Nothing ( Imported ( ModuleName "Golden.Annotations.M1" ) ( Name "foreign" ) ) )
         ( PropName "dontInlineClosure" )
       ),
-      ( Name "inlineMeLambda", ObjectProp ( Just Always )
+      ( Name "inlineMeLambda", ObjectProp Nothing
         ( Ref Nothing ( Imported ( ModuleName "Golden.Annotations.M1" ) ( Name "foreign" ) ) )
         ( PropName "inlineMeLambda" )
       )

diff --git a/test/ps/output/Golden.Annotations.M2/golden.ir b/test/ps/output/Golden.Annotations.M2/golden.ir
@@ -41,12 +41,12 @@ UberModule
           ( PropName "dontInlineClosure" )
         )
         ( AppN Nothing
-          ( ObjectProp ( Just Always )
+          ( ObjectProp Nothing
             ( Ref Nothing ( Imported ( ModuleName "Golden.Annotations.M1" ) ( Name "foreign" ) ) )
             ( PropName "inlineMeLambda" )
           )
           ( AppN Nothing
-            ( ObjectProp ( Just Always )
+            ( ObjectProp Nothing
               ( Ref Nothing
                 ( Imported ( ModuleName "Golden.Annotations.M1" ) ( Name "foreign" ) )
               )

diff --git a/test/ps/output/Golden.BugListGenericEq.Test/golden.ir b/test/ps/output/Golden.BugListGenericEq.Test/golden.ir
@@ -65,7 +65,7 @@ UberModule
                 )
               )
             ),
-            ( PropName "conj", AbsN ( Just Always )
+            ( PropName "conj", AbsN Nothing
               ( ParamNamed Nothing ( Name "b1$232" ) :| [] )
               ( AbsN Nothing
                 ( ParamNamed Nothing ( Name "b2$233" ) :| [] )
@@ -75,7 +75,7 @@ UberModule
                 )
               )
             ),
-            ( PropName "disj", AbsN ( Just Always )
+            ( PropName "disj", AbsN Nothing
               ( ParamNamed Nothing ( Name "b1$230" ) :| [] )
               ( AbsN Nothing
                 ( ParamNamed Nothing ( Name "b2$231" ) :| [] )
@@ -85,7 +85,7 @@ UberModule
                 )
               )
             ),
-            ( PropName "not", AbsN ( Just Always )
+            ( PropName "not", AbsN Nothing
               ( ParamNamed Nothing ( Name "b$229" ) :| [] )
               ( PrimNot Nothing ( Ref Nothing ( Local ( Name "b$229" ) ) ) )
             )
@@ -485,7 +485,7 @@ UberModule
           )
           ( LiteralObject Nothing
             [
-              ( PropName "eq", AbsN ( Just Always )
+              ( PropName "eq", AbsN Nothing
                 ( ParamNamed Nothing ( Name "r1$225$238" ) :| [] )
                 ( AbsN Nothing
                   ( ParamNamed Nothing ( Name "r2$226$239" ) :| [] )