From 1199cc52aad3aaa8c66355415e542e1f0f87d719 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 24 Oct 2026 03:32:22 +0200 Subject: [PATCH 01/12] fix(runtime): release deferred weak referents at statement boundaries Recheck conservatively retained weak referents once their transient owners unwind, without letting unrelated temporary roots postpone cleanup. Keep aggregate array slots from being mistaken for named lexical bindings and add lifecycle regressions for callback and Mojolicious request ownership. Refs #1646 Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex[bot]@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtimetypes/AutovivificationArray.java | 7 +- .../runtime/runtimetypes/MortalList.java | 25 ++++- .../MortalListDeferredCaptureTest.java | 59 +++++++++++- .../unit/issue_1646_callback_branch_destroy.t | 23 +++++ ...46_foreach_alias_container_owner_destroy.t | 52 +++++++++++ ...sue_1646_mojolicious_controller_lifetime.t | 40 ++++++++ ..._1646_reentrant_callback_capture_destroy.t | 42 +++++++++ .../unit/lib/Issue1646/PromiseProbe.pm | 93 +++++++++++++++++++ ...icious_promise_branch_destroy_regression.t | 38 ++++++++ 10 files changed, 373 insertions(+), 7 deletions(-) create mode 100644 src/test/resources/unit/issue_1646_callback_branch_destroy.t create mode 100644 src/test/resources/unit/issue_1646_foreach_alias_container_owner_destroy.t create mode 100644 src/test/resources/unit/issue_1646_mojolicious_controller_lifetime.t create mode 100644 src/test/resources/unit/issue_1646_reentrant_callback_capture_destroy.t create mode 100644 src/test/resources/unit/lib/Issue1646/PromiseProbe.pm create mode 100644 src/test/resources/unit/mojolicious_promise_branch_destroy_regression.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 0404c5f142..9748befadc 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -12,6 +12,7 @@ priorities and future plans. - Snapshot mutable array entries while marking package roots and during reachability walks so concurrent thread teardown cannot fail with `ConcurrentModificationException`. - Enforce restricted-hash key access and implement `Hash::Util` key, value, and hash locking (#1502, #1172). +- Preserve captured referent ownership when foreach lexicals alias aggregate cells, fixing prompt cleanup of nested one-shot callback owners (#1646). - Report the caller's scalar context correctly when inspecting frames in overloaded exceptions (#1859). - Avoid heap exhaustion when compiling very large generated subroutines, and preserve heredoc statement boundaries with `\&name` fallbacks (#1252). - Cover nested require caller packages and imported `CLASS` constants, and match defer ordering and caller frames around loop `continue` blocks (#1601, #1405, #1383). diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/AutovivificationArray.java b/src/main/java/org/perlonjava/runtime/runtimetypes/AutovivificationArray.java index dc8b750c16..dabd69c23c 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/AutovivificationArray.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/AutovivificationArray.java @@ -47,7 +47,12 @@ public static void vivify(RuntimeArray array) { RuntimeScalar referent = arrayProxy.scalarToAutovivify; if (referent instanceof RuntimeBaseProxy proxy) { - proxy.set(array.createReference()); + // A proxy is an aggregate element slot, not the local pad + // binding for a named @array. Marking this array as + // localBindingExists would keep it alive after its hash/array + // slot is replaced, so captured callbacks in the old array + // would never be released. + proxy.set(array.createAnonymousReference()); } else { referent.value = array; referent.type = RuntimeScalarType.ARRAYREFERENCE; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java index 3f496e2b6f..993dc4f6d3 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java @@ -1899,6 +1899,13 @@ && canDeferCapturedTargetCheckToBoundarySweep(state())) { // namespace. Preserve only objects proven reachable from a // live Perl root; final owner removal still destroys them at // a later boundary. + if (!isReachableFromPersistentRootCached(base)) { + // The full walker can see conservative in-flight roots + // that the persistent snapshot cannot classify. Recheck + // this target at the next statement boundary, once those + // transient owners unwind. + requestTargetedWeakSweep(base); + } base.refCount = 1; } else if (base.blessId != 0 && hasWeakRefs @@ -2057,12 +2064,20 @@ private static void maybeAutoSweepAtStatementBoundary( if (state.weakSweepSuppressionDepth > 0) return; Set releasedTargets = Collections.emptySet(); ReachabilityWalker.ReleasedWeakSweepResult releasedSweepResult = null; - if (!state.targetedWeakSweepReferents.isEmpty() && state.temporaryRoots.isEmpty()) { + if (!state.targetedWeakSweepReferents.isEmpty()) { releasedTargets = Collections.newSetFromMap(new IdentityHashMap<>()); - releasedTargets.addAll(state.targetedWeakSweepReferents); - state.targetedWeakSweepReferents.clear(); - releasedSweepResult = - ReachabilityWalker.sweepReleasedWeakReferents(releasedTargets); + for (RuntimeBase referent : new ArrayList<>(state.targetedWeakSweepReferents)) { + // Keep a target only while that target is actually reachable + // from a temporary root. Unrelated temporary values must not + // delay request cleanup until global destruction. + if (ReachabilityWalker.isReachableFromTemporaryRoots(referent)) continue; + releasedTargets.add(referent); + state.targetedWeakSweepReferents.remove(referent); + } + if (!releasedTargets.isEmpty()) { + releasedSweepResult = + ReachabilityWalker.sweepReleasedWeakReferents(releasedTargets); + } } if (topLevel) { maybeAutoSweep(state, releasedTargets, releasedSweepResult); diff --git a/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java b/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java index 1302aa1b08..bbc06b9da9 100644 --- a/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java +++ b/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java @@ -3,7 +3,10 @@ import org.junit.jupiter.api.Tag; import org.junit.jupiter.api.Test; +import java.util.concurrent.atomic.AtomicInteger; + import static org.junit.jupiter.api.Assertions.assertEquals; +import static org.junit.jupiter.api.Assertions.assertFalse; import static org.junit.jupiter.api.Assertions.assertTrue; @Tag("unit") @@ -65,6 +68,56 @@ void unreachableBlessedCaptureWithWeakObserverReleasesAtItsScopeBoundary() { } } + @Test + void temporaryOnlyRootDefersDestroyUntilTheNextStatementBoundary() { + PerlRuntime runtime = new PerlRuntime(); + try (PerlRuntime.Binding ignored = runtime.bind()) { + String className = "Issue1794::RequestTransaction"; + AtomicInteger destroyCalls = new AtomicInteger(); + RuntimeHash transaction = new RuntimeHash(); + transaction.blessId = NameNormalizer.getBlessId(className); + transaction.refCount = 1; + installDestroy(className, (args, context) -> { + destroyCalls.incrementAndGet(); + return new RuntimeScalar().getList(); + }); + + RuntimeScalar weak = referenceTo(transaction); + WeakRefRegistry.weaken(weak); + assertFalse(MortalList.isReachableFromPersistentRootCached(transaction), + "the weak observer is not a persistent owner"); + RuntimeHash unrelatedRoot = new RuntimeHash(); + MortalList.pushTemporaryRoot(unrelatedRoot); + try { + MortalList.pushTemporaryRoot(transaction); + try { + MortalList.deferDecrement(transaction); + MortalList.flush(); + + assertEquals(0, destroyCalls.get(), + "an active temporary root delays destruction during nested cleanup"); + assertEquals(1, transaction.refCount, + "the referent stays available until its temporary root is removed"); + assertEquals(RuntimeScalarType.HASHREFERENCE, weak.type); + } finally { + MortalList.popTemporaryRoot(transaction); + } + + MortalList.flushAboveMark(); + + assertEquals(1, destroyCalls.get(), + "the temporary-only owner is rechecked despite unrelated temporary roots"); + assertEquals(RuntimeBase.PerlLifecycleState.DESTROYED, + transaction.perlLifecycleState()); + assertEquals(RuntimeScalarType.UNDEF, weak.type, + "the weak observer clears when the request transaction is destroyed"); + } finally { + MortalList.popTemporaryRoot(unrelatedRoot); + GlobalVariable.removeGlobalCodeRefForStashDelete(className + "::DESTROY"); + } + } + } + private static RuntimeScalar referenceTo(RuntimeBase referent) { RuntimeScalar scalar = new RuntimeScalar(); scalar.type = RuntimeScalarType.HASHREFERENCE; @@ -73,7 +126,11 @@ private static RuntimeScalar referenceTo(RuntimeBase referent) { } private static void installDestroy(String className) { - RuntimeCode code = new RuntimeCode((args, context) -> new RuntimeScalar().getList(), null); + installDestroy(className, (args, context) -> new RuntimeScalar().getList()); + } + + private static void installDestroy(String className, PerlSubroutine body) { + RuntimeCode code = new RuntimeCode(body, null); int separator = className.lastIndexOf("::"); code.packageName = className.substring(0, separator); code.subName = "DESTROY"; diff --git a/src/test/resources/unit/issue_1646_callback_branch_destroy.t b/src/test/resources/unit/issue_1646_callback_branch_destroy.t new file mode 100644 index 0000000000..860e79aedd --- /dev/null +++ b/src/test/resources/unit/issue_1646_callback_branch_destroy.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use lib 'src/test/resources/unit/lib'; +use Issue1646::PromiseProbe; +use Test::More; + +my (@warnings, @errors); +{ + local $SIG{__WARN__} = sub { push @warnings, shift }; + + my $promise = Issue1646::PromiseProbe->new; + $promise->catch(sub { push @errors, @_ }); + $promise->then(sub { }); + $promise->reject('branches2'); + $promise->wait; + + is_deeply(\@errors, ['branches2'], 'handled branch receives the rejection'); + like($warnings[0] // '', qr/Unhandled rejected promise: branches2/, + 'the unhandled branch warns when its callback chain is released'); + is($warnings[1], undef, 'the branch warns only once'); +} + +done_testing; diff --git a/src/test/resources/unit/issue_1646_foreach_alias_container_owner_destroy.t b/src/test/resources/unit/issue_1646_foreach_alias_container_owner_destroy.t new file mode 100644 index 0000000000..11de0bc0a0 --- /dev/null +++ b/src/test/resources/unit/issue_1646_foreach_alias_container_owner_destroy.t @@ -0,0 +1,52 @@ +use strict; +use warnings; +use feature 'current_sub'; +use Scalar::Util qw(weaken); +use Test::More; +our $destroyed = 0; +{ + package Issue1646::Emitter; + sub emit { + my ($self, $name) = @_; + if (my $subscribers = $self->{events}{$name}) { + for my $cb (@$subscribers) { $self->$cb(@_) } + } + return $self; + } + sub once { + my ($self, $name, $cb) = @_; + Scalar::Util::weaken($self); + my $wrapper = sub { $self->unsubscribe($name => __SUB__); $cb->(@_) }; + push @{$self->{events}{$name}}, $wrapper; + return $wrapper; + } + sub unsubscribe { + my ($self, $name, $cb) = @_; + $self->{events}{$name} = [grep { $_ ne $cb } @{$self->{events}{$name}}]; + delete $self->{events}{$name} unless @{$self->{events}{$name}}; + return $self; + } +} +{ + package Issue1646::Owner; + our @ISA = ('Issue1646::Emitter'); + sub DESTROY { $main::destroyed++ } + sub write_chunk { + my ($self, $chunk, $cb) = @_; + $self->once(drain => sub { shift; $self->$cb(@_) }) if $cb; + return $self; + } +} +my $owner = bless {}, 'Issue1646::Owner'; +my $weak = $owner; +weaken($weak); +$owner->write_chunk(P => sub { + my $self = shift; + $self->write_chunk(oll => sub { shift->write_chunk('') }); + $self->emit('drain'); +}); +$owner->emit('drain'); +undef $owner; +is($destroyed, 1, 'owner destruction follows nested one-shot emission'); +ok(!defined $weak, 'weak owner is cleared after nested emission'); +done_testing; diff --git a/src/test/resources/unit/issue_1646_mojolicious_controller_lifetime.t b/src/test/resources/unit/issue_1646_mojolicious_controller_lifetime.t new file mode 100644 index 0000000000..3cdd987662 --- /dev/null +++ b/src/test/resources/unit/issue_1646_mojolicious_controller_lifetime.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' } + +use Test::More; + +BEGIN { + plan skip_all => 'Mojolicious is not installed' + unless eval { require Mojolicious::Lite; require Test::Mojo; require Mojo::IOLoop; 1 }; +} + +use Mojolicious::Lite; +use Test::Mojo; +use Mojo::IOLoop; + +{ + package Issue1646::Controller; + use Mojo::Base 'Mojolicious::Controller'; + + sub DESTROY { shift->stash->{destroyed} = 1 } +} + +app->controller_class('Issue1646::Controller'); +get '/longpoll' => sub { + my $controller = shift; + $controller->on(finish => sub { shift->stash->{finished}++ }); + $controller->write_chunk('P' => sub { + shift->write_chunk('oll!' => sub { shift->write_chunk('') }); + }); +}; + +my $test = Test::Mojo->new; +my $stash; +$test->app->plugins->once(before_dispatch => sub { $stash = shift->stash }); +$test->get_ok('/longpoll')->status_is(200)->content_is('Poll!'); +Mojo::IOLoop->one_tick until $stash->{finished}; +is($stash->{finished}, 1, 'finish event is emitted once'); +ok($stash->{destroyed}, 'controller is destroyed after the response completes'); + +done_testing; diff --git a/src/test/resources/unit/issue_1646_reentrant_callback_capture_destroy.t b/src/test/resources/unit/issue_1646_reentrant_callback_capture_destroy.t new file mode 100644 index 0000000000..8efea9f69a --- /dev/null +++ b/src/test/resources/unit/issue_1646_reentrant_callback_capture_destroy.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Scalar::Util qw(weaken); +use Test::More; + +BEGIN { + plan skip_all => 'Mojolicious is not installed' + unless eval { require Mojo::EventEmitter; 1 }; +} + +our $destroyed = 0; + +{ + package Issue1646::ReentrantCallbackOwner; + our @ISA = ('Mojo::EventEmitter'); + + sub DESTROY { $main::destroyed++ } + + sub write_chunk { + my ($self, $chunk, $callback) = @_; + $self->once(drain => sub { shift; $self->$callback(@_) }) if $callback; + return $self; + } +} + +my $owner = bless {}, 'Issue1646::ReentrantCallbackOwner'; +my $weak_owner = $owner; +weaken($weak_owner); +$owner->write_chunk('P' => sub { + my $self = shift; + $self->write_chunk('oll!' => sub { shift->write_chunk('') }); + $self->emit('drain'); +}); + +ok(defined $weak_owner, 'registered callbacks retain their captured owner'); +$owner->emit('drain'); +undef $owner; +is($destroyed, 1, 'reentrant one-shot callbacks release captures after emission'); +ok(!defined $weak_owner, 'captured owner weak reference clears after emission'); + +done_testing; diff --git a/src/test/resources/unit/lib/Issue1646/PromiseProbe.pm b/src/test/resources/unit/lib/Issue1646/PromiseProbe.pm new file mode 100644 index 0000000000..3d92e299ff --- /dev/null +++ b/src/test/resources/unit/lib/Issue1646/PromiseProbe.pm @@ -0,0 +1,93 @@ +package Issue1646::PromiseProbe; + +use strict; +use warnings; +use Scalar::Util qw(blessed); + +our @TICKS; +our $LOOP_RUNNING = 0; +our $LOOP_STOPPED = 0; + +sub new { bless { resolve => [], reject => [] }, shift } +sub clone { ref($_[0])->new } +sub catch { shift->then(undef, shift) } +sub reject { shift->_settle('reject', @_) } +sub resolve { shift->_settle('resolve', @_) } + +sub then { + my ($self, $resolve, $reject) = @_; + my $next = $self->clone; + $self->{handled} = 1; + push @{$self->{resolve}}, sub { _then_cb($next, $resolve, 'resolve', @_) }; + push @{$self->{reject}}, sub { _then_cb($next, $reject, 'reject', @_) }; + $self->_defer if $self->{results}; + return $next; +} + +sub wait { + my $self = shift; + return if $LOOP_RUNNING; + my $done; + $self->_finally(0, sub { $done++; $LOOP_STOPPED = 1 })->catch(sub { }); + _start_loop() until $done; +} + +sub _start_loop { + $LOOP_RUNNING = 1; + $LOOP_STOPPED = 0; + while (@TICKS && !$LOOP_STOPPED) { + my $tick = shift @TICKS; + $tick->(); + undef $tick; + } + $LOOP_RUNNING = 0; +} + +sub _finally { + my ($self, $handled, $finally) = @_; + my $next = $self->clone; + my $callback = sub { + my @results = @_; + $next->resolve($finally->())->then(sub { @results }); + }; + my $was_handled = $self->{handled}; + $self->catch($callback); + my $returned = $self->then($callback); + delete $self->{handled} if !$was_handled && !$handled; + return $returned; +} + +sub _defer { + my $self = shift; + return unless my $results = $self->{results}; + my $callbacks = $self->{status} eq 'resolve' ? $self->{resolve} : $self->{reject}; + @{$self}{qw(cycle resolve reject)} = (undef, [], []); + push @TICKS, sub { $_->(@$results) for @$callbacks }; +} + +sub _settle { + my ($self, $status, @results) = @_; + if (blessed($results[0]) && $results[0]->can('then') && $status eq 'resolve') { + $results[0]->then(sub { $self->resolve(@_) }, sub { $self->reject(@_) }); + } elsif (!$self->{results}) { + @{$self}{qw(results status)} = (\@results, $status); + $self->_defer; + } + return $self; +} + +sub _then_cb { + my ($next, $callback, $method, @results) = @_; + return $next->$method(@results) unless defined $callback; + my @values; + return $next->reject($@) unless eval { @values = $callback->(@results); 1 }; + return $next->resolve(@values); +} + +sub DESTROY { + my $self = shift; + return if $self->{handled} || ($self->{status} // '') ne 'reject' || !$self->{results}; + warn "Unhandled rejected promise: @{$self->{results}}"; +} + +1; diff --git a/src/test/resources/unit/mojolicious_promise_branch_destroy_regression.t b/src/test/resources/unit/mojolicious_promise_branch_destroy_regression.t new file mode 100644 index 0000000000..1d5e788014 --- /dev/null +++ b/src/test/resources/unit/mojolicious_promise_branch_destroy_regression.t @@ -0,0 +1,38 @@ +use strict; +use warnings; +use Scalar::Util qw(weaken); +use Test::More; + +plan skip_all => 'Mojolicious is not installed' unless eval { require Mojo::Promise; 1 }; + +my (@warnings, @errors); +{ + local $SIG{__WARN__} = sub { push @warnings, shift }; + + Mojo::Promise->reject('one'); + like($warnings[0] // '', qr/Unhandled rejected promise: one/, + 'a discarded rejected promise warns immediately'); + is($warnings[1], undef, 'the discarded promise warns only once'); + + @warnings = (); + Mojo::Promise->reject('two')->then(sub { })->wait; + like($warnings[0] // '', qr/Unhandled rejected promise: two/, + 'a waited rejection warns when its child is released'); + is($warnings[1], undef, 'the waited rejection warns only once'); + + @warnings = (); + + my $promise = Mojo::Promise->new; + $promise->catch(sub { push @errors, @_ }); + my $unhandled_branch = $promise->then(sub { }); + weaken($unhandled_branch); + $promise->reject('branches2'); + $promise->wait; + is_deeply(\@errors, ['branches2'], 'handled branch receives the rejection'); + ok(!defined $unhandled_branch, 'unhandled child branch is released after wait'); + like($warnings[0] // '', qr/Unhandled rejected promise: branches2/, + 'unhandled branch warns when its callback chain is released'); + is($warnings[1], undef, 'unhandled rejection warns only once'); +} + +done_testing; From 9220be78327d067188665846061954121715a7a1 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 24 Oct 2026 10:52:49 +0200 Subject: [PATCH 02/12] fix(runtime): preserve live roots during targeted weak sweeps Recheck targeted weak-sweep candidates against current temporary, package, and lexical roots at the statement boundary. Keep candidates that acquired a live owner after the sweep was queued, while still releasing targets retained only by unrelated temporary roots. Add regression coverage for a candidate that gains a live lexical owner before an unrelated temporary root is drained. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex[bot]@users.noreply.github.com> --- .../runtime/runtimetypes/MortalList.java | 7 ++-- .../MortalListDeferredCaptureTest.java | 35 +++++++++++++++++++ 2 files changed, 39 insertions(+), 3 deletions(-) diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java index 993dc4f6d3..cee4ab5b81 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java @@ -2068,9 +2068,10 @@ private static void maybeAutoSweepAtStatementBoundary( releasedTargets = Collections.newSetFromMap(new IdentityHashMap<>()); for (RuntimeBase referent : new ArrayList<>(state.targetedWeakSweepReferents)) { // Keep a target only while that target is actually reachable - // from a temporary root. Unrelated temporary values must not - // delay request cleanup until global destruction. - if (ReachabilityWalker.isReachableFromTemporaryRoots(referent)) continue; + // from any current Perl root. Unrelated temporary values must + // not delay request cleanup, but a lexical/package owner that + // appeared after the request must still protect the referent. + if (isReachableFromExternalRootCached(referent)) continue; releasedTargets.add(referent); state.targetedWeakSweepReferents.remove(referent); } diff --git a/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java b/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java index bbc06b9da9..a3e2b6b94f 100644 --- a/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java +++ b/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java @@ -118,6 +118,41 @@ void temporaryOnlyRootDefersDestroyUntilTheNextStatementBoundary() { } } + @Test + void targetedWeakSweepPreservesReferentThatGainsALiveRootBeforeBoundary() { + PerlRuntime runtime = new PerlRuntime(); + try (PerlRuntime.Binding ignored = runtime.bind()) { + RuntimeHash referent = new RuntimeHash(); + referent.refCount = 1; + RuntimeScalar weak = referenceTo(referent); + WeakRefRegistry.weaken(weak); + RuntimeScalar lexicalOwner = referenceTo(referent); + RuntimeHash unrelatedTemporary = new RuntimeHash(); + + MyVarCleanupStack.register(lexicalOwner); + MyVarCleanupStack.snapshotStackToLiveCounts(); + MortalList.invalidateAllRootSnapshots(); + try { + MortalList.requestTargetedWeakSweep(referent); + MortalList.pushTemporaryRoot(unrelatedTemporary); + try { + MortalList.flushAboveMark(); + + assertTrue(MortalList.isReachableFromPersistentRootCached(referent), + "the lexical owner remains a current Perl root"); + assertEquals(RuntimeScalarType.HASHREFERENCE, weak.type, + "an unrelated temporary root must not cause a live referent to be swept"); + } finally { + MortalList.popTemporaryRoot(unrelatedTemporary); + } + } finally { + MyVarCleanupStack.unregister(lexicalOwner); + WeakRefRegistry.unweaken(weak); + MortalList.invalidateAllRootSnapshots(); + } + } + } + private static RuntimeScalar referenceTo(RuntimeBase referent) { RuntimeScalar scalar = new RuntimeScalar(); scalar.type = RuntimeScalarType.HASHREFERENCE; From eeaaab072302d882ec28cd31187f30c1ae9caf13 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 24 Oct 2026 22:57:20 +0200 Subject: [PATCH 03/12] perf(runtime): avoid repeated persistent weak-root checks Remove targeted sweep candidates once a persistent Perl root proves they remain live. Their lexical or package owner will request a fresh sweep on release, while temporary-root candidates stay queued for a later boundary. Check live lexical roots before constructing the larger package snapshot. The full unit gate passes. The CPAN acceptance run upgrades Catalyst from FAIL to PASS; DBIx::Class and Mojolicious remain qualification gaps. Generated with [Codex](https://openai.com/codex/) Co-Authored-By: Codex --- .../runtime/runtimetypes/MortalList.java | 30 +++++++++++++------ .../MortalListDeferredCaptureTest.java | 6 +++- .../ReachabilityQueryCostTest.java | 27 +++++++++++++++++ 3 files changed, 53 insertions(+), 10 deletions(-) diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java index cee4ab5b81..6ae3459d94 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java @@ -1526,6 +1526,16 @@ static boolean isReachableFromExternalRootCached(RuntimeBase base) { static boolean isReachableFromPersistentRootCached(RuntimeBase base) { LifecycleRuntimeState state = state(); + // Check live lexicals before the package graph. Targeted weak sweeps + // often revisit objects that are still held by a current lexical; a + // positive lexical proof avoids walking the much larger, stable global + // graph for those candidates. + if (state.liveRootSnapshot == null) { + state.liveRootSnapshot = new ReachabilityWalker.LiveRootSnapshot(); + } + if (state.liveRootSnapshot.isReachable(base)) { + return true; + } if (state.externalRootSnapshot == null) { state.externalRootSnapshot = new ReachabilityWalker.ExternalRootSnapshot(); } @@ -1539,10 +1549,7 @@ static boolean isReachableFromPersistentRootCached(RuntimeBase base) { // direct-lexical exclusion semantics. return true; } - if (state.liveRootSnapshot == null) { - state.liveRootSnapshot = new ReachabilityWalker.LiveRootSnapshot(); - } - return state.liveRootSnapshot.isReachable(base); + return false; } static void invalidateExternalRootSnapshot() { @@ -2067,11 +2074,16 @@ private static void maybeAutoSweepAtStatementBoundary( if (!state.targetedWeakSweepReferents.isEmpty()) { releasedTargets = Collections.newSetFromMap(new IdentityHashMap<>()); for (RuntimeBase referent : new ArrayList<>(state.targetedWeakSweepReferents)) { - // Keep a target only while that target is actually reachable - // from any current Perl root. Unrelated temporary values must - // not delay request cleanup, but a lexical/package owner that - // appeared after the request must still protect the referent. - if (isReachableFromExternalRootCached(referent)) continue; + // Temporary roots are transient: leave their candidates queued + // so the next boundary can retry after the expression unwinds. + if (ReachabilityWalker.isReachableFromTemporaryRoots(referent)) continue; + // Persistent roots will request another sweep when their owner + // exits. Drop the candidate now so every later statement does + // not repeatedly traverse the live/package root snapshots. + if (isReachableFromPersistentRootCached(referent)) { + state.targetedWeakSweepReferents.remove(referent); + continue; + } releasedTargets.add(referent); state.targetedWeakSweepReferents.remove(referent); } diff --git a/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java b/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java index a3e2b6b94f..628f9f8eb9 100644 --- a/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java +++ b/src/test/java/org/perlonjava/runtime/runtimetypes/MortalListDeferredCaptureTest.java @@ -142,11 +142,15 @@ void targetedWeakSweepPreservesReferentThatGainsALiveRootBeforeBoundary() { "the lexical owner remains a current Perl root"); assertEquals(RuntimeScalarType.HASHREFERENCE, weak.type, "an unrelated temporary root must not cause a live referent to be swept"); + assertFalse(PerlRuntime.current().lifecycleState + .targetedWeakSweepReferents.contains(referent), + "a persistent root should not leave the candidate queued for every later boundary"); } finally { MortalList.popTemporaryRoot(unrelatedTemporary); } - } finally { MyVarCleanupStack.unregister(lexicalOwner); + MortalList.flushAboveMark(); + } finally { WeakRefRegistry.unweaken(weak); MortalList.invalidateAllRootSnapshots(); } diff --git a/src/test/java/org/perlonjava/runtime/runtimetypes/ReachabilityQueryCostTest.java b/src/test/java/org/perlonjava/runtime/runtimetypes/ReachabilityQueryCostTest.java index d24797810d..3604a2892a 100644 --- a/src/test/java/org/perlonjava/runtime/runtimetypes/ReachabilityQueryCostTest.java +++ b/src/test/java/org/perlonjava/runtime/runtimetypes/ReachabilityQueryCostTest.java @@ -128,6 +128,33 @@ void targetedWeakReleaseSkipsFullWalkerForSnapshotRootedTargets() { } } + @Test + void persistentRootQueryChecksLiveLexicalsBeforePackageGraph() { + PerlRuntime runtime = new PerlRuntime(); + try (PerlRuntime.Binding ignored = runtime.bind()) { + RuntimeHash target = new RuntimeHash(); + RuntimeScalar lexicalOwner = target.createReference(); + MyVarCleanupStack.register(lexicalOwner); + MyVarCleanupStack.snapshotStackToLiveCounts(); + MortalList.invalidateAllRootSnapshots(); + try { + try (MortalList.ReachabilityQueryMeasurement measurement = + MortalList.measureReachabilityQueries()) { + assertTrue(MortalList.isReachableFromPersistentRootCached(target)); + + ReachabilityQueryStats stats = measurement.stats(); + assertEquals(1, stats.liveRootSnapshotsBuilt, + "the live lexical graph is checked once"); + assertEquals(0, stats.externalRootSnapshotsBuilt, + "a live lexical proof skips the package root graph"); + } + } finally { + MyVarCleanupStack.unregister(lexicalOwner); + MortalList.invalidateAllRootSnapshots(); + } + } + } + @Test void targetedWeakReleaseDoesNotTreatTemporaryRootsAsPersistentOwners() { PerlRuntime runtime = new PerlRuntime(); From a02d9ac7dec3571cbfa78ad0955818195f43f959 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sun, 25 Oct 2026 02:45:52 +0200 Subject: [PATCH 04/12] fix(runtime): align B refcounts for destroy hash fields Remove the special increment that made B::REFCNT report a sole hash-field owner as multiple owners during DESTROY. Add a regression test for the native Perl count and expose direct hash-slot owners in internal refstate diagnostics. The complete `make` gate and the new system Perl/JVM/interpreter regression checks pass. DBIx::Class release qualification still has separate failures. Refs #1646 Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex[bot]@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/perlmodule/Internals.java | 18 ++--------- src/main/perl/lib/B.pm | 30 ++++-------------- .../refcount/b_refcount_destroy_hash_field.t | 31 +++++++++++++++++++ 4 files changed, 40 insertions(+), 40 deletions(-) create mode 100644 src/test/resources/unit/refcount/b_refcount_destroy_hash_field.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 9748befadc..4e4562ffda 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -13,6 +13,7 @@ priorities and future plans. - Enforce restricted-hash key access and implement `Hash::Util` key, value, and hash locking (#1502, #1172). - Preserve captured referent ownership when foreach lexicals alias aggregate cells, fixing prompt cleanup of nested one-shot callback owners (#1646). +- Match `B::REFCNT` to native B's treatment of its wrapper reference, preventing false resurrection from a schema's sole source registry owner (#1646). - Report the caller's scalar context correctly when inspecting frames in overloaded exceptions (#1859). - Avoid heap exhaustion when compiling very large generated subroutines, and preserve heredoc statement boundaries with `\&name` fallbacks (#1252). - Cover nested require caller packages and imported `CLASS` constants, and match defer ordering and caller frames around loop `continue` blocks (#1601, #1405, #1383). diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java index c3a1d3afd4..6ad8098d9a 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java @@ -545,22 +545,6 @@ public static RuntimeList svRefcount(RuntimeArray args, int ctx) { GlobalContext.encodeSpecialVar("H")); int extra = (base.localBindingExists && !compileHintsHash ? 1 : 0) + base.foreachAliasCount; - if (rc == 2 - && args.size() > 1 - && args.get(1).getBoolean() - && DestroyDispatch.isInsideDestroy() - && !ReachabilityWalker.hasLiveStrongScalarReferentOtherThan(base, arg)) { - // B::SV's private hash slot is one of the two selective - // owners. Ordinarily it is the temporary owner discounted - // below (a single live lexical therefore reports one). If - // there is no independently live scalar pad, the other owner - // is a real aggregate slot, as in DBIx::Class Schema's source - // registry during DESTROY, and must remain visible to B. This - // distinction is only meaningful while DESTROY is active: - // outside it, an unregistered lexical can look identical and - // must still report its single owner. - extra++; - } // Legacy fudge: anonymous tracked container with no counted // owners -- still report 1 to indicate "live SV". Used by // Sub::Quote / Moo introspection paths that probe for liveness. @@ -619,6 +603,7 @@ public static RuntimeList jperlReferenceByAddress(RuntimeArray args, int ctx) { *
  • {@code has_weak_refs} — true if the weak-ref registry has entries pointing here
  • *
  • {@code active_owner_count} — live scalar-store owners currently tracked for diagnostics
  • *
  • {@code semantic_capture_owner_count} — distinct captured pad owners
  • + *
  • {@code hash_slot_owner_count} — direct strong owners in hash slots
  • * */ public static RuntimeList jperl_refstate(RuntimeArray args, int ctx) { @@ -633,6 +618,7 @@ public static RuntimeList jperl_refstate(RuntimeArray args, int ctx) { result.put("class_name", new RuntimeScalar(className == null ? "" : className)); result.put("active_owner_count", new RuntimeScalar(base.activeOwnerCount())); result.put("semantic_capture_owner_count", new RuntimeScalar(base.semanticCaptureOwnerCount())); + result.put("hash_slot_owner_count", new RuntimeScalar(base.hashSlotOwnerCount)); String kind = "OTHER"; if (base instanceof RuntimeGlob) kind = "GLOB"; else if (base instanceof RuntimeHash) kind = "HASH"; diff --git a/src/main/perl/lib/B.pm b/src/main/perl/lib/B.pm index 879e87555f..6c43144746 100644 --- a/src/main/perl/lib/B.pm +++ b/src/main/perl/lib/B.pm @@ -64,30 +64,12 @@ package B::SV { sub REFCNT { # Return the selective refcount via Internals::SvREFCNT. # - # In PerlOnJava, B::SV stores the reference in $self->{ref} which is - # a tracked (blessed) hash element. This inflates the referent's - # selective refCount by +1 via setLargeRefCounted. - # - # In Perl 5, B::svref_2object() stores the SV pointer directly (a C - # pointer), so it does NOT inflate the referent's refcnt. However, - # Perl 5 has higher refcounts overall because ALL references count - # (hash elements, stack temporaries, mortal slots). PerlOnJava's - # selective refCount is lower because: - # 1. Stack/JVM temporaries don't contribute - # 2. Method call argument copies don't contribute - # - # The B::SV inflation (+1) roughly compensates for these deficits, - # so we return the raw selective refCount WITHOUT subtracting 1. - # - # For Schema::DESTROY's `refcount($source) > 1` check: - # - Source with 1 selective ref (e.g., source_registrations only): - # B::SV inflation → 2, REFCNT = 2 → > 1 → rescue ✓ - # (In Perl 5 this source also shows > 1 because stack temps add refs) - # - Source with 0 selective refs (untracked): - # B::SV inflation → 1, REFCNT = 1 → no rescue ✓ - # B's C implementation inspects the referent without creating a Perl - # owner. Ask the runtime to compensate for an independently live - # lexical owner that selective refcounting may not have counted. + # PerlOnJava stores the referent in this B::SV object's `ref` field, + # while native B stores an SV pointer. The runtime's B-object probe + # compensates for that wrapper so its slot is not reported as an + # independent Perl owner. This matters in DESTROY methods such as + # DBIx::Class::Schema::DESTROY, where a source held only in the + # schema's registry must report one owner and must not be rescued. Internals::SvREFCNT($_[0]->{ref}, 1); } diff --git a/src/test/resources/unit/refcount/b_refcount_destroy_hash_field.t b/src/test/resources/unit/refcount/b_refcount_destroy_hash_field.t new file mode 100644 index 0000000000..314050722d --- /dev/null +++ b/src/test/resources/unit/refcount/b_refcount_destroy_hash_field.t @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use B qw(svref_2object); + +{ + package BRefcountDestroyHashField; + + our $observed; + + sub new { + my $source = bless {}, 'BRefcountDestroyHashField::Source'; + return bless { sources => { Artist => $source } }, shift; + } + + sub DESTROY { + my ($self) = @_; + $observed = B::svref_2object($self->{sources}{Artist})->REFCNT; + } +} + +{ + my $schema = BRefcountDestroyHashField->new; + undef $schema; +} + +is($BRefcountDestroyHashField::observed, 1, + 'B reports one owner for a source held only by a DESTROYing hash field'); + +done_testing; From 66dd393a971f79af727e4aaa2894c938c2f15dde Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sun, 25 Oct 2026 05:22:39 +0100 Subject: [PATCH 05/12] fix(runtime): re-fire DESTROY after captured owner release When a resurrected object's final counted owner is released, invoke DESTROY again before conservative weak-root recovery can restore it from a stale caller snapshot. This restores DBIx::Class::Storage::TxnScopeGuard's duplicate DESTROY warning after captured caller arguments are cleared. Add focused coverage for a weakly registered transaction guard captured from a DESTROY warning. The full make gate, system Perl oracle, and both JPerl backends pass; DBIx::Class storage/error qualification still has one failure. Refs #1646 Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex[bot]@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/perlmodule/Internals.java | 6 ++ .../runtime/runtimetypes/MortalList.java | 31 +++++++- .../destroy_reref_after_captured_args.t | 79 +++++++++++++++++++ 4 files changed, 115 insertions(+), 2 deletions(-) create mode 100644 src/test/resources/unit/refcount/destroy_reref_after_captured_args.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 4e4562ffda..e854152001 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -14,6 +14,7 @@ priorities and future plans. - Enforce restricted-hash key access and implement `Hash::Util` key, value, and hash locking (#1502, #1172). - Preserve captured referent ownership when foreach lexicals alias aggregate cells, fixing prompt cleanup of nested one-shot callback owners (#1646). - Match `B::REFCNT` to native B's treatment of its wrapper reference, preventing false resurrection from a schema's sole source registry owner (#1646). +- Re-fire `DESTROY` after a resurrected object's final captured owner is released, even when a full-root snapshot still includes the earlier caller frame (#1646). - Report the caller's scalar context correctly when inspecting frames in overloaded exceptions (#1859). - Avoid heap exhaustion when compiling very large generated subroutines, and preserve heredoc statement boundaries with `\&name` fallbacks (#1252). - Cover nested require caller packages and imported `CLASS` constants, and match defer ordering and caller frames around loop `continue` blocks (#1601, #1405, #1383). diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java index 6ad8098d9a..b734c1b4ed 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java @@ -597,6 +597,9 @@ public static RuntimeList jperlReferenceByAddress(RuntimeArray args, int ctx) { *
  • {@code refCount} — raw {@link RuntimeBase#refCount}
  • *
  • {@code localBindingExists} — true when a named-variable slot still holds the container
  • *
  • {@code destroyFired} — true once DESTROY has run
  • + *
  • {@code needs_re_destroy} — true when a later release should re-fire DESTROY
  • + *
  • {@code currently_destroying} — true while the Perl DESTROY body is active
  • + *
  • {@code perl_lifecycle_state} — current explicit destruction lifecycle state
  • *
  • {@code blessId} — bless class id (0 = unblessed)
  • *
  • {@code class_name} — Perl class name (empty string if unblessed)
  • *
  • {@code kind} — runtime type: SCALAR / ARRAY / HASH / CODE / GLOB / OTHER
  • @@ -613,6 +616,9 @@ public static RuntimeList jperl_refstate(RuntimeArray args, int ctx) { result.put("refCount", new RuntimeScalar(base.refCount)); result.put("localBindingExists", new RuntimeScalar(base.localBindingExists)); result.put("destroyFired", new RuntimeScalar(base.destroyFired)); + result.put("needs_re_destroy", new RuntimeScalar(base.needsReDestroy)); + result.put("currently_destroying", new RuntimeScalar(base.currentlyDestroying)); + result.put("perl_lifecycle_state", new RuntimeScalar(base.perlLifecycleState().name())); result.put("blessId", new RuntimeScalar(base.blessId)); String className = NameNormalizer.getBlessStr(base.blessId); result.put("class_name", new RuntimeScalar(className == null ? "" : className)); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java index 6ae3459d94..c6aa7d26d3 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java @@ -1519,9 +1519,18 @@ private static boolean isReachableCached(RuntimeBase base) { static boolean isReachableFromExternalRootCached(RuntimeBase base) { if (ReachabilityWalker.isReachableFromTemporaryRoots(base)) { + if (base != null && base.refCountTrace) { + System.err.println("[REFCOUNT-KEEP] base=" + System.identityHashCode(base) + + " reason=temporary-root"); + } return true; } - return isReachableFromPersistentRootCached(base); + boolean reachable = isReachableFromPersistentRootCached(base); + if (reachable && base != null && base.refCountTrace) { + System.err.println("[REFCOUNT-KEEP] base=" + System.identityHashCode(base) + + " reason=persistent-root"); + } + return reachable; } static boolean isReachableFromPersistentRootCached(RuntimeBase base) { @@ -1569,7 +1578,12 @@ private static boolean isReachableFromFullRootSnapshot(RuntimeBase base) { if (state.fullRootSnapshot == null) { state.fullRootSnapshot = ReachabilityWalker.reachableFromRootsSnapshotWithStatus(); } - return state.fullRootSnapshot.isReachable(base); + boolean reachable = state.fullRootSnapshot.isReachable(base); + if (reachable && base != null && base.refCountTrace) { + System.err.println("[REFCOUNT-KEEP] base=" + System.identityHashCode(base) + + " reason=full-root"); + } + return reachable; } static boolean isUnblessedAggregateReachableDuringDrain(RuntimeBase base) { @@ -1796,6 +1810,15 @@ private static void processDeferredBase(RuntimeBase base, boolean clearWeakRefsF if (clearWeakRefsForLocalBinding) { WeakRefRegistry.clearWeakRefsTo(base); } + } else if (base.needsReDestroy && base.blessId != 0) { + // The object already ran DESTROY and was resurrected by a + // counted Perl owner. Reaching zero now releases that final + // owner, so honor Perl's re-fire before conservative weak-root + // recovery can restore the count from an in-flight caller + // snapshot left over from the first DESTROY. + base.refCount = Integer.MIN_VALUE; + DestroyDispatch.callDestroy(base); + return; } else if (base instanceof RuntimeCode code && hasWeakRefs && (RuntimeCode.isActiveCode(code) @@ -1962,6 +1985,10 @@ private static boolean blessedClassHasDestroy(RuntimeBase base) { private static boolean restoreReachableOwnerCount(RuntimeBase base) { int ownerCount = base.reachableOwnerCount(); if (ownerCount == 0) return false; + if (base.refCountTrace) { + System.err.println("[REFCOUNT-KEEP] base=" + System.identityHashCode(base) + + " reason=reachable-owner-count owners=" + ownerCount); + } base.refCount = ownerCount; return true; } diff --git a/src/test/resources/unit/refcount/destroy_reref_after_captured_args.t b/src/test/resources/unit/refcount/destroy_reref_after_captured_args.t new file mode 100644 index 0000000000..e4d2d909e5 --- /dev/null +++ b/src/test/resources/unit/refcount/destroy_reref_after_captured_args.t @@ -0,0 +1,79 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Warn; +use Carp qw(carp); +use Scalar::Util qw(refaddr weaken); + +our @captured_args; +my %destruction_registry; + +sub detected_reinvoked_destroy { + my ($object) = @_; + my $address = refaddr($object); + if (!defined $destruction_registry{$address}) { + $destruction_registry{$address} = $object; + weaken($destruction_registry{$address}); + return 0; + } + + carp('Preventing *MULTIPLE* DESTROY() invocations on CapturedTxnGuard'); + return 1; +} + +{ + package CapturedTxnGuard::Storage; + sub new { bless { dbh => bless({}, 'CapturedTxnGuard::DBH') }, shift } + sub _verify_pid { 1 } + sub _seems_connected { 1 } + sub txn_rollback { 1 } +} + +{ + package CapturedTxnGuard; + + sub new { + my ($class, $storage) = @_; + my $guard = { inactivated => 0, storage => $storage, dbh => $storage->{dbh} }; + Scalar::Util::weaken($guard->{dbh}); + return bless $guard, $class; + } + + sub DESTROY { + return if &main::detected_reinvoked_destroy; + + my $self = shift; + $self->{storage}->_verify_pid; + return unless $self->{dbh}; + + local $@; + Carp::carp('Guard went out of scope without explicit commit'); + my $rollback_exception; + eval { $self->{storage}->_seems_connected && $self->{storage}->txn_rollback }; + } +} + +{ + local $SIG{__WARN__} = sub { + package DB; + my $frame = 0; + while (my @caller = caller(++$frame)) { + push @main::captured_args, @DB::args; + } + }; + + my $storage = CapturedTxnGuard::Storage->new; + my $guard = CapturedTxnGuard->new($storage); + undef $guard; +} + +ok(grep({ ref($_) eq 'CapturedTxnGuard' } @captured_args), + 'caller() captures the guard from its DESTROY warning'); + +warnings_exist { + @captured_args = (); +} qr/Preventing \*MULTIPLE\* DESTROY\(\) invocations on CapturedTxnGuard/, + 're-fire DESTROY when the captured guard reference is released'; + +done_testing; From 88441109babcad0b6e6a0a7bf7cb93a416d04d84 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sun, 25 Oct 2026 06:20:53 +0100 Subject: [PATCH 06/12] test: remove unavailable Test::Warn dependency Capture the expected DESTROY warning with a local __WARN__ handler so the regression test runs in the minimal GitHub Actions environment. Generated with OpenAI Codex (https://openai.com/codex/) Co-Authored-By: OpenAI Codex --- .../unit/refcount/destroy_reref_after_captured_args.t | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/test/resources/unit/refcount/destroy_reref_after_captured_args.t b/src/test/resources/unit/refcount/destroy_reref_after_captured_args.t index e4d2d909e5..f0925356bd 100644 --- a/src/test/resources/unit/refcount/destroy_reref_after_captured_args.t +++ b/src/test/resources/unit/refcount/destroy_reref_after_captured_args.t @@ -2,7 +2,6 @@ use strict; use warnings; use Test::More; -use Test::Warn; use Carp qw(carp); use Scalar::Util qw(refaddr weaken); @@ -71,9 +70,13 @@ sub detected_reinvoked_destroy { ok(grep({ ref($_) eq 'CapturedTxnGuard' } @captured_args), 'caller() captures the guard from its DESTROY warning'); -warnings_exist { +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; @captured_args = (); -} qr/Preventing \*MULTIPLE\* DESTROY\(\) invocations on CapturedTxnGuard/, - 're-fire DESTROY when the captured guard reference is released'; +} +like(join('', @warnings), + qr/Preventing \*MULTIPLE\* DESTROY\(\) invocations on CapturedTxnGuard/, + 're-fire DESTROY when the captured guard reference is released'); done_testing; From 0d0a23ef43e610cbc2674e015719dbdd1f63bf6f Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sun, 25 Oct 2026 16:33:31 +0100 Subject: [PATCH 07/12] fix(runtime): track direct hash slot owners for refcount probes Record direct hash-slot ownership weakly so stale owners can be excluded from B::REFCNT results during destruction. Keep slot records accurate as scalar ownership changes and add a regression for a hash owner leaving scope. Generated with Codex (https://openai.com/codex) Co-Authored-By: Codex --- .../backend/bytecode/BytecodeInterpreter.java | 2 +- .../backend/bytecode/SlowOpcodeHandler.java | 2 +- .../runtime/operators/ReferenceOperators.java | 4 +- .../runtime/perlmodule/Internals.java | 18 +++-- .../runtime/perlmodule/Storable.java | 2 +- .../runtime/runtimetypes/DestroyDispatch.java | 2 +- .../runtimetypes/GlobalRuntimeScalar.java | 4 +- .../runtime/runtimetypes/MortalList.java | 14 ++-- .../runtimetypes/MyVarCleanupStack.java | 4 +- .../runtimetypes/ReachabilityWalker.java | 12 ++++ .../runtime/runtimetypes/RuntimeArray.java | 8 +-- .../runtime/runtimetypes/RuntimeBase.java | 72 +++++++++++++++++++ .../runtimetypes/RuntimeGraphCloner.java | 2 +- .../runtime/runtimetypes/RuntimeHash.java | 32 +++++++-- .../runtime/runtimetypes/RuntimeList.java | 8 +-- .../runtime/runtimetypes/RuntimeScalar.java | 31 +++++--- .../runtime/runtimetypes/RuntimeStash.java | 2 +- .../runtime/runtimetypes/WeakRefRegistry.java | 6 +- .../b_refcount_ignores_dead_hash_owner.t | 30 ++++++++ 19 files changed, 206 insertions(+), 49 deletions(-) create mode 100644 src/test/resources/unit/refcount/b_refcount_ignores_dead_hash_owner.t diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index 9de201e79b..781cd33f41 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -145,7 +145,7 @@ private static void releaseConsumedTemp(RuntimeBase temp, RuntimeBase target) { return; } - tempScalar.refCountOwned = false; + tempScalar.setRefCountOwned(false); if (base.refCountTrace) { base.traceRefCount(-1, "BytecodeInterpreter.releaseConsumedTemp"); base.releaseOwner(tempScalar, "releaseConsumedTemp"); diff --git a/src/main/java/org/perlonjava/backend/bytecode/SlowOpcodeHandler.java b/src/main/java/org/perlonjava/backend/bytecode/SlowOpcodeHandler.java index 4df3e1b7af..3a2b83481f 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/SlowOpcodeHandler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/SlowOpcodeHandler.java @@ -1355,7 +1355,7 @@ private static void releaseHashSliceTemporaryOwner(RuntimeScalar value) { base.releaseOwner(value, "HASH_SLICE_SET temporary owner transfer"); base.releaseActiveOwner(value); base.refCount--; - value.refCountOwned = false; + value.setRefCountOwned(false); } } diff --git a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java index 6c9cf65989..6278889d08 100644 --- a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java @@ -224,7 +224,7 @@ private static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar cl // tracking wasn't active at assignment time). Count it as 1. referent.refCount = 1; referent.recordOwner(runtimeScalar, "rebless from untracked"); - runtimeScalar.refCountOwned = true; + runtimeScalar.setRefCountOwned(true); } else { // First bless: start at refCount=1 and add to MortalList. // The mortal entry will decrement back to 0 at the next @@ -257,7 +257,7 @@ private static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar cl referent.refCount = existingScalarOwner ? 2 : 1; if (existingScalarOwner) { referent.recordOwner(runtimeScalar, "first bless of existing scalar ref"); - runtimeScalar.refCountOwned = true; + runtimeScalar.setRefCountOwned(true); } referent.acquireTransientTraceOwner("bless mortal temporary", "ReferenceOperators.first bless"); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java index b734c1b4ed..1e88809fa8 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java @@ -12,7 +12,6 @@ * The Strict class provides functionalities similar to the Perl strict module. */ public class Internals extends PerlModuleBase { - /** * Constructor initializes the module. */ @@ -543,6 +542,7 @@ public static RuntimeList svRefcount(RuntimeArray args, int ctx) { // compensates for the ampersand-call argument alias below. boolean compileHintsHash = base == GlobalVariable.getGlobalHash( GlobalContext.encodeSpecialVar("H")); + boolean bObjectProbe = args.size() > 1 && args.get(1).getBoolean(); int extra = (base.localBindingExists && !compileHintsHash ? 1 : 0) + base.foreachAliasCount; // Legacy fudge: anonymous tracked container with no counted @@ -560,8 +560,8 @@ public static RuntimeList svRefcount(RuntimeArray args, int ctx) { boolean fieldOwnedMethodResult = rc == 1 && !base.localBindingExists && base.hashSlotOwnerCount > 0 - && !ReachabilityWalker.hasLiveStrongScalarReferentOtherThan(base, arg); - boolean bObjectProbe = args.size() > 1 && args.get(1).getBoolean(); + && (bObjectProbe + || !ReachabilityWalker.hasLiveStrongScalarReferentOtherThan(base, arg)); int adjust = compileHintsHash ? -1 : base.localBindingExists || fieldOwnedMethodResult ? 0 : -1; @@ -573,7 +573,17 @@ public static RuntimeList svRefcount(RuntimeArray args, int ctx) { if (bObjectProbe && base.localBindingExists && !compileHintsHash) { adjust = -1; } - return new RuntimeScalar(rc + extra + adjust).getList(); + boolean insideDestroy = DestroyDispatch.isInsideDestroy(); + int staleHashOwners = 0; + if (rc > 1 && bObjectProbe && !base.localBindingExists && insideDestroy) { + int[] staleOwners = base.unreachableDirectHashSlotOwnerCounts(); + // Once a counted owner has leaked, include every unreachable + // hash slot in the correction. Some slots retain the raw + // refcount after their wrapper has already cleared its flag. + if (staleOwners[0] > 0) staleHashOwners = staleOwners[1]; + } + int reported = Math.max(0, rc + extra + adjust - staleHashOwners); + return new RuntimeScalar(reported).getList(); } return new RuntimeScalar(1).getList(); } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java b/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java index c81c9751ef..455c8650b5 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java @@ -352,7 +352,7 @@ public static void releaseApplyArgs(RuntimeArray args) { base.releaseOwner(elem, "Storable.releaseApplyArgs"); base.releaseActiveOwner(elem); base.refCount--; - elem.refCountOwned = false; + elem.setRefCountOwned(false); } } args.elements.clear(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java b/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java index 9b6049b2eb..6e62cae064 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java @@ -528,7 +528,7 @@ private static void doCallDestroy(RuntimeBase referent, String className) { } base.releaseActiveOwner(elem); base.refCount--; - elem.refCountOwned = false; + elem.setRefCountOwned(false); } } args.elements.clear(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalRuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalRuntimeScalar.java index 61b73e7919..05811f8c9d 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalRuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalRuntimeScalar.java @@ -227,7 +227,7 @@ public void dynamicRestoreState() { && localVar.value instanceof RuntimeBase base && base.refCount > 0) { displacedBase = base; - localVar.refCountOwned = false; + localVar.setRefCountOwned(false); displacedBase.releaseActiveOwner(localVar); } if (localVar != null @@ -281,7 +281,7 @@ public void dynamicRestoreState() { localVar.value = saved.originalVariable.value; localVar.blessId = saved.originalVariable.blessId; } - localVar.refCountOwned = false; + localVar.setRefCountOwned(false); } if (localVar != null) { localVar.ownsScalarReferenceContents = false; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java index c6aa7d26d3..31772acee8 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java @@ -540,7 +540,7 @@ public static void deferDecrementIfTracked(RuntimeScalar scalar) { || scalar.type == RuntimeScalarType.GLOB) && scalar.value instanceof RuntimeBase base) { if (base.refCount > 0) { - scalar.refCountOwned = false; + scalar.setRefCountOwned(false); if (base.refCountTrace) { base.traceRefCount(0, "MortalList.deferDecrementIfTracked (queued, scalar.refCountOwned->false)"); } @@ -559,7 +559,7 @@ public static void deferDecrementIfTracked(RuntimeScalar scalar) { // that stale ownership marker and ask the reachability walker to // decide at the next safe (non-nested) boundary whether the weak // observers should be cleared. - scalar.refCountOwned = false; + scalar.setRefCountOwned(false); if (base.refCountTrace) { base.releaseOwner(scalar, "deferDecrementIfTracked zero-count owner"); } @@ -893,7 +893,7 @@ public static void releaseTailCallCodeRef(RuntimeScalar codeRef) { return; } - codeRef.refCountOwned = false; + codeRef.setRefCountOwned(false); if (code.refCountTrace) { code.traceRefCount(-1, "MortalList.releaseTailCallCodeRef"); code.releaseOwner(codeRef, "releaseTailCallCodeRef"); @@ -925,7 +925,7 @@ private static void releaseTailCallArgElement(RuntimeScalar scalar) { return; } - scalar.refCountOwned = false; + scalar.setRefCountOwned(false); if (base.refCountTrace) { base.traceRefCount(-1, "MortalList.releaseTailCallArgElement"); base.releaseOwner(scalar, "releaseTailCallArgElement"); @@ -1009,7 +1009,7 @@ private static void deferDecrementRecursive(RuntimeScalar scalar) { if (base.blessId != 0) { boolean releasingLastOwner = false; if (s.refCountOwned && base.refCount > 0) { - s.refCountOwned = false; + s.setRefCountOwned(false); if (base.refCountTrace) { base.traceRefCount(0, "MortalList.deferDecrementRecursive (blessed, queued)"); base.releaseOwner(s, "deferDecrementRecursive blessed"); @@ -1057,7 +1057,7 @@ private static void deferDecrementRecursive(RuntimeScalar scalar) { boolean hasCleanupTargets = hasDirectWeakElementRefs || containerMayContainCleanupTargets(base); if (s.refCountOwned && base.refCount > 0) { - s.refCountOwned = false; + s.setRefCountOwned(false); if (base.refCountTrace) { base.traceRefCount(0, "MortalList.deferDecrementRecursive (unblessed container, queued)"); } @@ -1183,7 +1183,7 @@ public static void mortalizeForVoidDiscard(RuntimeList result) { && ReachabilityWalker.isScalarReachable(scalar); if (scalar.refCountOwned && base.refCount > 0 && unblessedDiscardableContainer && !reachableCodeRef) { - scalar.refCountOwned = false; + scalar.setRefCountOwned(false); if (base.refCountTrace) { base.traceRefCount(0, "MortalList.mortalizeForVoidDiscard (queued owned container discard)"); base.releaseOwner(scalar, "mortalizeForVoidDiscard container"); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java index 807c62df40..2cdf185b95 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java @@ -362,7 +362,7 @@ public static void retainBlessedGlobAliases(RuntimeGlob glob, RuntimeBase refere && scalar.value == glob && !scalar.refCountOwned && seen.put(scalar, Boolean.TRUE) == null) { - scalar.refCountOwned = true; + scalar.setRefCountOwned(true); referent.recordOwner(scalar, "blessed glob lexical alias"); referent.recordActiveOwner(scalar); referent.traceRefCount(+1, "MyVarCleanupStack.retainBlessedGlobAliases"); @@ -377,7 +377,7 @@ public static void retainBlessedGlobAliases(RuntimeGlob glob, RuntimeBase refere && scalar.value == glob && !scalar.refCountOwned && seen.put(scalar, Boolean.TRUE) == null) { - scalar.refCountOwned = true; + scalar.setRefCountOwned(true); referent.recordOwner(scalar, "blessed glob package alias"); referent.recordActiveOwner(scalar); referent.traceRefCount(+1, "MyVarCleanupStack.retainBlessedGlobAliases"); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java index d5153b130e..3addd1d150 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java @@ -1987,6 +1987,18 @@ public static boolean isReachableFromRoots(RuntimeBase target, boolean globalOnl } } } + // Active Perl call arguments are owning roots until their frame + // returns. The full graph walk seeds these frames already; keep + // this target-specific query consistent so a hash passed through + // @_ is not mistaken for an abandoned owner. + for (RuntimeArray args : RuntimeCode.snapshotArgsStack()) { + if (!budget.visitEdge()) return true; + if (args == target) return true; + if (seen.add(args)) { + todo.addLast(args); + if (stats != null) stats.rootsSeeded++; + } + } // Live regex lexicals own executable callback captures even when // weak-ref tracking has not populated the optimized live-count // snapshot. Seed only regex scalars from the actual cleanup stack diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java index 369ecc7732..5ffba17d7f 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java @@ -698,7 +698,7 @@ public static RuntimeScalar pop(RuntimeArray runtimeArray) { && (result.type & RuntimeScalarType.REFERENCE_BIT) != 0 && result.value instanceof RuntimeBase base && base.refCount > 0) { - result.refCountOwned = false; + result.setRefCountOwned(false); runtimeArray.forgetOwnedAliasElement(result); base.releaseActiveOwner(result); MortalList.requestWeakSweepsForDestroyedContainer(base); @@ -741,7 +741,7 @@ public static RuntimeScalar shift(RuntimeArray runtimeArray) { && (result.type & RuntimeScalarType.REFERENCE_BIT) != 0 && result.value instanceof RuntimeBase base && base.refCount > 0) { - result.refCountOwned = false; + result.setRefCountOwned(false); runtimeArray.forgetOwnedAliasElement(result); base.releaseActiveOwner(result); MortalList.requestWeakSweepsForDestroyedContainer(base); @@ -1757,7 +1757,7 @@ public RuntimeArray setFromListAliased(RuntimeList list) { // overwrites will still work correctly because setLarge checks // refCountOwned before decrementing. for (RuntimeScalar elem : this.elements) { - if (elem != null) elem.refCountOwned = false; + if (elem != null) elem.setRefCountOwned(false); markPackageRootedValue(elem); } this.elementsOwned = false; @@ -1788,7 +1788,7 @@ public RuntimeArray setFromReferenceList(RuntimeList list) { RuntimeScalar referent = reference.refAliasScalarReference(); this.elements.add(referent); markPackageRootedValue(referent); - referent.refCountOwned = false; + referent.setRefCountOwned(false); } this.elementsOwned = false; this.elementsAliased = true; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java index 553ac10c8b..aa6fe8a55a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java @@ -2,6 +2,9 @@ import java.util.Iterator; import java.util.Objects; +import java.lang.ref.WeakReference; +import java.util.ArrayList; +import java.util.List; import static org.perlonjava.runtime.runtimetypes.RuntimeScalarCache.scalarUndef; @@ -198,6 +201,75 @@ boolean deferSharedDestroy() { */ public int hashSlotOwnerCount = 0; + private static final class DirectHashSlotOwner { + final WeakReference hash; + final WeakReference scalar; + boolean countedWhenAdded; + + DirectHashSlotOwner(RuntimeHash hash, RuntimeScalar scalar) { + this.hash = new WeakReference<>(hash); + this.scalar = new WeakReference<>(scalar); + this.countedWhenAdded = scalar != null && scalar.refCountOwned; + } + } + + private final List directHashSlotOwners = new ArrayList<>(); + + /** Track hash slots separately from their scalar wrappers, which may be replaced. */ + public synchronized void updateDirectHashSlotOwner( + RuntimeHash owner, RuntimeScalar scalar, int delta) { + if (delta > 0) { + directHashSlotOwners.add(new DirectHashSlotOwner(owner, scalar)); + return; + } + for (Iterator it = directHashSlotOwners.iterator(); it.hasNext();) { + DirectHashSlotOwner record = it.next(); + RuntimeHash existing = record.hash.get(); + RuntimeScalar existingScalar = record.scalar.get(); + if (existing == null || existing == owner && existingScalar == scalar) { + it.remove(); + if (existing == owner && existingScalar == scalar) return; + } + } + } + + public synchronized void updateDirectHashSlotOwnerCounted( + RuntimeHash owner, RuntimeScalar scalar, boolean counted) { + for (DirectHashSlotOwner record : directHashSlotOwners) { + if (record.hash.get() == owner && record.scalar.get() == scalar) { + record.countedWhenAdded = counted; + } + } + } + + /** Count direct hash slots whose owner hash is outside the Perl root graph. */ + public synchronized int[] unreachableDirectHashSlotOwnerCounts() { + int countedUnreachable = 0; + int totalUnreachable = 0; + java.util.IdentityHashMap reachableCache = + new java.util.IdentityHashMap<>(); + for (Iterator it = directHashSlotOwners.iterator(); it.hasNext();) { + DirectHashSlotOwner record = it.next(); + RuntimeHash owner = record.hash.get(); + RuntimeScalar scalar = record.scalar.get(); + boolean counted = scalar == null ? record.countedWhenAdded : scalar.refCountOwned; + boolean unreachable; + if (owner == null) { + unreachable = true; + } else if (owner.perlLifecycleState() == PerlLifecycleState.DESTROYING) { + unreachable = false; + } else { + unreachable = reachableCache.computeIfAbsent( + owner, hash -> !ReachabilityWalker.isReachableFromRoots(hash)); + } + if (unreachable) { + totalUnreachable++; + if (counted) countedUnreachable++; + } + } + return new int[]{countedUnreachable, totalUnreachable}; + } + /** * Marks a scalar/container whose contents are reachable from package diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java index d7f02304e2..aba47d90a7 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java @@ -596,7 +596,7 @@ private void restoreScalarReferenceOwnership(RuntimeScalar source, RuntimeScalar referent.recordActiveOwner(target); referent.refCount++; referent.hadCountedReference = true; - target.refCountOwned = true; + target.setRefCountOwned(true); try (PerlRuntime.Binding ignored = targetRuntime.bind()) { ScalarRefRegistry.registerRef(target); } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java index d7ba5c74dd..eaca61812b 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java @@ -214,7 +214,7 @@ public RuntimeScalar put(String key, RuntimeScalar value) { } owner.markPackageRootedValue(value); RuntimeScalar result = super.put(key, value); - updateReferentHashSlotOwnership(previous, value); + updateReferentHashSlotOwnership(owner, previous, value, true); return result; } @@ -245,6 +245,9 @@ public void putAll(Map m) { } owner.markPackageRootedValue(value); } + for (Map.Entry entry : m.entrySet()) { + updateReferentHashSlotOwnership(owner, super.get(entry.getKey()), entry.getValue(), false); + } super.putAll(m); } @@ -252,6 +255,7 @@ public void putAll(Map m) { public RuntimeScalar remove(Object key) { RuntimeScalar previous = super.remove(key); if (previous != null) { + updateReferentHashSlotOwnership(owner, previous, null, false); if (owner.isHintHash && !owner.suppressHintHashLifecycleCleanup) { MortalList.deferDestroyForContainerClear(java.util.Collections.singletonList(previous)); } @@ -263,6 +267,9 @@ public RuntimeScalar remove(Object key) { @Override public void clear() { if (!isEmpty()) { + for (RuntimeScalar previous : values()) { + updateReferentHashSlotOwnership(owner, previous, null, false); + } if (owner.isHintHash && !owner.suppressHintHashLifecycleCleanup) { MortalList.deferDestroyForContainerClear(values()); } @@ -707,16 +714,27 @@ private static RuntimeBase directReferent(RuntimeScalar scalar) { } private static void updateReferentHashSlotOwnership( - RuntimeScalar oldValue, RuntimeScalar newValue) { + RuntimeHash owner, RuntimeScalar oldValue, RuntimeScalar newValue, + boolean updateLegacyCount) { RuntimeBase oldReferent = directReferent(oldValue); RuntimeBase newReferent = directReferent(newValue); - if (oldReferent == newReferent) return; - if (oldReferent != null && oldReferent.hashSlotOwnerCount > 0) { - oldReferent.hashSlotOwnerCount--; + if (oldReferent == newReferent) { + if (oldReferent != null && oldValue != newValue) { + oldReferent.updateDirectHashSlotOwner(owner, oldValue, -1); + oldReferent.updateDirectHashSlotOwner(owner, newValue, 1); + } + return; } - if (newReferent != null) { - newReferent.hashSlotOwnerCount++; + if (updateLegacyCount) { + if (oldReferent != null && oldReferent.hashSlotOwnerCount > 0) { + oldReferent.hashSlotOwnerCount--; + } + if (newReferent != null) { + newReferent.hashSlotOwnerCount++; + } } + if (oldReferent != null) oldReferent.updateDirectHashSlotOwner(owner, oldValue, -1); + if (newReferent != null) newReferent.updateDirectHashSlotOwner(owner, newValue, 1); } /** diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeList.java index a08f033257..fe9d18832b 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeList.java @@ -792,7 +792,7 @@ public RuntimeArray setFromList(RuntimeList value) { base.releaseOwner(rhsValue, "RuntimeList materialized-copy undo (undef-target)"); base.releaseActiveOwner(rhsValue); base.refCount--; - rhsValue.refCountOwned = false; + rhsValue.setRefCountOwned(false); } rhsIndex++; } @@ -816,7 +816,7 @@ public RuntimeArray setFromList(RuntimeList value) { base.releaseOwner(assigned, "RuntimeList materialized-copy undo (scalar-target)"); base.releaseActiveOwner(assigned); base.refCount--; - assigned.refCountOwned = false; + assigned.setRefCountOwned(false); } } else if (elem instanceof RuntimeArray runtimeArray) { List remaining = (rhsIndex < rhsSize) @@ -842,7 +842,7 @@ public RuntimeArray setFromList(RuntimeList value) { base.releaseOwner(r, "RuntimeList materialized-copy undo (array-target)"); base.releaseActiveOwner(r); base.refCount--; - r.refCountOwned = false; + r.setRefCountOwned(false); } } } else { @@ -877,7 +877,7 @@ public RuntimeArray setFromList(RuntimeList value) { base.releaseOwner(r, "RuntimeList materialized-copy undo (hash-target)"); base.releaseActiveOwner(r); base.refCount--; - r.refCountOwned = false; + r.setRefCountOwned(false); } } rhsIndex = rhsSize; // Consume the rest diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index 0ffffa56b9..7da83362cb 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -659,6 +659,15 @@ void retainClosureCaptureReferentsForUnweaken() { */ public boolean refCountOwned; + /** Update ownership bookkeeping and any direct hash-slot witness for this cell. */ + public void setRefCountOwned(boolean owned) { + this.refCountOwned = owned; + if (containerOwner instanceof RuntimeHash hashOwner + && value instanceof RuntimeBase referent) { + referent.updateDirectHashSlotOwnerCounted(hashOwner, this, owned); + } + } + /** A postfix ++/-- result transfers, rather than duplicates, its reference owner on assignment. */ private boolean postfixReferenceOwnershipTransfer; @@ -2142,7 +2151,7 @@ public static void incrementRefCountForContainerStore(RuntimeScalar scalar) { base.hadCountedReference = true; base.recordOwner(scalar, "incrementRefCountForContainerStore"); base.recordActiveOwner(scalar); - scalar.refCountOwned = true; + scalar.setRefCountOwned(true); // Phase B1 (refcount_alignment_52leaks_plan.md): track the // container element so ReachabilityWalker can see it via // ScalarRefRegistry. @@ -3098,7 +3107,13 @@ && hasLiveIo(assignedGlob)) { } // Update ownership: this scalar now owns a refCount iff we incremented. - this.refCountOwned = newOwned; + this.setRefCountOwned(newOwned); + if (containerOwner instanceof RuntimeHash hashOwner) { + if (oldBase != null) oldBase.updateDirectHashSlotOwner(hashOwner, this, -1); + if (this.value instanceof RuntimeBase newBase) { + newBase.updateDirectHashSlotOwner(hashOwner, this, 1); + } + } retainScalarReferenceContents(value); // Flush deferred mortal decrements from the current function scope. @@ -4958,7 +4973,7 @@ public RuntimeScalar undefine() { boolean releasedCode = false; releaseAllClosureCaptureReferents(code); if (this.refCountOwned && code.refCount > 0) { - this.refCountOwned = false; + this.setRefCountOwned(false); code.releaseActiveOwner(this); if (--code.refCount == 0) { code.refCount = Integer.MIN_VALUE; @@ -5030,7 +5045,7 @@ public RuntimeScalar undefine() { oldBase.refCount = Integer.MIN_VALUE; DestroyDispatch.callDestroy(oldBase); } else if (this.refCountOwned && oldBase.refCount > 0) { - this.refCountOwned = false; + this.setRefCountOwned(false); oldBase.releaseActiveOwner(this); if (--oldBase.refCount == 0) { if (oldBase.localBindingExists) { @@ -5960,9 +5975,9 @@ private RuntimeScalar postAutoIncrementLarge() { // returned reference becomes the first durable owner. The // assignment receiving this scalar will balance the temporary // copy, so retain one cleanup token for that returned value. - old.refCountOwned = true; + old.setRefCountOwned(true); old.postfixReferenceOwnershipTransfer = true; - this.refCountOwned = false; + this.setRefCountOwned(false); // Check if object is eligible for overloading int blessId = blessedId(this); if (blessId != 0) { @@ -6271,9 +6286,9 @@ private RuntimeScalar postAutoDecrementWithoutWatcherNotification() { default -> { // All reference types // See postAutoIncrementLarge(): the returned pre-mutation // reference inherits this lvalue's ownership token. - old.refCountOwned = true; + old.setRefCountOwned(true); old.postfixReferenceOwnershipTransfer = true; - this.refCountOwned = false; + this.setRefCountOwned(false); // Check if object is eligible for overloading int blessId = blessedId(this); if (blessId != 0) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java index 0c26546dc2..554c36688d 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java @@ -264,7 +264,7 @@ private RuntimeScalar deleteGlob(String k) { DestroyDispatch.callDestroy(base); } else if (base.refCount > 0 && savedScalar.refCountOwned) { // Tracked object: decrement refCount (the stash was holding a strong ref). - savedScalar.refCountOwned = false; + savedScalar.setRefCountOwned(false); base.releaseActiveOwner(savedScalar); if (--base.refCount == 0) { base.refCount = Integer.MIN_VALUE; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java index 5811970656..c6a2ce1dc9 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java @@ -163,7 +163,7 @@ private static void weaken( // get a double-decrement that causes premature destruction. // Clear refCountOwned because weaken's DEC consumes the ownership — // the weak scalar should not trigger another DEC on scope exit or overwrite. - ref.refCountOwned = false; + ref.setRefCountOwned(false); base.traceRefCount(-1, "WeakRefRegistry.weaken (decrement on weakening)"); base.releaseOwner(ref, "weaken"); base.releaseActiveOwner(ref); @@ -236,7 +236,7 @@ && hasWeakRefsTo(base) // is still alive in the stash. This breaks Sub::Quote/Sub::Defer // (which use weaken() for back-references) and cascades to break // Moo's accessor inlining (51 test failures). See §15. - ref.refCountOwned = false; + ref.setRefCountOwned(false); if (base.blessId == 0 && (base instanceof RuntimeArray || base instanceof RuntimeHash) && ReachabilityWalker.isReachableFromRoots(base)) { @@ -318,7 +318,7 @@ public static void unweaken(RuntimeScalar ref) { if (base.refCount >= 0) { base.traceRefCount(+1, "WeakRefRegistry.unweaken (restore strong count)"); base.refCount++; // restore strong count - ref.refCountOwned = true; // restore ownership + ref.setRefCountOwned(true); // restore ownership base.hadCountedReference = true; base.recordOwner(ref, "WeakRefRegistry.unweaken"); base.recordActiveOwner(ref); diff --git a/src/test/resources/unit/refcount/b_refcount_ignores_dead_hash_owner.t b/src/test/resources/unit/refcount/b_refcount_ignores_dead_hash_owner.t new file mode 100644 index 0000000000..bee03abdd0 --- /dev/null +++ b/src/test/resources/unit/refcount/b_refcount_ignores_dead_hash_owner.t @@ -0,0 +1,30 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +use B qw(svref_2object); +use Test::More; + +our (%KEEP, $REFCOUNT); +$KEEP{target} = bless {}, 'DeadHashOwnerTarget'; + +sub add_temporary_hash_owner { + my %temporary; + $temporary{copy} = $KEEP{target}; +} + +add_temporary_hash_owner(); + +{ + package DeadHashOwnerProbe; + sub DESTROY { + $main::REFCOUNT = B::svref_2object($main::KEEP{target})->REFCNT; + } +} + +my $probe = bless {}, 'DeadHashOwnerProbe'; +undef $probe; + +is($REFCOUNT, 1, 'B excludes a hash owner after its hash leaves scope'); + +done_testing; From 4d375b609ab9cab812c581a1e62d5b59d3267c40 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sun, 25 Oct 2026 16:35:44 +0100 Subject: [PATCH 08/12] docs: classify DBIx lifecycle assertion under issue 1646 Record the system Perl and clean-master comparison for DBIx::Class assertion 49, and keep the case open pending lifecycle work and full acceptance. Generated with Codex (https://openai.com/codex) Co-Authored-By: Codex --- dev/design/perl-ownership-rewrite.md | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/dev/design/perl-ownership-rewrite.md b/dev/design/perl-ownership-rewrite.md index 6759cfe64f..c29ec6f4fc 100644 --- a/dev/design/perl-ownership-rewrite.md +++ b/dev/design/perl-ownership-rewrite.md @@ -293,8 +293,15 @@ and first path establish implementation cost. target Perl loads the helper. These are pre-existing issues tracked in [#1656](https://github.com/fglock/PerlOnJava/issues/1656) and [#1434](https://github.com/fglock/PerlOnJava/issues/1434); the DBIx run's two - assertion failures remain separately unclassified under + assertion failures are tracked separately under [#1646](https://github.com/fglock/PerlOnJava/issues/1646). +- [x] Classify DBIx::Class 0.082844 `t/storage/error.t` assertion 49 on the + current lifecycle candidate: system Perl passes, and the same failure + reproduces on the clean master baseline. The candidate remains intermittent + (one recent run failed and two passed); the failed run still treated the + weak schema captured by DBI's handler as live after `$schema` was cleared. + Keep this result open under #1642 and rerun it after that lifecycle work is + reconciled; this does not count as DBIx acceptance. ### Next steps From 067bfdf9e23099b876bf1aff04bd79443a78d34a Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sun, 25 Oct 2026 16:57:41 +0100 Subject: [PATCH 09/12] docs: compare remaining DBIx failures with master Record system Perl, clean-master, and lifecycle-candidate outcomes for the DBIx leak and transaction guard tests without claiming acceptance. Generated with Codex (https://openai.com/codex) Co-Authored-By: Codex --- dev/design/perl-ownership-rewrite.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/dev/design/perl-ownership-rewrite.md b/dev/design/perl-ownership-rewrite.md index c29ec6f4fc..a20f2382c6 100644 --- a/dev/design/perl-ownership-rewrite.md +++ b/dev/design/perl-ownership-rewrite.md @@ -302,6 +302,14 @@ and first path establish implementation cost. weak schema captured by DBI's handler as live after `$schema` was cleared. Keep this result open under #1642 and rerun it after that lifecycle work is reconciled; this does not count as DBIx acceptance. +- [x] Compare the other DBIx failures with system Perl and clean master. + `t/storage/txn_scope_guard.t` assertion 18 also fails on both PerlOnJava + candidates and passes on system Perl; it misses the warning that guards + against repeated `DESTROY` calls. The clean master `t/52leaks.t` run fails + at `basic random_results`. The lifecycle candidate failed a later + `basic leaky_resultset_cond` check in the combined run, while a focused retry + completed with only the upstream TODO failures. The differing leak outcomes + are inconclusive; rerun all three programs together after #1642 is reconciled. ### Next steps From e2ad8c8ea51834b5996e60910eb30f32c370af0c Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sun, 25 Oct 2026 17:09:15 +0100 Subject: [PATCH 10/12] docs: note isolated DBIx guard reproduction Record that the reduced DBIx scope-guard capture case passes on both backends, while the full upstream test still fails in its broader suite context. Generated with Codex (https://openai.com/codex) Co-Authored-By: Codex --- dev/design/perl-ownership-rewrite.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/dev/design/perl-ownership-rewrite.md b/dev/design/perl-ownership-rewrite.md index a20f2382c6..d9fedd5bf4 100644 --- a/dev/design/perl-ownership-rewrite.md +++ b/dev/design/perl-ownership-rewrite.md @@ -309,7 +309,10 @@ and first path establish implementation cost. at `basic random_results`. The lifecycle candidate failed a later `basic leaky_resultset_cond` check in the combined run, while a focused retry completed with only the upstream TODO failures. The differing leak outcomes - are inconclusive; rerun all three programs together after #1642 is reconciled. + are inconclusive. A reduced scope-guard reproducer of the capture and + re-destruction path passes 3/3 on system Perl, JVM, and interpreter, so the + full `txn_scope_guard.t` failure depends on additional suite state. Rerun all + three programs together after #1642 is reconciled. ### Next steps From 05f9121f146620e3a4e711132cfaad4b0da89fb1 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sun, 25 Oct 2026 19:24:31 +0100 Subject: [PATCH 11/12] docs: refresh DBIx lifecycle acceptance results Record the clean-candidate results for the three DBIx lifecycle files and keep storage/error.t assertion 49 open pending #1642 reconciliation. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- dev/design/perl-ownership-rewrite.md | 32 ++++++++++++++-------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/dev/design/perl-ownership-rewrite.md b/dev/design/perl-ownership-rewrite.md index d9fedd5bf4..3a9c8efb19 100644 --- a/dev/design/perl-ownership-rewrite.md +++ b/dev/design/perl-ownership-rewrite.md @@ -297,22 +297,22 @@ and first path establish implementation cost. [#1646](https://github.com/fglock/PerlOnJava/issues/1646). - [x] Classify DBIx::Class 0.082844 `t/storage/error.t` assertion 49 on the current lifecycle candidate: system Perl passes, and the same failure - reproduces on the clean master baseline. The candidate remains intermittent - (one recent run failed and two passed); the failed run still treated the - weak schema captured by DBI's handler as live after `$schema` was cleared. - Keep this result open under #1642 and rerun it after that lifecycle work is - reconciled; this does not count as DBIx acceptance. -- [x] Compare the other DBIx failures with system Perl and clean master. - `t/storage/txn_scope_guard.t` assertion 18 also fails on both PerlOnJava - candidates and passes on system Perl; it misses the warning that guards - against repeated `DESTROY` calls. The clean master `t/52leaks.t` run fails - at `basic random_results`. The lifecycle candidate failed a later - `basic leaky_resultset_cond` check in the combined run, while a focused retry - completed with only the upstream TODO failures. The differing leak outcomes - are inconclusive. A reduced scope-guard reproducer of the capture and - re-destruction path passes 3/3 on system Perl, JVM, and interpreter, so the - full `txn_scope_guard.t` failure depends on additional suite state. Rerun all - three programs together after #1642 is reconciled. + reproduces on the clean master baseline. A clean rebuild of the current + candidate still fails 48/49 assertions. The weak schema captured by DBI's + handler remains live after `$schema` is cleared; after a forced quiet GC, + owner tracing reports no active scalar owners or capture slots despite the + stale positive refcount. The exact stale-count/root cause remains open under + #1642; rerun after that lifecycle work is reconciled. This does not count as + DBIx acceptance. +- [x] Rerun the three DBIx lifecycle files together on the clean candidate. + `t/storage/txn_scope_guard.t` now passes 18/18 and `t/52leaks.t` passes 11/11 + (including their TODO skips); the prior clean-master run failed the scope + guard assertion, and the earlier leak outcomes varied. `t/storage/error.t` + remains at 48/49, with assertion 49 failing as it does on clean master while + passing on system Perl. A reduced scope-guard reproducer passes on system + Perl, JVM, interpreter, and clean master, so it is not standalone regression + evidence. Full DBIx acceptance remains open until #1642 is reconciled and + the complete suite is rerun. ### Next steps From aab9a0dba1c5a96e6f8bf89714b521fc610d76d1 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Mon, 26 Oct 2026 07:29:47 +0100 Subject: [PATCH 12/12] fix: sweep nested weak refs after DESTROY Request a weak-reference sweep after blessed container cleanup completes so DBIx::Class callbacks no longer retain a dead Storage object through an inflated selective reference count. Cover the callback lifecycle on both execution backends and record the fix in the changelog. Generated with OpenAI Codex (https://openai.com/codex/) Co-Authored-By: OpenAI Codex --- docs/about/changelog.md | 1 + .../runtime/runtimetypes/DestroyDispatch.java | 10 ++++ .../DestroyDispatchNestedWeakSweepTest.java | 59 +++++++++++++++++++ 3 files changed, 70 insertions(+) create mode 100644 src/test/java/org/perlonjava/runtime/runtimetypes/DestroyDispatchNestedWeakSweepTest.java diff --git a/docs/about/changelog.md b/docs/about/changelog.md index e854152001..0f7aa271f4 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -15,6 +15,7 @@ priorities and future plans. - Preserve captured referent ownership when foreach lexicals alias aggregate cells, fixing prompt cleanup of nested one-shot callback owners (#1646). - Match `B::REFCNT` to native B's treatment of its wrapper reference, preventing false resurrection from a schema's sole source registry owner (#1646). - Re-fire `DESTROY` after a resurrected object's final captured owner is released, even when a full-root snapshot still includes the earlier caller frame (#1646). +- Recheck nested weak references after blessed container destruction returns, clearing DBIx::Class storage callbacks once their schema is gone (#1646). - Report the caller's scalar context correctly when inspecting frames in overloaded exceptions (#1859). - Avoid heap exhaustion when compiling very large generated subroutines, and preserve heredoc statement boundaries with `\&name` fallbacks (#1252). - Cover nested require caller packages and imported `CLASS` constants, and match defer ordering and caller frames around loop `continue` blocks (#1601, #1405, #1383). diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java b/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java index 6e62cae064..5d2f75f74a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java @@ -635,6 +635,16 @@ private static void doCallDestroy(RuntimeBase referent, String className) { RuntimeScalar.scopeExitCleanup(scalar); MortalList.flush(); } + // A blessed container may hold weakly observed objects whose + // selective counts remain inflated after its fields are released. + // Reconsider those descendants after DESTROY has returned, when + // its temporary $self lexical is no longer a Perl root. DBIx::Class + // keeps a weak Storage reference in the DBI error callback and + // expects it to be cleared as soon as the owning Schema is gone. + if ((referent instanceof RuntimeHash || referent instanceof RuntimeArray) + && MortalList.requestWeakSweepsForDestroyedContainer(referent)) { + requestSweepAfterOuterDestroy(); + } } catch (Exception e) { String msg = e.getMessage(); if (msg == null) msg = e.getClass().getName(); diff --git a/src/test/java/org/perlonjava/runtime/runtimetypes/DestroyDispatchNestedWeakSweepTest.java b/src/test/java/org/perlonjava/runtime/runtimetypes/DestroyDispatchNestedWeakSweepTest.java new file mode 100644 index 0000000000..de1bef40d9 --- /dev/null +++ b/src/test/java/org/perlonjava/runtime/runtimetypes/DestroyDispatchNestedWeakSweepTest.java @@ -0,0 +1,59 @@ +package org.perlonjava.runtime.runtimetypes; + +import org.junit.jupiter.api.Tag; +import org.junit.jupiter.api.Test; +import org.perlonjava.app.cli.CompilerOptions; +import org.perlonjava.app.scriptengine.PerlLanguageProvider; + +import static org.junit.jupiter.api.Assertions.assertEquals; + +@Tag("unit") +class DestroyDispatchNestedWeakSweepTest { + + @Test + void weakChildIsRecheckedAfterBlessedContainerDestroyReturns() throws Exception { + for (boolean interpreter : new boolean[]{false, true}) { + PerlRuntime runtime = new PerlRuntime(); + try (PerlRuntime.Binding ignored = runtime.bind()) { + execute(runtime, interpreter, "" + + "use Scalar::Util qw(weaken); " + + "package Issue1646::Storage; sub DESTROY { } " + + "package Issue1646::Schema; sub DESTROY { } " + + "package main; " + + "our $schema = bless { storage => bless({}, 'Issue1646::Storage') }, " + + " 'Issue1646::Schema'; " + + "our $weak_storage = $schema->{storage}; weaken($weak_storage); " + + "our $handle = { handler => sub { " + + " $weak_storage ? 'DBI Exception' : 'unhandled by DBIC' " + + "} }; "); + + RuntimeScalar schemaSlot = GlobalVariable.getGlobalVariable("main::schema"); + RuntimeHash schema = (RuntimeHash) schemaSlot.value; + RuntimeHash storage = (RuntimeHash) schema.elements.get("storage").value; + // Model selectively counted owners that remain after a large + // blessed owner graph is destroyed. The reachability walk must + // still clear the weak callback once the schema has gone. + storage.refCount = 132; + schemaSlot.refCountOwned = false; + schemaSlot.value = null; + schemaSlot.type = RuntimeScalarType.UNDEF; + schema.refCount = 0; + DestroyDispatch.callDestroy(schema); + + assertEquals("unhandled by DBIC", execute(runtime, interpreter, + "$handle->{handler}->()")); + } finally { + runtime.close(); + } + } + } + + private static String execute( + PerlRuntime runtime, boolean interpreter, String code) throws Exception { + CompilerOptions options = new CompilerOptions(); + options.fileName = ""; + options.useInterpreter = interpreter; + options.code = code; + return PerlLanguageProvider.executePerlCode(options, false).scalar().toString(); + } +}