simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Real Thread/yield + Thread/interrupted (jolt-l2gc)

Browse source 
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.
This commit is contained in:
Yogthos 2026-06-23 00:06:04 -04:00
parent 87aec859b8
commit 980ec73933
4 changed files with 59 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

45
host/chez/host-static.ss
View file

@ -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.

19
host/chez/io.ss
View file

@ -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.

1
host/chez/run-unit.ss
View file

@ -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"))

8
test/chez/unit.edn
View file

@ -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"}