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";