From 23bd3040454fbc243f061c5cb1b2b81f0ae06c25 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Sun, 12 Jul 2026 21:31:08 +0200 Subject: [PATCH 1/2] refactor(ir): spend the inline annotation at the paste; name-key the share opt-out (#171) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A whole-binding paste no longer lets the root annotation ride into the host binding: the pasted copy sheds it, mirroring the call-site paste in inlineSaturatedCall. With that, node annotations carry no directive weight once optimization starts rewriting the tree, so shareForeignAccessors now reads its @inline always opt-out from the name-keyed InlinePolicy instead of testing each read node's surviving annotation — the per-site contract of an explicit always pragma no longer depends on an annotation happening to survive every rewrite. Structural golden churn is annotation display only: pasted reads print Nothing where they printed Just Always. Generated Lua and eval oracles are byte-identical. --- ...2_190000_unisay_alias_to_always_binding.md | 10 ++- lib/Language/PureScript/Backend/IR/Inliner.hs | 6 +- .../PureScript/Backend/IR/Optimizer.hs | 70 ++++++++++++------- .../PureScript/Backend/IR/Optimizer/Spec.hs | 17 ++++- .../ps/output/Golden.Annotations.M1/golden.ir | 4 +- .../ps/output/Golden.Annotations.M2/golden.ir | 4 +- .../Golden.BugListGenericEq.Test/golden.ir | 8 +-- .../Golden.GenericEqTwoTypes.Test/golden.ir | 8 +-- test/ps/output/Golden.Primops.Test/golden.ir | 6 +- .../Golden.StringCodePoints.Test/golden.ir | 8 +-- 10 files changed, 89 insertions(+), 52 deletions(-) diff --git a/changelog.d/20260712_190000_unisay_alias_to_always_binding.md b/changelog.d/20260712_190000_unisay_alias_to_always_binding.md index 91c9d147..cdef7236 100644 --- 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 index 42cf0f49..fa50fe0b 100644 --- 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 index b04b46e3..cb525eaf 100644 --- 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 index c4f665a4..c26312b8 100644 --- a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs @@ -966,6 +966,15 @@ 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] describe "gates inlining by Complexity and Capture (issue #231)" do let main' = moduleNameFromString "Main" @@ -1721,9 +1730,13 @@ 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) ] describe "counts free references against the live module (#143)" do diff --git a/test/ps/output/Golden.Annotations.M1/golden.ir b/test/ps/output/Golden.Annotations.M1/golden.ir index 6e5f24db..df02c0ba 100644 --- 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 index 62d4443d..ad796623 100644 --- 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 index 4c1bbb16..d1ab1c23 100644 --- 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" ) :| [] ) diff --git a/test/ps/output/Golden.GenericEqTwoTypes.Test/golden.ir b/test/ps/output/Golden.GenericEqTwoTypes.Test/golden.ir index 1da8b6da..fce62845 100644 --- a/test/ps/output/Golden.GenericEqTwoTypes.Test/golden.ir +++ b/test/ps/output/Golden.GenericEqTwoTypes.Test/golden.ir @@ -65,7 +65,7 @@ UberModule ) ) ), - ( PropName "conj", AbsN ( Just Always ) + ( PropName "conj", AbsN Nothing ( ParamNamed Nothing ( Name "b1$220" ) :| [] ) ( AbsN Nothing ( ParamNamed Nothing ( Name "b2$221" ) :| [] ) @@ -75,7 +75,7 @@ UberModule ) ) ), - ( PropName "disj", AbsN ( Just Always ) + ( PropName "disj", AbsN Nothing ( ParamNamed Nothing ( Name "b1$218" ) :| [] ) ( AbsN Nothing ( ParamNamed Nothing ( Name "b2$219" ) :| [] ) @@ -85,7 +85,7 @@ UberModule ) ) ), - ( PropName "not", AbsN ( Just Always ) + ( PropName "not", AbsN Nothing ( ParamNamed Nothing ( Name "b$217" ) :| [] ) ( PrimNot Nothing ( Ref Nothing ( Local ( Name "b$217" ) ) ) ) ) @@ -95,7 +95,7 @@ UberModule ( QName { qnameModuleName = ModuleName "Data.Eq", qnameName = Name "eqInt" }, LiteralObject Nothing [ - ( PropName "eq", AbsN ( Just Always ) + ( PropName "eq", AbsN Nothing ( ParamNamed Nothing ( Name "r1$213" ) :| [] ) ( AbsN Nothing ( ParamNamed Nothing ( Name "r2$214" ) :| [] ) diff --git a/test/ps/output/Golden.Primops.Test/golden.ir b/test/ps/output/Golden.Primops.Test/golden.ir index 3aa8ef0e..354df0fc 100644 --- a/test/ps/output/Golden.Primops.Test/golden.ir +++ b/test/ps/output/Golden.Primops.Test/golden.ir @@ -58,7 +58,7 @@ UberModule ) ) ), - ( PropName "conj", AbsN ( Just Always ) + ( PropName "conj", AbsN Nothing ( ParamNamed Nothing ( Name "b1$213" ) :| [] ) ( AbsN Nothing ( ParamNamed Nothing ( Name "b2$214" ) :| [] ) @@ -68,7 +68,7 @@ UberModule ) ) ), - ( PropName "disj", AbsN ( Just Always ) + ( PropName "disj", AbsN Nothing ( ParamNamed Nothing ( Name "b1$211" ) :| [] ) ( AbsN Nothing ( ParamNamed Nothing ( Name "b2$212" ) :| [] ) @@ -78,7 +78,7 @@ UberModule ) ) ), - ( PropName "not", AbsN ( Just Always ) + ( PropName "not", AbsN Nothing ( ParamNamed Nothing ( Name "b$210" ) :| [] ) ( PrimNot Nothing ( Ref Nothing ( Local ( Name "b$210" ) ) ) ) ) diff --git a/test/ps/output/Golden.StringCodePoints.Test/golden.ir b/test/ps/output/Golden.StringCodePoints.Test/golden.ir index 4ec33ed1..7fe0dd51 100644 --- a/test/ps/output/Golden.StringCodePoints.Test/golden.ir +++ b/test/ps/output/Golden.StringCodePoints.Test/golden.ir @@ -191,7 +191,7 @@ UberModule ) ) ), - ( PropName "conj", AbsN ( Just Always ) + ( PropName "conj", AbsN Nothing ( ParamNamed Nothing ( Name "b1$1497" ) :| [] ) ( AbsN Nothing ( ParamNamed Nothing ( Name "b2$1498" ) :| [] ) @@ -201,7 +201,7 @@ UberModule ) ) ), - ( PropName "disj", AbsN ( Just Always ) + ( PropName "disj", AbsN Nothing ( ParamNamed Nothing ( Name "b1$1495" ) :| [] ) ( AbsN Nothing ( ParamNamed Nothing ( Name "b2$1496" ) :| [] ) @@ -211,7 +211,7 @@ UberModule ) ) ), - ( PropName "not", AbsN ( Just Always ) + ( PropName "not", AbsN Nothing ( ParamNamed Nothing ( Name "b$1494" ) :| [] ) ( PrimNot Nothing ( Ref Nothing ( Local ( Name "b$1494" ) ) ) ) ) @@ -221,7 +221,7 @@ UberModule ( QName { qnameModuleName = ModuleName "Data.Eq", qnameName = Name "eqInt" }, LiteralObject Nothing [ - ( PropName "eq", AbsN ( Just Always ) + ( PropName "eq", AbsN Nothing ( ParamNamed Nothing ( Name "r1$1490" ) :| [] ) ( AbsN Nothing ( ParamNamed Nothing ( Name "r2$1491" ) :| [] ) From cbb79d31b2541c41efd45c90ac5dadd1481c8f87 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Sun, 12 Jul 2026 21:40:45 +0200 Subject: [PATCH 2/2] test(optimizer): pin the veto boundary, the name-keyed always, and the share pass's annotation blindness (#171) Three regression pins around the #171 surface: a use-once alias to an @inline always binding still dissolves (the veto guards multi-use aliases only), a fold that drops the root annotation no longer disables an explicit always (the @inline never mirror), and shareForeignAccessors re-binds annotated reads of an undirected name, normalizing the inserted binding's annotation slot. --- .../PureScript/Backend/IR/Optimizer/Spec.hs | 98 +++++++++++++++++++ 1 file changed, 98 insertions(+) diff --git a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs index c26312b8..40c6e3d4 100644 --- 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) @@ -976,6 +977,69 @@ spec = describe "IR Optimizer" do ] 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" ext = moduleNameFromString "Ext" @@ -1739,6 +1803,40 @@ spec = describe "IR Optimizer" do , (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