Reap generated typed handles
ober
9cc2995291475801d7e9a27038919e6864801aae
--- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -634,9 +634,12 @@ Second module: typed `rope`. through generated byte buffer ownership helpers. Generated wrappers can explicitly drop typed handles. Option and result values now cross exported boundaries as opaque typed handles, matching the record/variant handle model. - Automatic handle finalization and richer direct Scheme conversions remain - future work. Boundary tests now cover stale handle use after drop, double-drop - rejection, and Option/Result handle round-trips. + Generated wrappers register typed handles with a Chez guardian and expose + `%typed-rust-reap-handles!`; handle creation opportunistically reaps queued + unreachable handles. Richer direct Scheme conversions and background/shutdown + finalizer integration remain future work. Boundary tests now cover stale + handle use after drop, double-drop rejection, guardian reaping, and + Option/Result handle round-trips. ### Milestone 3: Records and Variants --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -188,7 +188,8 @@ Current landing: Jerboa caller through `support/typed-run.ss`, so the caller can use public wrapper functions from ordinary `(jerboa prelude)` code without an explicit wrapper `load`. Wrapper smoke tests cover stale handle use after drop and - double-drop rejection, plus Option/Result opaque handle round-trips. + double-drop rejection, guardian-backed reaping for unreachable handles, plus + Option/Result opaque handle round-trips. - `support/typed-rust.ss`, `make typed-rust`, and `make typed-build` generate a disposable Cargo crate under `build/typed/rust`; `typed-build` also writes wrappers under `build/typed/jerboa` and runs `cargo build` against the @@ -915,8 +916,9 @@ Minimum excluded features: allowed before the owner moves and rejected after it moves. - Model FFI handles. The current generated wrapper layer models same-module record, variant, Option, and Result handles as tagged opaque values, exposes - explicit handle drops, clears dropped handle ids, and has boundary tests for - stale use, double-close rejection, and Option/Result handle round-trips. + explicit handle drops, clears dropped handle ids, registers handles with a + Chez guardian, and has boundary tests for stale use, double-close rejection, + guardian reaping, and Option/Result handle round-trips. ### Milestone 6: LLVM Prototype --- a/lib/jerboa/typed/wrapper.ss +++ b/lib/jerboa/typed/wrapper.ss @@ -383,11 +383,19 @@ (def (emit-wrapper-header needs-return-buffer? needs-handle-runtime? port) (write-line port 0 ";; Generated by Jerboa's typed wrapper backend. Do not edit.") (write-line port 0 "(import (jerboa prelude)") - (if needs-return-buffer? - (begin - (write-line port 0 " (only (chezscheme) foreign-procedure getenv load-shared-object") - (write-line port 0 " foreign-alloc foreign-free foreign-ref foreign-set! foreign-sizeof))")) - (write-line port 0 " (only (chezscheme) foreign-procedure getenv load-shared-object))")) + (cond + [(and needs-return-buffer? needs-handle-runtime?) + (write-line port 0 " (only (chezscheme) foreign-procedure getenv load-shared-object") + (write-line port 0 " foreign-alloc foreign-free foreign-ref foreign-set! foreign-sizeof") + (write-line port 0 " make-guardian))")] + [needs-return-buffer? + (write-line port 0 " (only (chezscheme) foreign-procedure getenv load-shared-object") + (write-line port 0 " foreign-alloc foreign-free foreign-ref foreign-set! foreign-sizeof))")] + [needs-handle-runtime? + (write-line port 0 " (only (chezscheme) foreign-procedure getenv load-shared-object") + (write-line port 0 " make-guardian))")] + [else + (write-line port 0 " (only (chezscheme) foreign-procedure getenv load-shared-object))")]) (newline port) (write-line port 0 "(def %typed-rust-library-path (getenv \"JERBOA_TYPED_RUST_LIB\"))") (write-line port 0 "(when %typed-rust-library-path") @@ -411,10 +419,20 @@ (write-line port 1 "(and (%typed-rust-uint64? id)") (write-line port 2 "(> id 0)))") (newline port) + (when needs-handle-runtime? + (write-line port 0 "(def %typed-rust-handle-guardian (make-guardian))") + (newline port)) (write-line port 0 "(def (%typed-rust-make-handle type id)") + (when needs-handle-runtime? + (write-line port 1 "(%typed-rust-reap-handles!)")) (write-line port 1 "(unless (%typed-rust-handle-id-valid? id)") (write-line port 2 "(error '%typed-rust-make-handle \"typed Rust returned invalid handle\" type id))") - (write-line port 1 "(vector 'typed-handle type id))") + (if needs-handle-runtime? + (begin + (write-line port 1 "(let ([handle (vector 'typed-handle type id)])") + (write-line port 2 "(%typed-rust-handle-guardian handle)") + (write-line port 2 "handle))")) + (write-line port 1 "(vector 'typed-handle type id))")) (newline port) (write-line port 0 "(def (%typed-rust-handle? value type)") (write-line port 1 "(and (vector? value)") @@ -436,6 +454,25 @@ (write-line port 2 "(eq? (vector-ref value 0) 'typed-handle)") (write-line port 2 "(%typed-rust-handle-id-valid? (vector-ref value 2))))") (newline port) + (write-line port 0 "(def (%typed-rust-finalize-handle! value)") + (write-line port 1 "(try") + (write-line port 2 "(if (%typed-rust-any-handle? value)") + (write-line port 3 "(let ([id (%typed-rust-handle-id value)])") + (write-line port 4 "(if (%typed-rust-handle-drop id)") + (write-line port 5 "(begin") + (write-line port 6 "(vector-set! value 2 0)") + (write-line port 6 "#t)") + (write-line port 5 "#f))") + (write-line port 3 "#f)") + (write-line port 2 "(catch (e) #f)))") + (newline port) + (write-line port 0 "(def (%typed-rust-reap-handles!)") + (write-line port 1 "(let loop ([count 0])") + (write-line port 2 "(let ([value (%typed-rust-handle-guardian)])") + (write-line port 3 "(if value") + (write-line port 4 "(loop (if (%typed-rust-finalize-handle! value) (+ count 1) count))") + (write-line port 4 "count))))") + (newline port) (write-line port 0 "(def (%typed-rust-handle-drop! value)") (write-line port 1 "(unless (%typed-rust-any-handle? value)") (write-line port 2 "(error '%typed-rust-handle-drop! \"expected typed handle\" value))") --- a/tests/test-typed-wrapper-e2e.ss +++ b/tests/test-typed-wrapper-e2e.ss @@ -108,6 +108,12 @@ (raises? (lambda () (token-size (make-box 7))))) (check "handle drop rejects non-handle" (raises? (lambda () (%typed-rust-handle-drop! "not a handle")))) +(let ([leaked-handle (make-box 101)]) + (set! leaked-handle #f) + (collect) + (collect) + (check "handle guardian reaps unreachable handles" + (> (%typed-rust-reap-handles!) 0))) (check "option and result handle drops" (and (%typed-rust-handle-drop! maybe-handle) (%typed-rust-handle-drop! maybe-roundtrip) --- a/tests/test-typed-wrappers.ss +++ b/tests/test-typed-wrappers.ss @@ -230,6 +230,17 @@ "(%typed-rust-handle-id-valid? (vector-ref value 2))")) #t) +(test "wrapper emits handle guardian reaper" + (and (substring? handle-wrapper + "(def %typed-rust-handle-guardian (make-guardian))") + (substring? handle-wrapper + "(%typed-rust-handle-guardian handle)") + (substring? handle-wrapper + "(def (%typed-rust-reap-handles!)") + (substring? handle-wrapper + "(%typed-rust-finalize-handle! value)")) + #t) + (test "wrapper returns option and result handles" (and (substring? option-result-wrapper "(foreign-procedure \"jt_sample_typed_option_result_maybe_value\" (unsigned-64) unsigned-64)")