Skip to content

Commit 94c13ce

Browse files
UnisayUnisay
authored
Merge pull request #70 from Unisay/issue-56/beta-reduce-unshift
fix: lower De Bruijn indices when a binder is removed (#56)
2 parents 0293ed2 + 7e1a852 commit 94c13ce

13 files changed

Lines changed: 1397 additions & 78 deletions

File tree

‎lib/Language/PureScript/Backend/IR/DCE.hs‎

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ import Language.PureScript.Backend.IR.Types
3030
, getAnn
3131
, listGrouping
3232
, rewriteExpTopDown
33+
, unshift
3334
)
3435

3536
data EntryPoint = EntryPoint ModuleName [Name]
@@ -122,16 +123,19 @@ eliminateDeadCode uber@UberModule {..} =
122123
pure . \case
123124
Abs ann param b
124125
| not (paramId `member` reachableIds) →
125-
Rewritten Recurse (Abs ann param' b)
126+
Rewritten Recurse (Abs ann param' b')
126127
where
127128
paramId ∷ Id =
128129
case param of
129130
ParamUnused (pid, _) → pid
130131
ParamNamed (pid, _) _name → pid
131-
param' =
132+
-- Blanking an unused named binder drops a slot from that name's
133+
-- De Bruijn namespace, so references in the body that skipped over it
134+
-- (index ≥ 1) must be lowered, just as in beta reduction (issue #56).
135+
(param', b') =
132136
case param of
133-
ParamUnused pann → ParamUnused pann
134-
ParamNamed pann _name → ParamUnused pann
137+
ParamUnused pann → (ParamUnused pann, b)
138+
ParamNamed pann name → (ParamUnused pann, unshift name 0 b)
135139
Let ann binds body →
136140
Rewritten Recurse case NE.nonEmpty preservedBinds of
137141
Nothing → body

‎lib/Language/PureScript/Backend/IR/Optimizer.hs‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Language.PureScript.Backend.IR.Types
3232
, substitute
3333
, thenRewrite
3434
, unIndex
35+
, unshift
3536
)
3637

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

307312
{- Note [Eta reduction is unsound]

‎lib/Language/PureScript/Backend/IR/Types.hs‎

Lines changed: 104 additions & 67 deletions
Original file line numberDiff line numberDiff line change
@@ -736,7 +736,87 @@ substitute name idx replacement = substitute' idx
736736
where
737737
go = substitute' index
738738

739-
-- | Increase the index of all bound variables matching the given variable name
739+
{- | Rewrite the De Bruijn index of every reference to @namespace@ that is free
740+
with respect to @minIndex@, using @adjust minIndex index@. Binders for other
741+
names are transparent; a binder for @namespace@ raises @minIndex@ by one (see
742+
Note [Sequential scoping of Let bindings] for the @Let@ case). This is the
743+
shared traversal behind 'shift' (which makes room for a new binder) and
744+
'unshift' (which closes the gap left by a removed one); keeping both on one
745+
traversal stops them from drifting apart.
746+
-}
747+
overFreeIndex
748+
∷ (Index → Index → Index)
749+
-- ^ Given the current @minIndex@ and a reference's index, the new index
750+
→ Name
751+
-- ^ The variable name to match (a.k.a. the namespace)
752+
→ Index
753+
-- ^ The minimum bound at or above which references are considered free
754+
→ RawExp ann
755+
→ RawExp ann
756+
overFreeIndex adjust namespace = go
757+
where
758+
go minIndex expression =
759+
case expression of
760+
Ref ann (Local name) index
761+
| name == namespace →
762+
Ref ann (Local name) (adjust minIndex index)
763+
Abs ann argument body →
764+
Abs ann argument (go minIndex' body)
765+
where
766+
minIndex'
767+
| paramName argument == Just namespace = minIndex + 1
768+
| otherwise = minIndex
769+
-- See Note [Sequential scoping of Let bindings]
770+
Let ann binds body →
771+
Let ann binds' body'
772+
where
773+
(bodyMinIndex, binds') = mapAccumL withGrouping minIndex binds
774+
body' = go bodyMinIndex body
775+
withGrouping minIdx grouping =
776+
case grouping of
777+
Standalone (annotation, boundName, expr) →
778+
( if boundName == namespace then minIdx + 1 else minIdx
779+
, Standalone (annotation, boundName, go minIdx expr)
780+
)
781+
RecursiveGroup recBinds →
782+
( minIdx'
783+
, RecursiveGroup $
784+
recBinds <&> \(nameAnn, boundName, expr) →
785+
(nameAnn, boundName, go minIdx' expr)
786+
)
787+
where
788+
minIdx' =
789+
minIdx
790+
+ fromIntegral
791+
(length (filter (== namespace) (bindingNames grouping)))
792+
App ann argument function →
793+
App ann (go minIndex argument) (go minIndex function)
794+
LiteralArray ann as →
795+
LiteralArray ann (go minIndex <$> as)
796+
LiteralObject ann props →
797+
LiteralObject ann (go minIndex <<$>> props)
798+
ReflectCtor ann a →
799+
ReflectCtor ann (go minIndex a)
800+
DataArgumentByIndex ann idx a →
801+
DataArgumentByIndex ann idx (go minIndex a)
802+
Eq ann a b →
803+
Eq ann (go minIndex a) (go minIndex b)
804+
ArrayLength ann a →
805+
ArrayLength ann (go minIndex a)
806+
ArrayIndex ann a indx →
807+
ArrayIndex ann (go minIndex a) indx
808+
ObjectProp ann a prop →
809+
ObjectProp ann (go minIndex a) prop
810+
ObjectUpdate ann a patches →
811+
ObjectUpdate ann (go minIndex a) (go minIndex <<$>> patches)
812+
IfThenElse ann p th el →
813+
IfThenElse ann (go minIndex p) (go minIndex th) (go minIndex el)
814+
_ → expression
815+
816+
{- | Increase the index of all references to the given name bound at or above
817+
@minIndex@. Used to make room when a new binder for that name is introduced,
818+
e.g. when substituting a term under a λ that shadows the name.
819+
-}
740820
shift
741821
∷ Int
742822
-- ^ The amount to shift by
@@ -747,72 +827,29 @@ shift
747827
→ RawExp ann
748828
-- ^ The expression to shift
749829
→ RawExp ann
750-
shift offset namespace minIndex expression =
751-
case expression of
752-
Ref ann (Local name) index →
753-
Ref ann (Local name) $
754-
index
755-
+ if name == namespace && minIndex <= index
756-
then fromIntegral offset
757-
else 0
758-
Abs ann argument body →
759-
Abs ann argument (shift offset namespace minIndex' body)
760-
where
761-
minIndex'
762-
| paramName argument == Just namespace = minIndex + 1
763-
| otherwise = minIndex
764-
-- See Note [Sequential scoping of Let bindings]
765-
Let ann binds body →
766-
Let ann binds' body'
767-
where
768-
(bodyMinIndex, binds') = mapAccumL withGrouping minIndex binds
769-
body' = shift offset namespace bodyMinIndex body
770-
withGrouping minIdx grouping =
771-
case grouping of
772-
Standalone (annotation, boundName, expr) →
773-
( if boundName == namespace then minIdx + 1 else minIdx
774-
, Standalone
775-
( annotation
776-
, boundName
777-
, shift offset namespace minIdx expr
778-
)
779-
)
780-
RecursiveGroup recBinds →
781-
( minIdx'
782-
, RecursiveGroup $
783-
recBinds <&> \(nameAnn, boundName, expr) →
784-
(nameAnn, boundName, shift offset namespace minIdx' expr)
785-
)
786-
where
787-
minIdx' =
788-
minIdx
789-
+ fromIntegral
790-
(length (filter (== namespace) (bindingNames grouping)))
791-
App ann argument function →
792-
App ann (go argument) (go function)
793-
LiteralArray ann as →
794-
LiteralArray ann (go <$> as)
795-
LiteralObject ann props →
796-
LiteralObject ann (go <<$>> props)
797-
ReflectCtor ann a →
798-
ReflectCtor ann (go a)
799-
DataArgumentByIndex ann idx a →
800-
DataArgumentByIndex ann idx (go a)
801-
Eq ann a b →
802-
Eq ann (go a) (go b)
803-
ArrayLength ann a →
804-
ArrayLength ann (go a)
805-
ArrayIndex ann a indx →
806-
ArrayIndex ann (go a) indx
807-
ObjectProp ann a prop →
808-
ObjectProp ann (go a) prop
809-
ObjectUpdate ann a patches →
810-
ObjectUpdate ann (go a) (go <<$>> patches)
811-
IfThenElse ann p th el →
812-
IfThenElse ann (go p) (go th) (go el)
813-
_ → expression
814-
where
815-
go = shift offset namespace minIndex
830+
shift offset =
831+
overFreeIndex \minIndex index →
832+
if minIndex <= index then index + fromIntegral offset else index
833+
834+
{- | Decrease by one the index of references to the given name bound strictly
835+
above @minIndex@: the inverse of @shift 1@, to be applied after a binder for
836+
the name is removed (e.g. by beta reduction) so that references which pointed
837+
past that binder are lowered back into place. References at exactly @minIndex@
838+
are the removed binder itself and have already been consumed by the
839+
accompanying substitution, so the strict @minIndex < index@ guard both leaves
840+
genuine inner references untouched and keeps the 'Natural' index from
841+
underflowing.
842+
-}
843+
unshift
844+
∷ Name
845+
-- ^ The variable name to match (a.k.a. the namespace)
846+
→ Index
847+
-- ^ References bound strictly above this bound are lowered
848+
→ RawExp ann
849+
→ RawExp ann
850+
unshift =
851+
overFreeIndex \minIndex index →
852+
if minIndex < index then index - 1 else index
816853

817854
$(makePrisms ''AlgebraicType)
818855
$(makePrisms ''Parameter)

‎test/Language/PureScript/Backend/IR/Gen.hs‎

Lines changed: 70 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
module Language.PureScript.Backend.IR.Gen where
22

3+
import Data.Map.Strict qualified as Map
34
import Data.Text qualified as Text
45
import Hedgehog (MonadGen)
56
import Hedgehog.Corpus qualified as Corpus
@@ -57,6 +58,75 @@ exp =
5758
)
5859
]
5960

61+
{- | A generation-time scope: each local name in scope mapped to the number of
62+
enclosing binders for it. Lets 'scopedExp' emit only references that resolve
63+
to a binder (a valid De Bruijn index for that name).
64+
-}
65+
type Scope = Map IR.Name Natural
66+
67+
{- | Generate a closed, well-scoped expression: every local reference has an
68+
index below the number of enclosing binders of that name. Restricted to
69+
λ / application / if / object / reference / scalar, which is enough to
70+
exercise beta reduction and name shadowing (the surface of issues #37 and
71+
#56) while keeping well-scopedness easy to guarantee by construction. 'Let'
72+
is intentionally left out; its sequential scoping is covered by the
73+
hand-written specs.
74+
-}
75+
scopedExp ∷ ∀ m. MonadGen m ⇒ m IR.Exp
76+
scopedExp =
77+
-- Cap the size hard: beta reduction duplicates substituted arguments, so an
78+
-- unbounded term can blow the optimizer up exponentially in memory. Small
79+
-- terms are plenty to surface scoping bugs (issues #37 / #56 both shrink to
80+
-- a handful of binders).
81+
Gen.scale (min 8) (scopedExpIn mempty)
82+
83+
scopedExpIn ∷ ∀ m. MonadGen m ⇒ Scope → m IR.Exp
84+
scopedExpIn scope =
85+
Gen.recursiveFrequency
86+
((4, scalarExp) : [(5, scopedRef) | not (null inScope)])
87+
[ (6, IR.application <$> scopedExpIn scope <*> scopedExpIn scope)
88+
,
89+
( 3
90+
, IR.ifThenElse
91+
<$> scopedExpIn scope
92+
<*> scopedExpIn scope
93+
<*> scopedExpIn scope
94+
)
95+
, (5, genAbs)
96+
, (4, genRedex)
97+
,
98+
( 2
99+
, IR.literalObject
100+
<$> Gen.list
101+
(Range.linear 1 4)
102+
((,) <$> genPropName <*> scopedExpIn scope)
103+
)
104+
]
105+
where
106+
inScope = [(nm, count) | (nm, count) ← Map.toList scope, count > 0]
107+
scopedRef = do
108+
(nm, count) ← Gen.element inScope
109+
index ← Gen.integral (Range.linear 0 (fromIntegral count - 1))
110+
pure (IR.refLocal nm index)
111+
genAbs = do
112+
(param, body) ← genBinderBody
113+
pure (IR.abstraction param body)
114+
-- An immediately-applied λ: a beta redex. Generating these directly (rather
115+
-- than hoping an application's head happens to be a λ) is what makes the
116+
-- well-scopedness property actually exercise beta reduction, including the
117+
-- shadowing case behind issue #56.
118+
genRedex = do
119+
(param, body) ← genBinderBody
120+
arg ← scopedExpIn scope
121+
pure (IR.application (IR.abstraction param body) arg)
122+
genBinderBody = do
123+
param ← parameter
124+
let scope' = case param of
125+
IR.ParamNamed _ nm → Map.insertWith (+) nm 1 scope
126+
IR.ParamUnused _ → scope
127+
body ← scopedExpIn scope'
128+
pure (param, body)
129+
60130
binding ∷ MonadGen m ⇒ m IR.Binding
61131
binding = Gen.frequency [(8, standaloneBinding), (2, recursiveBinding)]
62132

0 commit comments

Comments
 (0)