Harden STM and engine compatibility
ober
cd6c085a1fcfb1e6f6d5842b612a9adbfc82c07d
--- a/.github/workflows/security-baseline.yml +++ b/.github/workflows/security-baseline.yml @@ -13,7 +13,7 @@ jobs: baseline: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@34e114876b0b11c390a56381ad16ebd13914f8d5 # v4.3.1 - name: Required release files run: | new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,12 @@ +.PHONY: all build test + +all: + @echo "jerboa-compat — Gerbil compatibility modules" + @echo " make build Compile all modules" + @echo " make test Compile and run regression tests" + +build: + gxi build.ss + +test: build + gxi tests/stm-engine-test.ss --- a/README.md +++ b/README.md @@ -24,7 +24,14 @@ This package reproduces that surface on stock Gerbil. | `: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/engine` | native | Gerbil has **no** `:std/engine` (Chez `make-engine` has no Gambit analog). Arbitrary-thunk engines and `timed-eval` fail closed because lexical closures cannot cross exec safely; `timed-eval/cooperative` is available for trusted cleanup-aware work. | + +`timed-eval/cooperative` thunks can poll `(engine-cancelled?)` and unwind +normally when their budget expires; the helper performs a mandatory join so +`dynamic-wind` cleanup completes. The default `timed-eval`, `fuel-eval`, and +engine APIs reject arbitrary thunks. Production callers needing hostile-code +isolation must define a bounded data protocol and launch a fresh executable; +raw-fork callbacks are not a supported substitute. | `: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 --- a/engine.ss +++ b/engine.ss @@ -1,73 +1,89 @@ ;;; -*- Gerbil -*- -;;; jerboa-compat/engine — time-sliced evaluation engines. +;;; jerboa-compat/engine — bounded 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. +;;; Gambit cannot safely terminate an arbitrary Scheme thread, and an arbitrary +;;; lexical thunk cannot cross an exec boundary. The default engine and +;;; timed-eval APIs therefore fail closed. They must not resume the Gambit +;;; evaluator after raw fork in a process that may have runtime threads. +;;; +;;; Trusted tasks that need dynamic-wind cleanup can opt into +;;; timed-eval/cooperative and poll engine-cancelled?. That API deliberately +;;; joins after cancellation and is not suitable for hostile/non-cooperative +;;; code. (export make-eval-engine engine-run engine-result engine-expired? engine-map - timed-eval fuel-eval) + timed-eval timed-eval/cooperative fuel-eval engine-cancelled?) (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 ...)))) +(def *engine-cancel-token* (make-parameter #f)) + +(def (engine-cancelled?) + (let (token (*engine-cancel-token*)) + (and token (vector-ref token 0)))) -;; 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) +;; Capture an in-process cooperative worker's outcome so exceptions surface on +;; the joining side instead of becoming uncaught worker exceptions. +(def (start-cooperative-worker thunk token) (let (th (make-thread - (lambda () (try (cons 'ok (thunk)) (catch (e) (cons 'err e)))) - 'engine-worker)) + (lambda () + (parameterize ((*engine-cancel-token* token)) + (try (cons 'ok (thunk)) (catch (e) (cons 'err e))))) + 'engine-cooperative-worker)) (thread-start! th) th)) -(defstruct engx (thunk thread state value mx)) +(def (join-outcome outcome) + (cond + ((and (pair? outcome) (eq? (car outcome) 'ok)) (cdr outcome)) + ((and (pair? outcome) (eq? (car outcome) 'err)) + (let ((detail (cdr outcome))) + (if (string? detail) + (error 'isolated-evaluation detail) + (raise detail)))) + (else (error 'isolated-evaluation "invalid worker outcome")))) + +;; Evaluate with cooperative cancellation. This is intentionally named and +;; documented as trusted-only: a thunk that never polls engine-cancelled? can +;; make the mandatory join wait forever. +(def (timed-eval/cooperative seconds thunk) + (let* ((token (vector #f)) + (th (start-cooperative-worker thunk token)) + (sentinel '#(timed-eval-cooperative-timeout)) + (r (thread-join! th seconds sentinel))) + (if (eq? r sentinel) + (begin + (vector-set! token 0 #t) + (thread-join! th) + (values #f #f)) + (values (join-outcome r) #t)))) + +(defstruct engx (thunk state value mx)) (def (make-eval-engine thunk) - (make-engx thunk #f 'pending #f (make-mutex 'engine))) + (make-engx thunk 'pending #f (make-mutex 'engine))) -;; Run the engine for `ticks` worth of time. Returns #t if it completed. +;; Arbitrary Scheme closures cannot cross the required exec boundary, so the +;; legacy engine surface rejects before invoking the thunk. (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)) + (error 'engine-run + "arbitrary thunks require an exec-based worker; use timed-eval/cooperative only for trusted cleanup-aware work")) -;; 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)))))) + (join-outcome (engx-value eng)))) (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?). +;; The legacy API likewise rejects before invoking the thunk. (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)))))) + (error 'timed-eval + "arbitrary thunks require an exec-based worker; use timed-eval/cooperative only for trusted cleanup-aware work")) -;; Evaluate with a tick budget (approximated as ticks/1e7 seconds on Gambit). (def (fuel-eval ticks thunk) (timed-eval (ticks->seconds ticks) thunk)) --- a/stm.ss +++ b/stm.ss @@ -73,13 +73,16 @@ (let (we (assq tv (txr-writes tx))) (if we (cdr we) (let (re (assq tv (txr-reads tx))) - (if re (tvx-value tv) + (if re (caddr re) (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))) + ;; Retain both version and value so repeated reads are opaque: + ;; they never observe a value from a transaction that changed + ;; the TVar after our first read. + (txr-reads-set! tx (cons (list tv (car snap) (cdr snap)) (txr-reads tx))) (cdr snap))))))))) (def (tvar-write! tv val) @@ -97,33 +100,39 @@ (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)))))) + ;; Lock the complete read/write set in one stable global order. Keeping + ;; every read dependency locked through validation and publication closes + ;; the window where another transaction could change a previously checked + ;; TVar before our writes became visible. + (let* ((lock-set + (let loop ((pending writes) (all reads)) + (if (null? pending) all + (let (entry (car pending)) + (loop (cdr pending) + (if (assq (car entry) all) all (cons entry all))))))) + (sorted-locks + (sort lock-set (lambda (a b) (< (tvx-id (car a)) (tvx-id (car b)))))) + (sorted-writes + (sort writes (lambda (a b) (< (tvx-id (car a)) (tvx-id (car b))))))) + (for-each (lambda (e) (mutex-lock! (tvx-lock (car e)))) sorted-locks) + (try + (let (valid? + (every? (lambda (e) + (= (tvx-version (car e)) (cadr e))) + reads)) + (if valid? + (begin + (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-writes) + #t) + #f)) + (finally + (for-each (lambda (e) (mutex-unlock! (tvx-lock (car e)))) + (reverse sorted-locks))))))) (def (stm-wait-on-reads! tx) (let ((reads (txr-reads tx)) (w (make-thread-waiter))) new file mode 100644 --- /dev/null +++ b/tests/stm-engine-test.ss @@ -0,0 +1,97 @@ +;;; -*- Gerbil -*- + +(import :std/sugar + :jerboa-compat/stm + :jerboa-compat/engine) + +(def failures 0) + +(defrule (check! name assertion) + (if assertion + (displayln "ok: " name) + (begin + (set! failures (+ failures 1)) + (displayln "FAIL: " name)))) + +;; Classic write-skew: each transaction reads both TVars and conditionally +;; clears a different one. Serializable execution cannot leave both at zero. +(def left (make-tvar 1)) +(def right (make-tvar 1)) +(def gate-mx (make-mutex 'stm-test-gate)) +(def gate-cv (make-condition-variable 'stm-test-gate)) +(def gate-count 0) + +(def (first-attempt-barrier! first?) + (when (vector-ref first? 0) + (vector-set! first? 0 #f) + (mutex-lock! gate-mx) + (set! gate-count (+ gate-count 1)) + (if (= gate-count 2) + (condition-variable-broadcast! gate-cv) + (let loop () + (when (< gate-count 2) + (mutex-unlock! gate-mx gate-cv) + (mutex-lock! gate-mx) + (loop)))) + (mutex-unlock! gate-mx))) + +(def (skew-worker target other) + (let (first? (vector #t)) + (atomically + (let ((target-value (tvar-read target)) + (other-value (tvar-read other))) + (first-attempt-barrier! first?) + (when (= other-value 1) + (tvar-write! target 0)))))) + +(def t1 (spawn (lambda () (skew-worker left right)))) +(def t2 (spawn (lambda () (skew-worker right left)))) +(def join-timeout '#(stm-test-timeout)) +(def r1 (thread-join! t1 5 join-timeout)) +(def r2 (thread-join! t2 5 join-timeout)) +(check! "complete read/write set has a deadlock-free lock order" + (and (not (eq? r1 join-timeout)) (not (eq? r2 join-timeout)))) +(check! "write skew is serialized" + (not (and (= (tvar-ref left) 0) (= (tvar-ref right) 0)))) + +;; Cancellation must run cleanup and the worker must be joined before the +;; timeout helper returns. +(def cleanup-ran? (vector #f)) +(defvalues (timed-value completed?) + (timed-eval/cooperative + 0.01 + (lambda () + (dynamic-wind + void + (lambda () + (let loop () + (unless (engine-cancelled?) + (thread-yield!) + (loop)))) + (lambda () (vector-set! cleanup-ran? 0 #t)))))) +(check! "timed-eval reports cooperative timeout" (not completed?)) +(check! "timed-eval joins after structured cleanup" (vector-ref cleanup-ran? 0)) + +(def arbitrary-thunk-ran? (vector #f)) +(def engine + (make-eval-engine + (lambda () (vector-set! arbitrary-thunk-ran? 0 #t)))) +(check! "engine-run fails closed before running an arbitrary thunk" + (try + (begin (engine-run engine 100000) #f) + (catch (e) #t))) +(check! "engine-run rejection leaves the thunk untouched" + (not (vector-ref arbitrary-thunk-ran? 0))) + +(check! "timed-eval fails closed before running an arbitrary thunk" + (try + (begin + (timed-eval 0.01 + (lambda () (vector-set! arbitrary-thunk-ran? 0 #t))) + #f) + (catch (e) #t))) +(check! "timed-eval rejection leaves the thunk untouched" + (not (vector-ref arbitrary-thunk-ran? 0))) + +(displayln "stm-engine-tests: ok") +(exit (if (> failures 0) 1 0))