Skip to content

fix: lower De Bruijn indices when a binder is removed (#56) #70

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
Unisay merged 1 commit into from
Jun 14, 2026
Merged

fix: lower De Bruijn indices when a binder is removed (#56) #70

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
12 changes: 8 additions & 4 deletions lib/Language/PureScript/Backend/IR/DCE.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,7 @@ import Language.PureScript.Backend.IR.Types
, getAnn
, listGrouping
, rewriteExpTopDown
, unshift
)

data EntryPoint = EntryPoint ModuleName [Name]
Expand Down Expand Up @@ -122,16 +123,19 @@ eliminateDeadCode uber@UberModule {..} =
pure . \case
Abs ann param b
| not (paramId `member` reachableIds) →
Rewritten Recurse (Abs ann param' b)
Rewritten Recurse (Abs ann param' b')
where
paramId ∷ Id =
case param of
ParamUnused (pid, _) → pid
ParamNamed (pid, _) _name → pid
param' =
-- Blanking an unused named binder drops a slot from that name's
-- De Bruijn namespace, so references in the body that skipped over it
-- (index ≥ 1) must be lowered, just as in beta reduction (issue #56).
(param', b') =
case param of
ParamUnused pann → ParamUnused pann
ParamNamed pann _name → ParamUnused pann
ParamUnused pann → (ParamUnused pann, b)
ParamNamed pann name → (ParamUnused pann, unshift name 0 b)
Let ann binds body →
Rewritten Recurse case NE.nonEmpty preservedBinds of
Nothing → body
Expand Down
7 changes: 6 additions & 1 deletion lib/Language/PureScript/Backend/IR/Optimizer.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,7 @@ import Language.PureScript.Backend.IR.Types
, substitute
, thenRewrite
, unIndex
, unshift
)

optimizedUberModule ∷ UberModule → UberModule
Expand Down Expand Up @@ -301,7 +302,11 @@ betaReduce ∷ RewriteRule Ann
betaReduce =
pure . \case
App _ (Abs _ (ParamNamed _ param) body) r →
Rewritten Recurse $ substitute (Local param) 0 r body
-- Removing the λ closes a binder for 'param', so any reference to it
-- that the substitution shifted past the binder must be lowered back
-- with 'unshift'; otherwise it is left pointing one binder too far out
-- and reaches the Lua backend as an unbound local (issue #56).
Rewritten Recurse . unshift param 0 $ substitute (Local param) 0 r body
_ → NoChange

{- Note [Eta reduction is unsound]
Expand Down
171 changes: 104 additions & 67 deletions lib/Language/PureScript/Backend/IR/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -736,7 +736,87 @@ substitute name idx replacement = substitute' idx
where
go = substitute' index

-- | Increase the index of all bound variables matching the given variable name
{- | Rewrite the De Bruijn index of every reference to @namespace@ that is free
with respect to @minIndex@, using @adjust minIndex index@. Binders for other
names are transparent; a binder for @namespace@ raises @minIndex@ by one (see
Note [Sequential scoping of Let bindings] for the @Let@ case). This is the
shared traversal behind 'shift' (which makes room for a new binder) and
'unshift' (which closes the gap left by a removed one); keeping both on one
traversal stops them from drifting apart.
-}
overFreeIndex
∷ (Index → Index → Index)
-- ^ Given the current @minIndex@ and a reference's index, the new index
→ Name
-- ^ The variable name to match (a.k.a. the namespace)
→ Index
-- ^ The minimum bound at or above which references are considered free
→ RawExp ann
→ RawExp ann
overFreeIndex adjust namespace = go
where
go minIndex expression =
case expression of
Ref ann (Local name) index
| name == namespace →
Ref ann (Local name) (adjust minIndex index)
Abs ann argument body →
Abs ann argument (go minIndex' body)
where
minIndex'
| paramName argument == Just namespace = minIndex + 1
| otherwise = minIndex
-- See Note [Sequential scoping of Let bindings]
Let ann binds body →
Let ann binds' body'
where
(bodyMinIndex, binds') = mapAccumL withGrouping minIndex binds
body' = go bodyMinIndex body
withGrouping minIdx grouping =
case grouping of
Standalone (annotation, boundName, expr) →
( if boundName == namespace then minIdx + 1 else minIdx
, Standalone (annotation, boundName, go minIdx expr)
)
RecursiveGroup recBinds →
( minIdx'
, RecursiveGroup $
recBinds <&> \(nameAnn, boundName, expr) →
(nameAnn, boundName, go minIdx' expr)
)
where
minIdx' =
minIdx
+ fromIntegral
(length (filter (== namespace) (bindingNames grouping)))
App ann argument function →
App ann (go minIndex argument) (go minIndex function)
LiteralArray ann as →
LiteralArray ann (go minIndex <$> as)
LiteralObject ann props →
LiteralObject ann (go minIndex <<$>> props)
ReflectCtor ann a →
ReflectCtor ann (go minIndex a)
DataArgumentByIndex ann idx a →
DataArgumentByIndex ann idx (go minIndex a)
Eq ann a b →
Eq ann (go minIndex a) (go minIndex b)
ArrayLength ann a →
ArrayLength ann (go minIndex a)
ArrayIndex ann a indx →
ArrayIndex ann (go minIndex a) indx
ObjectProp ann a prop →
ObjectProp ann (go minIndex a) prop
ObjectUpdate ann a patches →
ObjectUpdate ann (go minIndex a) (go minIndex <<$>> patches)
IfThenElse ann p th el →
IfThenElse ann (go minIndex p) (go minIndex th) (go minIndex el)
_ → expression

{- | Increase the index of all references to the given name bound at or above
@minIndex@. Used to make room when a new binder for that name is introduced,
e.g. when substituting a term under a λ that shadows the name.
-}
shift
∷ Int
-- ^ The amount to shift by
Expand All @@ -747,72 +827,29 @@ shift
→ RawExp ann
-- ^ The expression to shift
→ RawExp ann
shift offset namespace minIndex expression =
case expression of
Ref ann (Local name) index →
Ref ann (Local name) $
index
+ if name == namespace && minIndex <= index
then fromIntegral offset
else 0
Abs ann argument body →
Abs ann argument (shift offset namespace minIndex' body)
where
minIndex'
| paramName argument == Just namespace = minIndex + 1
| otherwise = minIndex
-- See Note [Sequential scoping of Let bindings]
Let ann binds body →
Let ann binds' body'
where
(bodyMinIndex, binds') = mapAccumL withGrouping minIndex binds
body' = shift offset namespace bodyMinIndex body
withGrouping minIdx grouping =
case grouping of
Standalone (annotation, boundName, expr) →
( if boundName == namespace then minIdx + 1 else minIdx
, Standalone
( annotation
, boundName
, shift offset namespace minIdx expr
)
)
RecursiveGroup recBinds →
( minIdx'
, RecursiveGroup $
recBinds <&> \(nameAnn, boundName, expr) →
(nameAnn, boundName, shift offset namespace minIdx' expr)
)
where
minIdx' =
minIdx
+ fromIntegral
(length (filter (== namespace) (bindingNames grouping)))
App ann argument function →
App ann (go argument) (go function)
LiteralArray ann as →
LiteralArray ann (go <$> as)
LiteralObject ann props →
LiteralObject ann (go <<$>> props)
ReflectCtor ann a →
ReflectCtor ann (go a)
DataArgumentByIndex ann idx a →
DataArgumentByIndex ann idx (go a)
Eq ann a b →
Eq ann (go a) (go b)
ArrayLength ann a →
ArrayLength ann (go a)
ArrayIndex ann a indx →
ArrayIndex ann (go a) indx
ObjectProp ann a prop →
ObjectProp ann (go a) prop
ObjectUpdate ann a patches →
ObjectUpdate ann (go a) (go <<$>> patches)
IfThenElse ann p th el →
IfThenElse ann (go p) (go th) (go el)
_ → expression
where
go = shift offset namespace minIndex
shift offset =
overFreeIndex \minIndex index →
if minIndex <= index then index + fromIntegral offset else index

{- | Decrease by one the index of references to the given name bound strictly
above @minIndex@: the inverse of @shift 1@, to be applied after a binder for
the name is removed (e.g. by beta reduction) so that references which pointed
past that binder are lowered back into place. References at exactly @minIndex@
are the removed binder itself and have already been consumed by the
accompanying substitution, so the strict @minIndex < index@ guard both leaves
genuine inner references untouched and keeps the 'Natural' index from
underflowing.
-}
unshift
∷ Name
-- ^ The variable name to match (a.k.a. the namespace)
→ Index
-- ^ References bound strictly above this bound are lowered
→ RawExp ann
→ RawExp ann
unshift =
overFreeIndex \minIndex index →
if minIndex < index then index - 1 else index

$(makePrisms ''AlgebraicType)
$(makePrisms ''Parameter)
Expand Down
70 changes: 70 additions & 0 deletions test/Language/PureScript/Backend/IR/Gen.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
module Language.PureScript.Backend.IR.Gen where

import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import Hedgehog (MonadGen)
import Hedgehog.Corpus qualified as Corpus
Expand Down Expand Up @@ -57,6 +58,75 @@ exp =
)
]

{- | A generation-time scope: each local name in scope mapped to the number of
enclosing binders for it. Lets 'scopedExp' emit only references that resolve
to a binder (a valid De Bruijn index for that name).
-}
type Scope = Map IR.Name Natural

{- | Generate a closed, well-scoped expression: every local reference has an
index below the number of enclosing binders of that name. Restricted to
λ / application / if / object / reference / scalar, which is enough to
exercise beta reduction and name shadowing (the surface of issues #37 and
#56) while keeping well-scopedness easy to guarantee by construction. 'Let'
is intentionally left out; its sequential scoping is covered by the
hand-written specs.
-}
scopedExp ∷ ∀ m. MonadGen m ⇒ m IR.Exp
scopedExp =
-- Cap the size hard: beta reduction duplicates substituted arguments, so an
-- unbounded term can blow the optimizer up exponentially in memory. Small
-- terms are plenty to surface scoping bugs (issues #37 / #56 both shrink to
-- a handful of binders).
Gen.scale (min 8) (scopedExpIn mempty)

scopedExpIn ∷ ∀ m. MonadGen m ⇒ Scope → m IR.Exp
scopedExpIn scope =
Gen.recursiveFrequency
((4, scalarExp) : [(5, scopedRef) | not (null inScope)])
[ (6, IR.application <$> scopedExpIn scope <*> scopedExpIn scope)
,
( 3
, IR.ifThenElse
<$> scopedExpIn scope
<*> scopedExpIn scope
<*> scopedExpIn scope
)
, (5, genAbs)
, (4, genRedex)
,
( 2
, IR.literalObject
<$> Gen.list
(Range.linear 1 4)
((,) <$> genPropName <*> scopedExpIn scope)
)
]
where
inScope = [(nm, count) | (nm, count) ← Map.toList scope, count > 0]
scopedRef = do
(nm, count) ← Gen.element inScope
index ← Gen.integral (Range.linear 0 (fromIntegral count - 1))
pure (IR.refLocal nm index)
genAbs = do
(param, body) ← genBinderBody
pure (IR.abstraction param body)
-- An immediately-applied λ: a beta redex. Generating these directly (rather
-- than hoping an application's head happens to be a λ) is what makes the
-- well-scopedness property actually exercise beta reduction, including the
-- shadowing case behind issue #56.
genRedex = do
(param, body) ← genBinderBody
arg ← scopedExpIn scope
pure (IR.application (IR.abstraction param body) arg)
genBinderBody = do
param ← parameter
let scope' = case param of
IR.ParamNamed _ nm → Map.insertWith (+) nm 1 scope
IR.ParamUnused _ → scope
body ← scopedExpIn scope'
pure (param, body)

binding ∷ MonadGen m ⇒ m IR.Binding
binding = Gen.frequency [(8, standaloneBinding), (2, recursiveBinding)]

Expand Down
Loading
Loading