purescript-lua · Unisay · Jul 15, 2026 · Jul 15, 2026 · Jul 15, 2026 · Jul 15, 2026
diff --git a/bench/goldens/fnew_Bench.TupleFold.txt b/bench/goldens/fnew_Bench.TupleFold.txt
@@ -0,0 +1,8 @@
+chunk: Bench.TupleFold.lua
+runtime: LuaJIT 2.1.1741730670
+main-chunk FNEW: 2
+function-body FNEW: 1
+total FNEW: 3
+prototypes: 4
+function-body FNEW sites:
+  Bench.TupleFold.lua:15
diff --git a/bench/goldens/trace_tuple_fold.txt b/bench/goldens/trace_tuple_fold.txt
@@ -0,0 +1,13 @@
+spec: tuple_fold
+runtime: LuaJIT 2.1.1741730670
+workload: n=5000000 reps=4 result=124999750000
+aborts (distinct site -- reason):
+  Bench.TupleFold.lua:15 -- NYI: bytecode FNEW
+  Bench.TupleFold.lua:16 -- NYI: bytecode UCLO
+  Bench.TupleFold.lua:9 -- inner loop in root trace
+  tuple_fold.lua:22 -- inner loop in root trace
+bytecode end state (J*=compiled, I*=blacklisted):
+  Bench.TupleFold.lua:1 JFUNCF
+  Bench.TupleFold.lua:8 JLOOP
+  tuple_fold.lua:21 JLOOP
+counts: aborts=4 compiled=3 blacklisted=0
diff --git a/bench/macro/tuple_fold.lua b/bench/macro/tuple_fold.lua
@@ -0,0 +1,26 @@
+-- A fold-shaped loop carrying a Tuple accumulator. Call-pattern
+-- specialization (issue #208) passes the two fields as raw loop
+-- parameters, so the compiled loop does the same two-variable
+-- accumulation as the ideal below and allocates the box only on the
+-- exit path -- one table per call instead of one per iteration.
+return {
+  artifact = "Bench.TupleFold",
+  n = 5e6,
+  -- Ten calls of n/10 rather than one call of n: the same total work
+  -- for the timing runners, but keeps each hot-counter's bumps within
+  -- one recording attempt. See the note in array_foldl.lua.
+  drive = function(mod, n)
+    local acc
+    for _ = 1, 10 do
+      acc = mod.run(n / 10)
+    end
+    return acc
+  end,
+  ideal = function(n)
+    local s, i = 0, 0
+    while i < n do
+      s, i = s + i, i + 1
+    end
+    return s
+  end,
+}
diff --git a/changelog.d/20260715_120000_unisay_spec_constr.md b/changelog.d/20260715_120000_unisay_spec_constr.md
@@ -0,0 +1,15 @@
+### Added
+
+- Call-pattern specialization for recursive bindings, GHC's SpecConstr
+  discipline on the IR (#208): a recursive function that scrutinizes a
+  parameter and passes a known constructor at that position in its recursive
+  calls gets a specialized copy taking the constructor's fields as separate
+  parameters, and every qualifying call site is rewritten to it. Fold-shaped
+  loops with `Tuple`/`Maybe`/`Either` accumulators then carry raw values
+  instead of allocating a box per iteration; the box materializes only where
+  it escapes (the exit path). Specializations are capped per binding and
+  minted one layer per specialize+dce round, so nested accumulators unbox
+  incrementally without unbounded code growth. On the new `tuple_fold`
+  macro benchmark the compiled loop drops the per-iteration table build,
+  running ~2.5x faster under PUC Lua 5.1 (LuaJIT already sank the
+  allocation inside its trace, so it is unchanged there).
diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs
@@ -36,6 +36,12 @@ import Language.PureScript.Backend.IR.Pass
   , runSteps
   , runStepsChecked
   )
+import Language.PureScript.Backend.IR.Query
+  ( CtorShape (..)
+  , ctorShapeTag
+  , resolveKnownCtorApp
+  )
+import Language.PureScript.Backend.IR.SpecConstr (specConstr)
 import Language.PureScript.Backend.IR.Supply (SupplyM, freshName, runSupply)
 import Language.PureScript.Backend.IR.Types
   ( AlgebraicType (SumType)
@@ -150,7 +156,16 @@ optimizerPipeline policy =
     -- the case-of-known-constructor folds (#177/#213/#214), collapsing
     -- Maybe/Either/Writer/State chains into straight-line code. Code growth
     -- is bounded by 'inlineSizeBudget'.
-    RunFixpoint "specialize+dce" (specializePass :| [dcePass])
+    --
+    -- Call-pattern specialization (issue #208) rides in the same fixpoint:
+    -- a recursive binding whose recursion passes a known constructor at a
+    -- scrutinized parameter position gets an unboxed specialized copy, and
+    -- the next optimize round's constructor folds collapse the reboxes its
+    -- body carries. Each round mints one specialization layer, so the
+    -- fixpoint provides the bounded iteration a nested accumulator needs;
+    -- the per-binding cap in Language.PureScript.Backend.IR.SpecConstr
+    -- keeps the minting finite.
+    RunFixpoint "specialize+dce" (specializePass :| [dcePass, specConstrPass])
   , -- 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
@@ -223,6 +238,13 @@ optimizerPipeline policy =
       , passRequires = guc
       , passEnsures = guc
       }
+  specConstrPass =
+    Pass
+      { passName = "spec-constr"
+      , passRun = specConstr (uncurryVeto policy)
+      , passRequires = guc
+      , passEnsures = guc
+      }
   dcePass =
     Pass
       { passName = "dce"
@@ -1183,7 +1205,10 @@ propagateKnownCtorThroughLet env = \case
     go _before [] = Nothing
     go before (grouping : after) = case grouping of
       Standalone (_bAnn, name, rhs)
-        | Just (algTy, arity, args, tag) ← resolveKnownCtorApp env rhs
+        | Just (shape, args) ← resolveKnownCtorApp env rhs
+        , let algTy = ctorShapeType shape
+              arity = fromIntegral (length args) ∷ Natural
+              tag = ctorShapeTag shape
         , -- A self-referencing RHS cannot arise under GUC (a Standalone RHS
           -- does not see its own binder), but 'optimizedExpression' also runs
           -- on non-GUC input; dropping the binding would then dangle the
@@ -1265,111 +1290,17 @@ reduceKnownCtorRefRead env =
     -- Field reads fold only at the constructor's own algebraic type, as
     -- in 'reduceKnownConstructor'.
     DataArgumentByIndex ann algTy i spine
-      | Just (ctorAlgTy, _arity, args, _tag) ← resolveKnownCtorApp env spine
-      , algTy == ctorAlgTy
+      | Just (shape, args) ← resolveKnownCtorApp env spine
+      , algTy == ctorShapeType shape
       , Just arg ← args !!? fromIntegral i →
           Just (setAnn ann arg)
     -- Tag reads fold for sum types only, as in 'reduceKnownConstructor'.
     ReflectCtor ann spine
-      | Just (SumType, _arity, _args, tag) ← resolveKnownCtorApp env spine →
-          Just (LiteralString ann tag)
+      | Just (shape, _args) ← resolveKnownCtorApp env spine
+      , SumType ← ctorShapeType shape →
+          Just (LiteralString ann (ctorShapeTag shape))
     _ → Nothing
 
-{- | Recognise a known saturated constructor value and return its algebraic
-type, arity, field arguments, and tag string. It covers every shape a
-constructor value takes after uncurrying (see Note [Constructor applications
-are saturated]):
-
-  * an in-place 'Ctor' node (saturated by construction);
-  * an n-ary worker call @AppN (Ref Cʷ) [a₁,…,aₙ]@ — the shape the early
-    uncurry run rewrites a saturated arity-≥2 site into. 'unwindApp' does
-    not flatten a multi-argument 'AppN' (Note [n-ary application]), so this
-    shape is matched directly, not through the unary spine — miss it and
-    the folds silently stop firing on monadic chains;
-  * a curried unary spine @App (… (App (Ref C) a₁) …) aₙ@ — an arity-1
-    constructor reference, or an arity-≥2 curried wrapper reference a site
-    that saturates only after magicDo/flattening still carries before the
-    late uncurry run.
-
-A reference is resolved through the inline environment by 'ctorFunctionShape',
-which reads only the constructor's declared arity and tag — it pastes no
-'Ctor' node, so a chain that does not fold is not pessimised into pasted
-constructor thunks (issue #180). The result is returned only when the
-application is saturated (argument count equal to the declared arity).
--}
-resolveKnownCtorApp
-  ∷ InlineEnv → Exp → Maybe (AlgebraicType, Natural, [Exp], Text)
-resolveKnownCtorApp env = \case
-  Ctor _ algTy modName tyName ctorName args →
-    Just
-      ( algTy
-      , fromIntegral (length args)
-      , args
-      , ctorId modName tyName ctorName
-      )
-  AppN _ (Ref _ ctorRef) args
-    | Just (algTy, arity, tag) ← ctorFunctionShape env ctorRef
-    , arity == length args →
-        Just (algTy, fromIntegral arity, toList args, tag)
-  expr
-    | (Ref _ ctorRef, args@(_ : _)) ← unwindApp expr
-    , Just (algTy, arity, tag) ← ctorFunctionShape env ctorRef
-    , arity == length args →
-        Just (algTy, fromIntegral arity, args, tag)
-  _ → Nothing
-
-{- | The algebraic type, arity, and tag of a top-level binding that is a
-constructor /function/: the manifest lambda chain 'mkConstructor' emits over
-a saturated 'Ctor' of references to its parameters, the n-ary worker the
-uncurry split derives from it, or the curried wrapper delegating to such a
-worker. Resolving reads only the declaration, never pasting a 'Ctor' node.
-The visited set makes the wrapper→worker hop terminate on the arbitrary
-(possibly cyclic) input 'optimizedExpression' also runs on.
--}
-ctorFunctionShape
-  ∷ InlineEnv → Qualified Name → Maybe (AlgebraicType, Int, Text)
-ctorFunctionShape env = go Set.empty
- where
-  go visited ctorRef
-    | ctorRef `Set.member` visited = Nothing
-    | otherwise = do
-        rhs ← Map.lookup ctorRef env
-        let (params, body) = peelCtorParams rhs
-        case body of
-          Ctor _ algTy modName tyName ctorName args
-            | argsAreRefsTo params args →
-                Just (algTy, length params, ctorId modName tyName ctorName)
-          AppN _ (Ref _ workerRef) wargs
-            | argsAreRefsTo params (toList wargs)
-            , Just (algTy, arity, tag) ← go (Set.insert ctorRef visited) workerRef
-            , arity == length params →
-                Just (algTy, arity, tag)
-          _ → Nothing
-
-{- | Peel leading lambda parameters (through unary 'Abs' and n-ary 'AbsN'), as
-long as every one is named, returning the names in order and the body.
--}
-peelCtorParams ∷ Exp → ([Name], Exp)
-peelCtorParams = go []
- where
-  go ∷ [Name] → Exp → ([Name], Exp)
-  go acc = \case
-    AbsN _ params body
-      | Just names ← traverse paramName (toList params) →
-          go (acc <> names) body
-    e → (acc, e)
-
-{- | Whether the expressions are exactly local references to the given names,
-in order — a constructor lambda passing its parameters straight through.
--}
-argsAreRefsTo ∷ [Name] → [Exp] → Bool
-argsAreRefsTo names args =
-  length names == length args && and (zipWith isRefTo names args)
- where
-  isRefTo ∷ Name → Exp → Bool
-  isRefTo name (Ref _ (Local n)) = n == name
-  isRefTo _ _ = False
-
 {- | Resolve a method projection off a known top-level dictionary (issue
 #180). When @dict@ is a reference to a top-level 'LiteralObject' binding,
 @dict.method@ is replaced by the method expression itself — the concrete

diff --git a/lib/Language/PureScript/Backend/IR/Query.hs b/lib/Language/PureScript/Backend/IR/Query.hs
@@ -6,17 +6,25 @@ 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 (Name)
+  ( CtorName
+  , ModuleName
+  , Name (Name)
   , Qualified (Imported, Local)
+  , TyName
   , runModuleName
   )
 import Language.PureScript.Backend.IR.Types
-  ( Exp
+  ( AlgebraicType
+  , Exp
+  , RawExp (..)
   , bindingNames
   , countFreeRef
   , countFreeRefs
+  , ctorId
   , listGrouping
+  , paramName
   , subexpressions
+  , unwindApp
   )
 import Language.PureScript.Backend.IR.Types qualified as IR
 import Language.PureScript.Names (runtimeLazyName)
@@ -48,6 +56,119 @@ findPrimModuleInExpr expr =
     Local _name → False
     Imported moduleName _name → runModuleName moduleName == "Prim"
 
+--------------------------------------------------------------------------------
+-- Known-constructor resolution ------------------------------------------------
+
+{- | The identity of a data constructor: its algebraic type and the
+qualified name triple 'ctorId' renders into the runtime tag string.
+-}
+data CtorShape = CtorShape
+  { ctorShapeType ∷ AlgebraicType
+  , ctorShapeModule ∷ ModuleName
+  , ctorShapeTyName ∷ TyName
+  , ctorShapeCtor ∷ CtorName
+  }
+  deriving stock (Eq, Ord, Show)
+
+-- | The runtime tag string of the constructor ('ctorId').
+ctorShapeTag ∷ CtorShape → Text
+ctorShapeTag CtorShape {ctorShapeModule, ctorShapeTyName, ctorShapeCtor} =
+  ctorId ctorShapeModule ctorShapeTyName ctorShapeCtor
+
+{- | Recognise a known saturated constructor value and return its shape
+and field arguments. It covers every shape a constructor value takes
+after uncurrying (see Note [Constructor applications are saturated] in
+"Language.PureScript.Backend.IR.Types"):
+
+  * an in-place 'Ctor' node (saturated by construction);
+  * an n-ary worker call @AppN (Ref Cʷ) [a₁,…,aₙ]@ — the shape the early
+    uncurry run rewrites a saturated arity-≥2 site into. 'unwindApp' does
+    not flatten a multi-argument 'AppN' (Note [n-ary application]), so this
+    shape is matched directly, not through the unary spine — miss it and
+    the folds silently stop firing on monadic chains;
+  * a curried unary spine @App (… (App (Ref C) a₁) …) aₙ@ — an arity-1
+    constructor reference, or an arity-≥2 curried wrapper reference a site
+    that saturates only after magicDo/flattening still carries before the
+    late uncurry run.
+
+A reference is resolved through the given environment by
+'ctorFunctionShape', which reads only the constructor's declared shape —
+it pastes no 'Ctor' node, so a chain that does not fold is not pessimised
+into pasted constructor thunks (issue #180). The result is returned only
+when the application is saturated (argument count equal to the declared
+arity).
+-}
+resolveKnownCtorApp
+  ∷ Map (Qualified Name) Exp → Exp → Maybe (CtorShape, [Exp])
+resolveKnownCtorApp env = \case
+  Ctor _ algTy modName tyName ctorName args →
+    Just (CtorShape algTy modName tyName ctorName, args)
+  AppN _ (Ref _ ctorRef) args
+    | Just (shape, arity) ← ctorFunctionShape env ctorRef
+    , arity == length args →
+        Just (shape, toList args)
+  expr
+    | (Ref _ ctorRef, args@(_ : _)) ← unwindApp expr
+    , Just (shape, arity) ← ctorFunctionShape env ctorRef
+    , arity == length args →
+        Just (shape, args)
+  _ → Nothing
+
+{- | The shape and arity of a binding that is a constructor /function/:
+the manifest lambda chain 'Language.PureScript.Backend.IR.mkConstructor'
+emits over a saturated 'Ctor' of references to its parameters, the n-ary
+worker the uncurry split derives from it, or the curried wrapper
+delegating to such a worker. Resolving reads only the declaration, never
+pasting a 'Ctor' node. The visited set makes the wrapper→worker hop
+terminate on arbitrary (possibly cyclic) input.
+-}
+ctorFunctionShape
+  ∷ Map (Qualified Name) Exp → Qualified Name → Maybe (CtorShape, Int)
+ctorFunctionShape env = go Set.empty
+ where
+  go visited ctorRef
+    | ctorRef `Set.member` visited = Nothing
+    | otherwise = do
+        rhs ← Map.lookup ctorRef env
+        let (params, body) = peelCtorParams rhs
+        case body of
+          Ctor _ algTy modName tyName ctorName args
+            | argsAreRefsTo params args →
+                Just
+                  ( CtorShape algTy modName tyName ctorName
+                  , length params
+                  )
+          AppN _ (Ref _ workerRef) wargs
+            | argsAreRefsTo params (toList wargs)
+            , Just (shape, arity) ← go (Set.insert ctorRef visited) workerRef
+            , arity == length params →
+                Just (shape, arity)
+          _ → Nothing
+
+{- | Peel leading lambda parameters (through unary 'Abs' and n-ary 'AbsN'), as
+long as every one is named, returning the names in order and the body.
+-}
+peelCtorParams ∷ Exp → ([Name], Exp)
+peelCtorParams = go []
+ where
+  go ∷ [Name] → Exp → ([Name], Exp)
+  go acc = \case
+    AbsN _ params body
+      | Just names ← traverse paramName (toList params) →
+          go (acc <> names) body
+    e → (acc, e)
+
+{- | Whether the expressions are exactly local references to the given names,
+in order — a constructor lambda passing its parameters straight through.
+-}
+argsAreRefsTo ∷ [Name] → [Exp] → Bool
+argsAreRefsTo names args =
+  length names == length args && and (zipWith isRefTo names args)
+ where
+  isRefTo ∷ Name → Exp → Bool
+  isRefTo name (Ref _ (Local n)) = n == name
+  isRefTo _ _ = False
+
 collectBoundNames ∷ Exp → Set Name
 collectBoundNames =
   (`execAccum` Set.empty) . transformMOf subexpressions \e →