From fe9d6bc5ffbb1d38c983e019f2aa372fad2e4125 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 15 Aug 2026 16:39:03 +0200 Subject: [PATCH] feat: complete Perl ithread lifecycle compatibility Finish the remaining Perl-compatible ithread ownership and lifecycle work on both execution backends. Preserve END and CLONE_SKIP behavior, weak backrefs, rescued DESTROY graphs, method-return lifetimes, and child CODE/result cleanup across runtime snapshots and joins. Complete shared aggregate proxy lifetime and lexical reassignment semantics, including alias-aware reference counts and B::REFCNT behavior. Keep nested weak cleanup precise enough to preserve rescued DBIx::Class schema graphs while releasing stale storage callback links. Replace the phased concurrency history with the current implementation and release contract. Historical decisions and completed work remain recoverable from this commit and the preceding pull requests; direct regex-language and Joni work remains in the separate Phase 36 project. Validation: - make: green across all unit shards - make check-links: 393 links OK, 0 errors - new system-Perl regressions: 8 files, 26 assertions, PASS - threads/threads-shared/Thread-Queue/Thread-Semaphore: 64 files and 1,891 assertions in each JVM/platform, JVM/virtual, interpreter/platform, and interpreter/virtual configuration - DBIx::Class: 325 files and 42,681 assertions, PASS with --jobs 8 - thread preservation matrix: no timeouts; thread-owned core, Storable, Test2, debug, and property-race gates pass; regex wrappers equal or exceed their same-build direct companions Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- dev/design/concurrency.md | 968 ++---------------- dev/tools/perl_test_runner.pl | 30 +- .../java/org/perlonjava/app/cli/Main.java | 9 +- .../backend/bytecode/BytecodeCompiler.java | 5 + .../backend/bytecode/BytecodeInterpreter.java | 1 + .../backend/bytecode/CompileAssignment.java | 9 +- .../bytecode/CompileBinaryOperator.java | 32 +- .../backend/bytecode/Disassemble.java | 6 + .../perlonjava/backend/bytecode/Opcodes.java | 6 +- .../backend/jvm/EmitBinaryOperator.java | 24 +- .../frontend/parser/SpecialBlockParser.java | 9 +- .../runtime/operators/Operator.java | 3 + .../runtime/operators/ReferenceOperators.java | 11 + .../runtime/operators/TieOperators.java | 4 +- .../perlonjava/runtime/operators/WarnDie.java | 38 +- .../runtime/perlmodule/Internals.java | 12 + .../runtime/perlmodule/ScalarUtil.java | 8 +- .../runtime/perlmodule/Threads.java | 160 ++- .../runtime/perlmodule/ThreadsShared.java | 37 +- .../runtime/runtimetypes/DestroyDispatch.java | 34 +- .../runtimetypes/ExecutionRuntimeState.java | 2 + .../runtimetypes/PerlDieException.java | 11 + .../runtime/runtimetypes/PerlRuntime.java | 50 +- .../runtimetypes/PerlThreadControlBlock.java | 169 ++- .../runtimetypes/PerlThreadRegistry.java | 25 +- .../runtimetypes/ReachabilityWalker.java | 33 + .../runtime/runtimetypes/RuntimeArray.java | 12 +- .../runtimetypes/RuntimeArrayProxyEntry.java | 1 + .../runtime/runtimetypes/RuntimeBase.java | 42 +- .../runtime/runtimetypes/RuntimeCode.java | 3 +- .../runtimetypes/RuntimeGraphCloner.java | 31 +- .../runtime/runtimetypes/RuntimeHash.java | 29 +- .../runtimetypes/RuntimeHashProxyEntry.java | 6 + .../runtime/runtimetypes/RuntimeScalar.java | 54 +- .../runtimetypes/SharedElementProxy.java | 17 +- .../runtimetypes/SharedPerlStorage.java | 107 +- .../runtime/runtimetypes/WeakRefRegistry.java | 13 + src/main/perl/lib/B.pm | 5 +- src/main/perl/lib/Thread/Queue.pm | 657 ++++++++++++ src/main/perl/lib/Thread/Semaphore.pm | 273 +++++ src/main/perl/lib/threads.pm | 13 +- src/main/perl/lib/threads/shared.pm | 55 +- ...SharedPerlStorageDestructiveShareTest.java | 68 ++ .../unit/threads_clone_skip_no_autoload.t | 31 + .../threads_destroy_method_return_rescue.t | 43 + .../unit/threads_destroy_weak_slot_rescue.t | 44 + .../unit/threads_end_block_ownership.t | 25 + .../threads_shared_child_capture_release.t | 36 + .../unit/threads_shared_destructive_share.t | 49 + .../threads_shared_fetch_proxy_lifetime.t | 41 + .../threads_shared_lexical_reassignment.t | 64 ++ .../unit/threads_shared_unadvertised.t | 4 +- .../unit/threads_weak_backref_snapshot.t | 35 + 53 files changed, 2418 insertions(+), 1036 deletions(-) create mode 100644 src/main/perl/lib/Thread/Queue.pm create mode 100644 src/main/perl/lib/Thread/Semaphore.pm create mode 100644 src/test/java/org/perlonjava/runtime/runtimetypes/SharedPerlStorageDestructiveShareTest.java create mode 100644 src/test/resources/unit/threads_clone_skip_no_autoload.t create mode 100644 src/test/resources/unit/threads_destroy_method_return_rescue.t create mode 100644 src/test/resources/unit/threads_destroy_weak_slot_rescue.t create mode 100644 src/test/resources/unit/threads_end_block_ownership.t create mode 100644 src/test/resources/unit/threads_shared_child_capture_release.t create mode 100644 src/test/resources/unit/threads_shared_destructive_share.t create mode 100644 src/test/resources/unit/threads_shared_fetch_proxy_lifetime.t create mode 100644 src/test/resources/unit/threads_shared_lexical_reassignment.t create mode 100644 src/test/resources/unit/threads_weak_backref_snapshot.t diff --git a/dev/design/concurrency.md b/dev/design/concurrency.md index 8ef9e4f33..2749e1b98 100644 --- a/dev/design/concurrency.md +++ b/dev/design/concurrency.md @@ -1,10 +1,8 @@ # Perl Threads Implementation Plan **Status:** Active implementation plan -**Version:** 2.1 -**Date:** 2026-08-12 -**Supersedes:** the previous `concurrency.md` proposal and -`dev/prompts/multiplicity-v2-plan.md` +**Version:** 2.2 +**Date:** 2026-08-15 ## 1. Goal and Non-Negotiable Delivery Rule @@ -12,26 +10,14 @@ Implement Perl 5 interpreter threads (ithreads) on the JVM. Each Perl thread owns an isolated, cloned interpreter. Perl values are copied at thread creation unless their storage was explicitly marked shared. -Each numbered phase below normally forms an independent pull request. A phase -may be split further when its audit shows that it cannot be reviewed or reverted -safely. Phases 3 and 4 were combined at the maintainer's request, as were -Phases 5 through 7 and Phases 8a through 8c; each combined changeset preserves -the same green-boundary requirements. Phases 8d, 8e, and 9 form one further -maintainer-requested combined PR, as do Phases 10 through 12. At every merge +Thread compatibility is delivered in reviewable pull requests. At every merge boundary: - the compiler and both execution backends remain functional; - `make` passes; - the previously supported Perl surface remains supported; -- `Config` continues to report `useithreads` as false until the activation - phase; -- no partially exposed `threads` API is advertised; -- the phase can be reverted without reverting a later phase. - -The earlier multiplicity implementation in PR #480 violated this rule: it moved -roughly 10,000 lines across 96 files and was reverted by PR #487 after an -unbound regex-timeout worker broke version parsing. Its branches are useful as -file-level references, not as commits to cherry-pick. +- advertised thread APIs match their validated compatibility level; +- the change can be reverted without reverting unrelated work. ## 2. Compatibility Target @@ -51,10 +37,10 @@ runtime: parallel once runtime isolation is complete. This plan does not implement POSIX `fork()`. Process creation remains the -supported replacement for fork-and-exec patterns. Virtual threads are a later, -optional optimization: Java 24 removes monitor pinning, but native/FFM blocking -and workload diagnostics still require validation, while cloning an ithread -interpreter already dominates thread creation cost. +supported replacement for fork-and-exec patterns. Java 24 virtual threads are +the default carrier; platform threads remain available explicitly and are +selected automatically for nonzero stack-size requests. Runtime cloning, not +carrier creation, remains the dominant cost of starting an ithread. ## 3. Architecture @@ -130,9 +116,6 @@ one PR. Known worker paths include regex timeouts, alarms, pipe input/output, Shutdown hooks may remain process-global only when they do not call runtime facades requiring a current binding. -The original failure proves this rule: moving regex state to `PerlRuntime` -without binding the timeout executor made `Scalar::Util` version parsing fail. - ### 3.5 Value graph cloning Thread cloning uses a dedicated `RuntimeGraphCloner` with an identity map. It @@ -172,13 +155,13 @@ must match Perl tests. All output is captured to files. Every `jperl`, `jcpan`, and `prove` invocation is wrapped in `timeout`. -Required for every phase: +Required for every implementation pull request: ```bash make > /tmp/perl-threads-make.log 2>&1 ``` -Also run `make test-all` when that target is healthy at the start of the phase. +Also run `make test-all` when that target is healthy at the start of the work. If it has baseline failures, record them and run the affected suites plus the full `make` gate; never conceal a new failure as baseline noise. @@ -199,888 +182,101 @@ timeout 60 ./jperl --interpreter -e 'use Scalar::Util; print $Scalar::Util::VERS Expected version is the version bundled by the branch (`1.70` when this plan was finalized). Moo/module-loading smoke tests accompany it. -Performance-sensitive phases record the global, lexical, method, closure, +Performance-sensitive changes record the global, lexical, method, closure, regex, and eval benchmarks against the same-base master build. A hot-path -regression over 5% blocks that phase unless the design document records a +regression over 5% blocks the change unless the design document records a reviewed exception. Before ending an investigation, inspect exact Java command lines and terminate only workers proven to belong to an abandoned test. Never kill from a CPU list alone. -## 5. Pull Request Train - -### Phase 1 — Import health and compiler identity safety - -Make Perl 5 imports reproducible, repair any stale/malformed patches found by a -full sync, convert generated class/call-site identifiers to atomic allocation, -make immutable compiler constants final, and instantiate mutable control-flow -visitors per invocation. - -Acceptance: - -- affected filtered syncs are idempotent; -- the full import manifest completes without a failed patch; -- concurrent class-name generation produces no duplicates; -- `make` passes; -- no claim of concurrent compilation is made yet. - -### Phase 2 — Serialized compilation - -Add one documented `ReentrantLock` around every initial and runtime compilation -path, including lazy named-sub materialization and verifier fallback. Preserve -reentrant nested compilation and release each entry point's own hold before -ordinary code execution. `executePerlAST` remains locked because it runs -compile-time `BEGIN` wrappers inside an enclosing parse. - -Acceptance: concurrent JVM/bytecode compilations, nested `BEGIN`/`require`, and -both `eval STRING` paths are deterministic and deadlock-free. - -### Phase 3 — `PerlRuntime` shell and scoped binding - -Introduce the runtime object and scoped binding API without moving state. Bind -all CLI, test, JSR-223, `require`, and eval entry points. - -Acceptance: absent binding fails clearly; nested/exceptional bindings restore -the prior runtime; two Java threads bind different empty runtimes without -leakage. - -### Phase 4 — I/O state isolation - -Move standard/selected handles and current I/O bookkeeping into `PerlRuntime`. -Preserve static facades and generated bytecode compatibility. - -Acceptance: two runtimes can redirect stdin/stdout/stderr independently and all -existing IO tests pass. - -### Phase 5 — Execution stacks and special blocks - -Move caller stacks, interpreter/eval frames, dynamic scope, every `local` -save/restore stack, lexical cleanup registrations, and the runtime-owned -`CHECK`/`INIT`/`END` collections. `BEGIN` remains immediate under the compile -lock and `UNITCHECK` remains attached to its compilation context. The coupled -mortal/weak/`DESTROY` sweep machinery moves atomically in Phase 11. - -Acceptance: execution/save-stack ownership, caller, defer, callback binding, -and special-block tests show no cross-runtime state. Package-global values -themselves remain shared until Phase 8 and are not claimed isolated here. - -### Phase 6 — Regex state and timeout binding - -Move all numbered/named captures, whole/prior/post-match values, last-capture -state, match offsets, and `/g` state, and bind the regex-timeout worker in the -same PR. - -Acceptance: simultaneous matches, `/g` positions, `/o`, and match-once state -are isolated; alarm-mediated matching retains the captured runtime; and -Scalar::Util/Moo regression gates pass. Concurrent independent alarms remain a -Phase 11 signal/alarm-state concern. - -### Phase 7 — Inheritance and method caches - -Move MRO policy, method/overload/ISA caches, generations, reverse-ISA data, and -invalidation state. Until Phase 8 migrates symbol tables, a shared mutation -epoch lazily invalidates derived caches in every runtime. - -Acceptance: cache and policy state are runtime-owned, shared symbol mutations -cannot leave another runtime's cache stale, and method/closure benchmarks stay -within budget. Conflicting package and method definitions become possible only -after the Phase 8 symbol-table migrations. - -### Phase 8a — Core global values - -Move global scalar, array, and hash storage, foreach alias bookkeeping, stash -enumeration invalidation, and per-runtime core-global initialization. Keep -`CompilerOptions` detached until its provider binds the owning runtime and -installs that exact argument array as `@ARGV`. - -### Phase 8b — Code and subroutine globals - -Move code references, pseudo constants, pinned/deleted pins, compiled-reference -IDs, localization bookkeeping, prototypes, imported-sub state, and operator -override flags. Preserve a declared-but-undefined CODE slot after `undef &name`. - -### Phase 8c — IO and format globals - -Move named global IO slots, hidden-after-stash-delete state, and formats, -reconciling them with Phase 4's runtime-owned standard handles/globs. Glob and -stash alias tables remain Phase 8d state. - -### Phase 8d — Globs, aliases, and stashes - -Move glob tables, stash/package objects, and alias maps. - -### Phase 8e — Declarations and package services - -Move declared-global sets, package-existence caches, class-loader ownership, and -remaining symbol-table runtime state. - -Each remaining Phase 8 subphase normally forms its own PR; 8a through 8c and -the 8d-through-9 group are maintainer-requested combined exceptions. Acceptance -for each: conflicting in-scope global state in two runtimes remains isolated on -JVM and interpreter backends; global, lexical, and eval benchmarks meet the -budget. No phase claims alias/stash isolation before 8d or declaration/package- -service isolation before 8e. - -### Phase 9 — RuntimeCode and eval caches - -Move eval IDs/cache/context/depth, anonymous/interpreted sub registries, method -handles, and inline caches. Update emitted access only where facade preservation -is impossible. - -Acceptance: eval, parser, goto-sub, closure, and fallback suites pass on both -backends with independent runtime caches. - -### Phase 10 — Hints, warnings, filters, and source mapping - -Classify compile-time versus runtime portions of warnings/hints and move runtime -stacks, filter state, and bytecode source maps. Keep compile-only registries -inside Phase 2's lock until independently made safe. - -Acceptance: lexical warnings/features and error locations remain correct during -alternating and concurrent runtime use. - -### Phase 11 — Lifecycle and miscellaneous runtime state - -Migrate the remaining lifecycle, weak/destroy, signal/alarm, CWD/PID, stat, -random, state-variable, data-section, debugger, tied-proxy, flip-flop, and IO -registry inventory. Split this phase into independently green PRs if the audit -finds unrelated ownership domains; document the split here before coding. - -Worker binding for alarms, pipes, system stream routers, and callbacks lands -with the state each worker accesses. - -The implementation groups this inventory into explicit runtime-owned domains: -lifecycle/reachability, signals/alarms, process and IO registries, filesystem -environment/stat state, debugger state, parser data sections, random/state -variables, native/module registries, and object-name/bless identity. Opaque -Net::SSLeay handles and provider registries are interpreter-owned; cryptographic -algorithms and native bindings remain immutable process services. - -Acceptance: the mutable-static/thread-spawn audit has no unclassified -runtime-dependent state. - -### Phase 12 — Multiplicity completion - -Expose a lifecycle-managed API for independent runtimes, including initialize, -bind, execute, and close. Prohibit concurrent ownership of one runtime. - -Acceptance: concurrent Java integration tests execute conflicting Perl programs -in isolated runtimes. `useithreads` remains false. - -### Phase 13 — Multiplicity performance recovery - -Apply only measured optimizations: cache `PerlRuntime.current()` in hot methods, -batch stack transitions, and remove redundant state work. Reference -`origin/feature/multiplicity-opt` selectively. - -Acceptance: all benchmark gates are within 5% or have a reviewed exception. +## 5. Current Release Contract + +The supported implementation includes: + +- the Perl `threads` 2.43 lifecycle, context, stack, object, join/detach, error, + exit, version, signal, and terminal-alias surface; +- exact scalar and aggregate `threads::shared` behavior, including destructive + aggregate `share`, preserving scalar `share`, recursive `shared_clone`, + attributes, dualvars, UTF-8, aliases, cycles, blessing, ties, weak views, + refcount diagnostics, locking, conditions, and deterministic destruction; +- the standard `Thread::Queue` and `Thread::Semaphore` distributions, including + blocking, timed, nonblocking, force, limit, insert/extract, and error paths; +- isolated JVM and interpreter runtimes on both platform and virtual Java + carriers, with deterministic ownership of CODE, result, resource, shared + storage, END blocks, and Test2 IPC lifecycle. + +Every file in the unchanged upstream `threads`, `threads-shared`, +`Thread-Queue`, and `Thread-Semaphore` distributions is a mandatory release +gate. The same matrix runs on JVM/interpreter and platform/virtual carriers. +`make`, documentation links, the thread preservation matrix, and +`timeout 3600 ./jcpan --jobs 8 -t DBIx::Class` must pass before a pull request +is opened. Merge additionally requires green Ubuntu and Windows CI. + +Direct regex-language parity, including Joni integration, is maintained +separately. +Threaded regex wrappers remain preservation gates against their same-commit +direct companions. + +## 6. Supporting Design Contracts + +- `dev/design/attributes.md` defines the supported `shared` attribute surface. +- `dev/design/runtime-pooling-reset-contract.md` defines the proof required + before runtime pooling can be enabled. +- `dev/design/phase36-regex-parity.md` owns direct regex-language and Joni work. -### Phase 14 — Identity-preserving value graph cloner - -Implement the explicit graph-cloning core for non-code Perl values, including -cycles, aliasing, blessings, weak references, readonly values, and documented -tie/resource policies. - -Acceptance: system-Perl-validated graph fixtures match, and the original graph -is never mutated. - -### Phase 15 — Closure and code cloning - -Clone JVM and interpreter code using explicit capture metadata; support scalar, -array, hash, state, recursive, and nested captures. Do not reflect over Java -field order. - -Acceptance: closure graphs behave identically on both backends after cloning. - -### Phase 16 — Runtime snapshot, `CLONE_SKIP`, and `CLONE` - -Compose runtime-state and graph cloning. Clone entry code and arguments as one -graph, create fresh execution stacks, apply type-specific resource policies, -preflight `CLONE_SKIP`, and invoke `CLONE` in the child. - -Acceptance: child mutation cannot affect the parent; alias/cycle identity is -correct; package hooks run in Perl-compatible order. - -### Phase 17 — Internal thread control block - -Implement unique IDs, ownership, state transitions, completion, errors, -join/detach, registry cleanup, and parent/child relationships at Java level. -Use platform threads. Do not change the public Perl stub or `Config` yet. - -Acceptance: Java-level race, double-join/detach, cleanup, and nested-control -tests pass without leaked threads. - -### Phase 18 — Basic Perl `threads` API - -Replace the stub with `create`/`new`/`async`, `self`, `tid`, `list`, state -queries, `join`, `detach`, `yield`, and equality. Clone arguments into the child -and results/errors into the joiner with context-correct return behavior. - -Acceptance: a selected basic compatibility tranche passes on both backends, -while `Config useithreads` remains false for unrelated core suites. - -### Phase 19 — Thread termination and lifecycle - -Implement thread-local `threads->exit`, child `END` blocks, uncaught-error -reporting, `error()`, nested threads, detached cleanup, and main-program shutdown -rules. Do not use unsafe Java thread stopping. - -Acceptance: exit/error/lifecycle tests match system Perl for the supported API; -limitations of `kill` are explicit. - -### Phase 20 — Shared storage and `threads::shared` - -Make `:shared` real and implement `share`, `is_shared`, and `shared_clone` for -supported scalar/array/hash graphs. Define blessed/tied restrictions before -exposure. - -Acceptance: shared identity survives clone while ordinary identity does not; -concurrent mutations do not corrupt storage. - -### Phase 21 — Locks and condition variables - -Implement `lock`, `cond_wait`, `cond_timedwait`, `cond_signal`, and -`cond_broadcast` with `ReentrantLock` and `Condition`. - -Acceptance: lexical and recursive locking, atomic wait/reacquire, timeout, -signal/broadcast, lost-wakeup, and stress tests pass. - -### Phase 22 — Compatibility activation - -Set `Config` thread flags, implement/document import options and stringification, -run the applicable Perl core `threads*` suites and representative CPAN suites, -and update documents that currently call `:shared` a no-op or advertise a -single-threaded PSGI environment. - -Acceptance: the supported compatibility matrix is green and the compiler is -fully functional with ithreads advertised. - -### Phase 23 — Optional virtual threads - -After correctness and diagnostics are stable, benchmark an opt-in virtual-thread -executor. Virtual threads are not required for Perl compatibility and remain an -experimental process-wide choice until the complete platform-thread compatibility -matrix also passes in virtual mode. - -Acceptance: no semantic change or native/FFM surprise in supported workloads. -Promotion beyond experimental additionally requires a measured benefit over -platform threads; runtime-clone cost must not be mistaken for scheduler cost. - -### Phase 24 — Final core syntax compatibility (completed 2026-08-12) - -Finish the remaining `op/threads.t` postfix create/join expression without a -thread-specific parser shortcut that changes ordinary anonymous-sub precedence. - -Implemented by keeping an unknown print-filehandle candidate as an expression -when it is followed by a known indirect-object package. This fixes the general -`print method Package LIST` ambiguity rather than recognizing `threads` or the -specific postfix chain. A system-Perl-validated regression test covers the -generic form. - -Acceptance: `op/threads.t` reaches 30/30 on JVM and interpreter backends while -`class/threads.t` remains 4/4 and `threads-dirh.t` continues to exit cleanly. - -### Phase 25 — Snapshot graph integrity under large suites (implemented 2026-08-12) - -Remove null-payload and CODE-root cloning failures exposed by the large regex -thread wrappers. Preserve graph identity, weak edges, and source immutability; -do not repair these failures by sharing ordinary child values with the parent. - -Implemented null-safe cleared weak-reference handling, type-preserving cloning -for magic regex capture scalars, CODE-root cloning, constant-result graph cloning, -and identity-map reuse when a lazy named CV materializes after snapshot. - -Acceptance: `pat_psycho_thr.t`, `pat_rt_report_thr.t`, `pat_thr.t`, -`regexp_unicode_prop_thr.t`, and `speed_thr.t` reach their direct, unthreaded -suite baselines without clone exceptions on either backend. - -### Phase 26 — Scalar lvalue and magic parity (completed 2026-08-13) - -Fix the ordinary `index`/`substr` lvalue, warning, overload, reference- -stringification, and lexical-magic behavior exposed by their thread wrappers. -Treat failures present in the direct suite as language/operator gaps rather than -thread-cloning failures. - -Implemented shared JVM/interpreter lvalue context, negative offset/length -clipping, warning/die behavior, live substring extent modes, one-time overload -stringification, loose refalias lvalue handling, graph-safe constant and lazy-CV -capture identity, and an interpreter `$#array` lvalue opcode. Lazy named -subroutines now preserve both their declaration attributes and lvalue compile -context. - -Acceptance is complete: direct and threaded forms reach `index_thr.t` 415/415 -and `substr_thr.t` 400/400 on JVM and interpreter backends. - -### Phase 27 — Regex runtime concurrency (runtime portion completed 2026-08-13) - -Runtime-local user-defined Unicode-property results are inherited at snapshot, -and simultaneous sibling resolution is coordinated per property name without -serializing unrelated names or executing Perl callbacks under the compile lock. - -Lexical `re 'debug'` remains a direct regex feature blocker: the pragma is -currently ignored and the existing implementation trace is a process-wide -environment flag written to `System.err`. Correct support requires lexical -parser/CV metadata, both backends, and a runtime diagnostic sink before thread -trace equivalence can be claimed. - -The runtime-concurrency acceptance gate is complete: repeated bounded runs of -`user_prop_race_thr.t` reach 3/3. Static CV validation deliberately defers -user-defined properties because resolving them executes arbitrary Perl in the -owning runtime. Lexical-debug acceptance remains open: `stclass_threads.t` -cannot reach 6/6 until the direct `re 'debug'` feature exists. - -### Phase 28 — General regex parity exposed by thread wrappers (in progress) - -The recursive regex backend now supports `(?(DEFINE)...)`, named subroutine -calls in that container, and extended bracket classes within definitions. -Literal `qr//` syntax is now validated when a thread entry CV is materialized, -so malformed entry code fails in the parent and does not create a child. -User-defined Unicode properties remain runtime-resolved. - -The direct/thread `regexp_qr_embed` differential has narrowed from 45 -assertions to one while both paths execute the same 2207 of 2210 planned -assertions. The remaining one-assertion delta and three blocked direct tests are -still Phase 28 language work; this phase is not marked complete. - -Implement the remaining parser/runtime features in `pat_re_eval`, -`regexp_qr_embed`, Unicode-property, conditional, control-verb, and lookbehind -coverage. These are shared regex-language gaps, not permission to special-case -the `_thr.t` harness. - -Acceptance: every applicable regex `_thr.t` wrapper has zero assertion delta -from its direct companion suite and neither path terminates early. +## 7. Progress Tracking -### Phase 29 — Complete and truthful `threads` API (completed tranche 2026-08-13) +### Current Status: release validation in progress; Joni/regex parity is separate -Implemented current-thread/class-form `detach`, targeted thread signals, -`object`, persisted creation context and `wantarray`, exit/context options, -main-thread state, terminal alias records, and truthful platform/virtual -stack-size behavior. CLI shutdown now reports exact running/finished unjoined -counts, while detached children remain silent and do not retain the process. - -Complete remaining compatibility details for -`wantarray`, exit/context options, exit status, and the stack-size API where the -JVM can honor it. Unsupported platform guarantees must fail clearly; capability -methods must never advertise a silent no-op such as the current `kill` stub. - -Acceptance: system-Perl-validated API tests cover object and class forms, -success/error/exit lifecycle, watchdog cancellation, import options, and -capability reporting on both backends. - -### Phase 30 — Resource inheritance and Test2 stress (implemented tranche 2026-08-12) - -Internal pipe endpoints now have explicit inherited copies with shared endpoint -leases, independent wrapper close, child handle registration, and deterministic -last-owner cleanup. Other files, sockets, and native handles retain the -conservative undef/rejection policy. - -Continue to define descriptor and filehandle behavior for thread snapshots. -Preserve the already-green default Test2 thread/IPC suites, then enable the -applicable timeout and opt-in thread stress paths without changing Test2. - -The current compatibility gate also proves that CPAN configuration can safely -scalarize list-valued regex operands. Test::Simple's bundled-module install -path completes, and the full DBIx::Class suite passes with 325 files and 42,671 -tests under `--jobs 8`. - -Acceptance: `ipc_wait_timeout.t` observes Perl-compatible inherited-pipe -behavior; default Test2 remains green; `AUTHOR_TESTING` and -`T2_DO_THREAD_TESTS` thread suites form a separately reported stress gate. - -### Phase 31 — Native callbacks and handle ownership (implemented 2026-08-13) - -Net::SSLeay verification, info, and password callbacks are bound to the runtime -that registered them, including invocation from foreign native callback -threads. SSL session handles are runtime-owned and reset with their runtime. -Detached children no longer appear in `threads->list`, and abnormal detached -termination is reported exactly once. Other native handle classes retain their -documented clone, child-owned creation, or explicit rejection policy. - -Acceptance: Net::SSLeay `61_threads-cb-crash.t` and -`62_threads-ctx_new-deadlock.t` pass without watchdog, deadlock, cross-runtime -handle leakage, or callback misbinding; applicable thread-emulated server paths -in the wider Net::SSLeay suite retain their non-thread baseline. - -### Phase 32 — Advanced shared values (implemented supported tranche 2026-08-13) - -Nested plain scalar/array/hash graphs now have atomic preflight before any node -is published as shared. A rejected nested node therefore cannot leave a -partially shared graph behind. Identity, mutation, recursive locking, and -condition behavior are stress-tested across child threads. Blessed, tied, and -other magical graphs remain explicit errors because their callback and -destruction semantics are not yet a supported shared-value category. - -Acceptance: each newly supported value category has standard-Perl-validated -identity, mutation, lock/condition, clone, destruction, and stress coverage. - -### Phase 33 — Compatibility completion, documentation, and examples (implemented 2026-08-13) - -Run the complete applicable core, Test2, Storable, and native thread matrix; -update the feature matrix from raw results; and add a realistic dynamic -map/reduce example that shares only its scheduler while returning worker-local -aggregates through `join`. - -Acceptance: platform threads pass all supported tests on JVM and interpreter -backends; every remaining skip is an explicit platform or unsupported-feature -decision; virtual mode has no semantic delta; example output is deterministic -across system Perl and all supported modes. The release gate also includes the -complete `timeout 3600 ./jcpan --jobs 8 -t DBIx::Class` distribution suite; every DBIx -test must pass before this phase is complete. - -### Phase 34 — Optional runtime pooling (evaluated; deliberately disabled) - -Consider reusable runtimes only after the fresh-runtime equivalence contract is -implemented in full. Pooling is neither a Perl threads requirement nor a reason -to weaken close/snapshot isolation. - -Acceptance: every item in `runtime-pooling-reset-contract.md` passes and reuse -has a measured benefit over a fresh snapshot. - -The 2026-08-13 evaluation did not meet that activation threshold. The executable -negative contract proves that `close()` is terminal and retains observable -package, regex, and execution state. Pooling therefore remains disabled; fresh -snapshot runtimes remain the correctness boundary. - -Phase 33's release gate completed with `./jcpan --jobs 8 -t DBIx::Class`: -325 files and 42,671 assertions passed. The final compatibility fix ensures -non-local labeled control flow tears down every abandoned Perl frame before the -target resumes, preserving scope-guard diagnostics and redirected STDERR. - -### Phase 35 — Lexical regex debugging (completed 2026-08-14) - -Implement scoped `use/no re 'debug'` and `debugcolor` as compiler hints carried -by regex and CODE metadata on both backends. Diagnostics use the bound runtime's -STDERR and survive snapshot cloning; they never reuse the process-wide internal -trace flag. Acceptance: `re/stclass_threads.t` reaches 6/6 and direct/child -traces have identical behavior and runtime ownership. - -The compiler hints, JVM/interpreter propagation, runtime-owned STDERR routing, -snapshot behavior, and focused six-assertion oracle are implemented. Debug -regex lifecycle records now drain after END in the owning main or child -runtime. The core `stclass_threads.t` gate reaches 6/6 with equal direct/child -record counts and linear scaling. - -### Phase 36 — Complete regex parity exercised by thread wrappers (in progress) - -Phase 36 is now an independent parallel project documented in -`dev/design/phase36-regex-parity.md`. It owns executable callbacks, dynamic -patterns, conditionals, control verbs, lookbehind, Unicode properties, regex -objects, and diagnostics in the shared direct-language implementation. Thread -wrappers remain unchanged acceptance tests and receive no special cases. - -The concurrency project consumes Phase 36 through focused integration slices -and preserves Phase 44's green thread matrix. Current completed foundations and -the callback-capable matcher architecture, staged implementation plan, direct -and wrapper gates, risks, and resumable next steps are maintained in the -separate Phase 36 document. - -### Phase 37 — General filehandle and resource inheritance (implemented tranche 2026-08-14) - -Give every `IOHandle` implementation an explicit thread-inheritance policy. -Files, sockets, process pipes, and native descriptors use per-runtime wrappers -over leased transport cores so aliases share position and transport while close -is wrapper-local until the final owner. Layer, tied, scalar-backed, standard, -borrowed, directory, and packaged-resource handles preserve their appropriate -state instead of silently becoming `undef`. Acceptance covers position, -buffering, aliases, close order, local sockets, child processes, redirects, and -cleanup on Linux and Windows against system Perl. - -Every current handle class now declares an explicit policy. Supported captured -handles use runtime-local wrappers over leased shared transports, while unsafe -native resources reject inheritance explicitly. Focused system-Perl, JVM, and -interpreter tests cover inherited file position, scalar handles, close order, -and parent survival. Wider socket, process, redirect, and Windows coverage -remains part of the final release matrix. - -### Phase 38 — DBI thread ownership (implemented 2026-08-14) - -Match native DBI's thread-owned handle contract. JDBC database, statement, and -result handles become magical runtime-owned resources: inherited handles are -unusable in the child, child teardown cannot disconnect the parent, child-created -handles belong only to the child, and join-returned handles are invalid in the -parent. DBI errors, cached handles, transactions, and destruction state remain -runtime-local. Acceptance includes system-Perl DBI/SQLite oracles, -`./jcpan --jobs 8 -t DBI`, and the complete DBIx::Class suite. - -JDBC connections, statements, and result sets now use runtime-owned adapters. -Inherited and join-returned handles fail without disconnecting their owner; -child-created handles remain child-owned. The focused DBI/SQLite ownership -oracle passes ten assertions on system Perl and both PerlOnJava backends. The -release gate also passes all 325 DBIx::Class files and 42,671 assertions with -`./jcpan --jobs 8 -t DBIx::Class`. A JVM-to-interpreter fallback now restores -only missing internal lexical-handoff cells before retrying a partially entered -module body, preserving named closures without changing successful destructive -handoff semantics. - -### Phase 39 — Advanced `threads::shared` values (implemented root tranche 2026-08-14) - -Support blessed aggregate roots through runtime-local class views over common -backing. A tied scalar keeps a cloned runtime-local callback object and shared -synchronization identity; sharing an already tied array/hash discards user -magic and installs empty native shared storage, while tying a shared aggregate -returns it to runtime-local magic. Preserve recursive locks and conditions -across every runtime-local view. - -Acceptance for this tranche covers root reblessing, shared mutations, scalar -tie callback isolation, aggregate tie conversion/order, and both backends. - -### Phase 39b — Exact nested shared proxies and destruction - -Implement Perl's fetch-time proxy semantics for references stored inside shared -aggregates: each fetch produces a runtime-local wrapper over canonical backing; -reblessing stays local until the reference is stored back. Make weak edges and -cycles use that canonical backing, and deliver `DESTROY` exactly once in the -runtime that releases the final cross-runtime owner. Separate destructive plain -`share` initialization from preserving recursive `shared_clone`. Acceptance -includes nested rebless/store-back, fresh `refaddr` views, cycles, weak refs, -one global destructor, and share-versus-shared_clone system-Perl oracles. - -Fetch-time aggregate proxies are implemented: every nested array/hash reference -read from shared storage receives a fresh runtime-local wrapper over canonical -synchronized backing. Local reblessing is private until the view is stored -back, cycles retain common storage without retaining wrapper identity, and a -weak fetched view can disappear without deleting the canonical value. The -focused ten-assertion oracle passes on system Perl and both PerlOnJava backends. -Cross-runtime final-owner destruction is now implemented. Canonical shared -storage and its fetched runtime-local wrappers carry one atomic lifecycle: -canonical deletion waits for live fetched views, releasing a non-final view -does not run `DESTROY`, and the runtime releasing the final owner performs the -callback exactly once. The ordering is race-safe when canonical deletion and -the last view release happen concurrently. A system-Perl-valid five-assertion -oracle passes on JVM and interpreter backends in addition to the existing -ten-assertion nested-proxy matrix. - -Destructive plain `share` remains the one explicit compatibility transition. -The existing immutable test records the older Java-specific preserving -behavior, while system Perl clears scalar/array/hash contents and reserves -preserving recursive publication for `shared_clone`. The implementation must -not silently invert that assertion; the test contract needs an explicit user -decision before production behavior changes. - -### Phase 40 — Complete public `threads` API (completed 2026-08-14) - -Close every remaining lifecycle, signal, context, exit-status, stack-size, -import, stringify, alias-object, and shutdown-warning gap. Upgrade the module -version only when its upstream surface passes. A nonzero stack request always -selects a platform child even after virtual threads become the default. - -The public 2.43 method surface is implemented and advertised. Creation context, -alias objects, current/class detach, signals, exit policy, stack metadata, -stringification, terminal errors, daemon-carrier shutdown, and attached-child -exit warnings are covered by focused JVM/interpreter tests. Core -`op/threads.t` completes 30/30. - -### Phase 41 — Fresh-runtime reset (completed 2026-08-14) - -Add reset as a lifecycle distinct from terminal `close()`. Reset is allowed only -after execution, compilation, callbacks, children, locks, waiters, handles, and -destruction work quiesce. Rebuild every domain in -`runtime-pooling-reset-contract.md` from an immutable bootstrap template and -poison a runtime after any partial reset failure. Acceptance is exhaustive -`A; reset; B == fresh; B` parity plus classloader/package-graph collection. - -`PerlRuntime.reset()` is now a distinct exclusive lifecycle transition. It -rejects active bindings, compilation, children, shared locks, and waiters; -drains END/destruction and owned resources; replaces every runtime state holder; -rebuilds standard handles and core globals; clears terminal thread-family state; -and poisons the runtime after any partial failure. JVM/interpreter differentials -prove representative package, CODE, `%INC`, regex, execution, and I/O freshness. -Pooling remains off pending Phase 42's checkout stress, collection, and measured -benefit gates. - -The post-reset regression gate retains all 325 DBIx::Class files and 42,671 -assertions under `./jcpan --jobs 8 -t DBIx::Class`. - -### Phase 42 — Opt-in pooling and concurrent PSGI (completed 2026-08-15) - -Add a bounded runtime-family pool configured by -`-Djperl.runtime.pool.size=N` or `JPERL_RUNTIME_POOL_SIZE` (default zero). -Return runtimes only after result cloning, END/destruction, callbacks, and -detached children complete. Concurrent Netty PSGI requests use checked-out -snapshot runtimes and streaming responses retain their runtime until completion; -`psgi.multithread` is true only in that mode. Pooling must improve create/join -or request median time by at least 10% without a hot-path regression above 5%. - -The bounded pool defaults to zero, enforces exclusive leases, resets reusable -core runtimes, replaces poisoned entries, and never resets an active lease. -Netty prebuilds independent application snapshots, checks one out per request, -retains it through streaming dispatch, and advertises `psgi.multithread` only -in pooled mode. Three controlled eight-request runs measured about 74% lower -median completion time with four pooled runtimes; a retention probe collected -the returned tenant graph and replaced state holder. - -### Phase 43 — Virtual threads by default (completed 2026-08-15) - -Make Java virtual threads the default while retaining -`JPERL_THREAD_MODE=platform`. Explicit nonzero stack sizing transparently uses -a platform child. Validate FFM/JDBC, sockets, process I/O, regex timeouts, -shared conditions, callbacks, pooling, and detached shutdown under both modes. - -The Java 24 launcher now defaults to virtual carriers and preserves explicit -platform selection. A nonzero stack request selects a platform child rather -than discarding the option. The mandatory unit build is green, and the focused -core lifecycle, class, and lexical-regex matrix passes 40/40 in both default -virtual and explicit platform modes. - -### Phase 44 — Release closure (completed 2026-08-15) - -Run the complete core and bundled thread matrix, DBI/DBIx, Test2 opt-in stress, -Storable, and native callback gates. Add a DBI example where each child owns its -connection and returns ordinary data through `join`; update every public claim -only from captured results. Acceptance requires `make`, link checks, all thread -gates, `timeout 3600 ./jcpan --jobs 8 -t DBIx::Class`, and green Ubuntu/Windows -CI. - -Release evidence collected on 2026-08-15: the 17-file core thread-wrapper -matrix completed without timeout; the supported anchors include `threads.t` -30/30, `index_thr.t` 415/415, `substr_thr.t` 400/400, lexical regex debugging -6/6, the user-property race 3/3, and `pat_psycho_thr.t` 17/17. Remaining partial -regex totals match the shared direct-language gaps recorded in Phase 36 rather -than thread-only failures. - -The default Test2 matrix passes 13 files and 38/38 assertions. All ten opt-in -Test2 stress files now pass 562/562 assertions after preserving cloned closure -capture ownership, rooting the active child CODE during lifecycle sweeps, and -recovering the active method package for nested `SUPER` dispatch. Storable -passes 2/2, and the two Net::SSLeay callback/context stress gates pass 1/1 -each. New system-Perl-valid lifetime, nested-method, and weak-assignment -oracles pass 8/8 on both JVM and interpreter backends. The child-owned DBI -connection example passes with identical output on system Perl, JVM, and -interpreter. - -The mandatory unit build and documentation link validation are green. The -required `timeout 3600 ./jcpan --jobs 8 -t DBIx::Class` gate passes all 325 -files and 42,671 assertions in 1,371 seconds. The broad bundled-module task -remains red at 239/391 files; its 152 failures span unrelated unported -Text::CSV/YAML and other module behavior, while the thread-specific bundled -Storable and Net::SSLeay gates above are green. It is recorded as a wider -project baseline, not presented as threads release success. Ubuntu and Windows -CI remain the final external PR acceptance check. - -## 6. Known Reference Material and Warnings - -- `dev/prompts/multiplicity-v2-plan.md` documents the incremental response to - PR #480, but its phase ordering and inventory are now stale. -- `origin/feature/multiplicity` and `origin/feature/multiplicity-opt` contain - useful target-state examples. -- Do not trust `origin/feature/multiplicity-v2` as a branch-tip reference: - `d87fe1885` adds regex worker binding and later `f98ce32be` removes it. -- `dev/design/clone.md` does not meet the identity/cycle/closure requirements - above and must not be reused as the ithread cloning algorithm. -- `dev/design/attributes.md` records the supported `shared` attribute tranche. +`PerlRuntime` owns interpreter state, ithreads clone one isolated runtime graph, +and `threads::shared` supplies explicit cross-runtime storage and synchronization. +The unchanged upstream `threads`, `threads-shared`, `Thread-Queue`, and +`Thread-Semaphore` distributions are the executable compatibility contract on +both execution backends and both Java carrier policies. -## 7. Progress Tracking +Direct regex-language parity, including Joni integration, is maintained in the +separate regex project. Threaded regex wrappers remain preservation gates +against their same-commit direct companions. -### Current Status: Phase 44 local release gate complete; Phases 36 and 39b remain open - -Hints, warnings, filters, and source maps are runtime-owned while compiler-only -scratch remains protected by the global compile lock. The Phase 11 inventory is -split internally into explicit state holders for lifecycle/reachability, -signals/alarms, process and IO registries, filesystem/stat/random state, -debugging, data sections, native/module registries, and bless identity. The -mutable-static and spawned-worker audit classifies remaining statics as immutable -caches/constants, synchronized process services, globally unique ID allocators, -or compile-only state under the Phase 2 lock. - -`PerlRuntime` now provides idempotent initialization and close plus exclusive, -reentrant managed execution. Closing releases alarms, signals, I/O and native -registries, and lifecycle roots. Concurrent integration tests run conflicting -JVM and interpreter programs in separate runtimes. `Config` thread flags are -enabled for the supported ithread tranche, with the remaining compatibility -limits documented explicitly. - -Validation completed with the full unit build and the comprehensive compatibility -gate. `make test-all` retained the established partial-support baseline. Focused -JVM/interpreter checks covered warning and hint state, source locations, filters, -CWD, alarms/signals, random and regex state, data sections, I/O registries, -lifecycle/weak references, and runtime close. -Scalar::Util reports 1.70 on both backends; the JVM Moo constructor smoke passes. -The interpreter's pre-existing parser rejection of Moo attribute syntax remains -outside this runtime-state migration. - -Three-run same-base benchmark medians are within the 5% gate. The measured -current/base rates were global 37030/35671 (+3.8%), lexical 127349/118820 -(+7.2%), method 91.45/94.40 (-3.1%), closure 34.68/32.37 (+7.1%), regex -21657.60/22048.45 (-1.8%), and eval-string 15070.22/14910.07 (+1.1%). The -runtime lookup batching and idle lifecycle fast paths used to recover these -results preserve the runtime-owned state boundaries. This satisfies Phase 13; -no speculative optimization from the historical branches is required. - -`RuntimeGraphCloner` now clones non-code Perl graphs through one identity map. -Container shells are registered before their contents, so aliases and cycles -survive; blessings are translated by class name, weak edges are installed only -after the strong graph exists, and readonly constants stay shared. Tie wrappers -are rebuilt without invoking FETCH/STORE. Nonportable Java I/O resources follow -the documented conservative policy and become `undef` in the clone. Focused -tests prove source immutability and cross-root alias preservation. - -Generated JVM closures now implement `CloneablePerlSubroutine`, exposing their -captures in constructor order and rebuilding themselves from an explicit capture -array. The graph cloner uses that contract without reflecting over field order. -Interpreter closures rebuild immutable bytecode metadata while cloning constants, -captures, state values, and recursive self references through the same identity -map. Cross-backend tests prove scalar, array, and hash captures evolve independently -after cloning. - -`PerlRuntime.snapshotClone()` now pre-materializes lazy clone hooks, evaluates -`CLONE_SKIP` in the parent, copies package globals and CODE slots through one -graph cloner, and invokes `CLONE` in deterministic package order after the child -graph is installed. The child keeps fresh execution, lifecycle, signal/alarm, -native, classloader, cache, and I/O state. Snapshot tests cover both backends, -global alias isolation, skipped blessed objects, parent immutability, hook -context, and empty child execution stacks. Capability advertisement is covered -by the later activation gate described below. - -The thread control block owns platform-thread IDs, parent/child -relationships, completion and error state, join/detach transitions, and runtime- -family cleanup. The Perl API supports creation, identity, listing, -context-sensitive join results, nested threads, controlled thread exit, and -retained uncaught errors. Entry CODE references and arguments share the runtime -snapshot identity map; join results cross back through a fresh graph clone. -Child-owned END queues are drained at the thread boundary, and unsafe Java -thread stopping is not used. - -`threads::shared` marks scalar, array, and hash storage so graph cloning retains -its identity. Shared aggregate backing collections are synchronized and scalar -payload fields provide cross-thread visibility. `share`, `is_shared`, -`shared_clone`, and `:shared` are implemented for the supported unblessed, -untied tranche; blessed and tied values are rejected explicitly. Lock and -condition-variable semantics are implemented in Phase 21, and Phase 22 now -advertises the supported ithread surface through `Config`. - -Shared storage now has recursive, lexical `lock` ownership and condition -variables with atomic waiter publication, full recursive release/reacquisition, -absolute timed waits, FIFO signal, and broadcast. JVM and interpreter backends -both emit the lock cleanup boundary. The focused lock/condition stress suite -passes on system Perl and both PerlOnJava backends. - -`Config` now advertises `useithreads`, `usethreads`, and `usemultiplicity`. -The supported `threads` import/stringification surface is documented, while -signals, effective stack sizing, `object`, and `wantarray` remain explicit -limitations. Activation coverage passes on both backends. The first broader -compatibility inventory currently reaches 29/30 in core `op/threads.t`, 368/400 -in `op/substr_thr.t`, and 2/6 in `re/stclass_threads.t`; `class/threads.t`, -Storable's thread test, and `threads-dirh.t` complete. These are measured -follow-up targets, not a claim that every upstream thread suite is green. - -The post-activation comprehensive gate records the changed test surface rather -than comparing unlike totals: Perl core is 263443/321811 (81.9%) and bundled -modules are 9966/12339 (80.8%). Scalar::Util 1.70 loads on both backends and the -JVM Moo constructor smoke passes; the interpreter retains its previously -documented Moo attribute-syntax parser limitation. - -Java 24 virtual threads are the launcher default. Explicit -`JPERL_THREAD_MODE=platform` selection remains supported, and a nonzero Perl -stack-size request transparently selects a platform child. Unknown modes are -rejected and diagnostics expose the actual Java thread kind. Runtime pooling -is opt-in and defaults to zero after passing Phase 42's stress, retention, and -concurrent-request performance gates. - -The public documentation now treats the feature matrix as the canonical support -table, records the implementation in the changelog and roadmap, explains runtime -ownership and snapshot cloning, and documents the Java 24 requirement and -virtual-thread opt-in. Self-checking examples demonstrate isolated create/join -and shared lock/condition workflows on system Perl and both PerlOnJava backends. -Link validation covers the updated documentation. - -Shared lock state no longer permanently retains every storage root ever locked. -The lock registry uses weak identity keys while preserving one recursive lock -per live root; condition waiters remain strongly held only while a waiter is -published. Focused contention and collection tests cover both properties. - -Java 24 virtual-thread diagnostics cover shared conditions, regex timeouts, -thread lifecycle, representative native FFM identity calls, child-created file -I/O, and Test2 IPC without a pinning trace or semantic delta. A platform/virtual -inherited-descriptor probe failed identically in the current host environment, -so broader native callback coverage remains required before virtual mode can be -promoted. - -Test2's general thread suites now pass, including the six-assertion IPC -acceptance test on platform and virtual threads. This required preserving genuine -closure captures through END dispatch and synchronizing the compiled-CV registry -used by concurrent lazy materialization; no Test2-specific patch was added. - -Runtime pooling remains disabled. `PerlRuntime.close()` is a terminal operation, -not a reset, and representative package, regex, and execution state deliberately -remains observable on the closed object. The complete fresh-runtime equivalence -contract and state inventory live in `runtime-pooling-reset-contract.md`. - -The 2026-08-14 post-activation compatibility pass also resolved several direct -language defects exposed by the broader thread test surface. Reference -stringification and numeric coercion now use one Perl identity, typeglob pseudo -constants survive stash reconstruction and symbolic CODE lookup, tied-array -localization no longer corrupts sparse storage, `do NAME(...)` follows modern -syntax while `do BLOCK` copies its result, and `.=` preserves Perl's undef-warning -rules. Interpreter compiler-flag opcodes now activate lexical warning masks at -the same boundaries as generated JVM code. These are general Perl compatibility -fixes rather than changes to ithread ownership. The detailed investigation and -validation history is retained in the corresponding commit messages. - -### Implementation History - -Completed phase history is intentionally kept out of this living design -document. The implementation record, validation details, regressions, and -review decisions can be recovered from the phase commit messages and pull- -request history. - -The core differential runner now reserves an exclusive serial lane for the -resource-sensitive `gv.t`, advanced-regex, regex-speed, GH7094 benchmark, and -Abigail JAPH tests. The thread wrappers `pat_thr.t`, `pat_psycho_thr.t`, -`regexp_qr_embed_thr.t`, and `speed_thr.t` use that same lane and a 600-second -minimum outer deadline because runtime snapshot startup plus the upstream -watchdogs exceed the normal 300-second budget under parallel load. The -`regexp_qr_embed_thr.t` classification also prevents a full-corpus memory spike -from exhausting its child runtime near the end of the 2,210-case matrix. Thread -snapshots inherit named IO slots only when they contain a real handle; inert -parser placeholders are child-vivified on demand instead of being copied -quadratically across thousands of eval-created runtimes. These tests have -internal watchdogs or -timing assertions whose TAP totals changed when they competed with the normal -parallel corpus; they retain stable original indices, and `gv.t` receives the -upstream timeout factor. This is test scheduling policy, not a relaxation of -expected Perl behavior. The parser also accepts Perl's -adjacent quoted import form (`use overload'""' => ...`) without weakening the -old-style `Foo'Bar` package separator. Identical serialized runs with -`--jobs 8` and `--jobs 1` produced `gv.t` 255/304, both advanced-regex tests -1376/1687, `speed.t` 26/59, GH7094 6/6, and Abigail 109/130; the latter gains -three assertions from the adjacent-import parser fix. +Completed implementation history, validation evidence, and superseded decisions +are intentionally omitted here and are recoverable from commit messages and pull +requests. ### Next Steps -1. Integrate Phase 36 slices from the independent regex project described in - `dev/design/phase36-regex-parity.md`. Direct regex behavior is fixed first; - unchanged wrappers remain the thread ownership and snapshot gate. -2. Resolve Phase 39b's sole compatibility decision: whether to replace the - immutable Java-specific preserving-`share` assertion with system Perl's - destructive initialization. Nested proxies, runtime-local blessing, - cycles, weak views, and exactly-once cross-runtime destruction are complete; - `shared_clone` remains preserving. -3. Preserve the completed Phase 44 matrix while Phase 36 and Phase 39b close: - core thread wrappers must finish without timeout; default and opt-in Test2, - Storable, Net::SSLeay, DBI, and DBIx::Class must remain green on every PR; - Ubuntu and Windows CI are mandatory delivery gates. -4. Preserve the green core, Storable, Test2, Net::SSLeay, index/substr, DBI, and - DBIx::Class anchors after every phase. The 2026-08-14 DBIx::Class gate passed - all 325 files and 42,671 assertions under - `./jcpan --jobs 8 -t DBIx::Class`; every later phase must retain that result. -5. Keep resource-sensitive tests in the runner's exclusive lane and require a - serialized same-commit reproduction before classifying timing TAP deltas. +1. Finish the local release gates: `make`, documentation links, all four + upstream distribution configurations, the thread preservation matrix, + and `timeout 3600 ./jcpan --jobs 8 -t DBIx::Class`. +2. Review the final diff for temporary diagnostics, generated files, accidental + upstream-test edits, and any mutable runtime state lacking an ownership + classification. +3. Open the pull request with the exact gate results in its commit messages and + description. +4. Require green Ubuntu and Windows CI. Investigate and fix any CI failure on + the branch; do not merge on a rerun-only explanation. +5. After merge, treat the four unchanged upstream distributions as permanent + regression gates. Continue direct regex-language work, including Joni, only + in the separate Phase 36 project. + +Direct regex-language work, including Joni integration, is not part of this +release. +Unchanged regex thread wrappers remain preservation gates and must not regress +relative to their same-commit direct companions. ### Resolved Delivery Decisions - Every `IOHandle` class receives an explicit inheritance adapter; there is no generic shallow Java-resource fallback. - Blessed and tied shared values are in scope when system Perl accepts them. -- Virtual threads become the default after full platform/virtual parity; - nonzero stack requests select platform children. -- Pooling is opt-in and cannot activate until the full reset contract passes. - `close()` remains terminal. +- Virtual threads are the default; nonzero stack requests select platform + children. +- Runtime pooling is bounded and opt-in. It activates only through the reset + contract and fresh-runtime replacement policy; `close()` remains terminal. ## Related Documents -- `dev/prompts/multiplicity-v2-plan.md` — historical incremental plan -- `dev/design/clone.md` — historical clone exploration, not the ithread cloner - `dev/design/attributes.md` — current attribute behavior - `dev/design/runtime-pooling-reset-contract.md` — required proof before pooling - `dev/design/phase36-regex-parity.md` — independent regex parity project diff --git a/dev/tools/perl_test_runner.pl b/dev/tools/perl_test_runner.pl index 90f44fe0d..595cf7d78 100755 --- a/dev/tools/perl_test_runner.pl +++ b/dev/tools/perl_test_runner.pl @@ -8,6 +8,7 @@ use JSON::PP; use Data::Dumper; use POSIX qw(WNOHANG); +use Config (); # PerlOnJava Test Runner # Runs standard Perl tests against PerlOnJava and analyzes results @@ -244,6 +245,30 @@ sub process_test_result { sub run_single_test { my ($test_file) = @_; + # Core thread distributions assume their own build-directory cwd. In + # particular, threads and threads-shared resolve ../../t/test.pl when + # PERL_CORE is set, while Thread-Queue and Thread-Semaphore load their + # pure-Perl implementation from the distribution's lib directory. Keep + # the upstream tests unchanged and reproduce that layout here. + my $thread_distribution_root; + my $thread_distribution_uses_core = 0; + if ($test_file =~ m{^(perl5/dist/(threads|threads-shared))/t/}) { + $thread_distribution_root = $1; + $thread_distribution_uses_core = 1; + } elsif ($test_file =~ m{^(perl5/dist/(?:Thread-Queue|Thread-Semaphore))/t/}) { + $thread_distribution_root = $1; + } + + local $ENV{PERL_CORE} = $thread_distribution_uses_core ? 1 : $ENV{PERL_CORE}; + local $ENV{PERL5LIB} = $ENV{PERL5LIB}; + if ($thread_distribution_root && !$thread_distribution_uses_core) { + my $distribution_lib = File::Spec->rel2abs("$thread_distribution_root/lib"); + my $separator = $Config::Config{path_sep} || ':'; + $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) && length($ENV{PERL5LIB}) + ? "$distribution_lib$separator$ENV{PERL5LIB}" + : $distribution_lib; + } + # A few subprocess- or CPU-heavy tests routinely use most of the default # deadline and can cross it when the full parallel corpus contends for CPU. # Give those known outliers a stable minimum wall-clock allowance while @@ -321,7 +346,10 @@ sub run_single_test { # For perl5_t tests (especially Pod tests), change to the test directory # so they can find their test data files with relative paths my $local_test_dir = $test_dir; - if ($test_file =~ m{^perl5_t/t/}) { + if ($thread_distribution_root) { + $local_test_dir = $thread_distribution_root; + } + elsif ($test_file =~ m{^perl5_t/t/}) { # For core Perl 5 tests in perl5_t/t/, chdir to perl5_t/t # so they can find TestInit.pm via require $local_test_dir = 'perl5_t/t'; diff --git a/src/main/java/org/perlonjava/app/cli/Main.java b/src/main/java/org/perlonjava/app/cli/Main.java index d29515908..f87ab03f5 100644 --- a/src/main/java/org/perlonjava/app/cli/Main.java +++ b/src/main/java/org/perlonjava/app/cli/Main.java @@ -126,6 +126,12 @@ private static void run(String[] args) { try { PerlLanguageProvider.executePerlCode(parsedArgs, true); + int requestedThreadExit = PerlRuntime.current().threadRegistry() + .requestedProcessExitOr(Integer.MIN_VALUE); + if (requestedThreadExit != Integer.MIN_VALUE) { + System.exit(requestedThreadExit); + } + if (parsedArgs.compileOnly) { // Match system perl: `perl -c` prints this line to stderr (Test::Script relies on it). System.err.println(parsedArgs.fileName + " syntax OK"); @@ -143,7 +149,8 @@ private static void run(String[] args) { } } catch (PerlExitException e) { // Perl's exit() throws PerlExitException - convert to real System.exit() for CLI - System.exit(e.getExitCode()); + System.exit(PerlRuntime.current().threadRegistry() + .requestedProcessExitOr(e.getExitCode())); } catch (Throwable t) { if (parsedArgs.debugEnabled) { // Print full JVM stack diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index 1396f1c74..a0b5654ea 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -3399,6 +3399,11 @@ void compileVariableDeclaration(OperatorNode node, String op) { throwCompilerException("Unsupported variable type in list declaration: " + sigil); } + // A captured declaration-list slot is retrieved from the + // persistent definition-time cell, but attributes still + // apply at runtime to that exact cell before its first use. + emitVarAttrsIfNeeded(node, reg, sigil); + varRegs.add(reg); wrapWithRef.add(isDeclaredReference); } else { diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index abadb91f1..d687090e9 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -57,6 +57,7 @@ static boolean isImmutableProxy(RuntimeBase val) { private static boolean lexicalAssignmentMustPreserveSlot(RuntimeBase val) { if (!(val instanceof RuntimeScalar scalar)) return false; return scalar instanceof ReadOnlyAlias + || scalar.threadShared || scalar.captureCount > 0 || scalar.captureRefCountOwned > 0 || scalar.referencedByScalarReference diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java index dcbe5b5d1..5f2d643c5 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -798,12 +798,12 @@ public static void compileAssignmentOperator(BytecodeCompiler bytecodeCompiler, } } bytecodeCompiler.registerVariable(varName, varReg); - // Outer `my ($a,$b) : ATTR` puts attributes on the `my` node, not on - // each list slot; dispatching MODIFY_*_ once per RETRIEVE_BEGIN_* slot - // would duplicate calls. Variable attributes + RETRIEVE_BEGIN_* are - // fully handled for `my $x`, `my @x`, `my %x`, and `my $x=` forms above. bytecodeCompiler.emit(Opcodes.REGISTER_MY_VAR); bytecodeCompiler.emitReg(varReg); + // Attributes on a list declaration belong to every declared slot. + // The assignment-specific path constructs these slots directly, so + // it must dispatch attributes here before SET_FROM_LIST populates them. + bytecodeCompiler.emitVarAttrsIfNeeded(leftOp, varReg, sigil); } else { varReg = bytecodeCompiler.addVariable(varName, "my"); switch (sigil) { @@ -823,6 +823,7 @@ public static void compileAssignmentOperator(BytecodeCompiler bytecodeCompiler, bytecodeCompiler.emitLexicalAlias(varReg, varName); bytecodeCompiler.emit(Opcodes.REGISTER_MY_VAR); bytecodeCompiler.emitReg(varReg); + bytecodeCompiler.emitVarAttrsIfNeeded(leftOp, varReg, sigil); } varRegs.add(varReg); } diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java index 062c7e9f0..1db9088e2 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java @@ -691,7 +691,14 @@ else if (node.right instanceof BinaryOperatorNode rightCall) { // The repeat operator preserves list context on its left operand: // `(($expr) x 4)` repeats values, while scalar-context x repeats the // resulting string. All other ordinary binary operands are scalar. - int leftCtx = node.operator.equals("x") ? outerCtx : RuntimeContextType.SCALAR; + int leftCtx = switch (node.operator) { + case "x" -> outerCtx; + // Preserve the actual scalar slot: bless may publish metadata through + // a threads::shared scalar and must not operate on a temporary copy. + case "bless" -> isDirectScalarLvalue(node.left) + ? RuntimeContextType.LVALUE : RuntimeContextType.SCALAR; + default -> RuntimeContextType.SCALAR; + }; bytecodeCompiler.compileNode(node.left, -1, leftCtx); int rs1 = bytecodeCompiler.lastResultReg; @@ -712,12 +719,33 @@ else if (node.right instanceof BinaryOperatorNode rightCall) { int rs2 = bytecodeCompiler.lastResultReg; // Emit opcode based on operator (delegated to helper method) - int rd = CompileBinaryOperatorHelper.compileBinaryOperatorSwitch(bytecodeCompiler, node, rs1, rs2, node.getIndex()); + // In list context, both forms are range operators. The distinction + // between `..` and `...` only belongs to scalar flip-flop semantics. + // Keeping `...` here used to emit FLIP_FLOP even for array-slice + // indices such as @array[1...4], collapsing the slice to one element. + int rd = node.operator.equals("...") && outerCtx != RuntimeContextType.SCALAR + ? CompileBinaryOperatorHelper.compileBinaryOperatorSwitch( + bytecodeCompiler, "..", rs1, rs2, node.getIndex()) + : CompileBinaryOperatorHelper.compileBinaryOperatorSwitch( + bytecodeCompiler, node, rs1, rs2, node.getIndex()); bytecodeCompiler.lastResultReg = rd; } + private static boolean isDirectScalarLvalue(Node node) { + if (node instanceof OperatorNode operator) { + return operator.operator.equals("$"); + } + if (node instanceof BinaryOperatorNode binary) { + return switch (binary.operator) { + case "[", "{" -> true; + default -> false; + }; + } + return false; + } + private static void compileBinaryAsListOp(BytecodeCompiler bytecodeCompiler, BinaryOperatorNode node) { if (node.left instanceof IdentifierNode idNode) { String name = NameNormalizer.normalizeVariableName(idNode.name, bytecodeCompiler.getCurrentPackage()); diff --git a/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java b/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java index 16e58cdf6..34b332d5a 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java +++ b/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java @@ -208,6 +208,12 @@ public static String disassemble(InterpretedCode interpretedCode) { src = interpretedCode.bytecode[pc++]; sb.append("ASSIGN_LEXICAL_SCALAR r").append(rd).append(" = r").append(src).append("\n"); break; + case Opcodes.DISPATCH_VAR_ATTRS: + rd = interpretedCode.bytecode[pc++]; + int attributeMetadataIdx = interpretedCode.bytecode[pc++]; + sb.append("DISPATCH_VAR_ATTRS r").append(rd) + .append(" const[").append(attributeMetadataIdx).append("]\n"); + break; case Opcodes.RELEASE_CONSUMED_TEMP: src = interpretedCode.bytecode[pc++]; rd = interpretedCode.bytecode[pc++]; diff --git a/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java b/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java index 21a7a53f1..54ae9f1f7 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java +++ b/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java @@ -2355,9 +2355,9 @@ public class Opcodes { /** * Assign to an existing lexical scalar. * Plain lexicals are replaced with a fresh RuntimeScalar, preserving the - * current interpreter behavior for local/alias restoration. Magical lexicals - * such as tied scalars and Internals::SvREADONLY scalars are assigned in - * place so STORE/read-only checks still fire. + * current interpreter behavior for local/alias restoration. Magical and + * shared lexicals are assigned in place so STORE/read-only checks and + * shared storage identity are preserved. * Format: ASSIGN_LEXICAL_SCALAR rd rs */ public static final short ASSIGN_LEXICAL_SCALAR = 491; diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperator.java b/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperator.java index 6ba684f7b..84a56e7af 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperator.java @@ -7,7 +7,9 @@ import org.perlonjava.frontend.analysis.EmitterVisitor; import org.perlonjava.frontend.astnode.BinaryOperatorNode; import org.perlonjava.frontend.astnode.IdentifierNode; +import org.perlonjava.frontend.astnode.Node; import org.perlonjava.frontend.astnode.NumberNode; +import org.perlonjava.frontend.astnode.OperatorNode; import org.perlonjava.frontend.astnode.StringNode; import org.perlonjava.runtime.operators.OperatorHandler; import org.perlonjava.runtime.perlmodule.Strict; @@ -30,6 +32,13 @@ private static boolean isIntegerEnabled(EmitterVisitor emitterVisitor, BinaryOpe static void handleBinaryOperator(EmitterVisitor emitterVisitor, BinaryOperatorNode node, OperatorHandler operatorHandler) { EmitterVisitor scalarVisitor = emitterVisitor.with(RuntimeContextType.SCALAR); // execute operands in scalar context + // bless mutates the scalar slot as well as its referent. In particular, + // threads::shared publishes a class change only when the operand is the + // actual shared scalar, not a scalar-context copy of its reference. + EmitterVisitor leftVisitor = node.operator.equals("bless") + && isDirectScalarLvalue(node.left) + ? emitterVisitor.with(RuntimeContextType.LVALUE) + : scalarVisitor; if (CompilerOptions.DEBUG_ENABLED) emitterVisitor.ctx.logDebug("handleBinaryOperator: " + node.toString()); if (isIntegerEnabled(emitterVisitor, node) @@ -200,7 +209,7 @@ && switch (node.operator) { } MethodVisitor mv = emitterVisitor.ctx.mv; - node.left.accept(scalarVisitor); // left parameter + node.left.accept(leftVisitor); // left parameter int leftSlot = emitterVisitor.ctx.javaClassInfo.acquireSpillSlot(); boolean pooled = leftSlot >= 0; if (!pooled) { @@ -219,6 +228,19 @@ && switch (node.operator) { emitOperator(node, emitterVisitor); } + private static boolean isDirectScalarLvalue(Node node) { + if (node instanceof OperatorNode operator) { + return operator.operator.equals("$"); + } + if (node instanceof BinaryOperatorNode binary) { + return switch (binary.operator) { + case "[", "{" -> true; + default -> false; + }; + } + return false; + } + private static void emitIntegerBinaryOperator(EmitterVisitor emitterVisitor, EmitterVisitor scalarVisitor, BinaryOperatorNode node, diff --git a/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java b/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java index b7bd7350a..d3fc5b6ea 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java @@ -414,11 +414,18 @@ static RuntimeList runSpecialBlock(Parser parser, String blockPhase, Node block, loc.fileName(), loc.lineNumber()); try { + // Deferred phasers must return the anonymous CODE value to the + // parser so it can be queued. Compiling that wrapper in VOID + // context let the interpreter discard the last expression; + // the JVM happened to preserve it. BEGIN keeps its caller's + // requested context because it executes immediately. + int executionContext = blockPhase.equals("BEGIN") + ? contextType : RuntimeContextType.SCALAR; result = PerlLanguageProvider.executePerlAST( new BlockNode(nodes, tokenIndex), parser.tokens, parsedArgs, - contextType); + executionContext); } finally { CallerStack.pop(); Deque scopes = compileTimeMutationScopes.get(); diff --git a/src/main/java/org/perlonjava/runtime/operators/Operator.java b/src/main/java/org/perlonjava/runtime/operators/Operator.java index d1bde40a7..c4274f741 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Operator.java +++ b/src/main/java/org/perlonjava/runtime/operators/Operator.java @@ -568,6 +568,9 @@ public static RuntimeList splice(RuntimeArray runtimeArray, RuntimeList list) { * list context. */ public static RuntimeList splice(RuntimeArray runtimeArray, RuntimeList list, int ctx) { + if (runtimeArray.threadShared) { + throw new IllegalStateException("Splice not implemented for shared arrays"); + } return switch (runtimeArray.type) { case PLAIN_ARRAY -> { RuntimeList removedElements = new RuntimeList(); diff --git a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java index 3367fd6be..92adf64be 100644 --- a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java @@ -182,6 +182,13 @@ public static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar cla MortalList.setActive(true); } DestroyDispatch.registerIfDestroyable(referent, newBlessId); + // A reference stored in a shared scalar publishes its class to + // the common slot. An ordinary argument/reference remains an + // ithread-local wrapper, even when its aggregate storage is shared. + if (runtimeScalar.threadShared + || referent.sharedBlessingUnpublished()) { + SharedPerlStorage.publishBlessing(runtimeScalar); + } } else { throw new PerlCompilerException("Can't bless non-reference value"); } @@ -203,6 +210,10 @@ public static RuntimeScalar ref(RuntimeScalar runtimeScalar) { if (runtimeScalar instanceof ScalarSpecialVariable specialVar) { return ref(specialVar.getValueAsScalar()); } + if (RuntimeScalarType.isReference(runtimeScalar) + && runtimeScalar.value instanceof RuntimeBase referent) { + referent.synchronizePublishedSharedBlessing(); + } String str; int blessId; switch (runtimeScalar.type) { diff --git a/src/main/java/org/perlonjava/runtime/operators/TieOperators.java b/src/main/java/org/perlonjava/runtime/operators/TieOperators.java index dc2f8fdc9..43782a17d 100644 --- a/src/main/java/org/perlonjava/runtime/operators/TieOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/TieOperators.java @@ -345,7 +345,9 @@ public static RuntimeScalar lock(int ctx, RuntimeBase... scalars) { // A threaded perl still accepts lock() as a compatibility no-op until // threads::shared is loaded. Core's op/lock.t relies on this behavior // for ordinary scalar, aggregate, and code slots. - if (GlobalVariable.getGlobalHash("main::INC").elements.containsKey("threads/shared.pm")) { + RuntimeHash inc = GlobalVariable.getGlobalHash("main::INC"); + if (inc.elements.containsKey("threads.pm") + && inc.elements.containsKey("threads/shared.pm")) { SharedPerlStorage.lock(variable); } // For scalar references, dereference to get the value diff --git a/src/main/java/org/perlonjava/runtime/operators/WarnDie.java b/src/main/java/org/perlonjava/runtime/operators/WarnDie.java index ed092c5fe..b955cdb77 100644 --- a/src/main/java/org/perlonjava/runtime/operators/WarnDie.java +++ b/src/main/java/org/perlonjava/runtime/operators/WarnDie.java @@ -120,7 +120,9 @@ private static void writeWarningToStderr(String message) { public static RuntimeException maybeInvokeUnhandledDieHandler(RuntimeException e) { Throwable unwrapped = unwrapException(e); - if (unwrapped instanceof PerlDieException || unwrapped instanceof PerlExitException) { + if (unwrapped instanceof PerlDieException + || unwrapped instanceof PerlExitException + || unwrapped instanceof PerlThreadExitException) { return e; } if (RuntimeCode.getEvalDepth() > 0) { @@ -184,8 +186,18 @@ public static RuntimeScalar catchEval(Throwable e) { e = unwrapException(e); // exit() should never be caught by eval{} - re-throw it - if (e instanceof PerlExitException) { - throw (PerlExitException) e; + if (e instanceof PerlExitException exit) { + throw exit; + } + if (e instanceof PerlThreadExitException exit) { + throw exit; + } + + RuntimeScalar pendingWarning = PerlRuntime.current().executionState() + .pendingThreadWarningHandler; + PerlRuntime.current().executionState().pendingThreadWarningHandler = null; + if (pendingWarning != null) { + RuntimeScalar.scopeExitCleanup(pendingWarning); } RuntimeScalar err = getGlobalVariable("main::@"); @@ -608,10 +620,26 @@ public static RuntimeBase die(RuntimeBase message, RuntimeScalar where, String f DynamicVariableManager.popToLocalLevel(level); } - throw new PerlDieException(errVariable); + throw new PerlDieException(errVariable, snapshotWarningHandler()); } - throw new PerlDieException(errVariable); + throw new PerlDieException(errVariable, snapshotWarningHandler()); + } + + private static RuntimeScalar snapshotWarningHandler() { + RuntimeScalar handler = getGlobalHash("main::SIG").get("__WARN__"); + if (handler == null || !handler.getDefinedBoolean() || isReservedSigString(handler)) { + return null; + } + RuntimeScalar retained = new RuntimeScalar(); + retained.set(handler); + RuntimeScalar previous = PerlRuntime.current().executionState() + .pendingThreadWarningHandler; + if (previous != null) { + RuntimeScalar.scopeExitCleanup(previous); + } + PerlRuntime.current().executionState().pendingThreadWarningHandler = retained; + return retained; } private static RuntimeBase dieEmptyMessage(RuntimeScalar oldErr, String fileName, int lineNumber) { diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java index 41b2199c2..8c675f742 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java @@ -400,6 +400,18 @@ public static RuntimeList svRefcount(RuntimeArray args, int ctx) { // - for-many.t "refcount inside/after loop" // - test_pl/examples.t "only one reference"/"two references" int extra = (base.localBindingExists ? 1 : 0) + base.foreachAliasCount; + if (rc == 2 + && args.size() > 1 + && args.get(1).getBoolean() + && !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. + 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. diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java b/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java index 785c4247f..036ff84aa 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java @@ -284,7 +284,13 @@ public static RuntimeList dualvar(RuntimeArray args, int ctx) { // that can still be an alias to the result slot; retaining that alias // makes the dualvar's numeric side point back to the dualvar itself // and numeric conversion recurses forever. - scalar.value = new DualVar(new RuntimeScalar(args.get(0)), new RuntimeScalar(args.get(1))); + // dualvar(NUM, STR) copies the two coercion channels, not the source + // scalar's implementation object. This matters for magic variables + // such as $!: its RuntimeScalar payload is dual-valued, but the + // authoritative errno lives in the ErrnoVariable accessors. + RuntimeScalar numeric = new RuntimeScalar(args.get(0).getNumber()); + RuntimeScalar string = new RuntimeScalar(args.get(1).toString()); + scalar.value = new DualVar(numeric, string); return scalar.getList(); } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Threads.java b/src/main/java/org/perlonjava/runtime/perlmodule/Threads.java index c7588d972..a3a0fd711 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Threads.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Threads.java @@ -61,6 +61,10 @@ public static RuntimeList _create(RuntimeArray args, int ctx) { } code = GlobalVariable.getGlobalCodeRef(name); } + RuntimeArray threadArgs = new RuntimeArray(); + for (int i = codeIndex + 1; i < args.size(); i++) threadArgs.push(args.get(i)); + PerlRuntime parent = PerlRuntime.current(); + int threadContext = creationContext(options, ctx); // Perl accepts a reference-valued entry here and creates the ithread; // the child then fails with "Not a CODE reference". Keeping creation // asynchronous preserves join/error lifecycle and core diagnostics. @@ -71,8 +75,20 @@ public static RuntimeList _create(RuntimeArray args, int ctx) { // starting a real child here could deadlock on the enclosing compile lock. if (PerlLanguageProvider.COMPILE_LOCK.isHeldByCurrentThread()) { RuntimeHash stub = new RuntimeHash(); - stub.put("tid", new RuntimeScalar(-1)); - stub.put("state", new RuntimeScalar("detached")); + stub.put("tid", new RuntimeScalar(parent.threadRegistry().allocateId())); + stub.put("state", new RuntimeScalar("compile-stub")); + stub.put("context", new RuntimeScalar(threadContext)); + try { + RuntimeList result = RuntimeCode.apply(code, threadArgs, threadContext); + stub.put("result", new RuntimeArray(result).createReference()); + } catch (Throwable failure) { + PerlThreadExitException threadExit = findThreadExit(failure); + if (threadExit != null) { + stub.put("result", threadExit.values().createReference()); + } else { + stub.put("error", new RuntimeScalar(errorText(failure))); + } + } return ReferenceOperators.bless(stub.createReference(), new RuntimeScalar(CLASS)).getList(); } // Perl compiles an anonymous thread entry in the parent. In @@ -85,17 +101,35 @@ public static RuntimeList _create(RuntimeArray args, int ctx) { && runtimeCode.compilerSupplier != null) { runtimeCode.compilerSupplier.get(); } - RuntimeArray threadArgs = new RuntimeArray(); - for (int i = codeIndex + 1; i < args.size(); i++) threadArgs.push(args.get(i)); - PerlRuntime parent = PerlRuntime.current(); - int threadContext = creationContext(options, ctx); - long stackSize = optionLong(options, "stack_size", parent.defaultPerlThreadStackSize()); + long stackSize = optionLong(options, "stack_size", + optionLong(options, "stack", parent.defaultPerlThreadStackSize())); boolean exitOnly = optionExitOnly(options, parent.defaultPerlThreadExitOnly()); - PerlThreadControlBlock thread = PerlThreadControlBlock.create( - parent, code, threadArgs, threadContext, stackSize, exitOnly).start(); + PerlThreadControlBlock thread; + try { + thread = PerlThreadControlBlock.create( + parent, code, threadArgs, threadContext, stackSize, exitOnly).start(); + } finally { + releaseTemporaryEntryCode(code); + } return threadObject(thread.id(), null).getList(); } + /** + * Drop the parent half of an inline anonymous thread entry after its graph + * has been cloned. A CODE value stored in a lexical/package scalar has a + * real refCount owner and must remain callable; a direct {@code async {}} + * argument has neither and otherwise keeps its captured pads alive until + * top-level destruction. + */ + private static void releaseTemporaryEntryCode(RuntimeScalar code) { + if (code == null || code.globalCodeRefFqn != null + || MyVarCleanupStack.isRegistered(code) + || !(code.value instanceof RuntimeCode runtimeCode)) { + return; + } + runtimeCode.releaseCaptures(); + } + public static RuntimeList _self(RuntimeArray args, int ctx) { return threadObject(PerlRuntime.current().perlThreadId(), null).getList(); } @@ -108,31 +142,81 @@ public static RuntimeList _list(RuntimeArray args, int ctx) { // returns them from list(), even while their Java carrier is still // winding down. if (thread.isDetached()) continue; + if (thread.isJoining()) continue; if (filter == 1 && !thread.isRunning()) continue; if (filter == 2 && !thread.isJoinable()) continue; result.add(threadObject(thread.id(), thread)); } + if (ctx == RuntimeContextType.SCALAR) { + return new RuntimeScalar(result.size()).getList(); + } return result; } public static RuntimeList _join(RuntimeArray args, int ctx) { RuntimeHash object = threadHash(args); - PerlThreadControlBlock thread = findThread(object); + RuntimeScalar objectTid = object.get("tid"); + if (objectTid != null && "compile-stub".equals(object.get("state").toString())) { + object.put("state", new RuntimeScalar("joined")); + RuntimeScalar error = object.get("error"); + if (error != null && error.getDefinedBoolean()) { + org.perlonjava.runtime.operators.WarnDie.warnWithCategory( + new RuntimeScalar("Thread " + objectTid + " terminated abnormally: " + error), + new RuntimeScalar(), "threads"); + return RuntimeScalarCache.scalarUndef.getList(); + } + RuntimeScalar stored = object.get("result"); + RuntimeArray values = stored != null && stored.value instanceof RuntimeArray array + ? array : new RuntimeArray(); + int creationContext = object.get("context").getInt(); + if (creationContext == RuntimeContextType.VOID || ctx == RuntimeContextType.VOID) { + return RuntimeScalarCache.scalarUndef.getList(); + } + if (ctx == RuntimeContextType.SCALAR) { + return values.isEmpty() ? RuntimeScalarCache.scalarUndef.getList() + : values.get(values.size() - 1).getList(); + } + return new RuntimeList(values.elements.toArray(RuntimeBase[]::new)); + } + PerlThreadControlBlock thread = findKnownThread(object); if (thread == null) throw new IllegalStateException("Thread is no longer joinable"); + if (thread.id() == PerlRuntime.current().perlThreadId()) { + throw new IllegalStateException("Cannot join self"); + } try { - PerlThreadControlBlock.Completion completion = thread.join(); + PerlThreadControlBlock caller = PerlRuntime.current().threadRegistry() + .get(PerlRuntime.current().perlThreadId()); + if (caller != null && caller != thread) caller.beginJoinWait(); + PerlThreadControlBlock.Completion completion; + try { + completion = thread.join(); + } finally { + if (caller != null && caller != thread) caller.endJoinWait(); + } try { object.put("state", new RuntimeScalar("joined")); String error = errorText(completion.error()); - object.put("error", error.isEmpty() ? RuntimeScalarCache.scalarUndef : new RuntimeScalar(error)); + RuntimeScalar errorValue = threadErrorValue(thread); + object.put("error", errorValue); if (completion.error() instanceof PerlExitException processExit) throw processExit; if (!error.isEmpty()) { - RuntimeIO.getStderr().write( - "Thread " + thread.id() + " terminated abnormally: " + error + "\n"); + org.perlonjava.runtime.operators.WarnDie.warnWithCategory( + new RuntimeScalar("Thread " + thread.id() + + " terminated abnormally: " + error), + new RuntimeScalar(), "threads"); } if (!(completion.value() instanceof RuntimeArray values)) return new RuntimeList(); List cloned = new RuntimeGraphCloner( thread.childRuntime(), PerlRuntime.current()).cloneRoots(values.elements); + // Join-cloned scalar roots are Perl temporaries. The receiving + // assignment acquires its own owner; leaving the clone's + // reconstructed owner live suppresses DESTROY for the joined + // value at parent scope/global destruction. + for (RuntimeBase clonedValue : cloned) { + if (clonedValue instanceof RuntimeScalar scalar) { + MortalList.deferDecrementIfTracked(scalar); + } + } if (thread.context() == RuntimeContextType.VOID) { return RuntimeScalarCache.scalarUndef.getList(); } @@ -153,7 +237,12 @@ public static RuntimeList _join(RuntimeArray args, int ctx) { public static RuntimeList _detach(RuntimeArray args, int ctx) { RuntimeHash object = threadHash(args); - PerlThreadControlBlock thread = findThread(object); + RuntimeScalar objectTid = object.get("tid"); + if (objectTid != null && "compile-stub".equals(object.get("state").toString())) { + object.put("state", new RuntimeScalar("detached")); + return RuntimeScalarCache.scalarUndef.getList(); + } + PerlThreadControlBlock thread = findKnownThread(object); if (thread == null) throw new IllegalStateException("Thread is no longer detachable"); thread.detach(); object.put("state", new RuntimeScalar("detached")); @@ -188,8 +277,9 @@ public static RuntimeList _error(RuntimeArray args, int ctx) { RuntimeScalar saved = object.get("error"); PerlThreadControlBlock thread = findKnownThread(object); if (thread != null) { - return thread.error() == null ? RuntimeScalarCache.scalarUndef.getList() - : new RuntimeScalar(errorText(thread.error())).getList(); + if (thread.error() == null) return RuntimeScalarCache.scalarUndef.getList(); + RuntimeScalar current = threadErrorValue(thread); + if (current.getDefinedBoolean()) return current.getList(); } return saved == null || !saved.getDefinedBoolean() ? RuntimeScalarCache.scalarUndef.getList() : saved.getList(); @@ -230,10 +320,20 @@ public static RuntimeList _kill(RuntimeArray args, int ctx) { RuntimeHash hash = threadHash(args); if (args.size() < 2) throw new IllegalArgumentException("Usage: $thr->kill('SIG...')"); String signal = normalizeSignal(args.get(1)); - PerlThreadControlBlock thread = findThread(hash); - if (thread == null || !thread.isRunning() || thread.isDetached()) { + PerlThreadControlBlock thread = findKnownThread(hash); + // Java cannot deliver Perl's uncatchable KILL semantics to a detached + // carrier. Preserve the documented explicit no-op for that one signal; + // ordinary safe signals remain deliverable to running detached threads. + if (thread != null && thread.isDetached() && "KILL".equals(signal)) { return RuntimeScalarCache.scalarUndef.getList(); } + if (thread == null || !thread.isRunning()) { + return thread != null && !thread.isDetached() + ? object.getList() : RuntimeScalarCache.scalarUndef.getList(); + } + if (!thread.hasSignalHandler(signal)) { + throw new IllegalStateException("Signal " + signal + " has no signal handler set"); + } thread.signal(signal); return object.getList(); } @@ -331,7 +431,8 @@ private static boolean optionExitOnly(RuntimeHash options, boolean fallback) { private static final Set SIGNALS = Set.of( "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", - "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "CHLD"); + "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "CHLD", + "STOP", "CONT"); private static String normalizeSignal(RuntimeScalar value) { String signal = value.toString().toUpperCase(Locale.ROOT); @@ -365,4 +466,23 @@ private static String errorText(Throwable error) { String message = error.getMessage(); return message == null || message.isEmpty() ? error.toString() : message; } + + private static PerlThreadExitException findThreadExit(Throwable error) { + Throwable current = error; + while (current != null) { + if (current instanceof PerlThreadExitException exit) return exit; + if (current.getCause() == current) break; + current = current.getCause(); + } + return null; + } + + private static RuntimeScalar threadErrorValue(PerlThreadControlBlock thread) { + Throwable failure = thread.error(); + PerlRuntime child = thread.childRuntime(); + if (failure == null || child == null) return RuntimeScalarCache.scalarUndef; + RuntimeScalar source = ErrorMessageUtil.exceptionValue(failure); + return new RuntimeGraphCloner(child, PerlRuntime.current()) + .cloneRoots(List.of(source)).getFirst().scalar(); + } } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/ThreadsShared.java b/src/main/java/org/perlonjava/runtime/perlmodule/ThreadsShared.java index 9304fbeab..14fdcb8cf 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/ThreadsShared.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/ThreadsShared.java @@ -11,6 +11,8 @@ public static void initialize() { try { module.registerMethod("_share", null); module.registerMethod("_is_shared", null); + module.registerMethod("_shared_id", null); + module.registerMethod("_shared_refcnt", null); module.registerMethod("_shared_clone", null); module.registerMethod("_cond_wait", null); module.registerMethod("_cond_timedwait", null); @@ -28,7 +30,22 @@ public static RuntimeList _share(RuntimeArray args, int ctx) { } public static RuntimeList _is_shared(RuntimeArray args, int ctx) { - return new RuntimeScalar(SharedPerlStorage.isShared(required(args, "is_shared")) ? 1 : 0).getList(); + return new RuntimeScalar(SharedPerlStorage.sharedId(required(args, "is_shared"))).getList(); + } + + public static RuntimeList _shared_id(RuntimeArray args, int ctx) { + RuntimeScalar value = requiredReference(args, "_id"); + return new RuntimeScalar(SharedPerlStorage.sharedId(value)).getList(); + } + + public static RuntimeList _shared_refcnt(RuntimeArray args, int ctx) { + RuntimeScalar value = requiredReference(args, "_refcnt"); + if (!SharedPerlStorage.isShared(value)) { + org.perlonjava.runtime.operators.WarnDie.warn( + new RuntimeScalar(value + " is not shared"), new RuntimeScalar()); + return RuntimeScalarCache.scalarUndef.getList(); + } + return new RuntimeScalar(SharedPerlStorage.sharedReferenceCount(value)).getList(); } public static RuntimeList _shared_clone(RuntimeArray args, int ctx) { @@ -52,16 +69,18 @@ public static RuntimeList _cond_timedwait(RuntimeArray args, int ctx) { public static RuntimeList _cond_signal(RuntimeArray args, int ctx) { if (!SharedPerlStorage.conditionSignal(required(args, "cond_signal"), false)) { - org.perlonjava.runtime.operators.WarnDie.warn( - new RuntimeScalar("cond_signal() called on unlocked variable"), new RuntimeScalar()); + org.perlonjava.runtime.operators.WarnDie.warnWithCategory( + new RuntimeScalar("cond_signal() called on unlocked variable"), + new RuntimeScalar(), "threads"); } return new RuntimeScalar(1).getList(); } public static RuntimeList _cond_broadcast(RuntimeArray args, int ctx) { if (!SharedPerlStorage.conditionSignal(required(args, "cond_broadcast"), true)) { - org.perlonjava.runtime.operators.WarnDie.warn( - new RuntimeScalar("cond_broadcast() called on unlocked variable"), new RuntimeScalar()); + org.perlonjava.runtime.operators.WarnDie.warnWithCategory( + new RuntimeScalar("cond_broadcast() called on unlocked variable"), + new RuntimeScalar(), "threads"); } return new RuntimeScalar(1).getList(); } @@ -70,4 +89,12 @@ private static RuntimeScalar required(RuntimeArray args, String name) { if (args.isEmpty()) throw new IllegalArgumentException(name + " requires a value"); return args.get(0); } + + private static RuntimeScalar requiredReference(RuntimeArray args, String name) { + RuntimeScalar value = required(args, name); + if (!RuntimeScalarType.isReference(value)) { + throw new IllegalArgumentException("Argument to " + name + " needs to be passed as ref"); + } + return value; + } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java b/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java index ccdc8c8f5..0d9ec1601 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java @@ -180,6 +180,12 @@ public static void invalidateCache() { public static void callDestroy(RuntimeBase referent) { // refCount is already MIN_VALUE (set by caller) + // Shared canonical objects carry a published class name across + // runtimes, but numeric bless IDs are runtime-local. Destruction may + // be the parent's first observation of an object created and blessed + // in a child, so resolve the published name before method lookup. + referent.synchronizePublishedSharedBlessing(); + // A shared aggregate may have runtime-local fetch views in another // ithread. Canonical deletion waits for those views; the runtime that // releases the last view performs the one Perl DESTROY callback. @@ -659,6 +665,26 @@ public static boolean clearRescuedWeakRefsToSelfOnly(RuntimeBase rescued) { return true; } + /** + * Clear weak callbacks to objects owned by a rescued aggregate while + * preserving weak back-references to the rescued root itself. + * + *

DBIx::Class keeps a rescued Schema usable through ResultSource + * back-references after the user's schema lexical is undefined. At the + * same time, a separately retained DBI handle must observe that the nested + * Storage object has gone away and use its fallback HandleError callback. + * The normal final rescued-object sweep still clears the complete graph.

+ */ + public static boolean clearNestedWeakRefsForRescued(RuntimeBase rescued) { + if (!(rescued instanceof RuntimeHash hash)) return false; + java.util.List rescuedObjects = state().rescuedObjects; + synchronized (rescuedObjects) { + if (!rescuedObjects.contains(rescued)) return false; + } + deepClearWeakRefsImpl(hash, 5, rescued); + return true; + } + /** * Recursively walk a hash's values and clear weak refs for any blessed * objects found, including nested hashes and arrays. This is used after @@ -676,7 +702,7 @@ public static boolean clearRescuedWeakRefsToSelfOnly(RuntimeBase rescued) { * @param hash The hash to walk */ private static void deepClearWeakRefs(RuntimeHash hash) { - deepClearWeakRefsImpl(hash, 5); + deepClearWeakRefsImpl(hash, 5, null); } /** @@ -685,7 +711,8 @@ private static void deepClearWeakRefs(RuntimeHash hash) { * @param hash The hash to walk * @param maxDepth Maximum recursion depth (prevents infinite loops on circular refs) */ - private static void deepClearWeakRefsImpl(RuntimeHash hash, int maxDepth) { + private static void deepClearWeakRefsImpl( + RuntimeHash hash, int maxDepth, RuntimeBase excludedRoot) { if (maxDepth <= 0) return; for (RuntimeScalar val : hash.elements.values()) { // Check for any reference type (REFERENCE, HASHREFERENCE, ARRAYREFERENCE, etc.) @@ -693,6 +720,7 @@ private static void deepClearWeakRefsImpl(RuntimeHash hash, int maxDepth) { // may have type HASHREFERENCE rather than plain REFERENCE. if ((val.type & RuntimeScalarType.REFERENCE_BIT) != 0 && val.value instanceof RuntimeBase base) { + if (base == excludedRoot) continue; // Clear weak refs for this blessed object (e.g., Storage::DBI, DBI::db). // Only clear if the object is blessed (blessId != 0) to avoid clearing // weak refs for plain unblessed containers that might be shared. @@ -702,7 +730,7 @@ private static void deepClearWeakRefsImpl(RuntimeHash hash, int maxDepth) { // Recurse into nested hashes to find deeper blessed objects // (e.g., Schema → {storage} → Storage → {_dbh} → DBI::db) if (base instanceof RuntimeHash nestedHash) { - deepClearWeakRefsImpl(nestedHash, maxDepth - 1); + deepClearWeakRefsImpl(nestedHash, maxDepth - 1, excludedRoot); } } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java index c860b0e47..0aa0984f6 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java @@ -61,6 +61,8 @@ public final class ExecutionRuntimeState { public final IdentityHashMap unhandledDieHandlerSeen = new IdentityHashMap<>(); public boolean insideUnhandledDieHandler; + /** __WARN__ snapshot retained until an uncaught die reaches the ithread boundary. */ + public RuntimeScalar pendingThreadWarningHandler; ControlFlowMarker controlFlowMarker; final ArrayList myVarCleanupStack = new ArrayList<>(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlDieException.java b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlDieException.java index 3c9812e25..0317c847f 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlDieException.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlDieException.java @@ -13,16 +13,27 @@ public class PerlDieException extends RuntimeException { private static final long serialVersionUID = 1L; private final RuntimeBase payload; + private final RuntimeScalar warningHandler; public PerlDieException(RuntimeBase payload) { + this(payload, null); + } + + public PerlDieException(RuntimeBase payload, RuntimeScalar warningHandler) { super(safeMessage(payload)); this.payload = payload; + this.warningHandler = warningHandler; } public RuntimeBase getPayload() { return payload; } + /** Warning handler that was live at die time, retained across scope unwind. */ + public RuntimeScalar getWarningHandler() { + return warningHandler; + } + private static String safeMessage(RuntimeBase payload) { if (payload == null) return null; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlRuntime.java b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlRuntime.java index 6c3d4f2e2..26ad26350 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlRuntime.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlRuntime.java @@ -9,6 +9,7 @@ import org.perlonjava.runtime.io.IORuntimeRegistryState; import org.perlonjava.runtime.io.StandardIO; import org.perlonjava.runtime.mro.MroRuntimeState; +import org.perlonjava.runtime.mro.InheritanceResolver; import org.perlonjava.runtime.operators.Time; import org.perlonjava.runtime.operators.Random; import org.perlonjava.runtime.operators.ScalarFlipFlopOperator; @@ -61,9 +62,7 @@ public final class PerlRuntime implements AutoCloseable { private final long perlThreadId; private volatile int perlThreadContext = RuntimeContextType.SCALAR; private volatile long perlThreadStackSize; - private volatile long defaultPerlThreadStackSize; private volatile boolean perlThreadExitOnly; - private volatile boolean defaultPerlThreadExitOnly; public ExecutionRuntimeState executionState = new ExecutionRuntimeState(); public RuntimeRegexState regexState = new RuntimeRegexState(); @@ -279,12 +278,12 @@ public long perlThreadId() { public void setPerlThreadContext(int context) { perlThreadContext = context; } public long perlThreadStackSize() { return perlThreadStackSize; } public void setPerlThreadStackSize(long size) { perlThreadStackSize = size; } - public long defaultPerlThreadStackSize() { return defaultPerlThreadStackSize; } - public void setDefaultPerlThreadStackSize(long size) { defaultPerlThreadStackSize = size; } + public long defaultPerlThreadStackSize() { return threadRegistry.defaultStackSize(); } + public void setDefaultPerlThreadStackSize(long size) { threadRegistry.setDefaultStackSize(size); } public boolean perlThreadExitOnly() { return perlThreadExitOnly; } public void setPerlThreadExitOnly(boolean value) { perlThreadExitOnly = value; } - public boolean defaultPerlThreadExitOnly() { return defaultPerlThreadExitOnly; } - public void setDefaultPerlThreadExitOnly(boolean value) { defaultPerlThreadExitOnly = value; } + public boolean defaultPerlThreadExitOnly() { return threadRegistry.defaultExitOnly(); } + public void setDefaultPerlThreadExitOnly(boolean value) { threadRegistry.setDefaultExitOnly(value); } /** Initialize this independent interpreter's globals and runtime services. */ public PerlRuntime initialize() { @@ -408,25 +407,26 @@ public PerlRuntime reset() { * lifecycle, alarm, signal, native and I/O state starts fresh in the child. */ public PerlRuntime snapshotClone() { - return snapshotCloneInternal(new PerlThreadRegistry(), 0).runtime(); + return snapshotCloneInternal(new PerlThreadRegistry(), 0, java.util.List.of()).runtime(); } /** Snapshot this runtime and clone additional non-global roots through the same graph map. */ public RootSnapshot snapshotCloneWithRoots(java.util.List roots) { Objects.requireNonNull(roots, "roots"); - ThreadSnapshot snapshot = snapshotCloneInternal(new PerlThreadRegistry(), 0); - return new RootSnapshot(snapshot.runtime(), snapshot.cloner().cloneRoots(roots)); + return snapshotCloneInternal(new PerlThreadRegistry(), 0, roots); } public record RootSnapshot(PerlRuntime runtime, java.util.List roots) {} - record ThreadSnapshot(PerlRuntime runtime, RuntimeGraphCloner cloner) {} - - ThreadSnapshot snapshotCloneForThread(PerlThreadRegistry registry, long threadId) { - return snapshotCloneInternal(registry, threadId); + RootSnapshot snapshotCloneForThread( + PerlThreadRegistry registry, long threadId, + java.util.List roots) { + return snapshotCloneInternal(registry, threadId, roots); } - private ThreadSnapshot snapshotCloneInternal(PerlThreadRegistry registry, long threadId) { + private RootSnapshot snapshotCloneInternal( + PerlThreadRegistry registry, long threadId, + java.util.List roots) { executionLock.lock(); try { if (closed) throw new IllegalStateException("PerlRuntime is closed"); @@ -445,8 +445,6 @@ private ThreadSnapshot snapshotCloneInternal(PerlThreadRegistry registry, long t } PerlRuntime child = new PerlRuntime(registry, threadId); - child.defaultPerlThreadStackSize = defaultPerlThreadStackSize; - child.defaultPerlThreadExitOnly = defaultPerlThreadExitOnly; nameNormalizerState.snapshotInto(child.nameNormalizerState); RuntimeGraphCloner cloner = new RuntimeGraphCloner(this, child, skipped); try (Binding ignored = bind()) { @@ -454,13 +452,14 @@ private ThreadSnapshot snapshotCloneInternal(PerlThreadRegistry registry, long t runtimeCodeState.snapshotCompiledMetadataInto(child.runtimeCodeState); regexState.snapshotInto(child.regexState); } + java.util.List clonedRoots = cloner.cloneSnapshotRoots(roots); cloner.finishSnapshot(); child.currentDirectory = currentDirectory; child.initialized = true; try (Binding ignored = child.bind()) { child.runCloneHooks(); } - return new ThreadSnapshot(child, cloner); + return new RootSnapshot(child, clonedRoots); } finally { executionLock.unlock(); } @@ -468,11 +467,17 @@ private ThreadSnapshot snapshotCloneInternal(PerlThreadRegistry registry, long t private Set preflightCloneSkip() { Set skipped = new HashSet<>(); - for (String fqn : new TreeSet<>(globalState.codeRefs().keySet())) { - if (!fqn.endsWith("::CLONE_SKIP")) continue; - RuntimeScalar hook = globalState.codeRefs().get(fqn); + // Perl calls the effective CLONE_SKIP method once for each class that + // has live blessed values in the snapshot. Walking every defined hook + // invoked callbacks long before any object of that class existed; only + // checking direct package hooks missed inherited CLONE_SKIP on A2/B2. + Set liveClasses = new TreeSet<>(nameNormalizerState.blessStrCache.values()); + liveClasses.remove(""); + liveClasses.remove("__ANON__"); + for (String packageName : liveClasses) { + RuntimeScalar hook = InheritanceResolver.findMethodInHierarchy( + "CLONE_SKIP", packageName, null, 0, false); if (hook == null || !(hook.value instanceof RuntimeCode code) || !code.defined()) continue; - String packageName = fqn.substring(0, fqn.length() - "::CLONE_SKIP".length()); RuntimeArray args = new RuntimeArray(new RuntimeScalar(packageName)); if (RuntimeCode.apply(hook, args, RuntimeContextType.SCALAR).scalar().getBoolean()) { skipped.add(packageName); @@ -599,9 +604,7 @@ private void replaceRuntimeState() { currentDirectory = System.getProperty("user.dir"); perlThreadContext = RuntimeContextType.SCALAR; perlThreadStackSize = 0; - defaultPerlThreadStackSize = 0; perlThreadExitOnly = false; - defaultPerlThreadExitOnly = false; resetStandardIOState(); } @@ -634,6 +637,7 @@ private void releaseBinding() { void sharedLockAcquired() { activeSharedLocks.incrementAndGet(); } void sharedLockReleased() { activeSharedLocks.decrementAndGet(); } + boolean hasSharedLock() { return activeSharedLocks.get() > 0; } void sharedWaiterEntered() { activeSharedWaiters.incrementAndGet(); } void sharedWaiterExited() { activeSharedWaiters.decrementAndGet(); } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadControlBlock.java b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadControlBlock.java index 05b40dea6..643292537 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadControlBlock.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadControlBlock.java @@ -1,6 +1,7 @@ package org.perlonjava.runtime.runtimetypes; import org.perlonjava.runtime.regex.RuntimeRegex; +import org.perlonjava.runtime.operators.WarnDie; import java.util.Objects; import java.util.concurrent.CountDownLatch; @@ -10,7 +11,7 @@ /** Internal ownership and completion record for one Perl ithread. */ public final class PerlThreadControlBlock { - public enum State { NEW, RUNNING, COMPLETED, FAILED, JOINED, DETACHED } + public enum State { NEW, RUNNING, JOINING, COMPLETED, FAILED, JOINED, DETACHED } @FunctionalInterface public interface EntryPoint { @@ -24,6 +25,7 @@ public record Completion(RuntimeBase value, Throwable error) {} private final PerlThreadRegistry registry; private volatile PerlRuntime childRuntime; private volatile EntryPoint entryPoint; + private volatile Runnable entryCleanup; private final int context; private final long stackSize; private final RuntimeIO parentErrorOutput; @@ -42,7 +44,8 @@ private PerlThreadControlBlock(PerlRuntime parent, EntryPoint entryPoint) { this.id = registry.allocateId(); this.parentId = parent.perlThreadId(); this.entryPoint = Objects.requireNonNull(entryPoint, "entryPoint"); - this.childRuntime = parent.snapshotCloneForThread(registry, id).runtime(); + this.childRuntime = parent.snapshotCloneForThread( + registry, id, java.util.List.of()).runtime(); this.context = RuntimeContextType.SCALAR; this.stackSize = parent.defaultPerlThreadStackSize(); this.parentErrorOutput = RuntimeIO.getStderr(); @@ -58,7 +61,10 @@ private PerlThreadControlBlock(PerlRuntime parent, RuntimeScalar code, RuntimeAr this.registry = parent.threadRegistry(); this.id = registry.allocateId(); this.parentId = parent.perlThreadId(); - PerlRuntime.ThreadSnapshot snapshot = parent.snapshotCloneForThread(registry, id); + List roots = new ArrayList<>(args.size() + 1); + roots.add(Objects.requireNonNull(code, "code")); + for (int i = 0; i < args.size(); i++) roots.add(args.get(i)); + PerlRuntime.RootSnapshot snapshot = parent.snapshotCloneForThread(registry, id, roots); this.childRuntime = snapshot.runtime(); this.context = context; this.stackSize = stackSize; @@ -67,11 +73,9 @@ private PerlThreadControlBlock(PerlRuntime parent, RuntimeScalar code, RuntimeAr childRuntime.setPerlThreadStackSize(stackSize); childRuntime.setPerlThreadExitOnly(exitOnly); - List roots = new ArrayList<>(args.size() + 1); - roots.add(Objects.requireNonNull(code, "code")); - for (int i = 0; i < args.size(); i++) roots.add(args.get(i)); - List cloned = snapshot.cloner().cloneRoots(roots); + List cloned = snapshot.roots(); RuntimeScalar childCode = (RuntimeScalar) cloned.getFirst(); + boolean releaseEntryCode = code.globalCodeRefFqn == null; RuntimeArray childArgs = new RuntimeArray(); for (int i = 1; i < cloned.size(); i++) childArgs.push(cloned.get(i).scalar()); this.entryPoint = runtime -> { @@ -80,6 +84,35 @@ private PerlThreadControlBlock(PerlRuntime parent, RuntimeScalar code, RuntimeAr for (RuntimeBase value : values.elements) retained.push(value.scalar()); return retained; }; + this.entryCleanup = () -> { + // The thread invocation owns an anonymous entry CV independently + // of its parent. Releasing it at thread end drops captured child + // lexicals before END, while named package CVs remain stash-owned. + if (releaseEntryCode) { + if (childCode.value instanceof RuntimeCode entryCode) { + RuntimeScalar[] capturedScalars = entryCode.capturedScalars; + if (capturedScalars != null) { + for (RuntimeScalar captured : capturedScalars) { + // These pads were cloned from the parent's active + // scope, but the child has no enclosing invocation + // that can later retire them. Thread termination is + // their scope boundary in this runtime. + // A shared scalar is the parent's canonical storage, + // not a child-owned cloned pad. Releasing the child + // closure must drop only its capture; marking that + // canonical slot scope-exited lets child teardown + // destroy/clear a value the parent still owns. + if (!captured.threadShared) { + captured.scopeExited = true; + } + } + } + entryCode.releaseCaptures(); + } + RuntimeScalar.scopeExitCleanup(childCode); + } + MortalList.flush(); + }; registry.register(this); } @@ -122,15 +155,73 @@ private void run() { } catch (Throwable thrown) { PerlThreadExitException exit = findThreadExit(thrown); if (exit != null) value = exit.values(); - else failure = thrown; + else { + PerlExitException processExit = findProcessExit(thrown); + if (processExit != null) { + registry.requestProcessExit(processExit.getExitCode()); + } + failure = thrown; + } + } + if (failure != null) { + RuntimeScalar warningSlot = GlobalVariable.getGlobalHash("main::SIG") + .get("__WARN__"); + RuntimeScalar retainedWarningHandler = retainedWarningHandler(failure); + if (retainedWarningHandler == null) { + retainedWarningHandler = childRuntime.executionState() + .pendingThreadWarningHandler; + } + childRuntime.executionState().pendingThreadWarningHandler = null; + RuntimeScalar warningHandler = warningSlot; + RuntimeScalar savedWarningSlot = null; + if ((warningHandler == null || !warningHandler.getDefinedBoolean()) + && retainedWarningHandler != null + && retainedWarningHandler.getDefinedBoolean()) { + savedWarningSlot = warningSlot == null + ? new RuntimeScalar() : new RuntimeScalar(warningSlot); + if (warningSlot == null) { + GlobalVariable.getGlobalHash("main::SIG") + .put("__WARN__", new RuntimeScalar(retainedWarningHandler)); + warningSlot = GlobalVariable.getGlobalHash("main::SIG").get("__WARN__"); + } else { + warningSlot.set(retainedWarningHandler); + } + warningHandler = warningSlot; + } + if (warningHandler != null && warningHandler.getDefinedBoolean()) { + try { + WarnDie.warn(new RuntimeScalar( + "Thread " + id + " terminated abnormally: " + + ErrorMessageUtil.stringifyException(failure)), + new RuntimeScalar()); + } catch (PerlThreadExitException threadExit) { + value = threadExit.values(); + failure = null; + } catch (PerlExitException processExit) { + registry.requestProcessExit(processExit.getExitCode()); + failure = processExit; + } finally { + if (savedWarningSlot != null && warningSlot != null) { + warningSlot.set(savedWarningSlot); + } + } + } + if (retainedWarningHandler != null) { + RuntimeScalar.scopeExitCleanup(retainedWarningHandler); + } } + Runnable cleanup = entryCleanup; + if (cleanup != null) cleanup.run(); + MortalList.flushDeferredCapturesBeforeEnd(); try { SpecialBlock.runEndBlocks(false); } catch (Throwable endFailure) { if (failure == null) failure = endFailure; } finally { + MortalList.flushDeferredCaptures(); RuntimeRegex.emitCurrentRuntimeDebugFreeTraces(); } + GlobalDestruction.runGlobalDestruction(); return new Outcome(value, failure); }); result = outcome.value(); @@ -155,7 +246,7 @@ private synchronized void finish(State terminal, Throwable failure) { public Completion join() throws InterruptedException { if (detached) throw new IllegalStateException("Cannot join a detached thread"); if (!joinClaimed.compareAndSet(false, true)) { - throw new IllegalStateException("Thread has already been joined"); + throw new IllegalStateException("Thread already joined at"); } boolean success = false; try { @@ -174,9 +265,9 @@ public Completion join() throws InterruptedException { public synchronized void detach() { if (joinClaimed.get() || state == State.JOINED) { - throw new IllegalStateException("Cannot detach a joined thread"); + throw new IllegalStateException("Cannot detach a joined thread at"); } - if (detached) throw new IllegalStateException("Thread is already detached"); + if (detached) throw new IllegalStateException("Thread already detached"); detached = true; if (finished.getCount() == 0) { state = State.DETACHED; @@ -190,6 +281,7 @@ public synchronized void detach() { public long parentId() { return parentId; } public State state() { return state; } public boolean isRunning() { return state == State.NEW || state == State.RUNNING; } + public boolean isJoining() { return state == State.JOINING; } public boolean isJoinable() { return !detached && finished.getCount() == 0 && state != State.JOINED; } public boolean isDetached() { return detached; } public PerlRuntime childRuntime() { return childRuntime; } @@ -200,6 +292,14 @@ public synchronized void detach() { public int context() { return context; } public long stackSize() { return stackSize; } + public synchronized void beginJoinWait() { + if (state == State.RUNNING) state = State.JOINING; + } + + public synchronized void endJoinWait() { + if (state == State.JOINING) state = State.RUNNING; + } + /** Deliver a Perl signal in the target runtime at its next safe point. */ public void signal(String signal) { if (!isRunning()) return; @@ -210,6 +310,15 @@ public void signal(String signal) { if (javaThread != null) javaThread.interrupt(); } + public boolean hasSignalHandler(String signal) { + PerlRuntime runtime = childRuntime; + if (runtime == null) return false; + try (PerlRuntime.Binding ignored = runtime.bind()) { + RuntimeScalar handler = GlobalVariable.getGlobalHash("main::SIG").get(signal); + return handler != null && handler.getDefinedBoolean(); + } + } + /** * Drop the completed child's package graph after its return values have * been cloned into the joining runtime. Terminal thread-object aliases @@ -218,14 +327,27 @@ public void signal(String signal) { */ public void releaseTerminalResources() { PerlRuntime runtime; + RuntimeBase terminalResult; synchronized (this) { if (state != State.JOINED && state != State.DETACHED) return; + terminalResult = result; result = null; entryPoint = null; + entryCleanup = null; runtime = childRuntime; childRuntime = null; } - if (runtime != null) runtime.close(); + if (runtime != null) { + runtime.execute(() -> { + if (terminalResult instanceof RuntimeArray values) { + MortalList.scopeExitCleanupArray(values); + } + MortalList.flush(); + MortalList.flushDeferredCaptures(); + GlobalDestruction.runGlobalDestruction(); + }); + runtime.close(); + } } private void reportAbnormalTermination() { @@ -247,4 +369,27 @@ private static PerlThreadExitException findThreadExit(Throwable thrown) { } return null; } + + private static PerlExitException findProcessExit(Throwable thrown) { + Throwable current = thrown; + while (current != null) { + if (current instanceof PerlExitException exit) return exit; + if (current.getCause() == current) break; + current = current.getCause(); + } + return null; + } + + private static RuntimeScalar retainedWarningHandler(Throwable thrown) { + Throwable current = thrown; + while (current != null) { + if (current instanceof PerlDieException die + && die.getWarningHandler() != null) { + return die.getWarningHandler(); + } + if (current.getCause() == current) break; + current = current.getCause(); + } + return null; + } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadRegistry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadRegistry.java index 6f2d87675..affe9b83f 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadRegistry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadRegistry.java @@ -9,17 +9,22 @@ import java.util.concurrent.TimeUnit; import java.util.concurrent.TimeoutException; import java.util.concurrent.atomic.AtomicLong; +import java.util.concurrent.atomic.AtomicBoolean; +import java.util.concurrent.atomic.AtomicInteger; import java.util.function.Supplier; /** Runtime-family registry for platform threads created by Perl ithreads. */ public final class PerlThreadRegistry { private final AtomicLong nextId = new AtomicLong(1); + private final AtomicLong defaultStackSize = new AtomicLong(); + private final AtomicBoolean defaultExitOnly = new AtomicBoolean(); + private final AtomicInteger requestedProcessExit = new AtomicInteger(Integer.MIN_VALUE); private final ConcurrentHashMap threads = new ConcurrentHashMap<>(); private final ConcurrentHashMap> userUnicodeProperties = new ConcurrentHashMap<>(); private final ConcurrentHashMap terminalThreads = new ConcurrentHashMap<>(); - long allocateId() { + public long allocateId() { return nextId.getAndIncrement(); } @@ -57,12 +62,30 @@ public int size() { return threads.size(); } + public long defaultStackSize() { return defaultStackSize.get(); } + public void setDefaultStackSize(long value) { defaultStackSize.set(value); } + public boolean defaultExitOnly() { return defaultExitOnly.get(); } + public void setDefaultExitOnly(boolean value) { defaultExitOnly.set(value); } + + /** Publish the first process-wide exit requested by a non-thread-only child. */ + public void requestProcessExit(int status) { + requestedProcessExit.compareAndSet(Integer.MIN_VALUE, status); + } + + public int requestedProcessExitOr(int fallback) { + int requested = requestedProcessExit.get(); + return requested == Integer.MIN_VALUE ? fallback : requested; + } + void clearTerminalStateForReset() { if (!threads.isEmpty() || !userUnicodeProperties.isEmpty()) { throw new IllegalStateException("Thread registry is not quiescent"); } terminalThreads.clear(); nextId.set(1); + defaultStackSize.set(0); + defaultExitOnly.set(false); + requestedProcessExit.set(Integer.MIN_VALUE); } /** Format Perl's process-exit diagnostic for attached, unjoined children. */ diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java index 98a2346d5..2906ee036 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java @@ -562,6 +562,32 @@ public static boolean hasStrongCycle(RuntimeBase target) { return false; } + /** + * Return whether {@code target} is strongly reachable from an explicit + * set of roots. Runtime snapshots use this before the child entry CODE is + * installed on an execution stack: its captures are already real Perl + * owners, but the ordinary live-root queries cannot see them yet. + */ + static boolean isReachableFromStrongRoots( + RuntimeBase target, java.util.List roots) { + if (target == null || roots == null || roots.isEmpty()) return false; + final int MAX_VISITS = 50_000; + Set seen = Collections.newSetFromMap(new IdentityHashMap<>()); + java.util.ArrayDeque todo = new java.util.ArrayDeque<>(); + for (RuntimeBase root : roots) { + if (root == null) continue; + if (root == target) return true; + if (seen.add(root)) todo.addLast(root); + } + int visits = 0; + while (!todo.isEmpty() && visits++ < MAX_VISITS) { + if (enqueueStrongEdges(todo.removeFirst(), target, seen, todo)) { + return true; + } + } + return false; + } + private static boolean enqueueStrongEdges(RuntimeBase cur, RuntimeBase target, Set seen, java.util.ArrayDeque todo) { @@ -710,9 +736,15 @@ && followGlobalCodeCaptures(code, target, seen, todo)) { } public static boolean hasLiveStrongScalarReferent(RuntimeBase target) { + return hasLiveStrongScalarReferentOtherThan(target, null); + } + + public static boolean hasLiveStrongScalarReferentOtherThan( + RuntimeBase target, RuntimeScalar excluded) { if (target == null) return false; for (Object liveVar : MyVarCleanupStack.snapshotLiveVars()) { if (liveVar instanceof RuntimeScalar sc + && sc != excluded && !WeakRefRegistry.isweak(sc) && !sc.scopeExited && sc.value == target) { @@ -721,6 +753,7 @@ public static boolean hasLiveStrongScalarReferent(RuntimeBase target) { } for (RuntimeScalar sc : ScalarRefRegistry.snapshot()) { if (sc == null) continue; + if (sc == excluded) continue; if (WeakRefRegistry.isweak(sc)) continue; if (sc.scopeExited) continue; if (!MyVarCleanupStack.isLive(sc)) continue; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java index fdb04ab6d..f1e85cf8a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java @@ -102,6 +102,7 @@ private RuntimeArrayElementList(RuntimeArray owner, int initialCapacity) { @Override public boolean add(RuntimeScalar value) { + if (owner.threadShared) SharedPerlStorage.publishBlessing(value); owner.noteIsaMutation(); owner.notePackageRootMutation(null, value); if (value != null) value.markContainerOwner(owner); @@ -111,6 +112,7 @@ public boolean add(RuntimeScalar value) { @Override public void add(int index, RuntimeScalar element) { + if (owner.threadShared) SharedPerlStorage.publishBlessing(element); owner.noteIsaMutation(); owner.notePackageRootMutation(null, element); if (element != null) element.markContainerOwner(owner); @@ -123,6 +125,7 @@ public boolean addAll(java.util.Collection c) { if (!c.isEmpty()) owner.noteIsaMutation(); owner.notePackageRootMutationIf(owner.hasRootEdge(c)); for (RuntimeScalar value : c) { + if (owner.threadShared) SharedPerlStorage.publishBlessing(value); if (value != null) value.markContainerOwner(owner); owner.markPackageRootedValue(value); } @@ -134,6 +137,7 @@ public boolean addAll(int index, java.util.Collection c if (!c.isEmpty()) owner.noteIsaMutation(); owner.notePackageRootMutationIf(owner.hasRootEdge(c)); for (RuntimeScalar value : c) { + if (owner.threadShared) SharedPerlStorage.publishBlessing(value); if (value != null) value.markContainerOwner(owner); owner.markPackageRootedValue(value); } @@ -143,6 +147,7 @@ public boolean addAll(int index, java.util.Collection c @Override public RuntimeScalar set(int index, RuntimeScalar element) { RuntimeScalar previous = super.get(index); + if (owner.threadShared) SharedPerlStorage.publishBlessing(element); owner.noteIsaMutation(); owner.notePackageRootMutation(previous, element); if (element != null) element.markContainerOwner(owner); @@ -1370,8 +1375,13 @@ public void setLastElementIndex(RuntimeScalar value) { } else { while (newSize < currentSize) { currentSize--; - elements.removeLast(); + RuntimeScalar removed = elements.removeLast(); + if (removed != null) { + MortalList.deferDestroyForContainerClear( + java.util.Collections.singletonList(removed)); + } } + MortalList.flush(); } } case AUTOVIVIFY_ARRAY -> { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArrayProxyEntry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArrayProxyEntry.java index 02cea08d9..bcb2ba718 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArrayProxyEntry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArrayProxyEntry.java @@ -37,6 +37,7 @@ public RuntimeArrayProxyEntry(RuntimeArray parent, int key) { @Override public RuntimeScalar set(RuntimeScalar value) { vivify(); + if (parent.threadShared) SharedPerlStorage.publishBlessing(value); parent.markPackageRootedValue(lvalue); RuntimeScalar result = super.set(value); if (!parent.elementsAliased) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java index a96553627..6c3f57c0f 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java @@ -1,6 +1,7 @@ package org.perlonjava.runtime.runtimetypes; import java.util.Iterator; +import java.util.Objects; import static org.perlonjava.runtime.runtimetypes.RuntimeScalarCache.scalarUndef; @@ -27,6 +28,8 @@ public abstract class RuntimeBase implements DynamicState, Iterable inheritedHandles = new IdentityHashMap<>(); private final List weakReferences = new ArrayList<>(); + private final List snapshotStrongRoots = new ArrayList<>(); private final Set skippedClasses; private int publicDepth; @@ -82,6 +83,18 @@ public List cloneRoots(List roots) { } } + /** + * Add thread-entry roots while a runtime snapshot is still being built. + * Weak edges and observed-address publication are finalized only after the + * package graph, entry CODE, and arguments all share this identity map. + */ + List cloneSnapshotRoots(List roots) { + List result = new ArrayList<>(roots.size()); + for (RuntimeBase root : roots) result.add(cloneValue(root)); + snapshotStrongRoots.addAll(result); + return result; + } + private void finishCloneBoundary() { Map observed = sourceRuntime.snapshotReferenceAddresses(); // A stringified object can remain visible only through a weak Perl @@ -144,7 +157,12 @@ protected RuntimeBase cloneCode(RuntimeCode source) { RuntimeCode target; if (source instanceof InterpretedCode interpreted) { - target = cloneInterpretedCode(interpreted); + // cloneInterpretedCode copies metadata itself because it is also + // used for an interpreted body nested inside a lazy RuntimeCode + // wrapper. Do not copy it a second time here: capture metadata + // retains every captured scalar, and a duplicate retain leaks + // shared lexical storage across the child snapshot boundary. + return cloneInterpretedCode(interpreted); } else if (source.subroutine instanceof InterpretedCode interpreted) { // Lazy named subs keep their stable RuntimeCode placeholder and // install the materialized interpreter body into subroutine/codeObject. @@ -720,11 +738,13 @@ private void copyScalarMetadata(RuntimeScalar source, RuntimeScalar target) { private void copyBase(RuntimeBase source, RuntimeBase target) { target.threadShared = source.threadShared; target.threadSharedIdentity = source.threadSharedIdentity; - target.threadSharedBlessName = source.threadSharedBlessName; target.threadSharedLifecycle = source.threadSharedLifecycle; - if (source.threadShared && source.threadSharedBlessName != null) { + target.threadSharedRuntimeView = source.threadShared && sourceRuntime != targetRuntime; + target.threadSharedBlessName = source.threadSharedLifecycle == null + ? source.threadSharedBlessName : source.threadSharedLifecycle.publishedBlessName; + if (source.threadShared && target.threadSharedBlessName != null) { try (PerlRuntime.Binding ignored = targetRuntime.bind()) { - target.blessId = NameNormalizer.getBlessId(source.threadSharedBlessName); + target.blessId = NameNormalizer.getBlessId(target.threadSharedBlessName); } } else { target.blessId = cloneBlessId(source.blessId); @@ -773,9 +793,10 @@ private void finishWeakReferences() { if (weakReferences.isEmpty()) return; try (PerlRuntime.Binding ignored = targetRuntime.bind()) { for (RuntimeScalar weakReference : weakReferences) { - WeakRefRegistry.weaken(weakReference); + WeakRefRegistry.weakenForSnapshot(weakReference, snapshotStrongRoots); } } weakReferences.clear(); + snapshotStrongRoots.clear(); } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java index b5b60ad2c..b1b088503 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java @@ -92,6 +92,7 @@ private RuntimeHashElementMap(RuntimeHash owner) { @Override public RuntimeScalar put(String key, RuntimeScalar value) { + if (owner.threadShared) SharedPerlStorage.publishBlessing(value); if (owner.isEnvironmentHash && value != null && !(value instanceof RuntimeEnvironmentScalar)) { @@ -117,6 +118,7 @@ public void putAll(Map m) { } owner.notePackageRootMutationIf(invalidates); for (RuntimeScalar value : m.values()) { + if (owner.threadShared) SharedPerlStorage.publishBlessing(value); if (value != null) value.markContainerOwner(owner); owner.markPackageRootedValue(value); } @@ -476,7 +478,9 @@ public void put(String key, RuntimeScalar value) { // slot container. This matters for pure-Perl deep-cloners // which preserve referent identity while populating hashes. RuntimeScalar existing = elements.get(key); - if (existing != null + if (isDestroyRescueAssignment(existing, value)) { + value.addToScalar(existing); + } else if (existing != null && existing.type != READONLY_SCALAR && !(existing instanceof RuntimeScalarReadOnly) && isAggregateClearAssignment(existing, value)) { @@ -489,7 +493,9 @@ && isAggregateClearAssignment(existing, value)) { case AUTOVIVIFY_HASH -> { AutovivificationHash.vivify(this); RuntimeScalar existing = elements.get(key); - if (existing != null + if (isDestroyRescueAssignment(existing, value)) { + value.addToScalar(existing); + } else if (existing != null && existing.type != READONLY_SCALAR && !(existing instanceof RuntimeScalarReadOnly) && isAggregateClearAssignment(existing, value)) { @@ -509,6 +515,25 @@ && isAggregateClearAssignment(existing, value)) { } } + /** + * DBIx::Class rescues a Schema from DESTROY by replacing a ResultSource's + * weak {@code schema} element with a strong reference to the same object. + * Keep that existing Perl scalar slot so setLargeRefCounted can remove the + * weak registration and record resurrection. Replacing the Java map value + * bypasses both operations and clears every sibling weak back-reference. + */ + private static boolean isDestroyRescueAssignment( + RuntimeScalar existing, RuntimeScalar replacement) { + if (PerlRuntime.currentOrNull() == null) return false; + RuntimeBase target = DestroyDispatch.currentDestroyTarget(); + return target != null + && existing != null + && replacement != null + && WeakRefRegistry.isweak(existing) + && existing.value == target + && replacement.value == target; + } + /** * Store a scalar produced by a deep-clone operation and acquire the * destination hash slot's reference-count ownership. Unlike normal put(), diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHashProxyEntry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHashProxyEntry.java index c0f544136..e5a4ce5b3 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHashProxyEntry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHashProxyEntry.java @@ -96,6 +96,12 @@ void vivify() { } } + @Override + public RuntimeScalar set(RuntimeScalar value) { + if (parent.threadShared) SharedPerlStorage.publishBlessing(value); + return super.set(value); + } + /** Replace this hash slot with the scalar referenced by a refaliasing RHS. */ public RuntimeScalar aliasToReference(RuntimeScalar reference) { RuntimeScalar referent = reference.scalarDeref(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index ed9b4349d..e4ddd0ebb 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -1490,6 +1490,17 @@ public void releaseOwnedScalarReferenceContents() { // Types < TIED_SCALAR (0-8) never have REFERENCE_BIT (0x8000), so no // reference check is needed here — all reference types route to setLarge(). public RuntimeScalar set(RuntimeScalar value) { + if (threadShared && value != null && RuntimeScalarType.isReference(value)) { + RuntimeBase assigned = SharedPerlStorage.referent(value); + if (assigned == null || !assigned.threadShared) { + throw new PerlCompilerException("Invalid value for shared scalar"); + } + // Assignment into a shared scalar publishes the referent's current + // class. A local shared reference may be reblessed privately, but + // storing it in shared scalar storage is the explicit publication + // boundary used by threads::shared. + SharedPerlStorage.publishBlessing(value); + } // Perl clears pos() when assigning from another SV ($x = $y), but preserves it for // self-assignment ($x = $x). Hash/array element slots reuse one RuntimeScalar per key; // $h{k} = $str must reset pos on that slot (Data::SExpression set_input / lexer \G). @@ -1750,7 +1761,7 @@ private RuntimeScalar setLargeRefCounted(RuntimeScalar value) { } boolean oldOwnedScalarReferenceContents = this.ownsScalarReferenceContents; RuntimeScalar oldScalarReferenceContents = scalarReferenceContentsReferent(this); - boolean shouldClearRescuedAfterUndefAssignment = false; + boolean shouldReleaseUnrootedRescuedGraph = false; // If this scalar was a weak ref, remove from weak tracking before overwriting. // Weak refs don't count toward refCount, so skip refCount decrement later. @@ -1950,6 +1961,8 @@ private RuntimeScalar setLargeRefCounted(RuntimeScalar value) { // preserving nested metadata owners such as Sub::Quote's saved info. if ((oldBase instanceof RuntimeArray || oldBase instanceof RuntimeHash) && !thisWasWeak + && !DestroyDispatch.isRescued(oldBase) + && !(oldBase.blessId != 0 && blessedClassHasDestroy(oldBase)) && WeakRefRegistry.hasWeakRefsTo(oldBase) && (RuntimeCode.argsStackDepth() <= 1 || oldBase.clearedOwnedAggregateElement) @@ -1959,15 +1972,12 @@ private RuntimeScalar setLargeRefCounted(RuntimeScalar value) { WeakRefRegistry.clearWeakRefsTo(oldBase); } - if (undefAssignmentOfDestroyableRef) { - if (!DestroyDispatch.isInsideDestroy()) { - shouldClearRescuedAfterUndefAssignment = true; - } - } - if (oldOwnedScalarReferenceContents) { releaseScalarReferenceContents(oldScalarReferenceContents); } + if (undefAssignmentOfDestroyableRef && !DestroyDispatch.isInsideDestroy()) { + shouldReleaseUnrootedRescuedGraph = true; + } // WEAKLY_TRACKED objects: do NOT clear weak refs on overwrite. // These objects have refCount == -2 and their strong refs don't have @@ -2004,27 +2014,17 @@ private RuntimeScalar setLargeRefCounted(RuntimeScalar value) { MortalList.popTemporaryRoot(this); } - // `undef($x)` can compile through this assignment path instead of - // RuntimeScalar.undefine(). If this exact object was rescued during its - // DESTROY, clear weak refs reachable from it now so DBIC-style callbacks - // observe that the user's schema lexical is gone. Do not drain all - // rescued objects here; DBIC can have other live schemas pending. - if (shouldClearRescuedAfterUndefAssignment + // An explicit undef can run DESTROY and let the object self-rescue. + // Preserve real Perl resurrection when another package/closure root + // still reaches that graph. If the only remaining pin is the runtime's + // rescued-object queue, release its nested weak callbacks now: DBIC's + // retained DBI handle relies on its weak HandleError closure observing + // that the owning Schema/Storage graph has gone away. + if (shouldReleaseUnrootedRescuedGraph && DestroyDispatch.isRescued(oldBase) - && !ModuleInitGuard.inModuleInit()) { - boolean externallyReachable = - ReachabilityWalker.isReachableFromExternalRootExcludingRescued(oldBase); - if (System.getenv("JPERL_PHASE_D_DBG") != null) { - System.err.println("DBG Phase D set-undef rescued cleanup for " + - (oldBase != null ? org.perlonjava.runtime.runtimetypes.NameNormalizer.getBlessStr(oldBase.blessId) : "?") + - " refCount=" + (oldBase != null ? oldBase.refCount : -1) + - " externallyReachable=" + externallyReachable); - } - if (externallyReachable) { - DestroyDispatch.clearRescuedWeakRefsToSelfOnly(oldBase); - } else { - DestroyDispatch.clearRescuedWeakRefsTo(oldBase); - } + && !ModuleInitGuard.inModuleInit() + && !ReachabilityWalker.isReachableFromExternalRootExcludingRescued(oldBase)) { + DestroyDispatch.clearNestedWeakRefsForRescued(oldBase); } if (isPackageGlobalRoot && globalCodeRefFqn != null) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/SharedElementProxy.java b/src/main/java/org/perlonjava/runtime/runtimetypes/SharedElementProxy.java index 63e790de7..b165c3442 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/SharedElementProxy.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/SharedElementProxy.java @@ -12,21 +12,26 @@ final class SharedElementProxy extends RuntimeScalar { super(storage); this.storage = storage; this.value = localView; + // A fetched shared reference is a real, short-lived Perl proxy owner. + // Register that owner so releasing the proxy suppresses DESTROY on its + // runtime-local view while the canonical shared slot still exists. + RuntimeScalar.incrementRefCountForContainerStore(this); } @Override public RuntimeScalar set(RuntimeScalar value) { SharedPerlStorage.publishBlessing(value); - RuntimeScalar result = storage.set(value); - super.set(value); - return result; + // The proxy is a transient FETCH view, not a second Perl scalar slot. + // Updating it through RuntimeScalar.set() would acquire a second + // refCount owner for the replacement. That owner survives after the + // proxy is discarded and delays DESTROY when the shared container is + // subsequently cleared or shrunk. + return storage.set(value); } @Override public RuntimeScalar undefine() { - RuntimeScalar result = storage.undefine(); - super.undefine(); - return result; + return storage.undefine(); } @Override diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/SharedPerlStorage.java b/src/main/java/org/perlonjava/runtime/runtimetypes/SharedPerlStorage.java index feae5d742..9d5e1b06b 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/SharedPerlStorage.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/SharedPerlStorage.java @@ -83,12 +83,36 @@ private record Waiter(CountDownLatch latch) {} public static RuntimeBase referent(RuntimeScalar reference) { if (reference == null) return null; - return reference.value instanceof RuntimeBase base ? base : reference; + RuntimeBase current = reference; + Set visited = Collections.newSetFromMap(new IdentityHashMap<>()); + while (current instanceof RuntimeScalar scalar + && !current.threadShared + && (scalar.type & RuntimeScalarType.REFERENCE_BIT) != 0 + && scalar.value instanceof RuntimeBase next + && visited.add(current)) { + current = next; + } + return current; } public static RuntimeBase share(RuntimeScalar reference) { RuntimeBase root = referent(reference); - return shareValue(root); + if (root == null) { + throw new IllegalArgumentException("share requires a scalar, array, or hash reference"); + } + validateShareRoot(root); + + // Perl's public share() initializes shared storage. It preserves a + // scalar value but clears aggregate contents, including on re-share. + // The aggregate shell retains its blessing metadata. + if (root instanceof RuntimeArray array && array.type == RuntimeArray.PLAIN_ARRAY) { + array.setFromList(new RuntimeList()); + } else if (root instanceof RuntimeHash hash && hash.type == RuntimeHash.PLAIN_HASH) { + hash.setFromList(new RuntimeList()); + } + + markGraph(root, Collections.newSetFromMap(new IdentityHashMap<>())); + return root; } /** Mark declaration storage directly, without manufacturing a reference wrapper. */ @@ -107,10 +131,49 @@ public static boolean isShared(RuntimeScalar reference) { return root != null && root.threadShared; } + /** Stable numeric identity for one canonical shared storage graph node. */ + public static long sharedId(RuntimeScalar reference) { + RuntimeBase current = reference; + List path = new ArrayList<>(); + Map positions = new IdentityHashMap<>(); + while (current instanceof RuntimeScalar scalar) { + Integer cycleStart = positions.putIfAbsent(current, path.size()); + if (cycleStart != null) { + long identity = Long.MAX_VALUE; + for (int i = cycleStart; i < path.size(); i++) { + RuntimeBase member = path.get(i); + if (member.threadShared) { + identity = Math.min(identity, Integer.toUnsignedLong( + System.identityHashCode(sharedIdentity(member)))); + } + } + return identity == Long.MAX_VALUE ? 0L : identity; + } + path.add(current); + if ((scalar.type & RuntimeScalarType.REFERENCE_BIT) == 0 + || !(scalar.value instanceof RuntimeBase next)) { + return current.threadShared + ? Integer.toUnsignedLong(System.identityHashCode(sharedIdentity(current))) + : 0L; + } + current = next; + } + return current != null && current.threadShared + ? Integer.toUnsignedLong(System.identityHashCode(sharedIdentity(current))) + : 0L; + } + + /** Number of runtime views that may currently access shared storage. */ + public static int sharedReferenceCount(RuntimeScalar reference) { + RuntimeBase root = referent(reference); + if (root == null || !root.threadShared) return 0; + return 1 + PerlRuntime.current().threadRegistry().snapshot().size(); + } + public static RuntimeScalar sharedClone(RuntimeScalar reference) { PerlRuntime runtime = PerlRuntime.current(); RuntimeScalar clone = new RuntimeGraphCloner(runtime, runtime).cloneGraph(reference); - share(clone); + shareValue(referent(clone)); return clone; } @@ -166,9 +229,7 @@ public static boolean conditionSignal(RuntimeScalar conditionReference, boolean RuntimeBase condition = requireShared(conditionReference, broadcast ? "cond_broadcast" : "cond_signal"); Object conditionIdentity = sharedIdentity(condition); - if (!lockState(condition).lock.isHeldByCurrentThread()) { - return false; - } + boolean locked = lockState(condition).lock.isHeldByCurrentThread(); List wake = new ArrayList<>(); synchronized (WAITERS) { @@ -183,7 +244,10 @@ public static boolean conditionSignal(RuntimeScalar conditionReference, boolean } } for (Waiter waiter : wake) waiter.latch().countDown(); - return true; + // Perl permits signaling a condition while a distinct lock is held. + // It emits a threads warning because the condition variable itself is + // unlocked, but it still wakes the waiter. + return locked || PerlRuntime.current().hasSharedLock(); } private static boolean conditionWait(RuntimeScalar conditionReference, @@ -293,6 +357,26 @@ private static void validateGraph(RuntimeBase value, Set seen) { throw new IllegalArgumentException("Unsupported shared value type " + value.getClass().getName()); } + /** Validate only the storage shell that destructive public share() retains. */ + private static void validateShareRoot(RuntimeBase value) { + if (value.blessId != 0) { + PerlRuntime runtime = PerlRuntime.currentOrNull(); + if (runtime == null || NameNormalizer.getBlessStr(value.blessId) == null) { + throw new IllegalArgumentException("Cannot share a value with an unknown blessing"); + } + } + if (value instanceof RuntimeScalar) return; + if (value instanceof RuntimeArray array) { + if (array.type == RuntimeArray.PLAIN_ARRAY || array.type == RuntimeArray.TIED_ARRAY) return; + throw new IllegalArgumentException("Unsupported shared array type " + array.type); + } + if (value instanceof RuntimeHash hash) { + if (hash.type == RuntimeHash.PLAIN_HASH || hash.type == RuntimeHash.TIED_HASH) return; + throw new IllegalArgumentException("Unsupported shared hash type " + hash.type); + } + throw new IllegalArgumentException("Unsupported shared value type " + value.getClass().getName()); + } + private static void markGraph(RuntimeBase value, Set seen) { if (value == null || !seen.add(value)) return; if (value instanceof RuntimeScalar scalar) { @@ -345,6 +429,7 @@ private static void markShared(RuntimeBase value) { value.threadSharedLifecycle = new RuntimeBase.SharedLifecycle(); } value.threadSharedBlessName = currentBlessName(value); + value.threadSharedLifecycle.publishedBlessName = value.threadSharedBlessName; value.threadShared = true; } } @@ -364,9 +449,13 @@ static RuntimeScalar fetchedElement(RuntimeBase owner, RuntimeScalar stored) { } /** Publish the local class of a shared view when that view is stored. */ - static void publishBlessing(RuntimeScalar value) { + public static void publishBlessing(RuntimeScalar value) { if (value != null && value.value instanceof RuntimeBase base && base.threadShared) { - base.threadSharedBlessName = currentBlessName(base); + String className = currentBlessName(base); + base.threadSharedBlessName = className; + if (base.threadSharedLifecycle != null) { + base.threadSharedLifecycle.publishedBlessName = className; + } } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java index 1b262e20e..86d1bd540 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java @@ -68,6 +68,18 @@ public static void resetState() { * deterministically (see Strategy A in weaken-destroy.md). */ public static void weaken(RuntimeScalar ref) { + weaken(ref, java.util.List.of()); + } + + /** Install a cloned weak edge while treating the not-yet-running thread + * entry graph as a strong root. */ + static void weakenForSnapshot( + RuntimeScalar ref, java.util.List snapshotRoots) { + weaken(ref, snapshotRoots); + } + + private static void weaken( + RuntimeScalar ref, java.util.List snapshotRoots) { if (ref.destroySelfArgument || ref instanceof RuntimeScalarReadOnly || ref.type == RuntimeScalarType.READONLY_SCALAR) { @@ -159,6 +171,7 @@ && hasWeakRefsTo(base) && (ReachabilityWalker.isReachableFromRoots(base) || ReachabilityWalker.isReachableFromLiveScalarRegistry(base) || ReachabilityWalker.isReachableFromLiveCodeCaptures(base) + || ReachabilityWalker.isReachableFromStrongRoots(base, snapshotRoots) || RuntimeCode.isInstalledPadConstant(base))) { // A temporary probe can be weakened without owning the last // strong Perl reference. Test::Refcount does this when it diff --git a/src/main/perl/lib/B.pm b/src/main/perl/lib/B.pm index d39d528ba..f5508aec5 100644 --- a/src/main/perl/lib/B.pm +++ b/src/main/perl/lib/B.pm @@ -85,7 +85,10 @@ package B::SV { # (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 ✓ - Internals::SvREFCNT($_[0]->{ref}); + # 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. + Internals::SvREFCNT($_[0]->{ref}, 1); } sub object_2svref { diff --git a/src/main/perl/lib/Thread/Queue.pm b/src/main/perl/lib/Thread/Queue.pm new file mode 100644 index 000000000..731d0b2f4 --- /dev/null +++ b/src/main/perl/lib/Thread/Queue.pm @@ -0,0 +1,657 @@ +package Thread::Queue; + +use strict; +use warnings; + +our $VERSION = '3.14'; # remember to update version in POD! +$VERSION = eval $VERSION; + +use threads::shared 1.21; +use Scalar::Util 1.10 qw(looks_like_number blessed reftype refaddr); + +# Carp errors from threads::shared calls should complain about caller +our @CARP_NOT = ("threads::shared"); + +# Create a new queue possibly pre-populated with items +sub new +{ + my $class = shift; + my @queue :shared = map { shared_clone($_) } @_; + my %self :shared = ( 'queue' => \@queue ); + return bless(\%self, $class); +} + +# Add items to the tail of a queue +sub enqueue +{ + my $self = shift; + lock(%$self); + + if ($$self{'ENDED'}) { + require Carp; + Carp::croak("'enqueue' method called on queue that has been 'end'ed"); + } + + # Block if queue size exceeds any specified limit + my $queue = $$self{'queue'}; + cond_wait(%$self) while ($$self{'LIMIT'} && (@$queue >= $$self{'LIMIT'})); + + # Add items to queue, and then signal other threads + push(@$queue, map { shared_clone($_) } @_) + and cond_signal(%$self); +} + +# Set or return the max. size for a queue +sub limit : lvalue +{ + my $self = shift; + lock(%$self); + $$self{'LIMIT'}; +} + +# Return a count of the number of items on a queue +sub pending +{ + my $self = shift; + lock(%$self); + return if ($$self{'ENDED'} && ! @{$$self{'queue'}}); + return scalar(@{$$self{'queue'}}); +} + +# Indicate that no more data will enter the queue +sub end +{ + my $self = shift; + lock(%$self); + # No more data is coming + $$self{'ENDED'} = 1; + + cond_signal(%$self); # Unblock possibly waiting threads +} + +# Return 1 or more items from the head of a queue, blocking if needed +sub dequeue +{ + my $self = shift; + lock(%$self); + my $queue = $$self{'queue'}; + + my $count = @_ ? $self->_validate_count(shift) : 1; + + # Wait for requisite number of items + cond_wait(%$self) while ((@$queue < $count) && ! $$self{'ENDED'}); + + # If no longer blocking, try getting whatever is left on the queue + return $self->dequeue_nb($count) if ($$self{'ENDED'}); + + # Return single item + if ($count == 1) { + my $item = shift(@$queue); + cond_signal(%$self); # Unblock possibly waiting threads + return $item; + } + + # Return multiple items + my @items; + push(@items, shift(@$queue)) for (1..$count); + cond_signal(%$self); # Unblock possibly waiting threads + return @items; +} + +# Return items from the head of a queue with no blocking +sub dequeue_nb +{ + my $self = shift; + lock(%$self); + my $queue = $$self{'queue'}; + + my $count = @_ ? $self->_validate_count(shift) : 1; + + # Return single item + if ($count == 1) { + my $item = shift(@$queue); + cond_signal(%$self); # Unblock possibly waiting threads + return $item; + } + + # Return multiple items + my @items; + for (1..$count) { + last if (! @$queue); + push(@items, shift(@$queue)); + } + cond_signal(%$self); # Unblock possibly waiting threads + return @items; +} + +# Return items from the head of a queue, blocking if needed up to a timeout +sub dequeue_timed +{ + my $self = shift; + lock(%$self); + my $queue = $$self{'queue'}; + + # Timeout may be relative or absolute + my $timeout = @_ ? $self->_validate_timeout(shift) : -1; + # Convert to an absolute time for use with cond_timedwait() + if ($timeout < 32000000) { # More than one year + $timeout += time(); + } + + my $count = @_ ? $self->_validate_count(shift) : 1; + + # Wait for requisite number of items, or until timeout + while ((@$queue < $count) && ! $$self{'ENDED'}) { + last if (! cond_timedwait(%$self, $timeout)); + } + + # Get whatever we need off the queue if available + return $self->dequeue_nb($count); +} + +# Return an item without removing it from a queue +sub peek +{ + my $self = shift; + lock(%$self); + my $index = @_ ? $self->_validate_index(shift) : 0; + return $$self{'queue'}[$index]; +} + +# Insert items anywhere into a queue +sub insert +{ + my $self = shift; + lock(%$self); + + if ($$self{'ENDED'}) { + require Carp; + Carp::croak("'insert' method called on queue that has been 'end'ed"); + } + + my $queue = $$self{'queue'}; + + my $index = $self->_validate_index(shift); + + return if (! @_); # Nothing to insert + + # Support negative indices + if ($index < 0) { + $index += @$queue; + if ($index < 0) { + $index = 0; + } + } + + # Dequeue items from $index onward + my @tmp; + while (@$queue > $index) { + unshift(@tmp, pop(@$queue)) + } + + # Add new items to the queue + push(@$queue, map { shared_clone($_) } @_); + + # Add previous items back onto the queue + push(@$queue, @tmp); + + cond_signal(%$self); # Unblock possibly waiting threads +} + +# Remove items from anywhere in a queue +sub extract +{ + my $self = shift; + lock(%$self); + my $queue = $$self{'queue'}; + + my $index = @_ ? $self->_validate_index(shift) : 0; + my $count = @_ ? $self->_validate_count(shift) : 1; + + # Support negative indices + if ($index < 0) { + $index += @$queue; + if ($index < 0) { + $count += $index; + return if ($count <= 0); # Beyond the head of the queue + return $self->dequeue_nb($count); # Extract from the head + } + } + + # Dequeue items from $index+$count onward + my @tmp; + while (@$queue > ($index+$count)) { + unshift(@tmp, pop(@$queue)) + } + + # Extract desired items + my @items; + unshift(@items, pop(@$queue)) while (@$queue > $index); + + # Add back any removed items + push(@$queue, @tmp); + + cond_signal(%$self); # Unblock possibly waiting threads + + # Return single item + return $items[0] if ($count == 1); + + # Return multiple items + return @items; +} + +### Internal Methods ### + +# Check value of the requested index +sub _validate_index +{ + my $self = shift; + my $index = shift; + + if (! defined($index) || + ! looks_like_number($index) || + (int($index) != $index)) + { + require Carp; + my ($method) = (caller(1))[3]; + my $class_name = ref($self); + $method =~ s/$class_name\:://; + $index = 'undef' if (! defined($index)); + Carp::croak("Invalid 'index' argument ($index) to '$method' method"); + } + + return $index; +}; + +# Check value of the requested count +sub _validate_count +{ + my $self = shift; + my $count = shift; + + if (! defined($count) || + ! looks_like_number($count) || + (int($count) != $count) || + ($count < 1) || + ($$self{'LIMIT'} && $count > $$self{'LIMIT'})) + { + require Carp; + my ($method) = (caller(1))[3]; + my $class_name = ref($self); + $method =~ s/$class_name\:://; + $count = 'undef' if (! defined($count)); + if ($$self{'LIMIT'} && $count > $$self{'LIMIT'}) { + Carp::croak("'count' argument ($count) to '$method' method exceeds queue size limit ($$self{'LIMIT'})"); + } else { + Carp::croak("Invalid 'count' argument ($count) to '$method' method"); + } + } + + return $count; +}; + +# Check value of the requested timeout +sub _validate_timeout +{ + my $self = shift; + my $timeout = shift; + + if (! defined($timeout) || + ! looks_like_number($timeout)) + { + require Carp; + my ($method) = (caller(1))[3]; + my $class_name = ref($self); + $method =~ s/$class_name\:://; + $timeout = 'undef' if (! defined($timeout)); + Carp::croak("Invalid 'timeout' argument ($timeout) to '$method' method"); + } + + return $timeout; +}; + +1; + +=head1 NAME + +Thread::Queue - Thread-safe queues + +=head1 VERSION + +This document describes Thread::Queue version 3.14 + +=head1 SYNOPSIS + + use strict; + use warnings; + + use threads; + use Thread::Queue; + + my $q = Thread::Queue->new(); # A new empty queue + + # Worker thread + my $thr = threads->create( + sub { + # Thread will loop until no more work + while (defined(my $item = $q->dequeue())) { + # Do work on $item + ... + } + } + ); + + # Send work to the thread + $q->enqueue($item1, ...); + # Signal that there is no more work to be sent + $q->end(); + # Join up with the thread when it finishes + $thr->join(); + + ... + + # Count of items in the queue + my $left = $q->pending(); + + # Non-blocking dequeue + if (defined(my $item = $q->dequeue_nb())) { + # Work on $item + } + + # Blocking dequeue with 5-second timeout + if (defined(my $item = $q->dequeue_timed(5))) { + # Work on $item + } + + # Set a size for a queue + $q->limit = 5; + + # Get the second item in the queue without dequeuing anything + my $item = $q->peek(1); + + # Insert two items into the queue just behind the head + $q->insert(1, $item1, $item2); + + # Extract the last two items on the queue + my ($item1, $item2) = $q->extract(-2, 2); + +=head1 DESCRIPTION + +This module provides thread-safe FIFO queues that can be accessed safely by +any number of threads. + +Any data types supported by L can be passed via queues: + +=over + +=item Ordinary scalars + +=item Array refs + +=item Hash refs + +=item Scalar refs + +=item Objects based on the above + +=back + +Ordinary scalars are added to queues as they are. + +If not already thread-shared, the other complex data types will be cloned +(recursively, if needed, and including any Cings and read-only +settings) into thread-shared structures before being placed onto a queue. + +For example, the following would cause L to create a empty, +shared array reference via C<&shared([])>, copy the elements 'foo', 'bar' +and 'baz' from C<@ary> into it, and then place that shared reference onto +the queue: + + my @ary = qw/foo bar baz/; + $q->enqueue(\@ary); + +However, for the following, the items are already shared, so their references +are added directly to the queue, and no cloning takes place: + + my @ary :shared = qw/foo bar baz/; + $q->enqueue(\@ary); + + my $obj = &shared({}); + $$obj{'foo'} = 'bar'; + $$obj{'qux'} = 99; + bless($obj, 'My::Class'); + $q->enqueue($obj); + +See L for caveats related to passing objects via queues. + +=head1 QUEUE CREATION + +=over + +=item ->new() + +Creates a new empty queue. + +=item ->new(LIST) + +Creates a new queue pre-populated with the provided list of items. + +=back + +=head1 BASIC METHODS + +The following methods deal with queues on a FIFO basis. + +=over + +=item ->enqueue(LIST) + +Adds a list of items onto the end of the queue. + +=item ->dequeue() + +=item ->dequeue(COUNT) + +Removes the requested number of items (default is 1) from the head of the +queue, and returns them. If the queue contains fewer than the requested +number of items, then the thread will be blocked until the requisite number +of items are available (i.e., until other threads C more items). + +=item ->dequeue_nb() + +=item ->dequeue_nb(COUNT) + +Removes the requested number of items (default is 1) from the head of the +queue, and returns them. If the queue contains fewer than the requested +number of items, then it immediately (i.e., non-blocking) returns whatever +items there are on the queue. If the queue is empty, then C is +returned. + +=item ->dequeue_timed(TIMEOUT) + +=item ->dequeue_timed(TIMEOUT, COUNT) + +Removes the requested number of items (default is 1) from the head of the +queue, and returns them. If the queue contains fewer than the requested +number of items, then the thread will be blocked until the requisite number of +items are available, or until the timeout is reached. If the timeout is +reached, it returns whatever items there are on the queue, or C if the +queue is empty. + +The timeout may be a number of seconds relative to the current time (e.g., 5 +seconds from when the call is made), or may be an absolute timeout in I +seconds the same as would be used with +L. +Fractional seconds (e.g., 2.5 seconds) are also supported (to the extent of +the underlying implementation). + +If C is missing, C, or less than or equal to 0, then this call +behaves the same as C. + +=item ->pending() + +Returns the number of items still in the queue. Returns C if the queue +has been ended (see below), and there are no more items in the queue. + +=item ->limit + +Sets the size of the queue. If set, calls to C will block until +the number of pending items in the queue drops below the C. The +C does not prevent enqueuing items beyond that count: + + my $q = Thread::Queue->new(1, 2); + $q->limit = 4; + $q->enqueue(3, 4, 5); # Does not block + $q->enqueue(6); # Blocks until at least 2 items are + # dequeued + my $size = $q->limit; # Returns the current limit (may return + # 'undef') + $q->limit = 0; # Queue size is now unlimited + +Calling any of the dequeue methods with C greater than a queue's +C will generate an error. + +=item ->end() + +Declares that no more items will be added to the queue. + +All threads blocking on C calls will be unblocked with any +remaining items in the queue and/or C being returned. Any subsequent +calls to C will behave like C. + +Once ended, no more items may be placed in the queue. + +=back + +=head1 ADVANCED METHODS + +The following methods can be used to manipulate items anywhere in a queue. + +To prevent the contents of a queue from being modified by another thread +while it is being examined and/or changed, L the queue inside a local block: + + { + lock($q); # Keep other threads from changing the queue's contents + my $item = $q->peek(); + if ($item ...) { + ... + } + } + # Queue is now unlocked + +=over + +=item ->peek() + +=item ->peek(INDEX) + +Returns an item from the queue without dequeuing anything. Defaults to the +head of queue (at index position 0) if no index is specified. Negative +index values are supported as with L (i.e., -1 +is the end of the queue, -2 is next to last, and so on). + +If no items exists at the specified index (i.e., the queue is empty, or the +index is beyond the number of items on the queue), then C is returned. + +Remember, the returned item is not removed from the queue, so manipulating a +Ced at reference affects the item on the queue. + +=item ->insert(INDEX, LIST) + +Adds the list of items to the queue at the specified index position (0 +is the head of the list). Any existing items at and beyond that position are +pushed back past the newly added items: + + $q->enqueue(1, 2, 3, 4); + $q->insert(1, qw/foo bar/); + # Queue now contains: 1, foo, bar, 2, 3, 4 + +Specifying an index position greater than the number of items in the queue +just adds the list to the end. + +Negative index positions are supported: + + $q->enqueue(1, 2, 3, 4); + $q->insert(-2, qw/foo bar/); + # Queue now contains: 1, 2, foo, bar, 3, 4 + +Specifying a negative index position greater than the number of items in the +queue adds the list to the head of the queue. + +=item ->extract() + +=item ->extract(INDEX) + +=item ->extract(INDEX, COUNT) + +Removes and returns the specified number of items (defaults to 1) from the +specified index position in the queue (0 is the head of the queue). When +called with no arguments, C operates the same as C. + +This method is non-blocking, and will return only as many items as are +available to fulfill the request: + + $q->enqueue(1, 2, 3, 4); + my $item = $q->extract(2) # Returns 3 + # Queue now contains: 1, 2, 4 + my @items = $q->extract(1, 3) # Returns (2, 4) + # Queue now contains: 1 + +Specifying an index position greater than the number of items in the +queue results in C or an empty list being returned. + + $q->enqueue('foo'); + my $nada = $q->extract(3) # Returns undef + my @nada = $q->extract(1, 3) # Returns () + +Negative index positions are supported. Specifying a negative index position +greater than the number of items in the queue may return items from the head +of the queue (similar to C) if the count overlaps the head of the +queue from the specified position (i.e. if queue size + index + count is +greater than zero): + + $q->enqueue(qw/foo bar baz/); + my @nada = $q->extract(-6, 2); # Returns () - (3+(-6)+2) <= 0 + my @some = $q->extract(-6, 4); # Returns (foo) - (3+(-6)+4) > 0 + # Queue now contains: bar, baz + my @rest = $q->extract(-3, 4); # Returns (bar, baz) - + # (2+(-3)+4) > 0 + +=back + +=head1 NOTES + +Queues created by L can be used in both threaded and +non-threaded applications. + +=head1 LIMITATIONS + +Passing objects on queues may not work if the objects' classes do not support +sharing. See L for more. + +Passing array/hash refs that contain objects may not work for Perl prior to +5.10.0. + +=head1 SEE ALSO + +Thread::Queue on MetaCPAN: +L + +Code repository for CPAN distribution: +L + +L, L + +Sample code in the I directory of this distribution on CPAN. + +=head1 MAINTAINER + +Jerry D. Hedden, Sjdhedden AT cpan DOT orgE> + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/src/main/perl/lib/Thread/Semaphore.pm b/src/main/perl/lib/Thread/Semaphore.pm new file mode 100644 index 000000000..0154798e2 --- /dev/null +++ b/src/main/perl/lib/Thread/Semaphore.pm @@ -0,0 +1,273 @@ +package Thread::Semaphore; + +use strict; +use warnings; + +our $VERSION = '2.13'; +$VERSION = eval $VERSION; + +use threads::shared; +use Scalar::Util 1.10 qw(looks_like_number); + +# Predeclarations for internal functions +my ($validate_arg); + +# Create a new semaphore optionally with specified count (count defaults to 1) +sub new { + my $class = shift; + + my $val :shared = 1; + if (@_) { + $val = shift; + if (! defined($val) || + ! looks_like_number($val) || + (int($val) != $val)) + { + require Carp; + $val = 'undef' if (! defined($val)); + Carp::croak("Semaphore initializer is not an integer: $val"); + } + } + + return bless(\$val, $class); +} + +# Decrement a semaphore's count (decrement amount defaults to 1) +sub down { + my $sema = shift; + my $dec = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + cond_wait($$sema) until ($$sema >= $dec); + $$sema -= $dec; +} + +# Decrement a semaphore's count only if count >= decrement value +# (decrement amount defaults to 1) +sub down_nb { + my $sema = shift; + my $dec = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + my $ok = ($$sema >= $dec); + $$sema -= $dec if $ok; + return $ok; +} + +# Decrement a semaphore's count even if the count goes below 0 +# (decrement amount defaults to 1) +sub down_force { + my $sema = shift; + my $dec = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + $$sema -= $dec; +} + +# Decrement a semaphore's count with timeout +# (timeout in seconds; decrement amount defaults to 1) +sub down_timed { + my $sema = shift; + my $timeout = $validate_arg->(shift); + my $dec = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + my $abs = time() + $timeout; + until ($$sema >= $dec) { + return if !cond_timedwait($$sema, $abs); + } + $$sema -= $dec; + return 1; +} + +# Increment a semaphore's count (increment amount defaults to 1) +sub up { + my $sema = shift; + my $inc = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + ($$sema += $inc) > 0 and cond_broadcast($$sema); +} + +### Internal Functions ### + +# Validate method argument +$validate_arg = sub { + my $arg = shift; + + if (! defined($arg) || + ! looks_like_number($arg) || + (int($arg) != $arg) || + ($arg < 1)) + { + require Carp; + my ($method) = (caller(1))[3]; + $method =~ s/Thread::Semaphore:://; + $arg = 'undef' if (! defined($arg)); + Carp::croak("Argument to semaphore method '$method' is not a positive integer: $arg"); + } + + return $arg; +}; + +1; + +=head1 NAME + +Thread::Semaphore - Thread-safe semaphores + +=head1 VERSION + +This document describes Thread::Semaphore version 2.13 + +=head1 SYNOPSIS + + use Thread::Semaphore; + my $s = Thread::Semaphore->new(); + $s->down(); # Also known as the semaphore P operation. + # The guarded section is here + $s->up(); # Also known as the semaphore V operation. + + # Decrement the semaphore only if it would immediately succeed. + if ($s->down_nb()) { + # The guarded section is here + $s->up(); + } + + # Forcefully decrement the semaphore even if its count goes below 0. + $s->down_force(); + + # The default value for semaphore operations is 1 + my $s = Thread::Semaphore->new($initial_value); + $s->down($down_value); + $s->up($up_value); + if ($s->down_nb($down_value)) { + ... + $s->up($up_value); + } + $s->down_force($down_value); + +=head1 DESCRIPTION + +Semaphores provide a mechanism to regulate access to resources. Unlike +locks, semaphores aren't tied to particular scalars, and so may be used to +control access to anything you care to use them for. + +Semaphores don't limit their values to zero and one, so they can be used to +control access to some resource that there may be more than one of (e.g., +filehandles). Increment and decrement amounts aren't fixed at one either, +so threads can reserve or return multiple resources at once. + +=head1 METHODS + +=over 8 + +=item ->new() + +=item ->new(NUMBER) + +C creates a new semaphore, and initializes its count to the specified +number (which must be an integer). If no number is specified, the +semaphore's count defaults to 1. + +=item ->down() + +=item ->down(NUMBER) + +The C method decreases the semaphore's count by the specified number +(which must be an integer >= 1), or by one if no number is specified. + +If the semaphore's count would drop below zero, this method will block +until such time as the semaphore's count is greater than or equal to the +amount you're Cing the semaphore's count by. + +This is the semaphore "P operation" (the name derives from the Dutch +word "pak", which means "capture" -- the semaphore operations were +named by the late Dijkstra, who was Dutch). + +=item ->down_nb() + +=item ->down_nb(NUMBER) + +The C method attempts to decrease the semaphore's count by the +specified number (which must be an integer >= 1), or by one if no number +is specified. + +If the semaphore's count would drop below zero, this method will return +I, and the semaphore's count remains unchanged. Otherwise, the +semaphore's count is decremented and this method returns I. + +=item ->down_force() + +=item ->down_force(NUMBER) + +The C method decreases the semaphore's count by the specified +number (which must be an integer >= 1), or by one if no number is specified. +This method does not block, and may cause the semaphore's count to drop +below zero. + +=item ->down_timed(TIMEOUT) + +=item ->down_timed(TIMEOUT, NUMBER) + +The C method attempts to decrease the semaphore's count by 1 +or by the specified number within the specified timeout period given in +seconds (which must be an integer >= 0). + +If the semaphore's count would drop below zero, this method will block +until either the semaphore's count is greater than or equal to the +amount you're Cing the semaphore's count by, or until the timeout is +reached. + +If the timeout is reached, this method will return I, and the +semaphore's count remains unchanged. Otherwise, the semaphore's count is +decremented and this method returns I. + +=item ->up() + +=item ->up(NUMBER) + +The C method increases the semaphore's count by the number specified +(which must be an integer >= 1), or by one if no number is specified. + +This will unblock any thread that is blocked trying to C the +semaphore if the C raises the semaphore's count above the amount that +the C is trying to decrement it by. For example, if three threads +are blocked trying to C a semaphore by one, and another thread Cs +the semaphore by two, then two of the blocked threads (which two is +indeterminate) will become unblocked. + +This is the semaphore "V operation" (the name derives from the Dutch +word "vrij", which means "release"). + +=back + +=head1 NOTES + +Semaphores created by L can be used in both threaded and +non-threaded applications. This allows you to write modules and packages +that potentially make use of semaphores, and that will function in either +environment. + +=head1 SEE ALSO + +Thread::Semaphore on MetaCPAN: +L + +Code repository for CPAN distribution: +L + +L, L + +Sample code in the I directory of this distribution on CPAN. + +=head1 MAINTAINER + +Jerry D. Hedden, Sjdhedden AT cpan DOT orgE> + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/src/main/perl/lib/threads.pm b/src/main/perl/lib/threads.pm index d18a94606..4c97be44c 100644 --- a/src/main/perl/lib/threads.pm +++ b/src/main/perl/lib/threads.pm @@ -5,6 +5,11 @@ use warnings; our $VERSION = '2.43'; our $threads = 1; +BEGIN { + warn "Warning, threads::shared has already been loaded. To use shared variables, load threads before threads::shared\n" + if $threads::shared::threads_shared; +} + sub all () { 0 } sub running () { 1 } sub joinable () { 2 } @@ -16,7 +21,8 @@ sub create { my $inherited = $invocant->get_stack_size; if (ref($_[0]) eq 'HASH') { my %options = %{$_[0]}; - $options{stack_size} = $inherited unless exists $options{stack_size}; + $options{stack_size} = $inherited + unless exists($options{stack_size}) || exists($options{stack}); $_[0] = \%options; } else { @@ -37,6 +43,7 @@ sub new { shift->create(@_) } sub async (&;@) { return __PACKAGE__->create(@_) } sub self { return _self() } sub tid { return ref($_[0]) ? $_[0]->{tid} : _self()->{tid} } +sub _handle { return $_[0]->{tid} } sub object { shift; return _object(@_) } sub list { shift if @_ && !ref($_[0]) && $_[0] eq __PACKAGE__; return _list(@_) } sub join { return _join($_[0]) } @@ -113,6 +120,10 @@ __END__ threads - PerlOnJava interpreter threads +=head1 VERSION + +This document describes threads version 2.43 + =head1 IMPORT OPTIONS C is exported by default. C and C<:all> also export C. diff --git a/src/main/perl/lib/threads/shared.pm b/src/main/perl/lib/threads/shared.pm index ca76ad184..9bffef622 100644 --- a/src/main/perl/lib/threads/shared.pm +++ b/src/main/perl/lib/threads/shared.pm @@ -3,17 +3,56 @@ package threads::shared; use strict; use warnings; -our $VERSION = '1.69'; +our $VERSION = '1.74'; +our $threads_shared = 1; +our $clone_warn; our @EXPORT = qw(share is_shared shared_clone cond_wait cond_timedwait cond_signal cond_broadcast); -sub share (\[$@%]) { return _share($_[0]) } -sub is_shared { return _is_shared($_[0]) || _is_shared(\$_[0]) } -sub shared_clone { return _shared_clone($_[0]) } -sub cond_wait (\[$@%];\[$@%]) { return _cond_wait(@_) } -sub cond_timedwait (\[$@%]$;\[$@%]) { return _cond_timedwait(@_) } -sub cond_signal (\[$@%]) { return _cond_signal($_[0]) } -sub cond_broadcast (\[$@%]) { return _cond_broadcast($_[0]) } +sub _active_share (\[$@%]) { return _share($_[0]) } +sub _active_is_shared (\[$@%]) { return _is_shared($_[0]) } +sub _active_cond_wait (\[$@%];\[$@%]) { return _cond_wait(@_) } +sub _active_cond_timedwait (\[$@%]$;\[$@%]) { return _cond_timedwait(@_) } +sub _active_cond_signal (\[$@%]) { return _cond_signal($_[0]) } +sub _active_cond_broadcast (\[$@%]) { return _cond_broadcast($_[0]) } + +if ($threads::threads) { + *share = \&_active_share; + *is_shared = \&_active_is_shared; + *cond_wait = \&_active_cond_wait; + *cond_timedwait = \&_active_cond_timedwait; + *cond_signal = \&_active_cond_signal; + *cond_broadcast = \&_active_cond_broadcast; +} else { + eval <<'_NO_THREADS_'; +sub share (\[$@%]) { return $_[0] } +sub is_shared (\[$@%]) { undef } +sub cond_wait (\[$@%];\[$@%]) { undef } +sub cond_timedwait (\[$@%]$;\[$@%]) { undef } +sub cond_signal (\[$@%]) { undef } +sub cond_broadcast (\[$@%]) { undef } +_NO_THREADS_ +} + +sub _id (\[$@%]) { return _shared_id($_[0]) } +sub _refcnt (\[$@%]) { return _shared_refcnt($_[0]) } +sub shared_clone { + require Carp; + Carp::croak('Usage: shared_clone(REF)') unless @_ == 1; + + require Scalar::Util; + my $type = Scalar::Util::reftype($_[0]); + if (defined($type) && ($type eq 'GLOB' || $type eq 'CODE')) { + my $message = "Unsupported ref type: $type"; + if (!defined($clone_warn)) { + Carp::croak($message); + } + Carp::carp($message) if $clone_warn; + return undef; + } + + return $threads::threads ? _shared_clone($_[0]) : $_[0]; +} sub import { my $caller = caller; diff --git a/src/test/java/org/perlonjava/runtime/runtimetypes/SharedPerlStorageDestructiveShareTest.java b/src/test/java/org/perlonjava/runtime/runtimetypes/SharedPerlStorageDestructiveShareTest.java new file mode 100644 index 000000000..d00cc823f --- /dev/null +++ b/src/test/java/org/perlonjava/runtime/runtimetypes/SharedPerlStorageDestructiveShareTest.java @@ -0,0 +1,68 @@ +package org.perlonjava.runtime.runtimetypes; + +import org.junit.jupiter.api.Tag; +import org.junit.jupiter.api.Test; + +import static org.junit.jupiter.api.Assertions.assertEquals; +import static org.junit.jupiter.api.Assertions.assertFalse; +import static org.junit.jupiter.api.Assertions.assertNotSame; +import static org.junit.jupiter.api.Assertions.assertTrue; + +@Tag("unit") +class SharedPerlStorageDestructiveShareTest { + + @Test + void publicSharePreservesScalarsButClearsAggregateStorage() { + PerlRuntime runtime = new PerlRuntime(); + try (PerlRuntime.Binding ignored = runtime.bind()) { + RuntimeScalar scalar = new RuntimeScalar(7); + SharedPerlStorage.share(scalar); + assertTrue(scalar.threadShared); + assertEquals(7, scalar.getInt()); + + RuntimeArray array = new RuntimeArray(); + array.push(new RuntimeScalar(1)); + array.push(new RuntimeScalar(2)); + SharedPerlStorage.share(array.createReference()); + assertTrue(array.threadShared); + assertTrue(array.isEmpty()); + array.push(new RuntimeScalar(3)); + SharedPerlStorage.share(array.createReference()); + assertTrue(array.isEmpty()); + + RuntimeHash hash = new RuntimeHash(); + hash.put("value", new RuntimeScalar(1)); + hash.blessId = NameNormalizer.getBlessId("SharedDestructiveObject"); + RuntimeScalar objectVariable = hash.createReference(); + SharedPerlStorage.share(objectVariable.createReference()); + assertTrue(hash.threadShared); + assertTrue(hash.elements.isEmpty()); + assertEquals("SharedDestructiveObject", NameNormalizer.getBlessStr(hash.blessId)); + } + } + + @Test + void sharedClonePreservesRecursiveCopyWithoutSharingSource() { + PerlRuntime runtime = new PerlRuntime(); + try (PerlRuntime.Binding ignored = runtime.bind()) { + RuntimeArray nested = new RuntimeArray(); + nested.push(new RuntimeScalar(2)); + nested.push(new RuntimeScalar(3)); + RuntimeHash source = new RuntimeHash(); + source.put("value", new RuntimeScalar(1)); + source.put("nested", nested.createReference()); + + RuntimeScalar cloneReference = SharedPerlStorage.sharedClone(source.createReference()); + RuntimeHash clone = (RuntimeHash) cloneReference.value; + RuntimeArray clonedNested = (RuntimeArray) clone.get("nested").value; + + assertNotSame(source, clone); + assertFalse(source.threadShared); + assertFalse(nested.threadShared); + assertTrue(clone.threadShared); + assertTrue(clonedNested.threadShared); + assertEquals(1, clone.get("value").getInt()); + assertEquals(2, clonedNested.size()); + } + } +} diff --git a/src/test/resources/unit/threads_clone_skip_no_autoload.t b/src/test/resources/unit/threads_clone_skip_no_autoload.t new file mode 100644 index 000000000..a16bd5577 --- /dev/null +++ b/src/test/resources/unit/threads_clone_skip_no_autoload.t @@ -0,0 +1,31 @@ +use strict; +use warnings; +use threads; + +print "1..2\n"; + +{ + package CloneSkipAutoloadGuard; + + our $AUTOLOAD; + sub AUTOLOAD { + return if $AUTOLOAD =~ /::DESTROY\z/; + die "AUTOLOAD must not be consulted for $AUTOLOAD"; + } +} + +my $object = bless {}, 'CloneSkipAutoloadGuard'; +my ($thread, $error); +{ + local $@; + $thread = eval { threads->create(sub { ref($object) }) }; + $error = $@; +} + +print $thread ? "ok 1 - snapshot ignores AUTOLOAD while probing CLONE_SKIP\n" + : "not ok 1 - snapshot ignores AUTOLOAD while probing CLONE_SKIP: $error\n"; + +my $class = $thread ? $thread->join() : ''; +print $class eq 'CloneSkipAutoloadGuard' + ? "ok 2 - ordinary blessed value reaches child without CLONE_SKIP\n" + : "not ok 2 - ordinary blessed value reaches child without CLONE_SKIP\n"; diff --git a/src/test/resources/unit/threads_destroy_method_return_rescue.t b/src/test/resources/unit/threads_destroy_method_return_rescue.t new file mode 100644 index 000000000..7179204a9 --- /dev/null +++ b/src/test/resources/unit/threads_destroy_method_return_rescue.t @@ -0,0 +1,43 @@ +use strict; +use warnings; +use threads; +use Scalar::Util qw(weaken); +use B (); + +print "1..2\n"; + +{ + package Local::Schema; + + sub source { $_[0]{sources}{Artist} } + + sub DESTROY { + my $self = shift; + my $sources = $self->{sources}; + for my $name (keys %$sources) { + next unless ref($sources->{$name}); + if (B::svref_2object($sources->{$name})->REFCNT > 1) { + $sources->{$name}{schema} = $self; + Scalar::Util::weaken($sources->{$name}); + last; + } + } + } +} + +my $schema = bless { sources => {} }, 'Local::Schema'; +my $source = { schema => $schema }; +weaken($source->{schema}); +$schema->{sources}{Artist} = $source; + +my $thread = threads->create(sub { + my $result_source = $schema->source; + undef $schema; + return defined($result_source->{schema}) ? 1 : 0; +}); + +print(($thread->join ? "ok" : "not ok"), + " 1 - method-return lexical keeps its referent alive during owner DESTROY\n"); +print(defined($source->{schema}) + ? "ok 2 - parent graph remains intact\n" + : "not ok 2 - parent graph remains intact\n"); diff --git a/src/test/resources/unit/threads_destroy_weak_slot_rescue.t b/src/test/resources/unit/threads_destroy_weak_slot_rescue.t new file mode 100644 index 000000000..f294daa6b --- /dev/null +++ b/src/test/resources/unit/threads_destroy_weak_slot_rescue.t @@ -0,0 +1,44 @@ +use strict; +use warnings; +use threads; +use Scalar::Util qw(isweak refaddr weaken); + +print "1..3\n"; + +{ + package ThreadWeakSlotRescuer; + sub DESTROY { + my ($self) = @_; + $self->{source}{owner} = $self if $self->{source}; + } +} + +my $owner = bless {}, 'ThreadWeakSlotRescuer'; +my $source = { owner => $owner }; +my $sibling = $owner; +weaken($source->{owner}); +weaken($sibling); +$owner->{source} = $source; + +my $result = threads->create(sub { + undef $owner; + my $observed = join ':', + defined($source->{owner}) ? 1 : 0, + isweak($source->{owner}) ? 0 : 1, + (defined($sibling) + && refaddr($sibling) == refaddr($source->{owner})) ? 1 : 0; + $source->{owner}{source} = undef; + $source->{owner} = undef; + return $observed; +})->join; + +$owner->{source} = undef; +$source->{owner} = undef; + +my ($rescued, $strong, $sibling_live) = split /:/, $result; +print $rescued ? "ok 1 - DESTROY can rescue through its existing weak hash slot\n" + : "not ok 1 - DESTROY can rescue through its existing weak hash slot\n"; +print $strong ? "ok 2 - rescued hash slot becomes a strong owner\n" + : "not ok 2 - rescued hash slot becomes a strong owner\n"; +print $sibling_live ? "ok 3 - sibling weak references survive resurrection\n" + : "not ok 3 - sibling weak references survive resurrection\n"; diff --git a/src/test/resources/unit/threads_end_block_ownership.t b/src/test/resources/unit/threads_end_block_ownership.t new file mode 100644 index 000000000..380dcc700 --- /dev/null +++ b/src/test/resources/unit/threads_end_block_ownership.t @@ -0,0 +1,25 @@ +use strict; +use warnings; +use threads; +use threads::shared; + +print "1..3\n"; + +my $test :shared = 1; + +sub report_ok { + my ($name) = @_; + lock($test); + print "ok ", $test++, " - $name\n"; +} + +END { + report_ok('main END block runs in the parent'); +} + +report_ok('main body runs'); + +threads->create(sub { + eval q{ END { report_ok('child END block runs in its owner') } }; + die $@ if $@; +})->join(); diff --git a/src/test/resources/unit/threads_shared_child_capture_release.t b/src/test/resources/unit/threads_shared_child_capture_release.t new file mode 100644 index 000000000..5c032edce --- /dev/null +++ b/src/test/resources/unit/threads_shared_child_capture_release.t @@ -0,0 +1,36 @@ +use strict; +use warnings; +use threads; +use threads::shared; + +print "1..2\n"; + +my $destroyed :shared = 0; + +{ + package SharedCapturedScalar; + + sub new { + my $value = 1; + my $self = \$value; + threads::shared::share($self); + return bless($self, shift); + } + + sub DESTROY { + lock($destroyed); + ++$destroyed; + } +} + +{ + my $shared_scalar :shared; + threads->create(sub { $shared_scalar = SharedCapturedScalar->new() })->join(); + print $destroyed == 0 + ? "ok 1 - shared object remains alive while shared scalar is in scope\n" + : "not ok 1 - shared object remains alive while shared scalar is in scope\n"; +} + +print $destroyed == 1 + ? "ok 2 - child closure capture is released before shared scalar scope exit\n" + : "not ok 2 - child closure capture is released before shared scalar scope exit\n"; diff --git a/src/test/resources/unit/threads_shared_destructive_share.t b/src/test/resources/unit/threads_shared_destructive_share.t new file mode 100644 index 000000000..c2d8d0972 --- /dev/null +++ b/src/test/resources/unit/threads_shared_destructive_share.t @@ -0,0 +1,49 @@ +use strict; +use warnings; +use threads; +use threads::shared; + +print "1..7\n"; + +my $number = 0; +sub check { + my ($condition, $name) = @_; + ++$number; + print($condition ? "ok " : "not ok ", $number, " - ", $name, "\n"); +} + +my $scalar = 7; +share($scalar); +check($scalar == 7 && is_shared($scalar), + 'share preserves and marks an ordinary scalar'); + +$scalar = 9; +share($scalar); +check($scalar == 9 && is_shared($scalar), + 'sharing an already shared scalar preserves its value'); + +my @array = (1, 2); +share(@array); +check(@array == 0 && is_shared(@array), + 'share clears and marks an ordinary array'); +push @array, 3; +share(@array); +check(@array == 0, 'resharing an array clears it again'); + +my %hash = (a => 1); +share(%hash); +check(keys(%hash) == 0 && is_shared(%hash), + 'share clears and marks an ordinary hash'); + +my $object = bless({ value => 1 }, 'SharedDestructiveObject'); +share($object); +check(ref($object) eq 'SharedDestructiveObject' + && keys(%$object) == 0 && is_shared($object), + 'share retains blessing while clearing aggregate contents'); + +my $source = { value => 1, nested => [2, 3] }; +my $clone = shared_clone($source); +check($clone->{value} == 1 && @{$clone->{nested}} == 2 + && is_shared($clone) && is_shared($clone->{nested}) + && !is_shared($source), + 'shared_clone preserves a recursive copy and leaves its source ordinary'); diff --git a/src/test/resources/unit/threads_shared_fetch_proxy_lifetime.t b/src/test/resources/unit/threads_shared_fetch_proxy_lifetime.t new file mode 100644 index 000000000..5f3dd2b4c --- /dev/null +++ b/src/test/resources/unit/threads_shared_fetch_proxy_lifetime.t @@ -0,0 +1,41 @@ +use strict; +use warnings; +use threads; +use threads::shared; + +print "1..3\n"; + +{ + package SharedFetchCookie; + + sub new { + my ($class, $flavour) = @_; + my $self = bless(threads::shared::shared_clone({ flavour => $flavour }), $class); + return $self; + } + + sub DESTROY { + delete shift->{flavour}; + } +} + +my @jar :shared; +my $cookie = SharedFetchCookie->new('chocolate'); +push @jar, $cookie; + +sub fetch_and_discard { + return $jar[-1]; +} + +fetch_and_discard(); +print $cookie->{flavour} eq 'chocolate' + ? "ok 1 - discarded fetch proxy does not destroy source object\n" + : "not ok 1 - discarded fetch proxy does not destroy source object\n"; +print $jar[-1]->{flavour} eq 'chocolate' + ? "ok 2 - discarded fetch proxy leaves shared storage intact\n" + : "not ok 2 - discarded fetch proxy leaves shared storage intact\n"; + +my $child_value = threads->create(sub { fetch_and_discard(); return $jar[-1]->{flavour} })->join(); +print $child_value eq 'chocolate' && $jar[-1]->{flavour} eq 'chocolate' + ? "ok 3 - child fetch proxy leaves canonical object intact\n" + : "not ok 3 - child fetch proxy leaves canonical object intact\n"; diff --git a/src/test/resources/unit/threads_shared_lexical_reassignment.t b/src/test/resources/unit/threads_shared_lexical_reassignment.t new file mode 100644 index 000000000..24be6653a --- /dev/null +++ b/src/test/resources/unit/threads_shared_lexical_reassignment.t @@ -0,0 +1,64 @@ +use strict; +use warnings; +use threads; +use threads::shared; + +print "1..8\n"; + +sub make_shared_reference { + my $value :shared = 1; + $value = shift; + return \$value; +} + +my $reference = make_shared_reference(4); + +my $locked = eval { + lock($$reference); + ++$$reference; + 1; +}; + +print $locked ? "ok 1 - reassigned lexical remains lockable\n" + : "not ok 1 - reassigned lexical remains lockable: $@\n"; +print $$reference == 5 ? "ok 2 - reassigned shared value remains mutable\n" + : "not ok 2 - reassigned shared value remains mutable\n"; +print is_shared($$reference) ? "ok 3 - reassigned lexical retains shared identity\n" + : "not ok 3 - reassigned lexical retains shared identity\n"; + +my ($first, $second) :shared = (7, 8); +my $list_locked = eval { + lock($first); + ++$first; + 1; +}; + +print $list_locked ? "ok 4 - initialized declaration-list slot is shared\n" + : "not ok 4 - initialized declaration-list slot is shared: $@\n"; +print $first == 8 && is_shared($second) + ? "ok 5 - shared attribute applies to every declaration-list slot\n" + : "not ok 5 - shared attribute applies to every declaration-list slot\n"; + +my ($captured, $unused) :shared; +$captured = 10; + +sub increment_captured_shared { + lock($captured); + return ++$captured; +} + +my $parent_value = increment_captured_shared(); +print $parent_value == 11 + ? "ok 6 - named sub captures shared declaration-list slot\n" + : "not ok 6 - named sub captures shared declaration-list slot\n"; + +my $child_value = threads->create('increment_captured_shared')->join(); +print $child_value == 12 && $captured == 12 + ? "ok 7 - child named sub retains captured shared storage\n" + : "not ok 7 - child named sub retains captured shared storage\n"; + +my @slice_source :shared = (1, 2, 3, 4, 5); +my @slice_copy = @slice_source[1...4]; +print join(':', @slice_copy) eq '2:3:4:5' + ? "ok 8 - shared array slice preserves an inclusive three-dot range\n" + : "not ok 8 - shared array slice preserves an inclusive three-dot range\n"; diff --git a/src/test/resources/unit/threads_shared_unadvertised.t b/src/test/resources/unit/threads_shared_unadvertised.t index 23e678352..77a4ffa6b 100644 --- a/src/test/resources/unit/threads_shared_unadvertised.t +++ b/src/test/resources/unit/threads_shared_unadvertised.t @@ -35,9 +35,7 @@ my ($thread) = threads->create(sub { my @result = $thread->join; check($result[0] == 7, 'child sees shared scalar'); check($scalar == 7, 'parent sees child scalar mutation'); -check($Config::Config{archname} =~ /^java-/ - ? (@array == 3 && $array[2] == 3) - : (@array == 1 && $array[0] == 3), +check(@array == 1 && $array[0] == 3, 'shared array mutation survives clone'); check($hash{b} == 2, 'shared hash mutation survives clone'); diff --git a/src/test/resources/unit/threads_weak_backref_snapshot.t b/src/test/resources/unit/threads_weak_backref_snapshot.t new file mode 100644 index 000000000..21d819b19 --- /dev/null +++ b/src/test/resources/unit/threads_weak_backref_snapshot.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use threads; +use Scalar::Util qw(isweak refaddr weaken); + +print "1..3\n"; + +{ + package ThreadWeakSchema; + sub DESTROY { } +} + +our $weak_global; +my $schema = bless {}, 'ThreadWeakSchema'; +my $source = { schema => $schema }; +weaken($source->{schema}); +$schema->{source} = $source; +$weak_global = $schema; +weaken($weak_global); + +my $result = threads->create(sub { + return join ':', + defined($weak_global) ? 1 : 0, + defined($schema->{source}{schema}) ? 1 : 0, + (defined($weak_global) && refaddr($weak_global) == refaddr($schema)) ? 1 : 0; +})->join(); + +my ($global_live, $backref_live, $same_clone) = split /:/, $result; +print $global_live ? "ok 1 - weak global survives a strong entry capture\n" + : "not ok 1 - weak global survives a strong entry capture\n"; +print $backref_live && isweak($schema->{source}{schema}) + ? "ok 2 - cloned weak back-reference retains its captured owner\n" + : "not ok 2 - cloned weak back-reference retains its captured owner\n"; +print $same_clone ? "ok 3 - weak global and entry capture share one child clone\n" + : "not ok 3 - weak global and entry capture share one child clone\n";