Serialise a connection across the whole primitive; finalize on every path
A SQLite connection is a SERIAL resource and this library treated it as a shared one. SQLite ends a connection's implicit read transaction only when NO statement on it is active, so if fiber A has a statement open and fiber B runs a query on the SAME connection, B's read transaction cannot be released when B finalizes -- A is still using the btree. The connection is pinned to B's snapshot until A completes, and every later read on it silently misses anything committed in between.
Measured against kiln, whose controller shares one connection between its HTTP app and its run loop: /api/groups answered HTTP 200 with a pre-commit view of its own database -- 55 rows where an independent connection to the same file saw 755 -- and stayed that way until the process restarted.
Three defects, three changes.
- THE CONNECTION IS NOW HELD ACROSS THE WHOLE PRIMITIVE. sqlite-query, sqlite-query-row, sqlite-run and sqlite-exec take a per-connection lock for their whole duration, yields included.
Guarding only the busy window would not have been enough, and that is a
measurement rather than a judgement: a fiber yields inside an UNCONTENDED
query too, allocation-driven, roughly once per 450 rows. A witness fiber
counts ~44 yields across a 20000-row query with no contention anywhere. Scope is deliberately the PRIMITIVE. Held any coarser it would deadlock the
moment a consumer's database helper called another one. At primitive scope
reentrancy is impossible by construction: no user code runs between prepare
and finalize -- the call set there is natives plus pure list operations, with
no callback.- STATEMENTS ARE FINALIZED ON EVERY EXIT PATH. sqlite-query finalized only on its
elsebranch and sqlite-run only after a successful step, so a raise from sqlite-step -- the ordinary outcome when the busy budget is exhausted -- leaked the statement. A leaked statement holds the read transaction open for the life of the process, which is what turned a transient stale read into a permanent one. dynamic-wind's after thunk runs when the body raises, verified on this runtime rather than assumed.
- PRAGMA busy_timeout=N IS HONOURED INSTEAD OF SWALLOWED. It cannot be passed to SQLite: a blocking step freezes the whole cooperative scheduler, measured at 0 witness ticks in two seconds against 4701 for the retrying path. It was accepted and silently ignored -- dead configuration that read as live. It now sets the cooperative retry budget, which is the same intent expressed where this library can act on it. sqlite-busy-budget and sqlite-set-busy-budget! are the explicit form.
BEHAVIOUR CHANGE, stated plainly: concurrent database calls on ONE connection now serialise, and a fiber waiting on a connection whose holder is parked on a contended write waits for that whole busy budget. Callers wanting concurrent database work want separate connections. A wait longer than three times the busy budget raises rather than hanging, so two fibers deadlocking over two connections is a loud error rather than a silent stop.
NOT COVERED, and documented as such: the low-level prepare/step/finalize API cannot be serialised, because the library cannot know when the caller's statement is done; and BEGIN..COMMIT spans several primitives, so another fiber's query can still interleave inside a transaction. Give a transaction its own connection. docs/concurrency.md carries both.
test/test-sqlite-connection-pin.sgl is the regression test: four arms, the first two differing by exactly one read, which is the variable that decides the bug.
Adds sigil-test / sigil-test-runner as dev-dependencies. README has always claimed sigil test --report works and it could not: sigil test refuses to build a native package without them.
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_01NuSfnnNgQ81hjRygkkqWM6
docs/concurrency.md | 81 +++++++++++++++++++++++++++++++++++++++++++++
native/sqlite.c | 71 ++++++++++++++++++++++++++++++++++++++++
package.sgl | 10 +++++-
sigil.lock | 40 ++++++++++++++++++++---
src/sigil/sqlite.sgl | 281 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----------------------------
test/test-sqlite-connection-pin.sgl | 227 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6 files changed, 656 insertions(+), 54 deletions(-)docs/concurrency.mdadded
# Concurrency: one connection is one serial resource`sigil-sqlite` runs on a single-threaded cooperative scheduler. That makes twothings true at once, and the interaction between them is the whole of this page.1. A contended `sqlite3_step` must never block, or it freezes every fiber — including the one holding the lock, which can then never run to commit. So the native layer forces SQLite's own `busy_timeout` to 0 and the Scheme layer retries cooperatively, yielding between attempts.2. **A SQLite connection is a serial resource.** SQLite ends a connection's implicit read transaction only when *no statement on it is active*.Put those together and a shared connection has a sharp edge. If fiber A has astatement open — parked in the busy-retry, or simply part-way through a resultset — and fiber B runs a query on the *same* connection, B's read transactioncannot be released when B finalizes: A is still using the btree. The connectionis pinned to B's snapshot until A completes, and every later read on it silentlymisses anything committed in between.## What the library does about itEvery high-level primitive — `sqlite-query`, `sqlite-query-row`, `sqlite-run`,`sqlite-exec` — holds the connection exclusively for its whole duration, yieldsincluded. Concurrent calls on one connection serialise.**The lock spans the whole primitive, not just the busy window.** A fiber yieldsinside an *uncontended* query too: allocation-driven, roughly once per 450 rows.A 20000-row query yields about 44 times with no contention anywhere. Guardingonly the retry would leave every one of those windows open.Statements are finalized on **every** exit path, including a raise. A statementleaked by a raise holds the connection's read transaction open for the life ofthe process, which turns a transient stale read into a permanent one.## What this costs youConcurrent database work on one connection now **queues**. A fiber waiting for aconnection whose holder is parked on a contended write waits for that whole busybudget — by default 5 seconds. If you want database calls to proceedconcurrently, **give each fiber its own connection**. That is what connectionsare for, and WAL readers are cheap.A fiber that waits more than `*sqlite-connection-wait-seconds*` (15s, three timesthe busy budget) for a connection **raises** rather than waiting forever. Twofibers each holding a connection the other wants is a deadlock; a bounded waitturns it into a loud, attributable error instead of a process that stops with nooutput.## What is NOT covered**The low-level API.** `sqlite-prepare` / `sqlite-step` / `sqlite-finalize` arenot serialised and cannot be: the library does not know when your statement isfinished. If you hold a statement across steps on a connection another fiberalso uses, you own the hazard described at the top of this page. Use thehigh-level API, or give that work its own connection.**Multi-statement transactions.** `BEGIN` … `COMMIT` spans several primitives,and the lock is released between them, so another fiber's query can interleaveinside your transaction. There is deliberately no exported "hold this connectionacross several calls" primitive, because holding the lock across caller codedeadlocks the moment one of your database helpers calls another. **Give atransaction its own connection.**## busy_timeout`PRAGMA busy_timeout=N` cannot be passed to SQLite — a blocking step wouldfreeze the scheduler, which is the thing point 1 above exists to prevent. Itused to be accepted and silently ignored: dead configuration that read as live.It now sets the cooperative retry budget instead, which is the same intentexpressed where this library can act on it.The budget is **process-wide**, not per-connection: `sqlite-step` receives astatement and has no connection to look a per-connection value up on. Prefer`sqlite-set-busy-budget!`, which says so in its name; read it back with`sqlite-busy-budget`.## Diagnostics`sqlite-connection-locked?` answers whether a fiber currently holds aconnection. It is a diagnostic, not a synchronisation primitive: by the time youact on the answer it may have changed.native/sqlite.cmodified
typedef struct { sqlite3 *db; int closed; /* Cooperative connection lock. A SQLite connection is a SERIAL resource: * its implicit read transaction ends only when no statement is active, so * two fibers interleaving on one connection can pin a snapshot. The * scheme layer holds this across a whole primitive, yields included. * Single-threaded cooperative runtime, so a plain int is atomic enough: * only a yield can interleave, and this is never held across one without * the holder intending it. */ int locked;} SqliteDB;/* handle->db = db; handle->closed = 0; handle->locked = 0; return sigil_make_foreign(vm, db_type_tag, handle, db_finalizer, sizeof(SqliteDB));} return sigil_make_string(vm, msg, strlen(msg));}/* * %sqlite-try-acquire! db -> boolean * %sqlite-release! db -> unspecified * * A cooperative, per-connection mutual-exclusion flag. NOT a thread lock: the * runtime is single-threaded, so a plain int cannot be torn. Its whole job is * to stop two FIBERS interleaving inside one connection. * * Why a connection needs one at all: SQLite ends a connection's implicit read * transaction only when no statement on it is active. If fiber A has a * statement open (parked in the busy-retry, or simply mid-result-set) and * fiber B runs a query on the same connection, B's read transaction cannot be * released when B finalizes -- A is still using the btree. The connection is * then pinned to B's snapshot until A completes, and every later read on it * misses any commit made in between. See docs/concurrency.md. */static Value native_sqlite_try_acquire(SigilVM *vm, int argc, Value *args){ (void)argc; if (!is_db(args[0])) { sigil__vm_error(vm, SIGIL_ERR_TYPE, "%sqlite-try-acquire!: expected database handle"); return SIGIL_UNDEFINED; } SqliteDB *handle = as_db(args[0]); if (handle->locked) return SIGIL_FALSE; handle->locked = 1; return SIGIL_TRUE;}static Value native_sqlite_release(SigilVM *vm, int argc, Value *args){ (void)argc; if (!is_db(args[0])) { sigil__vm_error(vm, SIGIL_ERR_TYPE, "%sqlite-release!: expected database handle"); return SIGIL_UNDEFINED; } as_db(args[0])->locked = 0; return SIGIL_TRUE;}/* * sqlite-connection-locked? db -> boolean * Diagnostic only: is a fiber currently holding this connection? */static Value native_sqlite_connection_locked(SigilVM *vm, int argc, Value *args){ (void)argc; if (!is_db(args[0])) { sigil__vm_error(vm, SIGIL_ERR_TYPE, "sqlite-connection-locked?: expected database handle"); return SIGIL_UNDEFINED; } return sigil_bool(as_db(args[0])->locked != 0);}/* * Helper macro for module-scoped registration with export */ REGISTER_AND_EXPORT("sqlite-errmsg", native_sqlite_errmsg, SIGIL_ARITY_EXACT(1), "Get last error message"); /* Cooperative per-connection lock (see docs/concurrency.md). */ REGISTER_AND_EXPORT("%sqlite-try-acquire!", native_sqlite_try_acquire, SIGIL_ARITY_EXACT(1), "Try to acquire the connection"); REGISTER_AND_EXPORT("%sqlite-release!", native_sqlite_release, SIGIL_ARITY_EXACT(1), "Release the connection"); REGISTER_AND_EXPORT("sqlite-connection-locked?", native_sqlite_connection_locked, SIGIL_ARITY_EXACT(1), "Is a fiber holding this connection?"); sigil_end_module(vm);}package.sglmodified
(package name: "sigil-sqlite" version: "0.16.2" version: "0.16.3" sigil: "^0.17" description: "SQLite database bindings for Sigil" url: "https://codeberg.org/sigil/sigil-sqlite" dependencies: (list ) ;; Test harness. `sigil test` refuses to build a native package without ;; these, and README.md has always claimed `sigil test --report` works. dev-dependencies: (list (from-git url: "codeberg:sigil/sigil" package: "sigil-test" version: "^0.17") (from-git url: "codeberg:sigil/sigil" package: "sigil-test-runner" version: "^0.17")) ;; Native library definition libraries: (list (librarysigil.lockmodified
(package name: "sigil-lib" url: "codeberg:sigil/sigil" ref: "^0.17" sha: "8b3e7f90795b569a5ac3011c5a46311989230648" sha: "070f133a3524142b4febfd7c287385186b616252" package-selector: "sigil-lib" version: "0.17.13") version: "0.17.20") (package name: "sigil-stdlib" url: "codeberg:sigil/sigil" ref: "^0.17" sha: "8b3e7f90795b569a5ac3011c5a46311989230648" sha: "070f133a3524142b4febfd7c287385186b616252" package-selector: "sigil-stdlib" version: "0.17.13") version: "0.17.20") (package name: "sigil-test" url: "codeberg:sigil/sigil" ref: "^0.17" sha: "070f133a3524142b4febfd7c287385186b616252" package-selector: "sigil-test" version: "0.17.20") (package name: "sigil-test-runner" url: "codeberg:sigil/sigil" ref: "^0.17" sha: "070f133a3524142b4febfd7c287385186b616252" package-selector: "sigil-test-runner" version: "0.17.20") (package name: "sigil-ansi" url: "codeberg:sigil/sigil-ansi" ref: "^0.16.0" sha: "1e14b6f9d034ca8ef9f404e2ded316d0780ad7cf" version: "0.16.0") (package name: "sigil-json" url: "codeberg:sigil/sigil-json" ref: "^0.16.0" sha: "55c9e74712b5f79b45d41c65cfe0aef2c8f7e155" version: "0.16.0") (package name: "sigil-version" url: "codeberg:sigil/sigil-version" ref: "^0.16.0" sha: "2d2c9ef9c2694466f65abc14cddf9bfb9cada4a4" version: "0.16.0") (package name: "sigil-git" url: "codeberg:sigil/sigil-git" ref: "^0.16.0" sha: "2d54eb99d3ca0597b3ccd9d4829d312c54721086" version: "0.16.1"))src/sigil/sqlite.sglmodified
sqlite-query sqlite-query-row sqlite-run call-with-database) call-with-database ;; Cooperative busy-retry budget (see the busy_timeout notes below) sqlite-busy-budget sqlite-set-busy-budget! ;; Diagnostic: is a fiber holding this connection? sqlite-connection-locked?) (begin (loop))) result))))) ;; ========== Per-connection serialisation ========== ;; ;; A SQLITE CONNECTION IS A SERIAL RESOURCE AND THIS LIBRARY USED TO TREAT ;; IT AS A SHARED ONE. ;; ;; SQLite ends a connection's implicit read transaction only when NO ;; statement on it is active. So if fiber A has a statement open on a ;; connection and fiber B runs a query on the SAME connection, B's read ;; transaction cannot be released when B finalizes -- A is still using the ;; btree. The connection is pinned to B's snapshot until A finishes, and ;; every later read on it silently misses anything committed in between. ;; ;; That is not hypothetical: it produced a CI controller serving a ;; pre-commit view of its own database, HTTP 200, no error, permanently, ;; until the process restarted. Once pinned, the connection's own parked ;; write can never complete either -- it exhausts the busy budget, RAISES, ;; and (before this change) leaked its statement, which held the read ;; transaction open for the life of the process. ;; ;; GUARDING ONLY THE BUSY WINDOW IS NOT ENOUGH, and this is the measurement ;; that decided the design: a fiber yields inside an UNCONTENDED query too, ;; roughly once per 450 rows, driven by allocation rather than by time. A ;; witness fiber ticking across a 20000-row query counts ~44 yields with no ;; busy anywhere. So the lock spans the WHOLE primitive -- prepare through ;; finalize, every yield included -- not just the retry. ;; ;; SCOPE IS DELIBERATELY THE PRIMITIVE, NOT THE CALLER. Held any coarser, ;; the lock would deadlock the moment a consumer's DB helper called another ;; DB helper. At primitive scope reentrancy is impossible by construction: ;; no user code runs between prepare and finalize -- the whole call set ;; there is natives plus pure list operations, with no callback. ;; ;; WHAT IT COSTS, stated plainly because it is a real behaviour change: ;; concurrent DB calls on ONE connection now SERIALISE. A fiber waiting for ;; a connection whose holder is parked on a contended write waits for that ;; whole busy budget. Callers who want concurrency across DB work want ;; separate connections; that is what connections are for. ;; ;; The low-level API (sqlite-prepare / sqlite-step / sqlite-finalize) is ;; NOT covered -- it cannot be, since the library does not know when the ;; caller's statement is finished. A caller holding a statement across ;; steps on a shared connection still owns that hazard. See ;; docs/concurrency.md. (define-native (%sqlite-try-acquire! db) (: sqlite-db? -> boolean?)) (define-native (%sqlite-release! db) (: sqlite-db? -> boolean?)) ;;; Is a fiber currently holding this connection? Diagnostic. (define-native (sqlite-connection-locked? db) (: sqlite-db? -> boolean?)) ;; How long a fiber will wait for a connection another fiber holds before ;; giving up. It must exceed the busy budget, because a legitimate holder ;; may be parked on a contended write for exactly that long; three times is ;; the margin. A BOUND rather than an infinite wait on purpose: two ;; connections acquired in opposite orders by two fibers is a deadlock, and ;; a bounded wait turns that into a loud, attributable error instead of a ;; process that stops forever with no output. (define *sqlite-connection-wait-seconds* 15.0) (define *sqlite-connection-poll-interval* 0.001) ;;; Run `thunk` holding `db` exclusively. Releases on EVERY exit path, ;;; including a raise -- `dynamic-wind`'s after thunk runs when the body ;;; raises (measured, not assumed). (define (call-with-connection db thunk) (: sqlite-db? procedure? -> any?) (let ((deadline (+ (current-second) *sqlite-connection-wait-seconds*))) (let loop () (if (%sqlite-try-acquire! db) (dynamic-wind (lambda () #t) thunk (lambda () (%sqlite-release! db))) (if (> (current-second) deadline) (error (string-append "sqlite: connection busy -- another fiber has held it for " (number->string *sqlite-connection-wait-seconds*) "s. Either a DB call is wedged, or two fibers are each " "waiting for a connection the other holds. Use one " "connection per fiber if you need concurrent DB work.")) (begin (sleep *sqlite-connection-poll-interval*) (loop))))))) ;; ---------- busy_timeout: was accepted and ignored ---------- ;; ;; `PRAGMA busy_timeout=N` USED TO BE DEAD CONFIGURATION THAT READ AS LIVE. ;; The native layer forces SQLite's own busy_timeout to 0 on every call -- ;; deliberately, and it must keep doing so: a step that blocks inside C ;; freezes the entire cooperative scheduler, including the fiber holding ;; the lock, which can then never run to commit. That was measured: a ;; blocking step let a witness fiber tick 0 times in two seconds where the ;; retrying path let it tick 4701 times. ;; ;; So the PRAGMA cannot be passed through to SQLite. Instead of continuing ;; to swallow it, it is now HONOURED: it sets the cooperative retry budget, ;; which is the same intent expressed where this library can act on it. ;; `PRAGMA busy_timeout=5000` therefore means what a caller has always ;; reasonably assumed it meant. ;; ;; The budget is process-wide rather than per-connection, because ;; `sqlite-step` receives a statement and has no connection to look it up ;; on. Setting it from one connection changes it for all of them. Prefer ;; `sqlite-set-busy-budget!`, which says so. ;;; The cooperative busy-retry budget, in seconds. (define (sqlite-busy-budget) (: -> number?) *sqlite-busy-budget-seconds*) ;;; Set the cooperative busy-retry budget, in seconds. PROCESS-WIDE. (define (sqlite-set-busy-budget! seconds) (: number? -> number?) (set! *sqlite-busy-budget-seconds* seconds) seconds) (define (%lower-char c) (if (and (char>=? c #\A) (char<=? c #\Z)) (integer->char (+ (char->integer c) 32)) c)) (define (%lower-string s) (list->string (map %lower-char (string->list s)))) ;; Index of `needle` in `hay` at or after `start`, or #f. (define (%string-find hay needle start) (let ((hn (string-length hay)) (nn (string-length needle))) (let loop ((i start)) (cond ((> (+ i nn) hn) #f) ((string=? (substring hay i (+ i nn)) needle) i) (else (loop (+ i 1))))))) ;; If `sql` is a busy_timeout pragma, its value in milliseconds; else #f. ;; Deliberately tolerant about spacing and case, and deliberately narrow ;; about everything else: it must not claim statements it does not ;; understand. (define (%busy-timeout-pragma-ms sql) (let* ((low (%lower-string sql)) (p (%string-find low "pragma" 0)) (b (and p (%string-find low "busy_timeout" p))) (e (and b (%string-find low "=" b)))) (and e (let loop ((i (+ e 1)) (digits '())) (cond ((>= i (string-length low)) (if (null? digits) #f (string->number (list->string (reverse digits))))) ((and (char>=? (string-ref low i) #\0) (char<=? (string-ref low i) #\9)) (loop (+ i 1) (cons (string-ref low i) digits))) ((null? digits) (if (char=? (string-ref low i) #\space) (loop (+ i 1) digits) #f)) (else (string->number (list->string (reverse digits))))))))) ;;; Execute a SQL string directly. ;;; ;;; Suitable for DDL statements and simple queries that don't need ;;; ``` (define (sqlite-exec db sql) (: sqlite-db? string? -> boolean?) (retry-on-busy "sqlite-exec" (lambda () (%sqlite-exec-native db sql)))) (let ((ms (%busy-timeout-pragma-ms sql))) (when ms (sqlite-set-busy-budget! (/ ms 1000.0)))) (call-with-connection db (lambda () (retry-on-busy "sqlite-exec" (lambda () (%sqlite-exec-native db sql)))))) ;;; Step through a prepared statement. ;;; ;;; ``` (define (sqlite-query db sql . params) (: sqlite-db? string? any? ... -> list?) (let ((stmt (sqlite-prepare db sql))) (if (not stmt) '() (begin ;; Bind parameters (1-based index) (let loop ((params params) (idx 1)) (when (not (null? params)) (sqlite-bind stmt idx (car params)) (loop (cdr params) (+ idx 1)))) ;; Collect column names (let* ((col-count (sqlite-column-count stmt)) (col-names (let loop ((i 0) (names '())) (if (>= i col-count) (reverse names) (loop (+ i 1) (cons (string->symbol (sqlite-column-name stmt i)) names)))))) ;; Collect rows (let loop ((rows '())) (let ((result (sqlite-step stmt))) (cond ((eq? result 'row) ;; Build alist for this row (let ((row (let inner ((i 0) (pairs '())) (if (>= i col-count) (reverse pairs) (inner (+ i 1) (cons (cons (list-ref col-names i) (sqlite-column stmt i)) pairs)))))) (loop (cons row rows)))) (else (sqlite-finalize stmt) (reverse rows)))))))))) (call-with-connection db (lambda () (let ((stmt (sqlite-prepare db sql))) (if (not stmt) '() ;; The statement is finalized by the after thunk, so it is ;; released on EVERY exit path. It previously finalized only on ;; the `else` branch below, which meant a raise from ;; `sqlite-step` -- the ordinary outcome when the busy budget is ;; exhausted -- leaked the statement. A leaked statement holds ;; the connection's read transaction open for the life of the ;; process, which is what turned a transient stale read into a ;; permanent one. (dynamic-wind (lambda () #t) (lambda () ;; Bind parameters (1-based index) (let loop ((params params) (idx 1)) (when (not (null? params)) (sqlite-bind stmt idx (car params)) (loop (cdr params) (+ idx 1)))) ;; Collect column names (let* ((col-count (sqlite-column-count stmt)) (col-names (let loop ((i 0) (names '())) (if (>= i col-count) (reverse names) (loop (+ i 1) (cons (string->symbol (sqlite-column-name stmt i)) names)))))) ;; Collect rows (let loop ((rows '())) (let ((result (sqlite-step stmt))) (cond ((eq? result 'row) (let ((row (let inner ((i 0) (pairs '())) (if (>= i col-count) (reverse pairs) (inner (+ i 1) (cons (cons (list-ref col-names i) (sqlite-column stmt i)) pairs)))))) (loop (cons row rows)))) (else (reverse rows))))))) (lambda () (sqlite-finalize stmt)))))))) ;;; Execute a SQL query and return only the first row as an alist. ;;; Returns #f if no rows match. ;;; ``` (define (sqlite-run db sql . params) (: sqlite-db? string? any? ... -> boolean?) (let ((stmt (sqlite-prepare db sql))) (if (not stmt) #f (begin ;; Bind parameters (let loop ((params params) (idx 1)) (when (not (null? params)) (sqlite-bind stmt idx (car params)) (loop (cdr params) (+ idx 1)))) ;; Execute (let ((result (sqlite-step stmt))) (sqlite-finalize stmt) (and result #t)))))) (call-with-connection db (lambda () (let ((stmt (sqlite-prepare db sql))) (if (not stmt) #f ;; Finalized on every exit path -- see sqlite-query. (dynamic-wind (lambda () #t) (lambda () (let loop ((params params) (idx 1)) (when (not (null? params)) (sqlite-bind stmt idx (car params)) (loop (cdr params) (+ idx 1)))) (and (sqlite-step stmt) #t)) (lambda () (sqlite-finalize stmt)))))))) ;;; Open a database, call proc with the handle, and ensure it's closed. ;;;test/test-sqlite-connection-pin.sgladded
;;; Regression test for the shared-connection snapshot pin.;;;;;; THE DEFECT. SQLite ends a connection's implicit read transaction only when;;; NO statement on it is active. So if fiber A has a statement open on a;;; connection -- parked in the cooperative busy-retry, say -- and fiber B runs;;; a query on the SAME connection, B's read transaction cannot be released;;; when B finalizes: A is still using the btree. The connection is pinned to;;; B's snapshot until A completes, and every later read on it silently misses;;; anything committed in between.;;;;;; It produced a CI controller serving a pre-commit view of its own database:;;; HTTP 200, no error, and permanent, because the parked write then could not;;; complete either -- it exhausted the busy budget, RAISED, and leaked its;;; unfinalized statement, which held the read transaction open for the life of;;; the process.;;;;;; THE ORDER IS THE VARIABLE, which is why arm 1 has a control that differs by;;; exactly one read. Before the fix, READ-DURING-PARK returned the pre-commit;;; count and NO-READ-DURING-PARK did not.;;;;;; Arms:;;; 1. NO-READ-DURING-PARK control -- no read while the write is parked;;; 2. READ-DURING-PARK the defect: a read on the shared connection while;;; a write on it is parked, across an external commit;;; 3. RAISE-LEAKS-STATEMENT a write that exhausts the budget and raises must;;; still finalize, or it pins the connection forever;;; 4. BUSY-TIMEOUT-PRAGMA `PRAGMA busy_timeout=N` must actually set the;;; retry budget rather than be silently swallowed(import (sigil core) (sigil async) (sigil sqlite) (sigil time) (sigil string))(display "Testing SQLite shared-connection snapshot pin...\n")(define SEED 700)(define BASE 10)(define failures '())(define (fail! msg) (set! failures (cons msg failures)))(define (fresh-count path) (let* ((F (sqlite-open path)) (r (sqlite-query-row F "SELECT count(*) AS n FROM t")) (n (if r (assoc-ref 'n r) 'query-failed))) (sqlite-close F) n))(define (shared-count C) (let ((r (sqlite-query-row C "SELECT count(*) AS n FROM t"))) (if r (assoc-ref 'n r) 'query-failed)))(define (make-db path) (let ((C (sqlite-open path))) (sqlite-exec C "PRAGMA journal_mode=WAL") (sqlite-exec C "DROP TABLE IF EXISTS t") (sqlite-exec C "DROP TABLE IF EXISTS w") (sqlite-exec C "CREATE TABLE t (id INTEGER PRIMARY KEY, v TEXT)") (sqlite-exec C "CREATE TABLE w (id INTEGER PRIMARY KEY, v TEXT)") (let loop ((i 0)) (when (< i BASE) (sqlite-run C "INSERT INTO t (v) VALUES (?)" "base") (loop (+ i 1)))) C));; ---------------------------------------------------------------- arms 1 & 2;;;; `read-during?` is the ONLY difference between them.(define (run-pin-arm name path read-during?) (let ((C (make-db path)) (P #f) (committed #f) (reheld #f) (released #f) (started 0) (finished 0) (early 'not-taken) (shared 'unset) (fresh 'unset)) (set! P (sqlite-open path)) (with-async ;; The external writer: holds the lock, commits SEED rows, re-takes it so ;; the park outlives the commit, then releases. (go (begin (sqlite-exec P "BEGIN IMMEDIATE") (sleep 0.30) (let loop ((i 0)) (when (< i SEED) (sqlite-run P "INSERT INTO t (v) VALUES (?)" "seed") (loop (+ i 1)))) (sqlite-exec P "COMMIT") (set! committed #t) (sqlite-exec P "BEGIN IMMEDIATE") (set! reheld #t) (sleep 0.80) (sqlite-exec P "COMMIT") (set! released #t))) ;; The write on the SHARED connection. Parks on the external lock. (go (begin (sleep 0.05) (set! started (+ started 1)) (guard (exn (#t #f)) (sqlite-run C "INSERT INTO w (v) VALUES (?)" "shared-write")) (set! finished (+ finished 1)))) ;; THE ONE DIFFERENCE: a read on the shared connection during the park. (go (when read-during? (sleep 0.15) (set! early (shared-count C)))) ;; The measurement, once the external commit is durable. (go (begin (let loop ((n 0)) (when (and (not reheld) (< n 2000)) (sleep 0.005) (loop (+ n 1)))) (let loop ((n 0)) (when (and (not (and released (= finished started))) (< n 4000)) (sleep 0.005) (loop (+ n 1)))) (sleep 0.05) (set! shared (shared-count C)) (set! fresh (fresh-count path))))) (sqlite-close C) (sqlite-close P) (display (string-append " " name ": shared=" (number->string shared) " fresh=" (number->string fresh) " early-read=" (if (eq? early 'not-taken) "not-taken" (number->string early)) "\n")) ;; SETUP ASSERTIONS FIRST. Without these an "agree" could be two equal ;; wrong numbers -- a seed that never landed makes every arm pass. (when (not committed) (fail! (string-append name ": SETUP -- the external writer never committed"))) (when (not (= fresh (+ BASE SEED))) (fail! (string-append name ": SETUP -- an independent connection sees " (number->string fresh) ", expected " (number->string (+ BASE SEED))))) (when (and read-during? (eq? early 'not-taken)) (fail! (string-append name ": SETUP -- the during-park read never happened, " "so this arm did not test what it claims"))) ;; THE ASSERTION. (when (not (equal? shared fresh)) (fail! (string-append name ": THE CONNECTION IS PINNED. It reports " (number->string shared) " rows while an independent connection sees " (number->string fresh) " in the same database. A read ran on the shared " "connection while a write on it was parked, and the " "read transaction it opened could not be released."))) (list shared fresh)))(run-pin-arm "arm1 NO-READ-DURING-PARK (control)" "/tmp/sqlite-pin-a.db" #f)(run-pin-arm "arm2 READ-DURING-PARK" "/tmp/sqlite-pin-b.db" #t);; ------------------------------------------------------------------- arm 3;;;; A write that exhausts the busy budget RAISES. If it does not finalize on the;; way out, its statement holds the connection's read transaction open forever;; and every later read on that connection is stale.(define (run-leak-arm) (let* ((path "/tmp/sqlite-pin-c.db") (C (make-db path)) (P (sqlite-open path)) (raised #f) (after 'unset) (fresh 'unset)) (sqlite-set-busy-budget! 0.25) (sqlite-exec P "BEGIN IMMEDIATE") (guard (exn (#t (set! raised #t))) (sqlite-run C "INSERT INTO w (v) VALUES (?)" "doomed")) ;; The external writer commits and gets out of the way. (let loop ((i 0)) (when (< i SEED) (sqlite-run P "INSERT INTO t (v) VALUES (?)" "seed") (loop (+ i 1)))) (sqlite-exec P "COMMIT") (set! after (shared-count C)) (set! fresh (fresh-count path)) (sqlite-set-busy-budget! 5.0) (sqlite-close C) (sqlite-close P) (display (string-append " arm3 RAISE-LEAKS-STATEMENT: raised=" (if raised "#t" "#f") " shared-after=" (number->string after) " fresh=" (number->string fresh) "\n")) (when (not raised) (fail! "arm3: SETUP -- the contended write did not raise, so nothing was leaked or not leaked")) (when (not (= fresh (+ BASE SEED))) (fail! "arm3: SETUP -- the external writer's rows are not in the database")) (when (not (= after fresh)) (fail! (string-append "arm3: A RAISED STATEMENT WAS NOT FINALIZED. The connection " "reports " (number->string after) " rows where an independent " "connection sees " (number->string fresh) ". The leaked statement is holding the read transaction open.")))))(run-leak-arm);; ------------------------------------------------------------------- arm 4;;;; `PRAGMA busy_timeout=N` was accepted and silently ignored: the native layer;; forces SQLite's own busy_timeout to 0 (it must -- a blocking step freezes the;; whole cooperative scheduler). It now sets the cooperative retry budget.(define (run-pragma-arm) (let ((path "/tmp/sqlite-pin-d.db")) (let ((C (sqlite-open path))) (sqlite-set-busy-budget! 5.0) ;; CONTROL FIRST: an unrelated pragma must NOT move the budget, or this ;; arm would pass for any pragma at all. (sqlite-exec C "PRAGMA journal_mode=WAL") (when (not (= (sqlite-busy-budget) 5.0)) (fail! (string-append "arm4: CONTROL -- an unrelated pragma changed the budget to " (number->string (sqlite-busy-budget))))) (sqlite-exec C "PRAGMA busy_timeout=250") (display (string-append " arm4 BUSY-TIMEOUT-PRAGMA: budget after PRAGMA busy_timeout=250 is " (number->string (sqlite-busy-budget)) "s\n")) (when (not (= (sqlite-busy-budget) 0.25)) (fail! (string-append "arm4: `PRAGMA busy_timeout=250` did not set the retry budget; " "it is " (number->string (sqlite-busy-budget)) "s. Dead configuration that reads as live."))) (sqlite-set-busy-budget! 5.0) (sqlite-close C))))(run-pragma-arm);; ---------------------------------------------------------------- verdict(if (null? failures) (display "PASS: the shared connection is serialised; no pin, no leaked statement, busy_timeout honoured\n") (begin (display "FAIL:\n") (let loop ((f (reverse failures))) (when (not (null? f)) (display (string-append " - " (car f) "\n")) (loop (cdr f))))));; Final top-level value drives the harness exit code: 0 on pass, error on fail.(if (null? failures) 0 (error "shared-connection snapshot pin regression"))