purescript-lua · Unisay · Jul 12, 2026 · Jul 12, 2026 · Jul 12, 2026 · Jul 12, 2026
diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md
@@ -258,20 +258,21 @@ which collapses `Array Unit` to an empty table.
 
 ## FFI foreign module shape
 
-Foreign `.lua` files have a header of `local` helpers followed by a single
-returned table. Each exported value **must be wrapped in parentheses**:
+Foreign `.lua` files are ordinary Lua 5.1 modules, parsed with the compiler's
+own Lua 5.1 parser: a header of `local` helpers followed by a single returned
+table of exports. Values need no special wrapping, and comments are allowed
+anywhere, including between table fields:
 
 ```lua
 local function helper(x) return x + 1 end
 
 return {
-  foo = (function(a) return helper(a) end),
-  bar = (function(a) return function(b) return a + b end end),
+  foo = function(a) return helper(a) end,
+  -- comments between fields are fine
+  bar = function(a) return function(b) return a + b end end,
 }
 ```
 
-Do not put `--` comments between table fields. The FFI parser rejects them.
-
 ---
 
 ## Common pitfalls

diff --git a/changelog.d/20260712_150000_unisay_foreign_accessor_default.md b/changelog.d/20260712_150000_unisay_foreign_accessor_default.md
@@ -0,0 +1,12 @@
+### Changed
+
+- Foreign accessors are no longer `@inline always` by default (#248). An
+  accessor without a pragma now dissolves into its use site only when it has
+  at most one; at two or more sites it is kept as a shared binding, which
+  stage-2 promotion (#174) turns into a chunk local — every use becomes a
+  register/upvalue read instead of a repeated table-field read. Explicit
+  pragmas keep their meaning in both directions: `@inline <name> always`
+  restores the per-site field read, `@inline <name> never` keeps the shared
+  binding even when used once. Bodies lifted into the IR by the foreign-lift
+  pass are still marked inline-always by that pass, since they exist to
+  beta-reduce at saturated call sites.
diff --git a/lib/Language/PureScript/Backend/IR/Inliner.hs b/lib/Language/PureScript/Backend/IR/Inliner.hs
@@ -76,12 +76,20 @@ stages:
 A whole-binding pragma on a foreign name (@always@/@never@/@default@ only —
 there is no body to paste at an arity, nor a field to select) is drained
 into 'moduleForeigns' and reaches the linker, which binds each foreign name
-to an 'ObjectProp' accessor annotated with that pragma, defaulting to
-'Always' so the wrapper around the FFI object is inlined away unless a
-pragma says otherwise (see Note [Foreign bindings structure emitted by the
-Linker]). @never@ keeps the accessor as a shared binding — the way to
-declare sharing intent for an FFI value; an explicit @default@ resolves to
-the same built-in 'Always'.
+to an 'ObjectProp' accessor carrying that pragma alone (see
+Note [Foreign bindings structure emitted by the Linker]). An unannotated
+accessor dissolves into its use sites like any cheap projection, but the
+sharing is rebuilt at the end of the pipeline:
+'Language.PureScript.Backend.IR.Optimizer.shareForeignAccessors' re-binds a
+field read that survived at two or more sites, since a read repeated per
+site loses to a shared binding once stage-2 promotion turns that binding
+into a chunk local (issue #248). @always@ opts a name out of the re-binding
+— a per-site field read at any use count — and @never@ keeps the accessor a
+shared binding from the start, even when used once; an explicit @default@
+resolves to no annotation, same as leaving the pragma off. The lifted
+foreign bodies are the exception:
+'Language.PureScript.Backend.Lua.ForeignLift.liftForeigns' marks them
+@always@ itself, because they exist to beta-reduce at saturated call sites.
 
 The 'ForeignImport' expression itself — the table of a foreign module's
 exports — is the one shape the optimizer refuses to inline even when it is

diff --git a/lib/Language/PureScript/Backend/IR/Linker.hs b/lib/Language/PureScript/Backend/IR/Linker.hs
@@ -5,7 +5,6 @@ module Language.PureScript.Backend.IR.Linker where
 import Control.Lens (over)
 import Data.Graph (graphFromEdges', reverseTopSort)
 import Data.Set qualified as Set
-import Language.PureScript.Backend.IR.Inliner qualified as Inline
 import Language.PureScript.Backend.IR.Names
   ( ModuleName (..)
   , Name (..)
@@ -63,24 +62,25 @@ that downstream passes pattern-match by structure, so the producer here and the
 consumers must agree.
 
   * One 'ForeignImport' per module that has any foreigns, bound to the special
-    name @foreign@ (@QName moduleName (Name "foreign")@). It carries the module
+    name @foreign@ (@QName moduleName 'foreignName'@). It carries the module
     name, the source path, and the list of foreign names.
   * One 'ObjectProp' per foreign name, bound to @QName moduleName name@, that
     reads that name as a field off the @foreign@ import. It carries the name's
-    @inline@ pragma annotation when one is declared, and defaults to
-    'Inline.Always'.
+    @inline@ pragma annotation when one is declared and no annotation
+    otherwise, leaving the dissolve-or-share decision to the optimizer's use
+    count (see Note [Inline annotations and inlining heuristics]).
 
 'Language.PureScript.Backend.IR.DCE' depends on exactly these shapes: it splits
 the foreigns into 'ForeignImport's and 'ObjectProp's by pattern, and when it
 keeps a 'ForeignImport' it prunes the carried name list to the reachable names.
-Change either shape here and the DCE patterns silently stop matching.
+'Language.PureScript.Backend.IR.Optimizer.shareForeignAccessors' recognises
+dissolved copies of the accessor shape via 'foreignAccessorQName'. Change
+either shape here and those patterns silently stop matching.
 -}
 foreignBindings ∷ Module → [(QName, Exp)]
 foreignBindings Module {moduleName, modulePath, moduleForeigns} =
   foreignModuleBinding <> foreignNamesBindings
  where
-  foreignName = Name "foreign"
-
   foreignModuleBinding ∷ [(QName, Exp)] =
     [ ( QName moduleName foreignName
       , ForeignImport noAnn moduleName modulePath moduleForeigns
@@ -93,11 +93,30 @@ foreignBindings Module {moduleName, modulePath, moduleForeigns} =
     moduleForeigns <&> \(ann, name) →
       ( QName moduleName name
       , ObjectProp
-          (ann <|> Just Inline.Always)
+          ann
           (refImported moduleName foreignName)
           (PropName (nameToText name))
       )
 
+{- | The special name a module's 'ForeignImport' table is bound to
+(Note [Foreign bindings structure emitted by the Linker]). @foreign@ is a
+PureScript keyword, so no user-defined top-level binding can collide with it.
+-}
+foreignName ∷ Name
+foreignName = Name "foreign"
+
+{- | Recognise the accessor shape 'foreignBindings' emits — a field read off a
+module's @foreign@ import — and recover the 'QName' the accessor was bound
+to. Total on any expression: only the linker builds references to
+'foreignName', and the property name round-trips through 'nameToText' (see
+Note [Foreign bindings structure emitted by the Linker]).
+-}
+foreignAccessorQName ∷ RawExp ann → Maybe QName
+foreignAccessorQName = \case
+  ObjectProp _ann (Ref _refAnn (Imported modname name)) (PropName prop)
+    | name == foreignName → Just (QName modname (Name prop))
+  _ → Nothing
+
 qualifiedModuleBindings ∷ Module → [Grouping (QName, Exp)]
 qualifiedModuleBindings Module {moduleName, moduleBindings, moduleForeigns} =
   moduleBindings <&> \case

diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs
@@ -1,6 +1,6 @@
 module Language.PureScript.Backend.IR.Optimizer where
 
-import Control.Lens (over, toListOf)
+import Control.Lens (over, toListOf, transformOf, universeOf)
 import Control.Monad.Writer.CPS (WriterT, runWriterT, tell)
 import Data.Foldable (foldrM)
 import Data.List qualified as List
@@ -13,10 +13,14 @@ import Language.PureScript.Backend.IR.DCE (eliminateDeadCode)
 import Language.PureScript.Backend.IR.FlattenDeepBinds (flattenDeepBindsM)
 import Language.PureScript.Backend.IR.FloatIn (floatIn)
 import Language.PureScript.Backend.IR.Inliner (Annotation (..))
-import Language.PureScript.Backend.IR.Linker (UberModule (..))
+import Language.PureScript.Backend.IR.Linker
+  ( UberModule (..)
+  , foreignAccessorQName
+  )
 import Language.PureScript.Backend.IR.MagicDo (magicDo)
 import Language.PureScript.Backend.IR.Names
   ( FieldName
+  , ModuleName
   , Name (..)
   , PropName
   , QName (..)
@@ -64,6 +68,7 @@ import Language.PureScript.Backend.IR.Types
   , literalString
   , paramName
   , primNot
+  , refImported
   , rewriteExpBottomUpM
   , setAnn
   , subexpressions
@@ -141,6 +146,13 @@ optimizerPipeline policy =
     -- Maybe/Either/Writer/State chains into straight-line code. Code growth
     -- is bounded by 'inlineSizeBudget'.
     RunFixpoint "specialize+dce" (specializePass :| [dcePass])
+  , -- Rebuild sharing for the foreign-accessor reads that dissolution
+    -- and the call-site pastes above duplicated: a read surviving at
+    -- two or more sites is re-bound to its linker name, which stage-2
+    -- promotion then turns into a chunk local (issue #248). Runs after
+    -- the last pass that can multiply reads and before the final
+    -- flattening. See 'shareForeignAccessors'.
+    RunPass shareAccessorsPass
   , -- Flatten the remaining deeply-nested expression trees (issues #104,
     -- #108): continuation/bind chains of any monad (lambda-lifted
     -- into $kont helpers) and applicative/flipped-bind application
@@ -194,6 +206,7 @@ optimizerPipeline policy =
       , passEnsures = guc
       }
   floatInPass = gucPass "float-in" floatIn
+  shareAccessorsPass = gucPass "share-accessors" shareForeignAccessors
   magicDoPass =
     Pass
       { passName = "magicDo"
@@ -241,6 +254,103 @@ mergeForeignsIntoBindings uberModule@UberModule {..} =
         map Standalone uberModuleForeigns <> uberModuleBindings
     }
 
+{- | Rebuild sharing for foreign-accessor reads duplicated during
+optimization (issue #248). An unannotated accessor dissolves into its
+use sites like any cheap projection (the Deref tier of
+Note [Complexity and Capture gate inlining]), and call-site inlining
+multiplies the pasted read further: a dictionary method resolved at
+several sites pastes one field read per site. A field read repeated per
+site loses to a shared binding once stage-2 promotion
+('Language.PureScript.Backend.Lua.Promote') turns that binding into a
+chunk local, so this pass counts the reads that survived the pipeline
+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
+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}
+  | Map.null shared = uber
+  | otherwise =
+      uber
+        { uberModuleBindings =
+            insertAccessorBindings
+              (fmap (fmap (fmap rewriteExp)) uberModuleBindings)
+        , 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
+  -- whose module still has its 'ForeignImport' binding participate —
+  -- always the case for a well-scoped module, since the read itself
+  -- references the foreign table.
+  shared ∷ Map QName Exp
+  shared =
+    Map.fromListWith (\_new old → old) accessorReads
+      `Map.restrictKeys` sharedNames
+   where
+    sharedNames =
+      Map.keysSet $
+        Map.filter (> 1) $
+          Map.fromListWith (+) [(qname, 1 ∷ Natural) | (qname, _) ← accessorReads]
+
+  accessorReads ∷ [(QName, Exp)]
+  accessorReads =
+    [ (qname, node)
+    | expr ←
+        (snd <$> (listGrouping =<< uberModuleBindings))
+          <> (snd <$> uberModuleExports)
+    , node ← universeOf subexpressions expr
+    , isNothing (getAnn node)
+    , Just qname ← [foreignAccessorQName node]
+    , qname `Set.notMember` boundNames
+    , qnameModuleName qname `Set.member` modulesWithForeign
+    ]
+
+  -- Top-level names already bound: an accessor kept by an @inline
+  -- never@ veto reaches this pass as a binding, and its reads are
+  -- already references.
+  boundNames ∷ Set QName
+  boundNames =
+    Set.fromList (fst <$> (listGrouping =<< uberModuleBindings))
+
+  modulesWithForeign ∷ Set ModuleName
+  modulesWithForeign =
+    Set.fromList
+      [ qnameModuleName qname
+      | Standalone (qname, ForeignImport {}) ← uberModuleBindings
+      ]
+
+  rewriteExp ∷ Exp → Exp
+  rewriteExp = transformOf subexpressions \node →
+    case foreignAccessorQName node of
+      Just qname@(QName modname name)
+        | isNothing (getAnn node)
+        , qname `Map.member` shared →
+            refImported modname name
+      _ → node
+
+  insertAccessorBindings
+    ∷ [Grouping (QName, Exp)] → [Grouping (QName, Exp)]
+  insertAccessorBindings = concatMap \case
+    grouping@(Standalone (qname, ForeignImport {})) →
+      grouping
+        : [ Standalone (accessor, rhs)
+          | (accessor, rhs) ← Map.toAscList shared
+          , qnameModuleName accessor == qnameModuleName qname
+          ]
+    grouping → [grouping]
+
 {- | Every inlining directive of the module, keyed by binding name.
 Collected once from the pristine module: later rewrites can drop an
 annotation off its node (e.g. constant folding replaces a binding's root

diff --git a/lib/Language/PureScript/Backend/Lua/ForeignLift.hs b/lib/Language/PureScript/Backend/Lua/ForeignLift.hs
@@ -86,6 +86,7 @@ import Control.Monad.Oops qualified as Oops
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Data.Tagged (Tagged, untag)
+import Language.PureScript.Backend.IR.Inliner qualified as Inline
 import Language.PureScript.Backend.IR.Linker (UberModule (..))
 import Language.PureScript.Backend.IR.Names
   ( ModuleName
@@ -242,7 +243,15 @@ liftForeigns
       case expr of
         ObjectProp ann _ _ | qname `Set.member` allowlist →
           case liftAccessor sources qname of
-            Just lifted → pure (Right (qname, setAnn ann lifted))
+            -- A lifted body exists to beta-reduce at saturated call
+            -- sites, so it is marked @inline always@ here: without the
+            -- annotation a multi-use lifted body — an abstraction, not
+            -- a cheap projection — would stay a shared binding and its
+            -- call sites would never reduce (see Note [Inline
+            -- annotations and inlining heuristics]). An explicit
+            -- pragma still wins.
+            Just lifted →
+              pure (Right (qname, setAnn (ann <|> Just Inline.Always) lifted))
             Nothing → Oops.throw (NotLiftable qname)
         _ → pure (Left entry)
     let (keptForeigns, liftedBindings) = partitionEithers results