jerboa-compat: Gerbil shims for the Jerboa stdlib Gerbil lacks
ober
c4ddff5f03d5c52b6453822d708b340be2576760
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +.gerbil/ +*.o +*.o1 +*.o1.dSYM/ +*~ +manifest.ss new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,65 @@ +# jerboa-compat + +Gerbil-only compatibility shims providing the parts of Jerboa's standard library +that **Gerbil Scheme lacks**, so Jerboa `.ss` sources (e.g. from `jerboa-emacs`) +can be ported to Gerbil (e.g. `gerbil-emacs`) with mechanical import renames +instead of rewrites. + +> Repo routing: this is a Gerbil library, so it lives on **git.cons.io** as +> `gerbil-jerboa-compat` (Gerbil package name: `jerboa-compat`). The on-disk dir +> is `~/mine/jerboa-compat`. + +## Why + +`jerboa-emacs` and `gerbil-emacs` are forks of one ancestor and share almost the +same surface syntax (`def`, `defstruct`, `:std/sugar`, `[...]`, `(export …)`). +The friction when porting Jerboa → Gerbil is a handful of stdlib modules Jerboa +exposes that Gerbil does not — concentrated in `jerboa-emacs`'s `chez-powers.ss`. +This package reproduces that surface on stock Gerbil. + +## Modules + +| Module | Backing | Notes | +|---|---|---| +| `:jerboa-compat/atom` | native | Clojure-style atoms; was already portable Gerbil. | +| `:jerboa-compat/lru-cache` | native | Gerbil has `:std/misc/lru` with a different API; this gives Jerboa's `lru-cache-*` surface, thread-safe. | +| `:jerboa-compat/stm` | native | Gerbil has **no** `:std/stm`. STM on Gambit threads + condition variables (the fiber path is dropped). | +| `:jerboa-compat/engine` | native | Gerbil has **no** `:std/engine` (Chez `make-engine` has no Gambit analog). Emulated with a background thread joined under a time budget. | +| `:jerboa-compat/powers` | umbrella | Mirrors `chez-powers.ss`: re-exports the four above plus `:std/amb`, `:std/misc/{completion,rwlock,pqueue,wg,channel,rbtree,barrier}`, with Jerboa-named adapters where Gerbil's names differ. | + +## Porting import map + +When converting a `jerboa-emacs` source to `gerbil-emacs`: + +| Jerboa import | Gerbil import | +|---|---| +| `:jerboa-emacs/chez-powers` | `:jerboa-compat/powers` | +| `:jerboa-emacs/atom` | `:jerboa-compat/atom` | +| `:jerboa-emacs/<other>` | `:gemacs/<other>` | +| `:jerboa-scintilla/…` | `:gerbil-scintilla/…` | +| `:jerboa-qt/…` | `:gerbil-qt/…` | + +(The `jerboa-gerbil` converter applies these automatically.) + +## Residual gaps + +A few Jerboa symbols can't be backed by Gerbil's primitive without a native +rewrite; they are **not** yet exported by `powers.ss`: + +- `channel-length`, `channel-empty?`, `channel-select` — Gerbil's `:std/misc/channel` + is otherwise re-exported (put/get/try/close/closed?). +- `barrier-parties`, `barrier-waiting`, `barrier-reset!` — Gerbil's barrier is + one-shot (post/error/wait), not the cyclic N-party barrier Jerboa ships. +- `amb` is re-exported from `:std/amb`; confirm call sites (its dynamic-state + macros differ subtly from Jerboa's). + +Each is a small follow-up (a native ring-buffer channel and a cyclic barrier). + +## Build & test + +```bash +gerbil build # or ./build.ss +``` + +Modules are developed and tested through the `gerbil-mcp` toolchain +(`gerbil_compile_check`, `gerbil_eval`) against `/opt/gerbil/bin/gxi`. new file mode 100644 --- /dev/null +++ b/atom.ss @@ -0,0 +1,70 @@ +;;; -*- Gerbil -*- +;;; jerboa-compat/atom — Clojure-style atoms (thread-safe mutable references). +;;; +;;; Ported verbatim from jerboa-emacs' src/jerboa-emacs/atom.ss; it was already +;;; written in portable Gerbil surface syntax (def, :std/sugar, with-mutex), so +;;; no translation is required. Provided here so converted jerboa code that +;;; imported :jerboa-emacs/atom can import :jerboa-compat/atom unchanged. + +(export atom atom? atom-deref atom-reset! atom-swap! atom-update!) + +(import :std/sugar) + +;; Gerbil's :std/sugar has no with-mutex (jerboa's did). Define it locally on +;; the Gambit mutex primitives, exception-safe via dynamic-wind. +(def (call-with-mutex mx thunk) + (dynamic-wind + (lambda () (mutex-lock! mx)) + thunk + (lambda () (mutex-unlock! mx)))) + +(defrules with-mutex () + ((_ mx body ...) (call-with-mutex mx (lambda () body ...)))) + +(def +jc-atom-tag+ 'jerboa-compat-atom) + +(def (atom initial-value) + (vector +jc-atom-tag+ initial-value (make-mutex 'jerboa-compat-atom))) + +(def (atom? x) + (and (vector? x) + (= (vector-length x) 3) + (eq? (vector-ref x 0) +jc-atom-tag+))) + +(def (check-atom who a) + (unless (atom? a) + (error who "not an atom" a))) + +(def (atom-value a) + (vector-ref a 1)) + +(def (atom-value-set! a value) + (vector-set! a 1 value)) + +(def (atom-mutex a) + (vector-ref a 2)) + +(def (atom-deref a) + (check-atom 'atom-deref a) + (with-mutex (atom-mutex a) + (atom-value a))) + +(def (atom-reset! a value) + (check-atom 'atom-reset! a) + (with-mutex (atom-mutex a) + (atom-value-set! a value)) + value) + +(def (atom-swap! a proc) + (check-atom 'atom-swap! a) + (with-mutex (atom-mutex a) + (let ((value (proc (atom-value a)))) + (atom-value-set! a value) + value))) + +(def (atom-update! a proc . args) + (check-atom 'atom-update! a) + (with-mutex (atom-mutex a) + (let ((value (apply proc (atom-value a) args))) + (atom-value-set! a value) + value))) new file mode 100755 --- /dev/null +++ b/build.ss @@ -0,0 +1,12 @@ +#!/usr/bin/env gxi +;;; -*- Gerbil -*- +;;; Build script for jerboa-compat. Run: ./build.ss (or: gerbil build) + +(import :std/build-script) + +(defbuild-script + '("atom" + "lru-cache" + "stm" + "engine" + "powers")) new file mode 100644 --- /dev/null +++ b/engine.ss @@ -0,0 +1,73 @@ +;;; -*- Gerbil -*- +;;; jerboa-compat/engine — time-sliced evaluation engines. +;;; +;;; Chez's make-engine (instruction-counted preemption) has no Gambit +;;; equivalent, so this emulates engines with a background Gambit thread joined +;;; under a time budget. "ticks" are interpreted as a time budget +;;; (ticks / 1e7 seconds) — the same scaling jerboa's timed-eval used. An engine +;;; keeps running between engine-run calls, so it accumulates progress; it just +;;; cannot be paused mid-step. fuel-eval is therefore a time approximation. + +(export make-eval-engine engine-run engine-result engine-expired? engine-map + timed-eval fuel-eval) + +(import :std/sugar) + +(def +ticks-per-second+ 10000000) +(def (ticks->seconds ticks) (/ (exact->inexact ticks) +ticks-per-second+)) + +(def (call-with-mutex mx thunk) + (dynamic-wind (lambda () (mutex-lock! mx)) thunk (lambda () (mutex-unlock! mx)))) +(defrules with-mutex () ((_ mx body ...) (call-with-mutex mx (lambda () body ...)))) + +;; Worker captures its outcome as (ok . val) or (err . exn) so an exception in +;; the thunk surfaces on the joining side rather than as an uncaught-exception. +(def (start-worker thunk) + (let (th (make-thread + (lambda () (try (cons 'ok (thunk)) (catch (e) (cons 'err e)))) + 'engine-worker)) + (thread-start! th) + th)) + +(defstruct engx (thunk thread state value mx)) +(def (make-eval-engine thunk) + (make-engx thunk #f 'pending #f (make-mutex 'engine))) + +;; Run the engine for `ticks` worth of time. Returns #t if it completed. +(def (engine-run eng ticks) + (with-mutex (engx-mx eng) + (when (eq? (engx-state eng) 'pending) + (engx-thread-set! eng (start-worker (engx-thunk eng))) + (engx-state-set! eng 'running))) + (unless (eq? (engx-state eng) 'completed) + (let* ((sentinel '#(engine-timeout)) + (r (thread-join! (engx-thread eng) (ticks->seconds ticks) sentinel))) + (if (eq? r sentinel) + (engx-state-set! eng 'expired) ; out of fuel; thread keeps running + (begin (engx-state-set! eng 'completed) (engx-value-set! eng r))))) + (eq? (engx-state eng) 'completed)) + +;; Result of a completed engine (re-raises if the thunk raised); #f otherwise. +(def (engine-result eng) + (and (eq? (engx-state eng) 'completed) + (let (r (engx-value eng)) + (if (eq? (car r) 'ok) (cdr r) (raise (cdr r)))))) + +(def (engine-expired? eng) (eq? (engx-state eng) 'expired)) + +;; Like jerboa: builds a fresh engine that maps f over a fresh run of the thunk. +(def (engine-map f eng) + (make-eval-engine (lambda () (f ((engx-thunk eng)))))) + +;; Evaluate with a wall-clock budget (seconds). Returns (values result completed?). +(def (timed-eval seconds thunk) + (let* ((th (start-worker thunk)) + (sentinel '#(timed-eval-timeout)) + (r (thread-join! th seconds sentinel))) + (if (eq? r sentinel) + (begin (thread-terminate! th) (values #f #f)) + (if (eq? (car r) 'ok) (values (cdr r) #t) (raise (cdr r)))))) + +;; Evaluate with a tick budget (approximated as ticks/1e7 seconds on Gambit). +(def (fuel-eval ticks thunk) + (timed-eval (ticks->seconds ticks) thunk)) new file mode 100644 --- /dev/null +++ b/gerbil.pkg @@ -0,0 +1 @@ +(package: jerboa-compat) new file mode 100644 --- /dev/null +++ b/lru-cache.ss @@ -0,0 +1,130 @@ +;;; -*- Gerbil -*- +;;; jerboa-compat/lru-cache — bounded, thread-safe LRU cache (O(1) ops). +;;; +;;; Ported from jerboa's (std misc lru-cache) [Chez]. Gerbil ships :std/misc/lru +;;; but with a different surface; this provides jerboa's exact API. Chez +;;; hashtables -> Gerbil :std/misc/hash; a per-cache mutex makes it thread-safe. + +(export make-lru-cache lru-cache? lru-cache-get lru-cache-put! lru-cache-delete! + lru-cache-contains? lru-cache-clear! lru-cache-size lru-cache-capacity + lru-cache-keys lru-cache-values lru-cache-stats lru-cache-for-each) + +(import :std/sugar :std/misc/hash) + +(def (call-with-mutex mx thunk) + (dynamic-wind (lambda () (mutex-lock! mx)) thunk (lambda () (mutex-unlock! mx)))) +(defrules with-mutex () ((_ mx body ...) (call-with-mutex mx (lambda () body ...)))) + +;; doubly-linked node +(defstruct node (key value prev next)) +(def (mk-node key value) (make-node key value #f #f)) + +;; cache record (internal name lruc to avoid clashing with the public API names) +(defstruct lruc (capacity table head tail size hits misses mutex)) + +(def (make-lru-cache cap) + (unless (and (integer? cap) (> cap 0)) + (error 'make-lru-cache "capacity must be a positive integer" cap)) + (make-lruc cap (make-hash-table) #f #f 0 0 0 (make-mutex 'lru-cache))) + +(def (lru-cache? x) (lruc? x)) +(def (lru-cache-size c) (lruc-size c)) +(def (lru-cache-capacity c) (lruc-capacity c)) + +;; ---- internal linked-list ops (caller holds the mutex) ---- +(def (add-to-head! c n) + (node-prev-set! n #f) + (node-next-set! n (lruc-head c)) + (when (lruc-head c) (node-prev-set! (lruc-head c) n)) + (lruc-head-set! c n) + (unless (lruc-tail c) (lruc-tail-set! c n))) + +(def (remove-node! c n) + (let ((p (node-prev n)) (nx (node-next n))) + (if p (node-next-set! p nx) (lruc-head-set! c nx)) + (if nx (node-prev-set! nx p) (lruc-tail-set! c p)))) + +(def (move-to-head! c n) + (unless (eq? n (lruc-head c)) + (remove-node! c n) + (add-to-head! c n))) + +(def (evict-tail! c) + (let (t (lruc-tail c)) + (when t + (hash-remove! (lruc-table c) (node-key t)) + (remove-node! c t) + (lruc-size-set! c (- (lruc-size c) 1))))) + +;; ---- public ops ---- +(def lru-cache-get + (case-lambda + ((c key) (lru-cache-get c key #f)) + ((c key default) + (with-mutex (lruc-mutex c) + (let (n (hash-ref (lruc-table c) key #f)) + (if n + (begin + (lruc-hits-set! c (+ (lruc-hits c) 1)) + (move-to-head! c n) + (node-value n)) + (begin + (lruc-misses-set! c (+ (lruc-misses c) 1)) + default))))))) + +(def (lru-cache-put! c key value) + (with-mutex (lruc-mutex c) + (let (existing (hash-ref (lruc-table c) key #f)) + (if existing + (begin (node-value-set! existing value) (move-to-head! c existing)) + (begin + (when (= (lruc-size c) (lruc-capacity c)) (evict-tail! c)) + (let (n (mk-node key value)) + (hash-put! (lruc-table c) key n) + (lruc-size-set! c (+ (lruc-size c) 1)) + (add-to-head! c n))))))) + +(def (lru-cache-delete! c key) + (with-mutex (lruc-mutex c) + (let (n (hash-ref (lruc-table c) key #f)) + (when n + (remove-node! c n) + (hash-remove! (lruc-table c) key) + (lruc-size-set! c (- (lruc-size c) 1)))))) + +(def (lru-cache-contains? c key) + (with-mutex (lruc-mutex c) + (and (hash-ref (lruc-table c) key #f) #t))) + +(def (lru-cache-clear! c) + (with-mutex (lruc-mutex c) + (lruc-table-set! c (make-hash-table)) + (lruc-head-set! c #f) + (lruc-tail-set! c #f) + (lruc-size-set! c 0))) + +(def (lru-cache-keys c) + (with-mutex (lruc-mutex c) + (let loop ((n (lruc-head c)) (acc '())) + (if (not n) (reverse acc) (loop (node-next n) (cons (node-key n) acc)))))) + +(def (lru-cache-values c) + (with-mutex (lruc-mutex c) + (let loop ((n (lruc-head c)) (acc '())) + (if (not n) (reverse acc) (loop (node-next n) (cons (node-value n) acc)))))) + +(def (lru-cache-for-each proc c) + (let (pairs (with-mutex (lruc-mutex c) + (let loop ((n (lruc-head c)) (acc '())) + (if (not n) (reverse acc) + (loop (node-next n) (cons (cons (node-key n) (node-value n)) acc)))))) + (for-each (lambda (kv) (proc (car kv) (cdr kv))) pairs))) + +(def (lru-cache-stats c) + (with-mutex (lruc-mutex c) + (let* ((h (lruc-hits c)) (m (lruc-misses c)) (total (+ h m))) + (list (cons 'size (lruc-size c)) + (cons 'capacity (lruc-capacity c)) + (cons 'hits h) + (cons 'misses m) + (cons 'hit-rate (if (= total 0) 0.0 (exact->inexact (/ h total)))))))) new file mode 100644 --- /dev/null +++ b/powers.ss @@ -0,0 +1,89 @@ +;;; -*- Gerbil -*- +;;; jerboa-compat/powers — umbrella mirroring jerboa-emacs' chez-powers.ss. +;;; +;;; A converted jerboa-emacs source that did `(import :jerboa-emacs/chez-powers)` +;;; becomes `(import :jerboa-compat/powers)` and gets the same surface. Three +;;; tiers back it: +;;; 1. Natively implemented here (Gerbil has no equivalent): atom, stm, engine, +;;; lru-cache. +;;; 2. Gerbil stdlib, jerboa names match: completion, amb (+amb-fail). +;;; 3. Gerbil stdlib, jerboa names differ — adapter defs below: wg, pqueue, +;;; rwlock, rbtree. +;;; +;;; Residual gaps (Gerbil's primitive can't back these without a native rewrite; +;;; tracked in README): channel-length/channel-empty?/channel-select, and the +;;; cyclic-barrier ops barrier-parties/barrier-waiting/barrier-reset!. The +;;; underlying channel and (one-shot) barrier are otherwise re-exported. + +(export + ;; tier 1 — native jerboa-compat modules (exact jerboa surface) + (import: :jerboa-compat/atom) + (import: :jerboa-compat/stm) + (import: :jerboa-compat/engine) + (import: :jerboa-compat/lru-cache) + ;; tier 2/3 — Gerbil stdlib re-exported wholesale (their native names) + (import: :std/misc/completion) + (import: :std/misc/rwlock) + (import: :std/amb) + (import: :std/misc/pqueue) + (import: :std/misc/wg) + (import: :std/misc/channel) + (import: :std/misc/rbtree) + (import: :std/misc/barrier) + ;; jerboa-named adapters defined below + amb-fail + pqueue-length pqueue->list pqueue-for-each pqueue-clear! + wg? wg-add wg-done wg-wait + read-lock! read-unlock! write-lock! write-unlock! + rbtree-insert rbtree-lookup rbtree-delete rbtree-contains? + rbtree-size rbtree-min rbtree-max) + +(import :jerboa-compat/atom + :jerboa-compat/stm + :jerboa-compat/engine + :jerboa-compat/lru-cache + :std/misc/completion + :std/misc/rwlock + :std/amb + :std/misc/pqueue + :std/misc/wg + :std/misc/channel + :std/misc/rbtree + :std/misc/barrier) + +;; ---- amb ---- +(def (amb-fail) (amb)) ; empty amb = backtrack/fail + +;; ---- pqueue (Gerbil: pqueue-size / pqueue-contents; no for-each/clear!) ---- +(def pqueue-length pqueue-size) +(def pqueue->list pqueue-contents) +(def (pqueue-for-each proc pq) (for-each proc (pqueue-contents pq))) +(def (pqueue-clear! pq) + (let loop () (unless (pqueue-empty? pq) (pqueue-pop! pq) (loop)))) + +;; ---- wg (Gerbil: WG? / wg-add! / wg-wait!; no wg-done) ---- +(def wg? WG?) +(def (wg-add wg (n 1)) (wg-add! wg n)) ; Gerbil wg-add! is strictly arity-2 +(def (wg-done wg) (wg-add! wg -1)) +(def (wg-wait wg) (wg-wait! wg)) + +;; ---- rwlock (Gerbil prefixes with rwlock-) ---- +(def read-lock! rwlock-read-lock!) +(def read-unlock! rwlock-read-unlock!) +(def write-lock! rwlock-write-lock!) +(def write-unlock! rwlock-write-unlock!) + +;; ---- rbtree (Gerbil: put/get/remove; functional variants have no !) ---- +(def rbtree-insert rbtree-put) ; (rbtree-insert t k v) -> new tree +(def rbtree-lookup rbtree-get) ; (rbtree-lookup t k) -> value | #f +(def rbtree-delete rbtree-remove) +(def (rbtree-contains? t k) ; rbtree->list yields sorted (k . v) + (let loop ((l (rbtree->list t))) + (and (pair? l) (or (equal? (caar l) k) (loop (cdr l)))))) +(def (rbtree-size t) (length (rbtree->list t))) +(def (rbtree-min t) + (let (l (rbtree->list t)) (and (pair? l) (car l)))) +(def (rbtree-max t) + (let (l (rbtree->list t)) + (and (pair? l) + (let loop ((l l)) (if (null? (cdr l)) (car l) (loop (cdr l))))))) new file mode 100644 --- /dev/null +++ b/stm.ss @@ -0,0 +1,186 @@ +;;; -*- Gerbil -*- +;;; jerboa-compat/stm — Software Transactional Memory. +;;; +;;; Ported from jerboa's (std stm) [Chez + (std fiber)]. Gerbil ships no +;;; :std/stm. The fiber-waiter path is dropped — Gerbil concurrency is Gambit +;;; threads — so a transaction that (retry)s blocks on a Gambit condition +;;; variable until one of the tvars it read is written. +;;; +;;; Public surface matches jerboa exactly: make-tvar/tvar?/tvar-ref, +;;; atomically/tvar-read/tvar-write!/retry/or-else, plus Clojure-style refs. + +(export make-tvar tvar? tvar-ref atomically tvar-read tvar-write! retry or-else + make-ref ref? ref-deref dosync alter ref-set commute ensure io!) + +(import :std/sugar :std/sort) + +;; ---- tvar (internal struct name tvx; public names aliased below) ---- +(def *tvar-id* 0) +(def *tvar-id-mx* (make-mutex 'tvar-id)) +(def (next-tvar-id!) + (mutex-lock! *tvar-id-mx*) + (let (id *tvar-id*) + (set! *tvar-id* (+ id 1)) + (mutex-unlock! *tvar-id-mx*) + id)) + +(defstruct tvx (value version lock waiters id)) +(def tvar? tvx?) +(def (make-tvar init) (make-tvx init 0 (make-mutex 'tvar) '() (next-tvar-id!))) +(def (tvar-ref tv) (tvx-value tv)) ; raw, non-transactional read + +;; ---- condvar-based waiter (thread path only) ---- +(defstruct waiter (mutex cv signaled)) +(def (make-thread-waiter) + (make-waiter (make-mutex 'stm-waiter) (make-condition-variable 'stm-waiter) #f)) +(def (waiter-wait! w) + (let (m (waiter-mutex w)) + (mutex-lock! m) + (let loop () + (unless (waiter-signaled w) + (mutex-unlock! m (waiter-cv w)) ; atomically unlock + block on cv + (mutex-lock! m) + (loop))) + (mutex-unlock! m))) +(def (waiter-signal! w) + (let (m (waiter-mutex w)) + (mutex-lock! m) + (waiter-signaled-set! w #t) + (condition-variable-signal! (waiter-cv w)) + (mutex-unlock! m))) + +(def (notify-waiters! tv) + (let (ws (tvx-waiters tv)) + (tvx-waiters-set! tv '()) + (for-each waiter-signal! ws))) + +;; ---- transaction state ---- +(defstruct txr (reads writes)) +(def (make-tx) (make-txr '() '())) +(def *current-tx* (make-parameter #f)) + +(defstruct stm-retry-exn ()) +(def (retry) (raise (make-stm-retry-exn))) + +(def (every? pred lst) + (let loop ((l lst)) (or (null? l) (and (pred (car l)) (loop (cdr l)))))) +(def (remq-eq x lst) (filter (lambda (y) (not (eq? x y))) lst)) + +(def (tvar-read tv) + (let (tx (*current-tx*)) + (if (not tx) + (tvx-value tv) + (let (we (assq tv (txr-writes tx))) + (if we (cdr we) + (let (re (assq tv (txr-reads tx))) + (if re (tvx-value tv) + (let (snap (let (mx (tvx-lock tv)) + (mutex-lock! mx) + (let ((v (tvx-version tv)) (x (tvx-value tv))) + (mutex-unlock! mx) + (cons v x)))) + (txr-reads-set! tx (cons (cons tv (car snap)) (txr-reads tx))) + (cdr snap))))))))) + +(def (tvar-write! tv val) + (let (tx (*current-tx*)) + (if (not tx) + (let (mx (tvx-lock tv)) + (mutex-lock! mx) + (tvx-value-set! tv val) + (tvx-version-set! tv (+ (tvx-version tv) 1)) + (notify-waiters! tv) + (mutex-unlock! mx)) + (let (entry (assq tv (txr-writes tx))) + (if entry (set-cdr! entry val) + (txr-writes-set! tx (cons (cons tv val) (txr-writes tx)))))))) + +(def (tx-commit! tx) + (let ((reads (txr-reads tx)) (writes (txr-writes tx))) + ;; lock all written tvars in a stable id order to avoid deadlock + (let (sorted (sort writes (lambda (a b) (< (tvx-id (car a)) (tvx-id (car b)))))) + (for-each (lambda (e) (mutex-lock! (tvx-lock (car e)))) sorted) + (let (valid? + (every? (lambda (e) + (let* ((tv (car e)) (expected (cdr e)) (in-write (assq tv writes))) + (if in-write + (= (tvx-version tv) expected) + (let (mx (tvx-lock tv)) + (mutex-lock! mx) + (let (ok (= (tvx-version tv) expected)) + (mutex-unlock! mx) + ok))))) + reads)) + (cond + (valid? + (for-each (lambda (e) + (let (tv (car e)) + (tvx-value-set! tv (cdr e)) + (tvx-version-set! tv (+ (tvx-version tv) 1)) + (notify-waiters! tv))) + sorted) + (for-each (lambda (e) (mutex-unlock! (tvx-lock (car e)))) sorted) + #t) + (else + (for-each (lambda (e) (mutex-unlock! (tvx-lock (car e)))) sorted) + #f)))))) + +(def (stm-wait-on-reads! tx) + (let ((reads (txr-reads tx)) (w (make-thread-waiter))) + (for-each (lambda (e) + (let* ((tv (car e)) (mx (tvx-lock tv))) + (mutex-lock! mx) + (tvx-waiters-set! tv (cons w (tvx-waiters tv))) + (mutex-unlock! mx))) + reads) + (waiter-wait! w) + (for-each (lambda (e) + (let* ((tv (car e)) (mx (tvx-lock tv))) + (mutex-lock! mx) + (tvx-waiters-set! tv (remq-eq w (tvx-waiters tv))) + (mutex-unlock! mx))) + reads))) + +(def (%run-atomically thunk) + (if (*current-tx*) + (thunk) ; nested: join the outer transaction + (let loop () + (let (tx (make-tx)) + (parameterize ((*current-tx* tx)) + (let (outcome + (try + (let (result (thunk)) + (if (tx-commit! tx) (cons 'ok result) 'restart)) + (catch (e) + (if (stm-retry-exn? e) 'wait (raise e))))) + (cond + ((pair? outcome) (cdr outcome)) + ((eq? outcome 'wait) (stm-wait-on-reads! tx) (loop)) + (else (loop))))))))) + +(defrules atomically () + ((_ body ...) (%run-atomically (lambda () body ...)))) + +(defrules or-else () + ((_ e1 e2) (try e1 (catch (ex) (if (stm-retry-exn? ex) e2 (raise ex)))))) + +(defrules dosync () + ((_ body ...) (atomically body ...))) + +(defrules io! () + ((_ body ...) + (begin + (when (*current-tx*) (error "io! forms are not allowed inside a transaction")) + body ...))) + +;; ---- Clojure-style refs (thin aliases over tvars) ---- +(def make-ref make-tvar) +(def ref? tvar?) +(def ref-deref tvar-read) +(def (alter r f . args) + (let* ((old (tvar-read r)) (new (apply f old args))) + (tvar-write! r new) + new)) +(def (ref-set r val) (tvar-write! r val) val) +(def (commute r f . args) (apply alter r f args)) +(def (ensure r) (tvar-read r))