From ec30c9e405ba51ef8ea5f8f74fb240287577bd1b Mon Sep 17 00:00:00 2001 From: Yogthos Date: Sat, 20 Jun 2026 13:11:31 -0400 Subject: [PATCH] Chez concurrency pt.1: real OS-thread futures + blocking promises (shared heap) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit future/future-call run the body on a native thread (fork-thread) over the SAME heap — JVM semantics, not Janet's isolated-heap snapshot. deref blocks on a mutex+condition latch; timed (deref f ms val) uses an absolute deadline. promise is a real blocking promise (deref parks until deliver), replacing the Janet non-blocking atom shim. future?/future-done?/future-cancelled?/future-cancel /realized? are native (the overlay versions read Janet map keys); re-asserted in post-prelude over the overlay. pmap/pcalls/pvalues (overlay, over future) light up for free. Thread-safety this forces: - atoms get a per-atom mutex; swap!/swap-vals! are a JVM-style CAS loop (f runs outside the lock, so a watch/validator can deref the same atom); reset!/ compare-and-set! are atomic. - the dynamic binding stack becomes a Chez thread-parameter, so each future/thread has its own; Chez inherits it at fork, giving binding conveyance (the shim also installs an explicit snapshot). - Thread/sleep really sleeps now (a worker sleeping doesn't block the parent). Re-minted the seed: future-call now resolves at compile time, so pmap compiles to a var-deref instead of the host-static-call fallback that crashed. image.ss unchanged. Corpus: the 2 snapshot cases now match the JVM (shared) not Janet (isolated) — allowlisted on both Chez gates; the two racy future-cancel cases allowlisted; "promise undelivered" (blocks on JVM/Chez, profile :bucket :timeout) skipped like :throws. Zero-Janet corpus 2544 -> 2569, 0 new divergences, floor raised. Full Janet gate + JVM cert green. jolt-byjr --- host/chez/atoms.ss | 71 +++++++---- host/chez/concurrency.ss | 176 ++++++++++++++++++++++++++ host/chez/dyn-binding.ss | 22 ++-- host/chez/host-static.ss | 11 +- host/chez/post-prelude.ss | 17 +++ host/chez/rt.ss | 6 + host/chez/seed/prelude.ss | 2 +- test/chez/cli-test.janet | 23 +++- test/chez/run-corpus-prelude.janet | 19 ++- test/chez/run-corpus-zero-janet.janet | 25 +++- 10 files changed, 330 insertions(+), 42 deletions(-) create mode 100644 host/chez/concurrency.ss diff --git a/host/chez/atoms.ss b/host/chez/atoms.ss index da634fe..ab32d62 100644 --- a/host/chez/atoms.ss +++ b/host/chez/atoms.ss @@ -16,16 +16,21 @@ ;; Janet table, which a Chez atom record is not — so the peripheral ops + the ;; notify/validate behaviour live natively here, and post-prelude.ss re-asserts ;; them over the overlay's def-var! (jolt-mn9o). +;; `lock` (jolt-byjr) is a per-atom mutex guarding the read-modify-write critical +;; sections, so swap!/reset!/compare-and-set! are atomic under real OS threads +;; (futures/go blocks share the heap on Chez). The user fn in swap! runs OUTSIDE +;; the lock (a CAS retry loop, like the JVM) so it never deadlocks on re-entrant +;; access and a watch/validator can deref the same atom. (define-record-type jolt-atom - (fields (mutable val) (mutable watches) (mutable validator)) - (nongenerative jolt-atom-v2)) + (fields (mutable val) (mutable watches) (mutable validator) lock) + (nongenerative jolt-atom-v3)) ;; (atom init) / (atom init :validator f :meta m): scan the trailing keyword opts ;; for :validator (the only one with runtime behaviour; :meta is accepted/ignored). (define (jolt-atom-new v . opts) (let loop ((o opts) (validator jolt-nil)) (cond - ((or (null? o) (null? (cdr o))) (make-jolt-atom v '() validator)) + ((or (null? o) (null? (cdr o))) (make-jolt-atom v '() validator (make-mutex))) ((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator")) (loop (cddr o) (cadr o))) (else (loop (cddr o) validator))))) @@ -50,37 +55,57 @@ ((jolt-reduced? x) (jolt-reduced-val x)) (else (error #f "deref: unsupported reference type" x)))) -;; (swap! a f arg*) -> (reset! a (f @a arg*)); f is invoked through jolt-invoke. -;; Validate the new value BEFORE storing, notify watches AFTER (the seed order). +;; CAS the val from `old` to `nv` by identity (eq?), atomically. Returns #t on +;; success. The compute step (f) runs outside this, so we re-check under the lock. +(define (jolt-atom-cas! a old nv) + (with-mutex (jolt-atom-lock a) + (if (eq? (jolt-atom-val a) old) + (begin (jolt-atom-val-set! a nv) #t) + #f))) + +;; (swap! a f arg*): JVM-style CAS loop — read, compute f OUTSIDE the lock, then +;; atomically compare-and-set; retry if another thread changed it. Validate the +;; new value before storing, notify watches after (the seed order). (define (jolt-swap! a f . args) - (let* ((old (jolt-atom-val a)) - (nv (apply jolt-invoke f old args))) - (jolt-atom-validate a nv) - (jolt-atom-val-set! a nv) - (jolt-atom-notify a old nv) - nv)) + (let retry () + (let* ((old (jolt-atom-val a)) + (nv (apply jolt-invoke f old args))) + (jolt-atom-validate a nv) + (if (jolt-atom-cas! a old nv) + (begin (jolt-atom-notify a old nv) nv) + (retry))))) (define (jolt-reset! a v) - (let ((old (jolt-atom-val a))) - (jolt-atom-validate a v) - (jolt-atom-val-set! a v) + (jolt-atom-validate a v) + (let ((old (with-mutex (jolt-atom-lock a) + (let ((o (jolt-atom-val a))) (jolt-atom-val-set! a v) o)))) (jolt-atom-notify a old v) v)) +;; compare-and-set! keeps jolt= (value) semantics, done atomically under the lock. (define (jolt-compare-and-set! a oldv newv) - (if (jolt= (jolt-atom-val a) oldv) - (begin (jolt-reset! a newv) #t) - #f)) + (jolt-atom-validate a newv) + (let ((swapped (with-mutex (jolt-atom-lock a) + (if (jolt= (jolt-atom-val a) oldv) + (begin (jolt-atom-val-set! a newv) #t) + #f)))) + (when swapped (jolt-atom-notify a oldv newv)) + swapped)) (define (jolt-swap-vals! a f . args) - (let* ((old (jolt-atom-val a)) - (nv (apply jolt-invoke f old args))) - (jolt-reset! a nv) - (jolt-vector old nv))) + (let retry () + (let* ((old (jolt-atom-val a)) + (nv (apply jolt-invoke f old args))) + (jolt-atom-validate a nv) + (if (jolt-atom-cas! a old nv) + (begin (jolt-atom-notify a old nv) (jolt-vector old nv)) + (retry))))) (define (jolt-reset-vals! a v) - (let ((old (jolt-atom-val a))) - (jolt-reset! a v) + (jolt-atom-validate a v) + (let ((old (with-mutex (jolt-atom-lock a) + (let ((o (jolt-atom-val a))) (jolt-atom-val-set! a v) o)))) + (jolt-atom-notify a old v) (jolt-vector old v))) ;; --- watches / validators (jolt-mn9o) --------------------------------------- diff --git a/host/chez/concurrency.ss b/host/chez/concurrency.ss new file mode 100644 index 0000000..7386f91 --- /dev/null +++ b/host/chez/concurrency.ss @@ -0,0 +1,176 @@ +;; concurrency.ss (jolt-byjr) — real OS-thread futures + promises for the Chez host. +;; +;; SHARED-HEAP semantics (JVM Clojure), NOT Janet's isolated-heap snapshot: a +;; future body runs on a native thread (fork-thread) over the SAME heap, so a +;; captured atom is shared and the body's mutations are visible to the parent — +;; matching `clojure.core` on the JVM. deref blocks on a mutex+condition latch. +;; +;; future / future-call / future-cancel / future? / future-done? / future-cancelled? +;; promise / deliver, and the deref extension for both, are bound here (some +;; re-asserted in post-prelude.ss over the overlay's Janet-shaped versions). +;; +;; pmap / pcalls / pvalues live in the clojure.core overlay (40-lazy) expressed +;; over `future`, so they light up for free once future-call exists. +;; +;; Loaded near the end of rt.ss — after atoms.ss (jolt-deref, the atom lock) and +;; dyn-binding.ss (the thread-local binding stack we convey into the worker). +;; Requires a threaded Chez build (fork-thread / make-mutex / make-condition). + +;; --- time helpers ----------------------------------------------------------- +;; A relative duration / absolute deadline from a millisecond count (a jolt number). +(define (ms->duration ms) + (let* ((ms* (exact (floor ms))) + (secs (quotient ms* 1000)) + (nanos (* (remainder ms* 1000) 1000000))) + (make-time 'time-duration nanos secs))) +(define (ms->deadline ms) (add-duration (current-time 'time-utc) (ms->duration ms))) + +;; --- futures ---------------------------------------------------------------- +;; A future is a mutable cell guarded by `mu`; workers/derefs coordinate on `cv`. +;; done? — result (or cancellation) is final; derefs may proceed +;; cancelled? — future-cancel won before the body finished +;; ok? — payload is a value (else payload is a raised condition/value) +;; payload — the result value, or the captured throw +(define-record-type jolt-future + (fields (mutable done?) (mutable cancelled?) (mutable ok?) (mutable payload) mu cv) + (nongenerative jolt-future-v1)) + +;; (future-call thunk): spawn a thread running (thunk). The dynamic bindings in +;; effect now are conveyed into the worker (Chez inherits thread-parameters at +;; fork; we also install an explicit snapshot for certainty). The result — value +;; or thrown condition — is latched and broadcast; a cancel that already finalized +;; the future makes the late result a no-op. +(define (jolt-future-call thunk) + (let ((f (make-jolt-future #f #f #f jolt-nil (make-mutex) (make-condition))) + (snap (dyn-binding-stack))) + (fork-thread + (lambda () + (dyn-binding-stack snap) + (let ((r (guard (e (#t (cons #f e))) (cons #t (jolt-invoke thunk))))) + (with-mutex (jolt-future-mu f) + (unless (jolt-future-done? f) ; not already cancelled + (jolt-future-ok?-set! f (car r)) + (jolt-future-payload-set! f (cdr r)) + (jolt-future-done?-set! f #t)) + (condition-broadcast (jolt-future-cv f)))))) + f)) + +;; Final value of a settled future (called OUTSIDE the lock): re-raise a captured +;; throw, signal a cancellation, else the value. +(define (jolt-future-finish f) + (cond + ((jolt-future-cancelled? f) + (jolt-throw (jolt-ex-info "Future cancelled" (jolt-hash-map)))) + ((jolt-future-ok? f) (jolt-future-payload f)) + (else (raise (jolt-future-payload f))))) + +(define (jolt-future-deref f) + (with-mutex (jolt-future-mu f) + (let loop () + (unless (jolt-future-done? f) + (condition-wait (jolt-future-cv f) (jolt-future-mu f)) + (loop)))) + (jolt-future-finish f)) + +;; (deref f timeout-ms timeout-val): wait up to timeout-ms; return timeout-val if +;; it has not settled by the absolute deadline. +(define (jolt-future-deref-timed f ms timeout-val) + (let* ((deadline (ms->deadline ms)) + (settled (with-mutex (jolt-future-mu f) + (let loop () + (cond ((jolt-future-done? f) #t) + ((condition-wait (jolt-future-cv f) (jolt-future-mu f) deadline) + (loop)) ; woken — recheck + (else (jolt-future-done? f))))))) ; timed out: final check + (if settled (jolt-future-finish f) timeout-val))) + +;; future-cancel: the running thread can't be interrupted, but the future object +;; reflects the cancellation — if not already settled, mark it cancelled+done so +;; derefs raise and the predicates flip. Returns true iff this call cancelled it. +(define (jolt-future-cancel f) + (let ((cancelled (with-mutex (jolt-future-mu f) + (if (jolt-future-done? f) + #f + (begin (jolt-future-cancelled?-set! f #t) + (jolt-future-done?-set! f #t) + (condition-broadcast (jolt-future-cv f)) + #t))))) + cancelled)) + +(define (jolt-future-done?* f) (and (jolt-future? f) (jolt-future-done? f))) +(define (jolt-native-future-done? x) + (if (jolt-future? x) (jolt-future-done? x) + (jolt-throw (jolt-ex-info "future-done? requires a future" (jolt-hash-map))))) +(define (jolt-native-future-cancelled? x) + (and (jolt-future? x) (jolt-future-cancelled? x))) + +;; --- promises --------------------------------------------------------------- +;; A blocking promise (JVM), not Janet's non-blocking atom shim: deref parks until +;; deliver, then caches the value. deliver wins once; later delivers return nil. +(define-record-type jolt-promise + (fields (mutable delivered?) (mutable value) mu cv) + (nongenerative jolt-promise-v1)) + +(define (jolt-promise-new) (make-jolt-promise #f jolt-nil (make-mutex) (make-condition))) + +(define (jolt-deliver p v) + (if (jolt-promise? p) + (let ((won (with-mutex (jolt-promise-mu p) + (if (jolt-promise-delivered? p) + #f + (begin (jolt-promise-value-set! p v) + (jolt-promise-delivered?-set! p #t) + (condition-broadcast (jolt-promise-cv p)) + #t))))) + (if won p jolt-nil)) + (jolt-throw (jolt-ex-info "deliver requires a promise" (jolt-hash-map))))) + +(define (jolt-promise-deref p) + (with-mutex (jolt-promise-mu p) + (let loop () + (unless (jolt-promise-delivered? p) + (condition-wait (jolt-promise-cv p) (jolt-promise-mu p)) + (loop)))) + (jolt-promise-value p)) + +(define (jolt-promise-deref-timed p ms timeout-val) + (let* ((deadline (ms->deadline ms)) + (got (with-mutex (jolt-promise-mu p) + (let loop () + (cond ((jolt-promise-delivered? p) #t) + ((condition-wait (jolt-promise-cv p) (jolt-promise-mu p) deadline) + (loop)) + (else (jolt-promise-delivered? p))))))) + (if got (jolt-promise-value p) timeout-val))) + +;; --- deref extension -------------------------------------------------------- +;; Chain the fully-built jolt-deref (atoms/vars/volatiles/reduced) with futures + +;; promises, and accept the timed (deref ref ms val) arity for both. +(define %pre-conc-deref jolt-deref) +(set! jolt-deref + (lambda (x . opts) + (cond + ((jolt-future? x) + (if (null? opts) (jolt-future-deref x) + (jolt-future-deref-timed x (car opts) (cadr opts)))) + ((jolt-promise? x) + (if (null? opts) (jolt-promise-deref x) + (jolt-promise-deref-timed x (car opts) (cadr opts)))) + (else (apply %pre-conc-deref x opts))))) + +;; realized? for a Chez future/promise (the overlay reads Janet map keys). Wrap the +;; overlay version in post-prelude.ss; here just the future/promise predicate. +(define (jolt-conc-realized? x) + (cond ((jolt-future? x) (jolt-future-done? x)) + ((jolt-promise? x) (jolt-promise-delivered? x)) + (else #f))) + +;; --- bind into clojure.core ------------------------------------------------- +(def-var! "clojure.core" "future-call" jolt-future-call) +(def-var! "clojure.core" "future-cancel" jolt-future-cancel) +(def-var! "clojure.core" "future?" jolt-future?) +(def-var! "clojure.core" "future-done?" jolt-native-future-done?) +(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?) +(def-var! "clojure.core" "promise" jolt-promise-new) +(def-var! "clojure.core" "deliver" jolt-deliver) +(def-var! "clojure.core" "deref" jolt-deref) diff --git a/host/chez/dyn-binding.ss b/host/chez/dyn-binding.ss index 7a9a470..fb42ff0 100644 --- a/host/chez/dyn-binding.ss +++ b/host/chez/dyn-binding.ss @@ -15,11 +15,15 @@ ;; the stack before falling back to the cell root. Loaded LAST (after vars.ss and ;; ns.ss) so it chains the fully-extended jolt-var-get and overrides rt.ss var-deref. -(define dyn-binding-stack '()) +;; THREAD-LOCAL (jolt-byjr): a Chez thread parameter, so each OS thread (a future +;; / go block) has its own binding stack. Chez initializes a new thread's parameter +;; to the spawning thread's value at fork time, giving Clojure binding conveyance +;; for free (the future shim also installs an explicit snapshot, belt-and-suspenders). +(define dyn-binding-stack (make-thread-parameter '())) ;; find the innermost (cell . value) pair binding CELL, or #f. (define (dyn-find-binding cell) - (let loop ((frames dyn-binding-stack)) + (let loop ((frames (dyn-binding-stack))) (and (pair? frames) (or (assq cell (car frames)) (loop (cdr frames)))))) @@ -28,7 +32,7 @@ ;; value happens to be jolt-nil. (define dyn-no-binding (list 'no-binding)) (define (dyn-binding-value cell) - (if (pair? dyn-binding-stack) + (if (pair? (dyn-binding-stack)) (let ((p (dyn-find-binding cell))) (if p (let ((val (cdr p))) @@ -39,21 +43,21 @@ ;; push-thread-bindings: frame is a jolt map of var-cell -> value. Fold it into an ;; identity-keyed alist of mutable pairs and push. (define (jolt-push-thread-bindings frame) - (set! dyn-binding-stack - (cons (pmap-fold frame (lambda (k v acc) (cons (cons k v) acc)) '()) - dyn-binding-stack)) + (dyn-binding-stack + (cons (pmap-fold frame (lambda (k v acc) (cons (cons k v) acc)) '()) + (dyn-binding-stack))) jolt-nil) (define (jolt-pop-thread-bindings) - (when (pair? dyn-binding-stack) - (set! dyn-binding-stack (cdr dyn-binding-stack))) + (when (pair? (dyn-binding-stack)) + (dyn-binding-stack (cdr (dyn-binding-stack)))) jolt-nil) ;; get-thread-bindings: a jolt map of every currently-bound cell -> value, ;; innermost wins. Merge oldest-frame-first (the stack head is innermost). The ;; result can be re-pushed by with-bindings* / bound-fn*. (define (jolt-get-thread-bindings) - (let loop ((frames (reverse dyn-binding-stack)) (m (jolt-hash-map))) + (let loop ((frames (reverse (dyn-binding-stack))) (m (jolt-hash-map))) (if (null? frames) m (loop (cdr frames) diff --git a/host/chez/host-static.ss b/host/chez/host-static.ss index dc38e4b..369bae5 100644 --- a/host/chez/host-static.ss +++ b/host/chez/host-static.ss @@ -128,9 +128,16 @@ (cons "PI" (->num (* 4 (atan 1)))) (cons "E" (->num (exp 1))) (cons "random" (lambda args (->num (random 1.0)))))) -;; Thread: no real threading here (futures/timing are jolt-byjr). sleep is a no-op. +;; Thread: real OS threads back futures/promises (jolt-byjr), so sleep genuinely +;; parks the calling thread for `ms` milliseconds (a worker sleeping doesn't block +;; the parent). yield hands off the scheduler. (register-class-statics! "Thread" - (list (cons "sleep" (lambda (ms . _) jolt-nil)) + (list (cons "sleep" (lambda (ms . _) + (let* ((ms* (exact (floor ms))) + (secs (quotient ms* 1000)) + (nanos (* (remainder ms* 1000) 1000000))) + (sleep (make-time 'time-duration nanos secs))) + jolt-nil)) (cons "yield" (lambda () jolt-nil)) (cons "interrupted" (lambda () #f)) (cons "currentThread" (lambda () (make-jhost "thread" '()))))) diff --git a/host/chez/post-prelude.ss b/host/chez/post-prelude.ss index 4f42e6e..af69537 100644 --- a/host/chez/post-prelude.ss +++ b/host/chez/post-prelude.ss @@ -38,3 +38,20 @@ ;; ns-name: the overlay reads (get ns :name) — nil on a jns namespace record. ;; Native version (defined in ns.ss) returns the namespace's name symbol. (def-var! "clojure.core" "ns-name" jolt-ns-name) +;; concurrency (jolt-byjr): the overlay's future-done?/future-cancelled?/realized? +;; read a Janet future-map's :cached/:cancelled keys, and promise/deliver are a +;; non-blocking atom shim. A Chez future/promise is a record, and we want JVM +;; (blocking, shared-heap) semantics — re-assert the native versions. realized? +;; wraps the overlay (which still handles delay/lazy-seq/atom) for non-futures. +(def-var! "clojure.core" "future-done?" jolt-native-future-done?) +(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?) +(def-var! "clojure.core" "future?" jolt-future?) +(def-var! "clojure.core" "promise" jolt-promise-new) +(def-var! "clojure.core" "deliver" jolt-deliver) +(def-var! "clojure.core" "deref" jolt-deref) +(let ((overlay-realized? (var-deref "clojure.core" "realized?"))) + (def-var! "clojure.core" "realized?" + (lambda (x) + (if (or (jolt-future? x) (jolt-promise? x)) + (jolt-conc-realized? x) + (jolt-invoke overlay-realized? x))))) diff --git a/host/chez/rt.ss b/host/chez/rt.ss index b2c7716..fc2a2ee 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -325,3 +325,9 @@ ;; on Chez, inc6b) calls these to build its expansion as reader forms. Needs the ;; collection/seq layer + def-var!; order-independent past those. (load "host/chez/syntax-quote.ss") + +;; concurrency (jolt-byjr): real OS-thread futures + blocking promises, shared-heap +;; (JVM) semantics. Loaded LAST — chains the fully-built jolt-deref and conveys the +;; thread-local binding stack (dyn-binding.ss) into workers. pmap/pcalls/pvalues +;; (overlay, over `future`) light up once future-call exists here. +(load "host/chez/concurrency.ss") diff --git a/host/chez/seed/prelude.ss b/host/chez/seed/prelude.ss index 9b1b7a2..7f3f779 100644 --- a/host/chez/seed/prelude.ss +++ b/host/chez/seed/prelude.ss @@ -945,7 +945,7 @@ (guard (e (#t #f)) (def-var! "clojure.core" "take-nth" (letrec ((take-nth (case-lambda ((n) (let fnrec177 ((n n)) (lambda (rf) (let fnrec178 ((rf rf)) (let* ((iv (jolt-invoke (var-deref "clojure.core" "volatile!") -1.0))) (case-lambda (() (let fnrec179 () (jolt-invoke rf ))) ((result) (let fnrec180 ((result result)) (jolt-invoke rf result))) ((result input) (let fnrec181 ((result result) (input input)) (let* ((i (jolt-invoke (var-deref "clojure.core" "vswap!") iv jolt-inc))) (if (jolt-zero? (remainder i n)) (jolt-invoke rf result input) result)))))))))) ((n coll) (let fnrec182 ((n n) (coll coll)) (jolt-invoke (var-deref "clojure.core" "make-lazy-seq") (lambda () (let fnrec183 () (jolt-invoke (var-deref "clojure.core" "coll->cells") (let* ((temp__15__auto (jolt-seq coll))) (if (jolt-truthy? temp__15__auto) (let* ((s temp__15__auto)) (jolt-cons (jolt-first s) (jolt-invoke take-nth n (jolt-drop n s)))) jolt-nil))))))))))) take-nth))) (guard (e (#t #f)) - (def-var! "clojure.core" "pmap" (letrec ((pmap (case-lambda ((f coll) (let fnrec184 ((f f) (coll coll)) (jolt-map (var-deref "clojure.core" "deref") (jolt-invoke (var-deref "clojure.core" "doall") (jolt-map (lambda (x) (let fnrec185 ((x x)) (host-static-call "clojure.core" "future-call" (lambda () (let fnrec186 () (jolt-invoke f x)))))) coll))))) ((f coll . colls) (let fnrec187 ((f f) (coll coll) (colls (list->cseq colls))) (jolt-invoke pmap (lambda (xs) (let fnrec188 ((xs xs)) (jolt-apply f xs))) (jolt-apply jolt-map jolt-vector coll colls))))))) pmap))) + (def-var! "clojure.core" "pmap" (letrec ((pmap (case-lambda ((f coll) (let fnrec184 ((f f) (coll coll)) (jolt-map (var-deref "clojure.core" "deref") (jolt-invoke (var-deref "clojure.core" "doall") (jolt-map (lambda (x) (let fnrec185 ((x x)) (jolt-invoke (var-deref "clojure.core" "future-call") (lambda () (let fnrec186 () (jolt-invoke f x)))))) coll))))) ((f coll . colls) (let fnrec187 ((f f) (coll coll) (colls (list->cseq colls))) (jolt-invoke pmap (lambda (xs) (let fnrec188 ((xs xs)) (jolt-apply f xs))) (jolt-apply jolt-map jolt-vector coll colls))))))) pmap))) (guard (e (#t #f)) (def-var! "clojure.core" "pcalls" (letrec ((pcalls (lambda fns (let fnrec189 ((fns (list->cseq fns))) (jolt-invoke (var-deref "clojure.core" "pmap") (lambda (f) (let fnrec190 ((f f)) (jolt-invoke f ))) fns))))) pcalls))) (guard (e (#t #f)) diff --git a/test/chez/cli-test.janet b/test/chez/cli-test.janet index 4e0f5b8..ea5d2a7 100644 --- a/test/chez/cli-test.janet +++ b/test/chez/cli-test.janet @@ -47,7 +47,28 @@ ["(map eval [(quote (+ 1 1)) (quote (* 3 3))])" "(2 9)"] ["(defmacro add1 [x] (list (quote +) x 1)) (add1 10)" "11"] ["(defmacro twice [x] `(do ~x ~x)) (twice (+ 2 3))" "5"] - ["(defmacro m [x] `(+ ~x 1)) (m (m (m 0)))" "3"]]) + ["(defmacro m [x] `(+ ~x 1)) (m (m (m 0)))" "3"] + # jolt-byjr: concurrency — futures/pmap/promise on real OS threads (shared heap). + ["(deref (future (+ 1 2)))" "3"] + ["@(future (* 6 7))" "42"] + ["(deref (future (mapv inc [1 2 3])))" "[2 3 4]"] + ["(let [f (future (+ 1 1))] [(deref f) (deref f)])" "[2 2]"] + ["(future? (future 1))" "true"] + ["(future? 42)" "false"] + ["(let [f (future 1)] (deref f) (future-done? f))" "true"] + ["(let [f (future 1)] (deref f) (realized? f))" "true"] + ["(let [f (future 42)] (deref f) (deref f 1000 :nope))" "42"] + ["(vec (pmap inc [1 2 3]))" "[2 3 4]"] + ["(vec (pmap + [1 2 3] [4 5 6]))" "[5 7 9]"] + ["(vec (pcalls (fn [] 1) (fn [] 2)))" "[1 2]"] + ["(vec (pvalues (+ 1 2) (+ 3 4)))" "[3 7]"] + # shared heap = JVM semantics (NOT Janet's isolated-heap snapshot): a captured + # atom is shared, so the future's swap! is visible to the parent. + ["(let [a (atom 0)] (deref (future (swap! a inc))) @a)" "1"] + ["(let [a (atom 0)] (dorun (pmap (fn [_] (swap! a inc)) [1 2 3 4])) @a)" "4"] + # promise blocks until delivered (JVM), unlike the Janet atom-shim. + ["(let [p (promise)] (deliver p 7) @p)" "7"] + ["(let [p (promise)] (future (deliver p :hi)) @p)" ":hi"]]) (each [src want] cases (def [code out err] (joltc src)) diff --git a/test/chez/run-corpus-prelude.janet b/test/chez/run-corpus-prelude.janet index dd49cae..c1e6e6f 100644 --- a/test/chez/run-corpus-prelude.janet +++ b/test/chez/run-corpus-prelude.janet @@ -91,7 +91,22 @@ "atom?" true # Same atom-class gap, via the folded-in conformance case (jolt-ohtd): # (instance? clojure.lang.Atom (atom 1)). - "instance? Atom" true}) + "instance? Atom" true + # concurrency (jolt-byjr): the Chez runtime now uses real OS-thread futures + # sharing the heap = JVM semantics, NOT Janet's isolated-heap snapshot. So a + # captured atom is shared (the corpus :expected is the Janet snapshot value). + # Deliberate per jvm-parity-north-star. Same allowlist as the zero-Janet gate. + "captured atom is snapshotted, not shared" true # Chez 1 (shared) vs Janet 0 + "snapshot semantics" true # pmap: Chez 2 (shared) vs Janet 0 + # future-cancel of a trivial body races the worker under real threads (cancel + # usually loses -> false), like the JVM; the Janet :expected relies on its + # cooperative scheduler. Flaky/divergent. + "cancel an in-flight future returns true" true + "future-cancelled? after cancel" true}) + +# Cases that BLOCK forever on a shared-heap / JVM host (profile.edn :bucket +# :timeout) — skip, like :throws, so a hung per-case process can't stall the gate. +(def skip-blocking {"promise undelivered" true}) (def ctx (d/make-ctx)) @@ -130,7 +145,7 @@ (def t1 (os/clock)) (each row cases (def {:expected e :actual a :label l} row) - (if (= e :throws) + (if (or (= e :throws) (get skip-blocking l)) nil # :throws error-semantics aren't modeled here; skip (counted out of run) (let [src (string "(= " e " " a ")") res (d/eval-e-with-prelude ctx src prelude-path)] diff --git a/test/chez/run-corpus-zero-janet.janet b/test/chez/run-corpus-zero-janet.janet index 31ed6c7..7b364ae 100644 --- a/test/chez/run-corpus-zero-janet.janet +++ b/test/chez/run-corpus-zero-janet.janet @@ -78,7 +78,24 @@ "inf inside coll" true # #?@ reader-conditional splicing into the enclosing seq isn't supported yet # (plain #? works); a single niche corpus case. - "reader cond splice" true}) + "reader cond splice" true + # concurrency (jolt-byjr): Chez futures are real OS threads sharing the heap = + # JVM semantics, NOT Janet's isolated-heap snapshot. So a captured atom IS + # shared (the corpus :expected is the Janet snapshot value). Deliberate per the + # jvm-parity-north-star — Chez matches the JVM, Janet keeps the old snapshot. + "captured atom is snapshotted, not shared" true # Chez 1 (shared) vs Janet 0 + "snapshot semantics" true # pmap: Chez 2 (shared) vs Janet 0 + # future-cancel on a trivial body is timing-dependent under real threads: the + # future usually completes before the cancel (cancel -> false), like the JVM. + # The Janet :expected "true" relies on cooperative scheduling. Flaky/divergent. + "cancel an in-flight future returns true" true + "future-cancelled? after cancel" true}) + +# Cases that BLOCK forever on a shared-heap / JVM host (profile.edn :bucket +# :timeout) — skip them, like :throws: a single hung case would stall the whole +# batched process. (deref of an undelivered promise blocks on the JVM and now on +# Chez; Janet's non-blocking atom-shim returned nil.) +(def skip-blocking @{"promise undelivered" true}) (var pass 0) (def crashes @[]) # nonzero chez exit (analyzer/emitter raised, or runtime gap) @@ -116,8 +133,8 @@ (def rows-by-idx @{}) (def pairs @[]) (eachp [i row] cases - (def {:expected e :actual a} row) - (if (= e :throws) + (def {:expected e :actual a :label l} row) + (if (or (= e :throws) (get skip-blocking l)) (++ throws) (let [key (string i)] (put rows-by-idx key row) @@ -166,7 +183,7 @@ # Regression floor: raise as the Chez-hosted compiler closes gaps. The gate fails # on any NEW divergence or if pass drops below the floor. Strided runs scale to 0. -(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_ZJ_FLOOR") "2544"))) +(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_ZJ_FLOOR") "2569"))) (def floor (if (os/getenv "JOLT_CORPUS_LIMIT") 0 base-floor)) (when (or (> (length diverged) 0) (< pass floor)) (printf "REGRESSION: pass %d < floor %d or %d new divergence(s)" pass floor (length diverged)))