From 980ec73933ccc15201e738cfa5738792a3172a70 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Tue, 23 Jun 2026 00:06:04 -0400 Subject: [PATCH] Real Thread/yield + Thread/interrupted (jolt-l2gc) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Thread/yield was a no-op and Thread/interrupted always returned false. Now: - yield calls libc sched_yield (resolved once via the process symbols), so a spin loop relinquishes the CPU. Falls back to a zero-length park if the symbol can't be resolved. - each OS thread carries an interrupt flag (a box, thread-local). currentThread returns a handle wrapping the calling thread's flag, so .interrupt from another thread sets the target's flag. .isInterrupted reads without clearing; the static Thread/interrupted reads and clears — JVM semantics. Consolidates the Thread surface: currentThread + the instance methods live in io.ss (where the handle and its classloader are built), the flag box + yield + the interrupted static in host-static.ss. Unit cases cover yield, the read/clear split, and a cross-thread interrupt over a future. --- host/chez/host-static.ss | 45 ++++++++++++++++++++++++++++++++-------- host/chez/io.ss | 19 ++++++++++++----- host/chez/run-unit.ss | 1 + test/chez/unit.edn | 8 +++++++ 4 files changed, 59 insertions(+), 14 deletions(-) diff --git a/host/chez/host-static.ss b/host/chez/host-static.ss index 534ab7e..5ef6b02 100644 --- a/host/chez/host-static.ss +++ b/host/chez/host-static.ss @@ -161,21 +161,48 @@ (cons "PI" (->dbl (* 4 (atan 1)))) (cons "E" (->dbl (exp 1))) (cons "random" (lambda args (random 1.0))))) -;; Thread: real OS threads back futures/promises, 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" +;; Thread: real OS threads back futures/promises. +;; - sleep parks the calling thread for `ms` ms (a worker sleeping doesn't block +;; the parent). +;; - yield hands the CPU to another runnable thread (libc sched_yield). +;; - each thread carries an interrupt flag; interrupted (static) reads AND clears +;; the current thread's flag, matching the JVM. currentThread / .interrupt / +;; .isInterrupted are wired in io.ss, where the thread handle is built. + +;; Per-thread interrupt flag, lazily allocated so each OS thread gets its own box. +;; A thread handle (from currentThread) captures this box, so .interrupt from +;; another thread sets the target thread's flag. +(define thread-interrupt-box (make-thread-parameter #f)) +(define (current-interrupt-box) + (or (thread-interrupt-box) + (let ((b (box #f))) (thread-interrupt-box b) b))) +(define (clear-thread-interrupt!) (set-box! (current-interrupt-box) #f)) + +;; libc sched_yield, resolved once; fall back to a zero-length park if the symbol +;; isn't available. +(define thread-yield! + (let ((fp #f) (tried? #f)) + (lambda () + (unless tried? + (set! tried? #t) + (set! fp (guard (e (#t #f)) + (load-shared-object #f) + (foreign-procedure "sched_yield" () int)))) + (if fp (fp) (sleep (make-time 'time-duration 0 0))) + jolt-nil))) + +(define thread-statics (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" '()))))) -(register-host-methods! "thread" - (list (cons "getContextClassLoader" (lambda (self) (make-jhost "classloader" '()))))) + (cons "yield" (lambda _ (thread-yield!))) + (cons "interrupted" (lambda _ (let* ((b (current-interrupt-box)) (v (unbox b))) + (set-box! b #f) (and v #t)))))) +(register-class-statics! "Thread" thread-statics) +(register-class-statics! "java.lang.Thread" thread-statics) ;; clojure.lang.LockingTransaction: jolt has no STM (no refs/dosync), so a ;; transaction is never running. isRunning -> false. diff --git a/host/chez/io.ss b/host/chez/io.ss index 972c278..75271bd 100644 --- a/host/chez/io.ss +++ b/host/chez/io.ss @@ -369,13 +369,22 @@ (if (jolt-nil? u) jolt-nil (host-new "StringReader" (jolt-slurp (url-strip-scheme (url-spec u)))))))))) (register-class-statics! "ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader)))) (register-class-statics! "java.lang.ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader)))) -;; Thread/currentThread -> a thread jhost whose getContextClassLoader is the loader. -(define the-thread (make-jhost "thread" (vector))) +;; Thread/currentThread -> a fresh thread jhost wrapping THIS thread's interrupt +;; flag (the box from current-interrupt-box, host-static.ss), so .interrupt from +;; any thread sets the target thread's flag and .isInterrupted reads it without +;; clearing (instance semantics; the static Thread/interrupted reads-and-clears). +;; getContextClassLoader hands back the loader. (register-host-methods! "thread" (list (cons "getContextClassLoader" (lambda (self) the-classloader)) - (cons "getName" (lambda (self) "main")))) -(register-class-statics! "Thread" (list (cons "currentThread" (lambda () the-thread)))) -(register-class-statics! "java.lang.Thread" (list (cons "currentThread" (lambda () the-thread)))) + (cons "getName" (lambda (self) "main")) + (cons "interrupt" (lambda (self) + (when (box? (jhost-state self)) (set-box! (jhost-state self) #t)) + jolt-nil)) + (cons "isInterrupted" (lambda (self) + (and (box? (jhost-state self)) (unbox (jhost-state self)) #t))))) +(define (current-thread-handle) (make-jhost "thread" (current-interrupt-box))) +(register-class-statics! "Thread" (list (cons "currentThread" current-thread-handle))) +(register-class-statics! "java.lang.Thread" (list (cons "currentThread" current-thread-handle))) ;; --- java.io.File / java.util.UUID constructors ----------------------------- ;; (java.io.File. parent child) joins with "/"; (File. path) wraps the path. diff --git a/host/chez/run-unit.ss b/host/chez/run-unit.ss index 68205f6..c756ae8 100644 --- a/host/chez/run-unit.ss +++ b/host/chez/run-unit.ss @@ -56,6 +56,7 @@ (hashtable-clear! ns-alias-table) (hashtable-clear! ns-refer-table) (hashtable-clear! ns-refer-all-table) + (clear-thread-interrupt!) ; a case that set the runner thread's interrupt flag mustn't leak (when zj-ghier (jolt-invoke (var-deref "clojure.core" "reset!") (var-cell-root zj-ghier) (jolt-invoke (var-deref "clojure.core" "make-hierarchy")))) (set-chez-ns! "user")) diff --git a/test/chez/unit.edn b/test/chez/unit.edn index 1134ce9..53cb5bb 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -117,6 +117,14 @@ {:suite "reify" :expr "(do (defprotocol Q (qa [_]) (qb [_])) (extend-protocol Q java.lang.Object (qa [_] :da) (qb [_] :db)) (def r (reify Q (qa [_] :ra))) [(qa r) (qb r)])" :expected "[:ra :db]"} {:suite "interrupt" :expr "(jolt.host/run-interruptible (jolt.host/make-interrupt) (fn [] (+ 1 2)))" :expected "3"} {:suite "interrupt" :expr "(let [t (jolt.host/make-interrupt)] (jolt.host/interrupt! t) (try (jolt.host/run-interruptible t (fn [] (loop [i 0] (recur (inc i))))) :not-interrupted (catch :default e (:jolt/interrupted (ex-data e)))))" :expected "true"} + {:suite "interrupt" :expr "(do (Thread/yield) :ok)" :expected ":ok"} + {:suite "interrupt" :expr "(nil? (Thread/yield))" :expected "true"} + {:suite "interrupt" :expr "(.isInterrupted (Thread/currentThread))" :expected "false"} + {:suite "interrupt" :expr "(let [t (Thread/currentThread)] (.interrupt t) (.isInterrupted t))" :expected "true"} + {:suite "interrupt" :expr "(let [t (Thread/currentThread)] (.interrupt t) [(.isInterrupted t) (.isInterrupted t)])" :expected "[true true]"} + {:suite "interrupt" :expr "(let [t (Thread/currentThread)] (.interrupt t) [(Thread/interrupted) (Thread/interrupted)])" :expected "[true false]"} + {:suite "interrupt" :expr "(do (.interrupt (Thread/currentThread)) (Thread/interrupted) (.isInterrupted (Thread/currentThread)))" :expected "false"} + {:suite "interrupt" :expr "(let [t (atom nil) started (promise) go (promise) f (future (reset! t (Thread/currentThread)) (deliver started true) (deref go) (.isInterrupted (deref t)))] (deref started) (.interrupt (deref t)) (deliver go true) (deref f))" :expected "true"} {:suite "ns-tl" :expr "(do (in-ns (quote foo.bar)) (str *ns*))" :expected "foo.bar"} {:suite "ns-tl" :expr "(do (create-ns (quote my.ns)) (binding [*ns* (find-ns (quote my.ns))] (str *ns*)))" :expected "my.ns"} {:suite "ns-tl" :expr "(do (in-ns (quote app.core)) (def sekret 42) (in-ns (quote user)) (binding [*ns* (find-ns (quote app.core))] (load-string \"sekret\")))" :expected "42"}